diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 82a81432..56830820 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -561,14 +561,66 @@ namespace eval punk { @id -id ::punk::grepstr @cmd -name punk::grepstr\ -summary\ - "Grep for regex pattern in supplied (possibly ANSI) string."\ + "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\ -help\ - "" + "The grepstr command can find strings in ANSI text even if there are interspersed + ANSI colour codes etc. Even if a word has different coloured/styled letters, the + regex can match the plaintext. (Search is performed on ansistripped text, and then + the matched sections are highlighted and overlayed on the original styled/colourd + input. + If the input string has ANSI movement codes - the resultant text may not be directly + searchable because the parts of a word may be separated by various codes and other + plain text. To search such an input string, the string should first be 'rendered' to + a form where the ANSI only represents SGR styling (and perhaps other non-movement + codes) using something like overtype::renderline or overtype::rendertext." + @leaders -min 0 -max 0 @opts - -returnlines -type string -default all -choices {matched all} - -ansistrip -type none - -no-linenumbers -type none + -returnlines -type string -typesynopsis matched|all -default matched -choicecolumns 1 -choices {matched all} -choicelabels { + "matched"\ + " Return only lines that matched." + "all"\ + " Return all lines. + This has a similar effect to the 'grep' trick of matching on 'pattern|$' + (The $ matches all lines that have an end; ie all lines, but there is no + associated character to which to apply highlighting) + except that when instead using -returnlines all with --line-number, the * + indicator after the linenumber will only be highlighted for lines with matches, + and the following matchcount will indicate zero for non-matching lines." + } + -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num + -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ + "Print num lines of leading and trailing context surrounding each match." + -A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num + --showbreak= -type string -default "-- %c%\U2260" -help\ + "When returning matched lines and there is a break in consecutive output, + display the break with the given string. %c% is a placeholder for the + number of lines skipped. + Use empty-string for no break display. + grepstr --showbreak= needle $haystacklines + + The unix grep utility commonly uses -- for this indicator. + grepstr --showbreak=-- needle $haystacklines + + Customisation example: + grepstr -n \"--showbreak=(skipped %c% lines)\" needle $haystacklines + " + -ansistrip -type none -help\ + "Strip all ansi codes from the input string before processing. + This is not necessary for regex matching purposes, as the matching is always + performed on the ansistripped characters anyway, but by stripping ANSI, the + result only has the ANSI supplied by the -highlight option." + + #-n|--line-number as per grep utility, except that we include a * for matches + -n|--line-number -type none -help\ + "Each output line is preceded by its relative line number in the file, starting at line 1. + For lines that matched the regex, the line number will be suffixed with a * indicator + with the same highlighting as the matched string(s). + The number of matches in the line immediately follows the * + For lines with no matches the * indicator is present with no highligthing and suffixed + with zeros." + -i|--ignore-case -type none -help\ + "Perform case insensitive matching." -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" -- -type none @@ -585,12 +637,26 @@ namespace eval punk { if {[dict exists $received -ansistrip]} { set data [punk::ansi::ansistrip $data] } - set highlight [dict get $opts -highlight] - set returnlines [dict get $opts -returnlines] - if {[dict exists $received -no-linenumbers]} { - set do_linenums 0 + set highlight [dict get $opts -highlight] + set returnlines [dict get $opts -returnlines] + set context [dict get $opts --context] ;#int + set beforecontext [dict get $opts --before-context] + set beforecontext [expr {max($beforecontext,$context)}] + set aftercontext [dict get $opts --after-context] + set aftercontext [expr {max($aftercontext,$context)}] + set showbreak [dict get $opts --showbreak] + set ignorecase [dict exists $received --ignore-case] + if {$ignorecase} { + set nocase "-nocase" + } else { + set nocase "" + } + + + if {[dict exists $received --line-number]} { + set do_linenums 1 ;#display lineindex+1 } else { - set do_linenums 1 + set do_linenums 0 } if {[llength $highlight] == 0} { @@ -604,7 +670,7 @@ namespace eval punk { set data [string map {\r\n \n} $data] if {![punk::ansi::ta::detect $data]} { set lines [split $data \n] - set matches [lsearch -all -regexp $lines $pattern] + set matches [lsearch -all {*}$nocase -regexp $lines $pattern] set result "" if {$returnlines eq "all"} { set returnlines [punk::lib::range 0 [llength $lines]-1] @@ -612,48 +678,107 @@ namespace eval punk { set returnlines $matches } set max [lindex $returnlines end] + if {[string is integer -strict $max]} { + incr max + } set w1 [string length $max] - foreach linenum $returnlines { + #lineindex is zero based - display of linenums is 1 based + set resultlines [dict create] + foreach lineindex $returnlines { + set ln [lindex $lines $lineindex] + set col1 "" if {$do_linenums} { - set col1 "[format %${w1}s $linenum] " + set col1 [format %${w1}s [expr {$lineindex+1}]] + } + if {$lineindex in $matches} { + set ln [regsub -all {*}$nocase -- $pattern $ln $H&$R] ;#n + set matchcount [regexp -all {*}$nocase -- $pattern $ln] + if {$do_linenums} { + append col1 $H*$R[format %03s $matchcount] + } } else { - set col1 "" + if {$do_linenums} { + append col1 "*000" + } + } + #--------------------------------------------------------------- + set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] + set s [expr {$lineindex-$beforecontext-1}] + if {$s < -1} {set s -1} + foreach p $prelines { + incr s + #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format %${w1}s [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } } - set ln [lindex $lines $linenum] - if {$linenum in $matches} { - set ln [regsub -all -- $pattern $ln $H&$R] + #--------------------------------------------------------------- + if {$do_linenums} { + set show "$col1 $ln" + } else { + set show $ln + } + dict set resultlines $lineindex $show + #--------------------------------------------------------------- + set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] + set s $lineindex + foreach p $postlines { + incr s + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format %${w1}s [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } } - append result $col1 $ln \n + #--------------------------------------------------------------- + } - set result [string trimright $result \n] - return $result } else { set plain [punk::ansi::ansistrip $data] set plainlines [split $plain \n] set lines [split $data \n] - set matches [lsearch -all -regexp $plainlines $pattern] + set matches [lsearch -all {*}$nocase -regexp $plainlines $pattern] if {$returnlines eq "all"} { set returnlines [punk::lib::range 0 [llength $lines]-1] } else { set returnlines $matches } set max [lindex $returnlines end] + if {[string is integer -strict $max]} { + #if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary. + incr max + } set w1 [string length $max] set result "" set placeholder \UFFEF ;#review - foreach linenum $returnlines { - set ln [lindex $lines $linenum] + set resultlines [dict create] + foreach lineindex $returnlines { + set ln [lindex $lines $lineindex] + set col1 "" if {$do_linenums} { - set col1 "[format %${w1}s $linenum] " - } else { - set col1 "" - } - if {$linenum in $matches} { - set plain_ln [lindex $plainlines $linenum] - set parts [regexp -all -indices -inline -- $pattern $plain_ln] + set col1 [format %${w1}s [expr {$lineindex+1}]] + } + if {$lineindex in $matches} { + set plain_ln [lindex $plainlines $lineindex] + set parts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln] + set matchcount [llength $parts] + if {$do_linenums} { + append col1 $H*$R[format %03s $matchcount] + } if {[llength $parts] == 0} { - #shouldn't happen - append result $col1 $ln \n + #This probably can't happen (?) + #If it does.. it's more likely to be an issue with our line index than with regexp + puts stderr "Unexpected regex mismatch in grepstr - line marked with ??? (shouldn't happen)" + set matchshow "??? $ln" + #dict set resultlines $lineindex $show } else { set overlay "" set i 0 @@ -667,14 +792,75 @@ namespace eval punk { append overlay [string repeat $placeholder [string length $tail]] #puts "$overlay" #puts "$ln" - append result $col1 [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] \n + set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] + if {$do_linenums} { + set matchshow "$col1 $rendered" + } else { + set matchshow $rendered + } + } + #--------------------------------------------------------------- + set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] + set s [expr {$lineindex-$beforecontext-1}] + if {$s < -1} {set s -1} + foreach p $prelines { + incr s + #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format %${w1}s [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } + } + #--------------------------------------------------------------- + dict set resultlines $lineindex $matchshow + #--------------------------------------------------------------- + set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] + set s $lineindex + foreach p $postlines { + incr s + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format %${w1}s [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } } + #--------------------------------------------------------------- } else { - append result $col1 $ln \n + if {$do_linenums} { + append col1 "*000" + set show "$col1 $ln" + } else { + set show $ln + } + dict set resultlines $lineindex $show } } - return $result } + set ordered_resultlines [lsort -integer [dict keys $resultlines]] + set result "" + set i -1 + foreach r $ordered_resultlines { + incr i + if {$showbreak ne "" && $r > $i} { + set c [expr {$r - $i}] + append result [string map [list %c% $c] $showbreak] \n + } + append result [dict get $resultlines $r] \n + set i $r + } + if {$showbreak ne "" && $i<[llength $lines]-1} { + set c [expr {[llength $lines]-1-$i}] + append result [string map [list %c% $c] $showbreak] \n + } + set result [string trimright $result \n] + return $result } proc stacktrace {} { @@ -932,20 +1118,6 @@ namespace eval punk { } return $varlist } - proc splitstrposn {s p} { - if {$p <= 0} { - if {$p == 0} { - list "" $s - } else { - list $s "" - } - } else { - scan $s %${p}s%s - } - } - proc splitstrposn_nonzero {s p} { - scan $s %${p}s%s - } proc _split_var_key_at_unbracketed_comma {varspecs} { set varlist [list] @@ -971,18 +1143,8 @@ namespace eval punk { } } else { if {$c eq ","} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] + lappend varlist [punk::lib::string_splitbefore $token $first_term] + set token "" set token_index -1 ;#reduce by 1 because , not included in next token set first_term -1 @@ -999,18 +1161,7 @@ namespace eval punk { incr token_index } if {[string length $token]} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] + lappend varlist [punk::lib::string_splitbefore $token $first_term] } return $varlist } @@ -1034,6 +1185,7 @@ namespace eval punk { } else { if {$c eq ","} { if {$first_term > -1} { + #lassign [punk::lib::string_splitbefore $token $first_term] v k set v [string range $token 0 $first_term-1] set k [string range $token $first_term end] ;#key section includes the terminal char lappend varlist [list $v $k] diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 450099be..2681dcf0 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -723,7 +723,8 @@ tcl::namespace::eval punk::ansi { } lappend adjusted_row $i } - append result [textblock::join_basic -- {*}$adjusted_row] \n + #append result [textblock::join_basic -- {*}$adjusted_row] \n + append result [textblock::join_basic_raw {*}$adjusted_row] \n incr rowindex } @@ -1981,10 +1982,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set blockrow [list] set height 50 ;#number of lines (excluding header) vertically in a blockrow set columns 5 ;#number of columns in a blockrow - set i -1 - set t "" - set start 0 - set colidx -1 variable TK_colour_map ;#use the version without lowercased additions - this gives the display names with casing as shown in Tk colour man page. if {!$do_merge} { set map $TK_colour_map @@ -2031,9 +2028,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set overheight 0 + set t "" + set start 0 + set colidx -1 + set i -1 foreach cname $keys { - set data [dict get $map $cname] incr i + set data [dict get $map $cname] if {$overheight || $i % $height == 0} { set overheight 0 incr colidx @@ -2072,17 +2073,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fg "rgb-$cdec-contrasting" $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] } - if {$i == 0 || $i % $height != 0} { - if {$t ne ""} { - $t configure -frametype {} - $t configure_column 0 -headers [list "TK colours $start - $i"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend blockrow [$t print] " " - lappend blocklist $blockrow - $t destroy - } + + if {$t ne ""} { + $t configure -frametype {} + $t configure_column 0 -headers [list "TK colours $start - $i"] + $t configure_column 0 -header_colspans [list any] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend blockrow [$t print] " " + lappend blocklist $blockrow + $t destroy } + set result "" foreach blockrow $blocklist { append result [textblock::join -- {*}$blockrow] \n @@ -2569,16 +2570,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t add_row [list $i $descr $s [ansistring VIEW $s]] } x11 - X11 { - set tail [tcl::string::tolower [tcl::string::range $i 4 end]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } + set cname [tcl::string::tolower [tcl::string::range $i 4 end]] + set cont [string range $cname end-11 end] + switch -exact -- $cont {-contrasting - -contrastive {set cname [string range $tail end-12]}} + if {[tcl::dict::exists $X11_colour_map $cname]} { set dec [tcl::dict::get $X11_colour_map $cname] set hex [colour_dec2hex $dec] @@ -2854,18 +2849,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #foreground web colour - set tail [tcl::string::tolower [tcl::string::range $i 4 end]] + set cname [tcl::string::tolower [tcl::string::range $i 4 end]] #-contrasting #-contrastive - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } + set cont [string range $cname end-11 end] + switch -- $cont { -contrasting - -contrastive {set cname [string range $cname 0 end-12]} } + if {[tcl::dict::exists $WEB_colour_map $cname]} { set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { @@ -3184,16 +3173,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tk { #foreground tk names variable TK_colour_map_lookup ;#use the dict with added lowercase versions - set tail [tcl::string::tolower [tcl::string::range $i 3 end]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } + + set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + lassign [punk::lib::string_splitbefore $cname end-11] c cont + switch -exact -- $cont { -contrasting - -contrastive {set cname $c} } if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] @@ -3216,17 +3199,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Tk - TK { #background X11 names variable TK_colour_map_lookup ;#with lc versions - set tail [tcl::string::tolower [tcl::string::range $i 3 end]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } - #set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + + set cname [tcl::string::tolower [tcl::string::range $i 3 end]] + lassign [punk::lib::string_splitbefore $cname end-11] c cont + switch -- $cont { -contrasting - -contrastive {set cname $c} } + if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] switch -- $cont { @@ -3251,7 +3228,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {[tcl::string::first : $i] > 0} { lappend e $i } else { - puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- tk- term- rgb# rgb-" } } } @@ -3751,8 +3728,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -rawansi -type ansi -default "" -resetcodes -type list -default {reset} -rawresets -type ansi -default "" - -fullcodemerge -type boolean -default 0 -help\ - "experimental" -overridecodes -type list -default {} -rawoverrides -type ansi -default "" @values -min 1 -max 1 @@ -3767,13 +3742,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #we know there are no valid codes that start with - if {[lsearch [lrange $args 0 end-1] -*] == -1} { - #no opts - set text [lindex $args end] - set codelists [lrange $args 0 end-1] - set R [a] ;#plain ansi reset + #no opts - skip args parser + #maint: keep defaults in sync with definition above + set codelists $args + set text [lpop codelists] + set R [a] ;#plain ansi reset (equiv of default "reset") set rawansi "" set rawresets "" - set fullmerge 0 set overrides "" set rawoverrides "" } else { @@ -3784,7 +3759,6 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawansi [dict get $opts -rawansi] set R [a+ {*}[dict get $opts -resetcodes]] set rawresets [dict get $opts -rawresets] - set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } @@ -3793,22 +3767,18 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes set codes [concat {*}$codelists] ;#flatten set base [a+ {*}$codes] + set baselist [punk::ansi::ta::get_codes_single $base] if {$rawansi ne ""} { set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] - if {$fullmerge} { - set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] - } else { - set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]] - } + set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]] + set baselist [punk::ansi::ta::get_codes_single $base] } if {$rawresets ne ""} { set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] - if {$fullmerge} { - set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] - } else { - set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] - } + set Rcodes [punk::ansi::ta::get_codes_single $R] + set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]] } + if {$rawoverrides ne ""} { set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] set overrides [list {*}$overrides {*}$rawoverridecodes] @@ -3830,20 +3800,105 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt - if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R + } + } + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R + } } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } } - default { - if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R + append emit $code + } + } + return [append emit $R] + } else { + return $base$text$R + } + } + proc ansiwrap_raw {rawansi rawresets rawoverrides text} { + set codelists "" + set R "" + set overrides "" + #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. + #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes + set codes [concat {*}$codelists] ;#flatten + set base [a+ {*}$codes] + set baselist [punk::ansi::ta::get_codes_single $base] + if {$rawansi ne ""} { + set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] + set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]] + set baselist [punk::ansi::ta::get_codes_single $base] + } + if {$rawresets ne ""} { + set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] + set Rcodes [punk::ansi::ta::get_codes_single $R] + set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]] + } + + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } + + set codestack [list] + if {[punk::ansi::ta::detect $text]} { + set emit "" + #set parts [punk::ansi::ta::split_codes $text] + set parts [punk::ansi::ta::split_codes_single $text] + foreach {pt code} $parts { + switch -- [llength $codestack] { + 0 { + append emit $base $pt $R + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { + append emit $base $pt $R + set codestack [list] } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R } } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R + } } #parts ends on a pt - last code always empty string if {$code ne ""} { @@ -3889,6 +3944,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { return $base$text$R } + } proc ansiwrap_naive {codes text} { return [a_ {*}$codes]$text[a] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 9c8343bd..49d85aa7 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -664,7 +664,7 @@ tcl::namespace::eval punk::args { proc New_command_form {name} { #probably faster to inline a literal dict create in the proc than to use a namespace variable set leaderdirective_defaults [tcl::dict::create\ - -type string\ + -type any\ -optional 0\ -allow_ansi 1\ -validate_ansistripped 0\ @@ -679,7 +679,7 @@ tcl::namespace::eval punk::args { -ensembleparameter 0\ ] set optdirective_defaults [tcl::dict::create\ - -type string\ + -type any\ -optional 1\ -allow_ansi 1\ -validate_ansistripped 0\ @@ -698,7 +698,7 @@ tcl::namespace::eval punk::args { #parsekey is name of argument to use as a key in punk::args::parse result dicts set valdirective_defaults [tcl::dict::create\ - -type string\ + -type any\ -optional 0\ -allow_ansi 1\ -validate_ansistripped 0\ @@ -1607,7 +1607,7 @@ tcl::namespace::eval punk::args { -min - -minvalues { if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is 0. got $v @id:$DEF_definition_id" } #set val_min $v dict set F $fid VAL_MIN $v @@ -1615,7 +1615,7 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } #set val_max $v dict set F $fid VAL_MAX $v @@ -3250,6 +3250,7 @@ tcl::namespace::eval punk::args { _argerror_load_colours if {[llength $args] %2 != 0} { + set arg_error_isrunning 0 error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" } @@ -3258,7 +3259,12 @@ tcl::namespace::eval punk::args { set badarg "" set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) set goodargs [list] + #----------------------- + #todo!! make changeable from config file + #JJJ 2025-07-16 set returntype table ;#table as string + #set returntype string + #---------------------- set as_error 1 ;#usual case is to raise an error set scheme error set form 0 @@ -3629,8 +3635,7 @@ tcl::namespace::eval punk::args { set tail "" } else { set idlen [string length $id] - set prefix [string range $opt 0 $idlen-1] - set tail [string range $opt $idlen end] + lassign [punk::lib::string_splitbefore $opt $idlen] prefix tail } lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail } @@ -3887,14 +3892,15 @@ tcl::namespace::eval punk::args { } else { set shortestid [dict get $idents $c] } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } + lassign [punk::lib::string_splitbefore $c [string length $shortestid]] prefix tail + #if {$shortestid eq $c} { + # set prefix $c + # set tail "" + #} else { + # set idlen [string length $shortestid] + # set prefix [string range $c 0 $idlen-1] + # set tail [string range $c $idlen end] + #} set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] if {[llength $markers]} { set mk " [join $markers {}]" @@ -4657,7 +4663,7 @@ tcl::namespace::eval punk::args { # ----------------- set tp [string trim $tp ?] ;#shouldn't be necessary #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. + #we shouldn't have an optional clause member if there is only one member - the whole argument should be marked -optional true instead. # ----------------- #todo - support complex type members such as -type {{literal a|b} int OR} @@ -4674,10 +4680,8 @@ tcl::namespace::eval punk::args { set match [lindex $tp_alternative 1] if {$v eq $match} { set alloc_ok 1 - #lpop all_remaining ledit all_remaining end end if {![dict get $ARG_INFO $clausename -multiple]} { - #lpop tailnames ledit tailnames end end } #the type (or one of the possible type alternates) matched a literal @@ -4689,10 +4693,8 @@ tcl::namespace::eval punk::args { if {[string match "$pfx*" $v} { set alloc_ok 1 set alloc_ok 1 - #lpop all_remaining ledit all_remaining end end if {![dict get $ARG_INFO $clausename -multiple]} { - #lpop tailnames ledit tailnames end end } break @@ -4704,10 +4706,8 @@ tcl::namespace::eval punk::args { if {[string match "*$sfx" $v} { set alloc_ok 1 set alloc_ok 1 - #lpop all_remaining ledit all_remaining end end if {![dict get $ARG_INFO $clausename -multiple]} { - #lpop tailnames ledit tailnames end end } break @@ -4724,6 +4724,9 @@ tcl::namespace::eval punk::args { } } else { + #todo - use _split_type_expression + + #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) #This is better caught during definition. #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} @@ -4733,14 +4736,11 @@ tcl::namespace::eval punk::args { set alloc_count 0 #clause name may have more entries than types - extras at beginning are ignored set rtypelist [lreverse $typelist] - set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] - #assert length of rtypelist >= $rclausename set alloc_ok 0 set reverse_type_index 0 #todo handle type-alternates # for example: -type {string literal(x)|literal(y)} - foreach tp $rtypelist membername $rclausename { - #(membername may be empty if not enough elements) + foreach tp $rtypelist { #set rv [lindex $rcvals end-$alloc_count] set rv [lindex $all_remaining end-$alloc_count] if {[string match {\?*\?} $tp]} { @@ -4752,13 +4752,7 @@ tcl::namespace::eval punk::args { switch -glob $tp { literal* { set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } + set match [string range $litinfo 1 end-1] #todo -literalprefix if {$rv eq $match} { set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok @@ -4789,6 +4783,7 @@ tcl::namespace::eval punk::args { #review - optional non-literal makes things harder.. #we don't want to do full type checking here - but we now risk allocating an item that should actually #be allocated to the previous value + # todo - lsearch to next literal or non-optional? set prev_type [lindex $rtypelist $reverse_type_index+1] if {[string match literal* $prev_type]} { set litinfo [string range $prev_type 7 end] @@ -4796,7 +4791,6 @@ tcl::namespace::eval punk::args { if {[string match (*) $litinfo]} { set match [string range $litinfo 1 end-1] } else { - #prev membername set match [lindex $rclausename $reverse_type_index+1] } if {$rv ne $match} { @@ -4851,11 +4845,11 @@ tcl::namespace::eval punk::args { set alloc_count 0 set resultlist [list] set n [expr {[llength $thistype]-1}] - #name can have more or less items than typelist - set thisnametail [lrange $thisname end-$n end] set tpidx 0 set newtypelist $thistype - foreach tp $thistype membername $thisnametail { + set has_choices [expr {[tcl::dict::exists $ARG_INFO $thisname -choices] || [tcl::dict::exists $ARG_INFO $thisname -choicegroups]}] + foreach tp $thistype { + #usual case is a single tp (basic length-1 clause) - but tp may commonly have alternates eg int|literal(xxx) set v [lindex $all_remaining $alloc_count] if {[string match {\?*\?} $tp]} { set clause_member_optional 1 @@ -4865,84 +4859,95 @@ tcl::namespace::eval punk::args { set tp [string trim $tp ?] set member_satisfied 0 + if {$has_choices} { + #each tp in the clause is just for validating a value outside the choice-list when -choicerestricted 0 + set member_satisfied 1 + } - #----------------------------------------------------------------------------------- - #first build category lists of any literal,literalprefix,stringstartwith,other - # - set ctg_literals [list] - set ctg_literalprefixes [list] - set ctg_stringstartswith [list] - set ctg_other [list] - #foreach tp_alternative [split $tp |] {} - foreach tp_alternative [_split_type_expression $tp] { - #JJJJ - switch -exact -- [lindex $tp_alternative 0] { - literal { - set litinfo [lindex $tp_alternative 1] - lappend ctg_literals $litinfo - } - literalprefix { - set litinfo [lindex $tp_alternative 1] - lappend ctg_literalprefixes $litinfo - } - stringstartswith { - set pfx [lindex $tp_alternative 1] - lappend ctg_stringstartswith $pfx - } - default { - lappend ctg_other $tp_alternative + + if {!$member_satisfied} { + #----------------------------------------------------------------------------------- + #first build category lists of any literal,literalprefix,stringstartwith,other + # + set ctg_literals [list] + set ctg_literalprefixes [list] + set ctg_stringstartswith [list] + set ctg_stringendswith [list] + set ctg_other [list] + #foreach tp_alternative [split $tp |] {} + foreach tp_alternative [_split_type_expression $tp] { + #JJJJ + lassign $tp_alternative t textra + switch -exact -- $t { + literal { + lappend ctg_literals $textra + } + literalprefix { + lappend ctg_literalprefixes $textra + } + stringstartswith { + lappend ctg_stringstartswith $textra + } + stringendswith { + lappend ctg_stringendswith $textra + } + default { + lappend ctg_other $tp_alternative + } } } - } - #----------------------------------------------------------------------------------- - if {[llength $ctg_other] > 0} { - #presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align - #we don't do full validation here -leave main validation for later (review) - foreach tp_alternative $ctg_other { - switch -exact -- $tp_alternative { - int { - if {[string is integer -strict $v]} { - set member_satisfied 1 - break + #----------------------------------------------------------------------------------- + if {[llength $ctg_other] > 0} { + #presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align + #we don't do full validation here -leave main validation for later (review) + foreach tp_alternative $ctg_other { + switch -exact -- $tp_alternative { + int { + if {[string is integer -strict $v]} { + set member_satisfied 1 + break + } } - } - double { - if {[string is double -strict $v]} { - set member_satisfied 1 - break + double { + if {[string is double -strict $v]} { + set member_satisfied 1 + break + } } - } - bool { - if {[string is boolean -strict $v]} { - set member_satisfied 1 - break + bool { + if {[string is boolean -strict $v]} { + set member_satisfied 1 + break + } } - } - number { - if {[string is integer -strict $v] || [string is double -strict $v]} { - set member_satisfied 1 - break + number { + if {[string is integer -strict $v] || [string is double -strict $v]} { + set member_satisfied 1 + break + } } - } - dict { - if {[string is dict $v]} { + dict { + if {[punk::args::lib::string_is_dict $v]} { + set member_satisfied 1 + break + } + } + default { + #REVIEW!!! + #can get infinite loop in get_dict if not satisfied - unstoppable until memory exhausted. + #todo - catch/detect in caller set member_satisfied 1 break } } - default { - #REVIEW!!! - #can get infinite loop in get_dict if not satisfied - unstoppable until memory exhausted. - #todo - catch/detect in caller - set member_satisfied 1 - break - } } } } + if {!$member_satisfied && ([llength $ctg_literals] || [llength $ctg_literalprefixes])} { if {$v in $ctg_literals} { set member_satisfied 1 + lset newtypelist $tpidx validated-$tp } else { #ctg_literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed #(exact match would have been caught in other branch of this if) @@ -4952,6 +4957,7 @@ tcl::namespace::eval punk::args { #matched prefix must be for one of the entries in ctg_literalprefixes - valid set member_satisfied 1 set v $full_v ;#map prefix given as arg to the full literalprefix value + lset newtypelist $tpidx validated-$tp } } } @@ -4959,10 +4965,24 @@ tcl::namespace::eval punk::args { foreach pfx $ctg_stringstartswith { if {[string match "$pfx*" $v]} { set member_satisfied 1 + lset newtypelist $tpidx validated-$tp + #review. consider multi-word typespec with RPN? + # {*}$tp_alternative validated break } } } + if {!$member_satisfied && [llength $ctg_stringendswith]} { + foreach pfx $ctg_stringendswith { + if {[string match "*$pfx" $v]} { + set member_satisfied 1 + lset newtypelist $tpidx validated-$tp + break + } + } + } + + if {$member_satisfied} { if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { @@ -4975,6 +4995,7 @@ tcl::namespace::eval punk::args { lappend resultlist "" } } else { + #may have satisfied one of the basic type tests above lappend resultlist $v incr alloc_count } @@ -5007,7 +5028,7 @@ tcl::namespace::eval punk::args { #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" @@ -5094,421 +5115,428 @@ tcl::namespace::eval punk::args { } #old version - proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { - #set type $type_expression ;#todo - 'split' on | - set vlist $clausevalues_raw - set vlist_check $clausevalues_check + ###proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { + ### #set type $type_expression ;#todo - 'split' on | + ### set vlist $clausevalues_raw + ### set vlist_check $clausevalues_check + + ### set type_alternatives [_split_type_expression $type_expression] + ### #each type_alternative is a list of varying length depending on arguments supported by first word. + ### #TODO? + ### #single element types: int double string etc + ### #two element types literal literalprefix stringstartswith stringendswith + ### #TODO + ### set stype [lindex $type_alternatives 0] + ### #e.g int + ### #e.g {literal blah)etc} + ### set type [lindex $stype 0] + ### #switch on first word of each stype + ### # + + ### #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? + ### switch -- $type { + ### any {} + ### literal { + ### foreach clauseval $vlist { + ### set e [lindex $clauseval $clausecolumn] + ### set testval [lindex $stype 1] + ### if {$e ne $testval} { + ### set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### stringstartwith { + ### foreach clauseval $vlist { + ### set e [lindex $clauseval $clausecolumn] + ### set testval [lindex $stype 1] + ### if {![string match $testval* $e]} { + ### set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### list { + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {![tcl::string::is list -strict $e_check]} { + ### set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + ### } + ### if {[tcl::dict::size $thisarg_checks]} { + ### tcl::dict::for {checkopt checkval} $thisarg_checks { + ### switch -- $checkopt { + ### -minsize { + ### # -1 for disable is as good as zero + ### if {[llength $e_check] < $checkval} { + ### set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + ### } + ### } + ### -maxsize { + ### if {$checkval ne "-1"} { + ### if {[llength $e_check] > $checkval} { + ### set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### } + ### } + ### } + ### indexexpression { + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {[catch {lindex {} $e_check}]} { + ### set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### string - ansistring - globstring { + ### #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + ### #we possibly don't want to always have to regex on things that don't pass the other more basic checks + ### # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + ### # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + ### # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + ### # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + ### # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + ### # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + ### #todo? - way to validate both unstripped and stripped? + ### set pass_quick_list_e [list] + ### set pass_quick_list_e_check [list] + ### set remaining_e $vlist + ### set remaining_e_check $vlist_check + ### #review - order of -regexprepass and -regexprefail in original rawargs significant? + ### #for now -regexprepass always takes precedence + ### set regexprepass [tcl::dict::get $thisarg -regexprepass] + ### set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + ### if {$regexprepass ne ""} { + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e [lindex $clauseval $clausecolumn] + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {[regexp [lindex $regexprepass $clausecolumn] $e]} { + ### lappend pass_quick_list_e $clauseval + ### lappend pass_quick_list_e_check $clauseval_check + ### } + ### } + ### set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + ### set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + ### } + ### if {$regexprefail ne ""} { + ### foreach clauseval $remaining_e clauseval_check $remaining_e_check { + ### set e [lindex $clauseval $clausecolumn] + ### set e_check [lindex $clauseval_check $clausecolumn] + ### #puts "----> checking $e vs regex $regexprefail" + ### if {[regexp $regexprefail $e]} { + ### if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + ### #review - %caller% ?? + ### set msg [tcl::dict::get $thisarg -regexprefailmsg] + ### } else { + ### set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + ### } + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### switch -- $type { + ### ansistring { + ### #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + ### #.. so we need to look at the original values in $vlist not $vlist_check + + ### #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + ### #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + ### package require punk::ansi + ### foreach clauseval $remaining_e { + ### set e [lindex $clauseval $clausecolumn] + ### if {![punk::ansi::ta::detect $e]} { + ### set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### globstring { + ### foreach clauseval $remaining_e { + ### set e [lindex $clauseval $clausecolumn] + ### if {![regexp {[*?\[\]]} $e]} { + ### set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + + ### if {[tcl::dict::size $thisarg_checks]} { + ### foreach clauseval $remaining_e_check { + ### set e_check [lindex $clauseval $clausecolumn] + ### if {[dict exists $thisarg_checks -minsize]} { + ### set minsize [dict get $thisarg_checks -minsize] + ### # -1 for disable is as good as zero + ### if {[tcl::string::length $e_check] < $minsize} { + ### set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### if {[dict exists $thisarg_checks -maxsize]} { + ### set maxsize [dict get $thisarg_checks -maxsize] + ### if {$checkval ne "-1"} { + ### if {[tcl::string::length $e_check] > $maxsize} { + ### set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### } + ### number { + ### #review - consider effects of Nan and Inf + ### #NaN can be considered as 'technically' a number (or at least a special numeric value) + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### if {[tcl::dict::exists $thisarg -typeranges]} { + ### set ranges [tcl::dict::get $thisarg -typeranges] + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e [lindex $clauseval $clausecolumn] + ### set e_check [lindex $clauseval_check $clausecolumn] + ### set range [lindex $ranges $clausecolumn] + ### lassign {} low high ;#set both empty + ### lassign $range low high + + ### if {"$low$high" ne ""} { + ### if {[::tcl::mathfunc::isnan $e]} { + ### set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### if {$low eq ""} { + ### if {$e_check > $high} { + ### set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } elseif {$high eq ""} { + ### if {$e_check < $low} { + ### set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } else { + ### if {$e_check < $low || $e_check > $high} { + ### set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### } + ### int { + ### #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {![tcl::string::is integer -strict $e_check]} { + ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### if {[tcl::dict::exists $thisarg -typeranges]} { + ### set ranges [tcl::dict::get $thisarg -typeranges] + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e [lindex $clauseval $clausecolumn] + ### set e_check [lindex $clauseval_check $clausecolumn] + ### set range [lindex $ranges $clausecolumn] + ### lassign $range low high + ### if {"$low$high" ne ""} { + ### if {$low eq ""} { + ### #lowside unspecified - check only high + ### if {$e_check > $high} { + ### set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } elseif {$high eq ""} { + ### #highside unspecified - check only low + ### if {$e_check < $low} { + ### set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } else { + ### #high and low specified + ### if {$e_check < $low || $e_check > $high} { + ### set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### } + ### double { + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {![tcl::string::is double -strict $e_check]} { + ### set e [lindex $clauseval $clausecolumn] + ### set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### if {[tcl::dict::size $thisarg_checks]} { + ### if {[dict exists $thisarg_checks -typeranges]} { + ### set ranges [dict get $thisarg_checks -typeranges] + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### set range [lindex $ranges $clausecolumn] + ### #todo - small-value double comparisons with error-margin? review + ### #todo - empty string for low or high + ### lassign $range low high + ### if {$e_check < $low || $e_check > $high} { + ### set e [lindex $clauseval $clausecolumn] + ### set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### bool { + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {![tcl::string::is boolean -strict $e_check]} { + ### set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### dict { + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {[llength $e_check] %2 != 0} { + ### set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + ### } + ### } + ### if {[tcl::dict::size $thisarg_checks]} { + ### if {[dict exists $thisarg_checks -minsize]} { + ### set minsizes [dict get $thisarg_checks -minsize] + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### set minsize [lindex $minsizes $clausecolumn] + ### # -1 for disable is as good as zero + ### if {[tcl::dict::size $e_check] < $minsize} { + ### set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### if {[dict exists $thisarg_checks -maxsize]} { + ### set maxsizes [dict get $thisarg_checks -maxsize] + ### foreach clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### set maxsize [lindex $maxsizes $clausecolumn] + ### if {$maxsize ne "-1"} { + ### if {[tcl::dict::size $e_check] > $maxsize} { + ### set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### } + ### } + ### alnum - + ### alpha - + ### ascii - + ### control - + ### digit - + ### graph - + ### lower - + ### print - + ### punct - + ### space - + ### upper - + ### wordchar - + ### xdigit { + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {![tcl::string::is $type -strict $e_check]} { + ### set e [lindex $clauseval $t] + ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### file - + ### directory - + ### existingfile - + ### existingdirectory { + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e [lindex $clauseval $clausecolumn] + ### set e_check [lindex $clauseval_check $clausecolumn] + ### #//review - we may need '?' char on windows + ### if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + ### #what about special file names e.g on windows NUL ? + ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + ### } + ### if {$type eq "existingfile"} { + ### if {![file exists $e_check]} { + ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + ### } + ### } elseif {$type eq "existingdirectory"} { + ### if {![file isdirectory $e_check]} { + ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### } + ### char { + ### #review - char vs unicode codepoint vs grapheme? + ### foreach clauseval $vlist clauseval_check $vlist_check { + ### set e_check [lindex $clauseval_check $clausecolumn] + ### if {[tcl::string::length $e_check] != 1} { + ### set e [lindex $clauseval $clausecolumn] + ### set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + ### } + ### } + ### } + ### default { + ### } + ### } + + ###} - set type_alternatives [_split_type_expression $type_expression] - #each type_alternative is a list of varying length depending on arguments supported by first word. - #TODO? - #single element types: int double string etc - #two element types literal literalprefix stringstartswith stringendswith - #TODO - set stype [lindex $type_alternatives 0] - #e.g int - #e.g {literal blah)etc} - set type [lindex $stype 0] - #switch on first word of each stype - # - - #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - switch -- $type { - any {} - literal { - foreach clauseval $vlist { - set e [lindex $clauseval $clausecolumn] - set testval [lindex $stype 1] - if {$e ne $testval} { - set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - stringstartwith { - foreach clauseval $vlist { - set e [lindex $clauseval $clausecolumn] - set testval [lindex $stype 1] - if {![string match $testval* $e]} { - set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - list { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - if {$regexprepass ne ""} { - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - lappend pass_quick_list_e $clauseval - lappend pass_quick_list_e_check $clauseval_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach clauseval $remaining_e clauseval_check $remaining_e_check { - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach clauseval $remaining_e { - set e [lindex $clauseval $clausecolumn] - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach clauseval $remaining_e { - set e [lindex $clauseval $clausecolumn] - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach clauseval $remaining_e_check { - set e_check [lindex $clauseval $clausecolumn] - if {[dict exists $thisarg_checks -minsize]} { - set minsize [dict get $thisarg_checks -minsize] - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - set range [lindex $ranges $clausecolumn] - lassign {} low high ;#set both empty - lassign $range low high + #new version + #list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname + #common basic case: list of single item being a single value clause. + #precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A} + proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn default_type_expression list_of_clauses_raw list_of_clauses_check list_of_clauses_types argspecs} { + #default_type_expression is for the chosen clausecolumn + #if {$argname eq "frametype"} { + #puts "--->checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against default_type_expression $default_type_expression" + #puts "--->list_of_clauses_raw : $list_of_clauses_raw" + #puts "--->list_of_clauses_check: $list_of_clauses_check" + #puts "--->$argname -type: [dict get $thisarg -type]" + #} - if {"$low$high" ne ""} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - set range [lindex $ranges $clausecolumn] - lassign $range low high - if {"$low$high" ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - double { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {![tcl::string::is double -strict $e_check]} { - set e [lindex $clauseval $clausecolumn] - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - set range [lindex $ranges $clausecolumn] - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $range low high - if {$e_check < $low || $e_check > $high} { - set e [lindex $clauseval $clausecolumn] - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - bool { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsizes [dict get $thisarg_checks -minsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - set minsize [lindex $minsizes $clausecolumn] - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsizes [dict get $thisarg_checks -maxsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - set maxsize [lindex $maxsizes $clausecolumn] - if {$maxsize ne "-1"} { - if {[tcl::dict::size $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {![tcl::string::is $type -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$type eq "existingfile"} { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } elseif {$type eq "existingdirectory"} { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $clausecolumn] - if {[tcl::string::length $e_check] != 1} { - set e [lindex $clauseval $clausecolumn] - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - default { - } - } + set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just the default_type_expression for the clausecolumn - } + set default_type_alternatives [_split_type_expression $default_type_expression] + #--------------------- + #pre-calc prefix sets based on the default. + set alt_literals [lsearch -all -inline -index 0 $default_type_alternatives literal] + set literals [lmap v $alt_literals {lindex $v 1}] + set alt_literalprefixes [lsearch -all -inline -index 0 $default_type_alternatives literalprefix] + set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] + #--------------------- - #new version - proc _check_clausecolumn2 {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { - #puts "--->checking arg:$argname checkvalue:[lindex $clausevalues_check $clausecolumn] against type_expression $type_expression" - set vlist [list] - set cidx -1 - foreach cv $clausevalues_raw { - incr cidx - lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go - } - set vlist_check [list] - set cidx -1 - foreach cv $clausevalues_check { - incr cidx - lappend vlist_check [list $cidx $cv] - } - - set type_alternatives [_split_type_expression $type_expression] #each type_alternative is a list of varying length depending on arguments supported by first word. #TODO? #single element types: int double string etc @@ -5516,107 +5544,79 @@ tcl::namespace::eval punk::args { #TODO #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) - set clause_results [lrepeat [llength $clausevalues_raw] [lrepeat [llength $type_alternatives] _]] - #e.g for clause_values_raw {{a b c} {1 2 3}} when clausecolumn is 0 + set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $default_type_alternatives] _]] + #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0 #-types {int|char|literal(ok) char double} - #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)} + #we are checking a and 1 against the defaulttype_expression e.g int|char|literal(ok) (type_alternatives = {int char literal(ok)} #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} + #review: for a particular clause the active type_expression might be overridden with 'any' if the column has already passed a -choices test # - - set a_idx -1 - foreach atype $type_alternatives { - incr a_idx - #set atype [lindex $type_alternatives 0] - #e.g int - #e.g {literal blah} - - - set type [lindex $atype 0] - #switch on first word of each atype - # - - #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - switch -- $type { - any {} - literal { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - set e [lindex $clauseval $clausecolumn] - set testval [lindex $atype 1] + set e_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_raw *] + set check_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] + set typelist_vals_raw [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_types *] + set typelist_vals [lmap v $typelist_vals_raw {string trim $v ?}] + + set c_idx -1 + foreach e $e_vals e_check $check_vals clause_column_type_expression $typelist_vals { + incr c_idx + set col_type_alternatives [_split_type_expression $clause_column_type_expression] + set firstany [lsearch -exact $col_type_alternatives any] + if {$firstany > -1} { + lset clause_results $c_idx $firstany 1 + continue + } + set a_idx -1 + foreach typealt $col_type_alternatives { + incr a_idx + lassign $typealt type testval ;#testval will be empty for basic types, but applies to literal, literalprefix, stringstartswith etc. + switch -exact -- $type { + literal { if {$e ne $testval} { set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] } else { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx ;#this clause is satisfied - no need to process it for other atypes - ledit vlist_check $c_idx $c_idx + #this clause is satisfied - no need to process it for other typealt + break } } - } - literalprefix { - set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal] - set literals [lmap v $alt_literals {lindex $v 1}] - set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix] - set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] - - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - set e [lindex $clauseval $clausecolumn] - #this specific literalprefix value not relevant - we're testing against all in the set of typealternates - #set testval [lindex $atype 1] + literalprefix { + #this specific literalprefix testval value not relevant - we're testing against all in the set of typealternates set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] if {$match ne "" && $match ni $literals} { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx ;#this clause is satisfied - no need to process it for other atypes - ledit vlist_check $c_idx $c_idx + #this clause is satisfied - no need to process it for other typealt + break } else { set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] } } - } - stringstartswith { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - set e [lindex $clauseval $clausecolumn] - set testval [lindex $atype 1] + stringstartswith { if {[string match $testval* $e]} { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } else { set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] } } - } - stringendswith { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - set e [lindex $clauseval $clausecolumn] - set testval [lindex $atype 1] + stringendswith { if {[string match *$testval $e]} { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } else { set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] } } - } - list { - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] - set passed_checks 1 + list { if {![tcl::string::is list -strict $e_check]} { set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } else { if {[dict exists $thisarg_checks -minsize]} { # -1 for disable is as good as zero @@ -5624,86 +5624,56 @@ tcl::namespace::eval punk::args { if {[llength $e_check] < $minsize} { set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } - if {$passed_checks && [dict exist $thisarg_checks -maxsize]} { + if {[dict exist $thisarg_checks -maxsize]} { set maxsize [dict get $thisarg_checks -maxsize] if {$maxsize ne "-1"} { if {[llength $e_check] > $maxsize} { set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } + lset clause_results $c_idx $a_idx 1 + break } - } - indexexpression { - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + indexexpression { if {[catch {lindex {} $e_check}]} { set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] } else { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - if {$regexprepass ne ""} { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check _ clauseval_check - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] + break + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + if {$regexprepass ne ""} { if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - #lappend pass_quick_list_e [list $c_idx $clauseval] - #lappend pass_quick_list_e_check [list $c_idx $clauseval_check] lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } } - #set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - #set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check _ clauseval_check - - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] + if {$regexprefail ne ""} { #puts "----> checking $e vs regex $regexprefail" if {[regexp $regexprefail $e]} { if {[tcl::dict::exists $thisarg -regexprefailmsg]} { @@ -5715,54 +5685,35 @@ tcl::namespace::eval punk::args { #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] #review - tests? + continue } } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $clauses_dict not $clauses_dict_check - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - set e [lindex $clauseval $clausecolumn] + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi if {![punk::ansi::ta::detect $e]} { set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - } - } - } - globstring { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { continue } - set e [lindex $clauseval $clausecolumn] + } + globstring { if {![regexp {[*?\[\]]} $e]} { set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } } } - } - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } if {[tcl::dict::size $thisarg_checks]} { - set passed_checks 1 - set e_check [lindex $clauseval_check $clausecolumn] if {[dict exists $thisarg_checks -minsize]} { set minsize [dict get $thisarg_checks -minsize] # -1 for disable is as good as zero @@ -5770,136 +5721,84 @@ tcl::namespace::eval punk::args { set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } - if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { + if {[dict exists $thisarg_checks -maxsize]} { set maxsize [dict get $thisarg_checks -maxsize] if {$checkval ne "-1"} { if {[tcl::string::length $e_check] > $maxsize} { set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } else { - if {[lindex $clause_results $c_idx $a_idx] eq "_"} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } } + lset clause_results $c_idx $a_idx 1 + break } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check __ clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] set range [lindex $ranges $clausecolumn] lassign {} low high ;#set both empty lassign $range low high - set passed_checks 1 if {"$low$high" ne ""} { if {[::tcl::mathfunc::isnan $e]} { set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } - if {$passed_checks} { - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 - } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } - } else { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check __ clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx } + lset clause_results $c_idx $a_idx 1 + break } - - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + int { + #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {![tcl::string::is integer -strict $e_check]} { set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] set range [lindex $ranges $clausecolumn] lassign $range low high - set passed_checks 1 if {"$low$high" ne ""} { if {$low eq ""} { #lowside unspecified - check only high @@ -5907,7 +5806,7 @@ tcl::namespace::eval punk::args { set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } elseif {$high eq ""} { #highside unspecified - check only low @@ -5915,306 +5814,927 @@ tcl::namespace::eval punk::args { set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } else { #high and low specified if {$e_check < $low || $e_check > $high} { set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } - } else { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx } + lset clause_results $c_idx $a_idx 1 + break } - } - double { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + double { if {![tcl::string::is double -strict $e_check]} { - set e [lindex $clauseval $clausecolumn] set msg "$argclass $argname for %caller% requires type double. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } - } - if {[tcl::dict::exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - set e_check [lindex $clauseval_check $clausecolumn] + if {[tcl::dict::exists $thisarg_checks -typeranges]} { + set ranges [dict get $thisarg_checks -typeranges] set range [lindex $ranges $clausecolumn] #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - set passed_checks 1 lassign $range low high if {$low$high ne ""} { - if {$e_check < $low || $e_check > $high} { - set e [lindex $clauseval $clausecolumn] + if {$low eq ""} { + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass $argname for %caller% must be double less than or equal to $high. Received: '$e'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue + } + } elseif {$high eq ""} { + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass $argname for %caller% must be double greater than or equal to $low. Received: '$e'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue + } + } elseif {$e_check < $low || $e_check > $high} { set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 + continue } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } - } else { - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - continue - } - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx } + lset clause_results $c_idx $a_idx 1 + break } - } - bool { - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + bool { if {![tcl::string::is boolean -strict $e_check]} { set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + continue } else { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } } - } - dict { - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + dict { if {[llength $e_check] %2 != 0} { set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - } - } - foreach idx_clauseval_check $vlist_check { - lassign $idx_clauseval_check c_idx clauseval_check - if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] continue } - set passed_checks 1 if {[tcl::dict::size $thisarg_checks]} { if {[dict exists $thisarg_checks -minsize]} { set minsizes [dict get $thisarg_checks -minsize] - set e_check [lindex $clauseval_check $clausecolumn] set minsize [lindex $minsizes $clausecolumn] # -1 for disable is as good as zero if {[tcl::dict::size $e_check] < $minsize} { set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - set passed_checks 0 + lset clause_results $c_idx $a_idx [list err [list sizeviolation $type minsize $minsize] msg $msg] + continue } } - if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { - set e_check [lindex $clauseval_check $clausecolumn] + if {[dict exists $thisarg_checks -maxsize]} { set maxsize [lindex $maxsizes $clausecolumn] if {$maxsize ne "-1"} { if {[tcl::dict::size $e_check] > $maxsize} { set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - set passed_checks 0 + lset clause_results $c_idx $a_idx [list err [list sizeviolation $type maxsize $maxsize] msg $msg] + continue } } } } - - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - set e_check [lindex $clauseval_check $clausecolumn] + lset clause_results $c_idx $a_idx 1 + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { if {![tcl::string::is $type -strict $e_check]} { - set e [lindex $clauseval $t] set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue } else { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } } - } - file - - directory - - existingfile - - existingdirectory { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - - set e [lindex $clauseval $clausecolumn] - set e_check [lindex $clauseval_check $clausecolumn] - + file - + directory - + existingfile - + existingdirectory { #//review - we may need '?' char on windows - set passed_checks 1 if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { #what about special file names e.g on windows NUL ? set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - set passed_checks 0 - } - if {$passed_checks} { - if {$type eq "existingfile"} { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - set passed_checks 0 - } - } elseif {$type eq "existingdirectory"} { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - set passed_checks 0 - } - } + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + if {$type eq "existingfile"} { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue + } + } elseif {$type eq "existingdirectory"} { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue + } } + lset clause_results $c_idx $a_idx 1 } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - - set e_check [lindex $clauseval_check $clausecolumn] + char { + #review - char vs unicode codepoint vs grapheme? if {[tcl::string::length $e_check] != 1} { - set e [lindex $clauseval $clausecolumn] set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue } else { lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } } - } - tk_screen_units { - foreach idx_clauseval $vlist idx_clauseval_check $vlist_check { - lassign $idx_clauseval c_idx clauseval - lassign $idx_clauseval_check c_idx clauseval_check - - set e_check [lindex $clauseval_check $clausecolumn] - set passed_checks 1 + tk_screen_units { switch -exact -- [string index $e_check end] { c - i - m - p { set numpart [string range $e_check 0 end-1] if {![tcl::string::is double $numpart]} { - set e [lindex $clauseval $clausecolumn] set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - set passed_checks 0 + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue } } default { if {![tcl::string::is double $e_check]} { - set e [lindex $clauseval $clausecolumn] set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - set passed_checks 0 + lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] + continue } } } - if {$passed_checks} { - lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx - } + lset clause_results $c_idx $a_idx 1 + break } - } - default { - #default pass for unrecognised types - review. - foreach idx_clauseval $vlist { - lassign $idx_clauseval c_idx clauseval + default { + #default pass for unrecognised types - review. lset clause_results $c_idx $a_idx 1 - ledit vlist $c_idx $c_idx - ledit vlist_check $c_idx $c_idx + break } } } } + foreach clauseresult $clause_results { if {[lsearch $clauseresult 1] == -1} { #no pass for this clause - fetch first? error and raise #todo - return error containing clause_indices so we can report more than one failing element at once? foreach e $clauseresult { - if {[lindex $e 0] eq "errorcode"} { - #errorcode msg msg checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against type_expression $type_expression" + # puts "--->list_of_clauses_raw : $list_of_clauses_raw" + # puts "--->list_of_clauses_check: $list_of_clauses_check" + # puts "--->$argname -type: [dict get $thisarg -type]" + # } + + # set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just passed type_expression + + # #set vlist [list] + # set clauses_dict [dict create] ;#key is ordinal position, remove entries as they are satsified + # set cidx -1 + # foreach cv $list_of_clauses_raw { + # incr cidx + # #REVIEW + # #if {$clause_size ==1} { + # # lappend vlist [list $cidx [list $cv]] + # #} else { + # #lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go + # dict set clauses_dict $cidx $cv + # #} + # } + # #set vlist_check [list] + # set clauses_dict_check [dict create] + # set cidx -1 + # foreach cv $list_of_clauses_check { + # incr cidx + # #if {$clause_size == 1} { + # # lappend vlist_check [list $cidx [list $cv]] + # #} else { + # #lappend vlist_check [list $cidx $cv] + # dict set clauses_dict_check $cidx $cv + # #} + # } + + # set type_alternatives [_split_type_expression $type_expression] + # #each type_alternative is a list of varying length depending on arguments supported by first word. + # #TODO? + # #single element types: int double string etc + # #two element types literal literalprefix stringstartswith stringendswith + # #TODO + + # #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) + # set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $type_alternatives] _]] + # #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0 + # #-types {int|char|literal(ok) char double} + # #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)} + # #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} + # # + + + # set a_idx -1 + # foreach typealt $type_alternatives { + # incr a_idx + + # set type [lindex $typealt 0] + # #e.g int + # #e.g {literal blah} + # #e.g {literalprefix abc} + + # #switch on first word of each typealt + # # + + # #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? + # switch -- $type { + # any {} + # literal { + # dict for {c_idx clauseval} $clauses_dict { + # set e [lindex $clauseval $clausecolumn] + # set testval [lindex $typealt 1] + # if {$e ne $testval} { + # set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + # } else { + # lset clause_results $c_idx $a_idx 1 + # #this clause is satisfied - no need to process it for other typealt + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # literalprefix { + # set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal] + # set literals [lmap v $alt_literals {lindex $v 1}] + # set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix] + # set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] + + # dict for {c_idx clauseval} $clauses_dict { + # set e [lindex $clauseval $clausecolumn] + # #this specific literalprefix value not relevant - we're testing against all in the set of typealternates + # #set testval [lindex $typealt 1] + # set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] + # if {$match ne "" && $match ni $literals} { + # lset clause_results $c_idx $a_idx 1 + # #this clause is satisfied - no need to process it for other typealt + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } else { + # set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + # } + # } + # } + # stringstartswith { + # dict for {c_idx clauseval} $clauses_dict { + # set e [lindex $clauseval $clausecolumn] + # set testval [lindex $typealt 1] + # if {[string match $testval* $e]} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } else { + # set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + # } + # } + # } + # stringendswith { + # dict for {c_idx clauseval} $clauses_dict { + # set e [lindex $clauseval $clausecolumn] + # set testval [lindex $typealt 1] + # if {[string match *$testval $e]} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } else { + # set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] + # } + # } + # } + # list { + # dict for {c_idx clauseval_check} $clauses_dict_check { + # set e_check [lindex $clauseval_check $clausecolumn] + # set passed_checks 1 + # if {![tcl::string::is list -strict $e_check]} { + # set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } else { + # if {[dict exists $thisarg_checks -minsize]} { + # # -1 for disable is as good as zero + # set minsize [dict get $thisarg_checks -minsize] + # if {[llength $e_check] < $minsize} { + # set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # if {$passed_checks && [dict exist $thisarg_checks -maxsize]} { + # set maxsize [dict get $thisarg_checks -maxsize] + # if {$maxsize ne "-1"} { + # if {[llength $e_check] > $maxsize} { + # set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # indexexpression { + # dict for {c_idx clauseval_check} $clauses_dict_check { + # set e_check [lindex $clauseval_check $clausecolumn] + # if {[catch {lindex {} $e_check}]} { + # set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } else { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # string - ansistring - globstring { + # #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + # #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + # #todo? - way to validate both unstripped and stripped? + # #review - order of -regexprepass and -regexprefail in original rawargs significant? + # #for now -regexprepass always takes precedence + # #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? + # set regexprepass [tcl::dict::get $thisarg -regexprepass] + # set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + # if {$regexprepass ne ""} { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # set e [lindex $clauseval $clausecolumn] + # set e_check [lindex $clauseval_check $clausecolumn] + # if {[regexp [lindex $regexprepass $clausecolumn] $e]} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # if {$regexprefail ne ""} { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + + # set e [lindex $clauseval $clausecolumn] + # set e_check [lindex $clauseval_check $clausecolumn] + # #puts "----> checking $e vs regex $regexprefail" + # if {[regexp $regexprefail $e]} { + # if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + # #review - %caller% ?? + # set msg [tcl::dict::get $thisarg -regexprefailmsg] + # } else { + # set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + # } + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] + # #review - tests? + # } + # } + # } + # switch -- $type { + # ansistring { + # #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + # #.. so we need to look at the original values in $clauses_dict not $clauses_dict_check + + # #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + # #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + # package require punk::ansi + # dict for {c_idx clauseval} $clauses_dict { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set e [lindex $clauseval $clausecolumn] + # if {![punk::ansi::ta::detect $e]} { + # set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } + # } + # } + # globstring { + # dict for {c_idx clauseval} $clauses_dict { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set e [lindex $clauseval $clausecolumn] + # if {![regexp {[*?\[\]]} $e]} { + # set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } + # } + # } + # } + + # dict for {c_idx clauseval_check} $clauses_dict_check { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # if {[tcl::dict::size $thisarg_checks]} { + # set passed_checks 1 + # set e_check [lindex $clauseval_check $clausecolumn] + # if {[dict exists $thisarg_checks -minsize]} { + # set minsize [dict get $thisarg_checks -minsize] + # # -1 for disable is as good as zero + # if {[tcl::string::length $e_check] < $minsize} { + # set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { + # set maxsize [dict get $thisarg_checks -maxsize] + # if {$checkval ne "-1"} { + # if {[tcl::string::length $e_check] > $maxsize} { + # set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } else { + # if {[lindex $clause_results $c_idx $a_idx] eq "_"} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # } + # number { + # #review - consider effects of Nan and Inf + # #NaN can be considered as 'technically' a number (or at least a special numeric value) + # dict for {c_idx clauseval_check} $clauses_dict_check { + # set e_check [lindex $clauseval_check $clausecolumn] + # if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } + # } + # if {[tcl::dict::exists $thisarg -typeranges]} { + # set ranges [tcl::dict::get $thisarg -typeranges] + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set e [lindex $clauseval $clausecolumn] + # set e_check [lindex $clauseval_check $clausecolumn] + # set range [lindex $ranges $clausecolumn] + # lassign {} low high ;#set both empty + # lassign $range low high + # set passed_checks 1 + # if {"$low$high" ne ""} { + # if {[::tcl::mathfunc::isnan $e]} { + # set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # if {$passed_checks} { + # if {$low eq ""} { + # if {$e_check > $high} { + # set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } elseif {$high eq ""} { + # if {$e_check < $low} { + # set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } else { + # if {$e_check < $low || $e_check > $high} { + # set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict usnet clauses_dict_check $c_idx + # } + # } + # } else { + # dict for {c_idx clauseval} $clauses_dict { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict usnet clauses_dict_check $c_idx + # } + # } + + # } + # int { + # #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + # dict for {c_idx clauseval_check} $clauses_dict_check { + # set e_check [lindex $clauseval_check $clausecolumn] + # if {![tcl::string::is integer -strict $e_check]} { + # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } + # } + # if {[tcl::dict::exists $thisarg -typeranges]} { + # set ranges [tcl::dict::get $thisarg -typeranges] + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set e [lindex $clauseval $clausecolumn] + # set e_check [lindex $clauseval_check $clausecolumn] + # set range [lindex $ranges $clausecolumn] + # lassign $range low high + # set passed_checks 1 + # if {"$low$high" ne ""} { + # if {$low eq ""} { + # #lowside unspecified - check only high + # if {$e_check > $high} { + # set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } elseif {$high eq ""} { + # #highside unspecified - check only low + # if {$e_check < $low} { + # set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } else { + # #high and low specified + # if {$e_check < $low || $e_check > $high} { + # set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } else { + # dict for {c_idx clauseval} $clauses_dict { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # double { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # set e_check [lindex $clauseval_check $clausecolumn] + # if {![tcl::string::is double -strict $e_check]} { + # set e [lindex $clauseval $clausecolumn] + # set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } + # } + # if {[tcl::dict::exists $thisarg_checks -typeranges]} { + # set ranges [dict get $thisarg_checks -typeranges] + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set e_check [lindex $clauseval_check $clausecolumn] + # set range [lindex $ranges $clausecolumn] + # #todo - small-value double comparisons with error-margin? review + # #todo - empty string for low or high + # set passed_checks 1 + # lassign $range low high + # if {$low$high ne ""} { + # if {$e_check < $low || $e_check > $high} { + # set e [lindex $clauseval $clausecolumn] + # set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } else { + # dict for {c_idx clauseval} $clauses_dict { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # bool { + # dict for {c_idx clauseval_check} $clauses_dict_check { + # set e_check [lindex $clauseval_check $clausecolumn] + # if {![tcl::string::is boolean -strict $e_check]} { + # set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } else { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # dict { + # dict for {c_idx clauseval_check} $clauses_dict_check { + # puts "check_clausecolumn2 dict handler: c_idx:$c_idx clausecolumn:$clausecolumn clauseval_check:$clauseval_check" + # set e_check [lindex $clauseval_check $clausecolumn] + # if {[llength $e_check] %2 != 0} { + # set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + # } + # } + # dict for {c_idx clauseval_check} $clauses_dict_check { + # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { + # continue + # } + # set passed_checks 1 + # if {[tcl::dict::size $thisarg_checks]} { + # if {[dict exists $thisarg_checks -minsize]} { + # set minsizes [dict get $thisarg_checks -minsize] + # set e_check [lindex $clauseval_check $clausecolumn] + # set minsize [lindex $minsizes $clausecolumn] + # # -1 for disable is as good as zero + # if {[tcl::dict::size $e_check] < $minsize} { + # set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { + # set e_check [lindex $clauseval_check $clausecolumn] + # set maxsize [lindex $maxsizes $clausecolumn] + # if {$maxsize ne "-1"} { + # if {[tcl::dict::size $e_check] > $maxsize} { + # set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # } + + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # alnum - + # alpha - + # ascii - + # control - + # digit - + # graph - + # lower - + # print - + # punct - + # space - + # upper - + # wordchar - + # xdigit { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + # set e_check [lindex $clauseval_check $clausecolumn] + # if {![tcl::string::is $type -strict $e_check]} { + # set e [lindex $clauseval $t] + # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # } else { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # file - + # directory - + # existingfile - + # existingdirectory { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + + # set e [lindex $clauseval $clausecolumn] + # set e_check [lindex $clauseval_check $clausecolumn] + + # #//review - we may need '?' char on windows + # set passed_checks 1 + # if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + # #what about special file names e.g on windows NUL ? + # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # if {$passed_checks} { + # if {$type eq "existingfile"} { + # if {![file exists $e_check]} { + # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } elseif {$type eq "existingdirectory"} { + # if {![file isdirectory $e_check]} { + # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # char { + # #review - char vs unicode codepoint vs grapheme? + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + + # set e_check [lindex $clauseval_check $clausecolumn] + # if {[tcl::string::length $e_check] != 1} { + # set e [lindex $clauseval $clausecolumn] + # set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + # } else { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # tk_screen_units { + # dict for {c_idx clauseval} $clauses_dict { + # set clauseval_check [dict get $clauses_dict_check $c_idx] + + # set e_check [lindex $clauseval_check $clausecolumn] + # set passed_checks 1 + # switch -exact -- [string index $e_check end] { + # c - i - m - p { + # set numpart [string range $e_check 0 end-1] + # if {![tcl::string::is double $numpart]} { + # set e [lindex $clauseval $clausecolumn] + # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # default { + # if {![tcl::string::is double $e_check]} { + # set e [lindex $clauseval $clausecolumn] + # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." + # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] + # set passed_checks 0 + # } + # } + # } + # if {$passed_checks} { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # default { + # #default pass for unrecognised types - review. + # dict for {c_idx clauseval} $clauses_dict { + # lset clause_results $c_idx $a_idx 1 + # dict unset clauses_dict $c_idx + # dict unset clauses_dict_check $c_idx + # } + # } + # } + # } + # foreach clauseresult $clause_results { + # if {[lsearch $clauseresult 1] == -1} { + # #no pass for this clause - fetch first? error and raise + # #todo - return error containing clause_indices so we can report more than one failing element at once? + # foreach e $clauseresult { + # if {[lindex $e 0] eq "errorcode"} { + # #errorcode msg 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { + set end_leaders 1 + break + } + if {[catch { + lappend pre_values [lpop remaining_rawargs 0] + }]} { + set end_leaders 1 + break + } + } else { + if {[catch { + lappend pre_values [lpop remaining_rawargs 0] + }]} { + set end_leaders 1 + break ;#let validation of required leaders report the error? + } + } incr ridx } } @@ -7112,49 +7654,55 @@ tcl::namespace::eval punk::args { #treating opts as list for this loop. foreach optset $OPT_NAMES { set parsekey "" - set is_parsekey 0 + set has_parsekey_override 0 if {[tcl::dict::exists $argstate $optset -parsekey]} { set parsekey [tcl::dict::get $argstate $optset -parsekey] - set is_parsekey 1 } if {$parsekey eq ""} { - set is_parsekey 0 + set has_parsekey_override 0 #fall back to last element of aliased option e.g -fg|-foreground -> "-foreground" set parsekey [string trimright [lindex [split $optset |] end] =] + } else { + set has_parsekey_override 1 } lappend seen_pks $parsekey - set found "" + set is_found 0 + set foundkey "" set foundval "" #no lsearch -stride avail in 8.6 foreach {k v} $opts { if {$k eq $parsekey} { - set found $k + set foundkey $k + set is_found 1 set foundval $v + #can be multiple - last match wins - don't 'break' out of foreach } } ;#avoiding further dict/list shimmering #if {[dict exists $opts $parsekey]} { # set found $parsekey # set foundval [dict get $opts $parsekey] #} - if {$found eq "" && $is_parsekey} { - #.g we may have in opts -decreasing|-SORTDIRECTION -increasing|-SORTDIRECTION + if {!$is_found && $parsekey ne $optset} { + #.g we may have in opts things like: -decreasing|-SORTDIRECTION -increasing|-SORTDIRECTION #(where -SORTDIRECTION was configured as -parsekey) #last entry must win #NOTE - do not use dict for here. opts is not strictly a dict - dupe keys will cause wrong ordering foreach {o v} $opts { if {[string match *|$parsekey $o]} { - set found $o + set foundkey $o + set is_found 1 set foundval $v - #use last match - don't break + #last match wins - don't 'break' out of foreach } } } - if {$found ne ""} { - dict set ordered_opts $found $foundval + if {$is_found} { + dict set ordered_opts $foundkey $foundval } elseif {[tcl::dict::exists $OPT_DEFAULTS $optset]} { - if {$is_parsekey} { + if {$parsekey ne $optset} { set tailopt [string trimright [lindex [split $optset |] end] =] if {$tailopt ne $parsekey} { + #defaults for multiple options sharing a -parsekey value ? review dict set ordered_opts $tailopt|$parsekey [dict get $OPT_DEFAULTS $optset] } else { dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] @@ -7171,8 +7719,8 @@ tcl::namespace::eval punk::args { #keep working with opts only as list here.. if {[llength $opts] > 2*[dict size $ordered_opts]} { foreach {o o_val} $opts { - lassign [split $o |] _ pk - if {$pk ne "" && $pk in $seen_pks} { + lassign [split $o |] _ parsekey ;#single pipe - 2 elements only | + if {$parsekey ne "" && $parsekey in $seen_pks} { continue } if {![dict exists $ordered_opts $o]} { @@ -7202,6 +7750,9 @@ tcl::namespace::eval punk::args { set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] #---------------------------------------- + set argument_clause_typestate [dict create] ;#Track *updated* -type info for argument clauses for those subelements that were fully validated during _get_dict_can_assign_value + + set start_position $positionalidx set nameidx 0 #MAINTENANCE - (*nearly*?) same loop logic as for value @@ -7210,6 +7761,7 @@ tcl::namespace::eval punk::args { set ldr [lindex $leaders $ldridx] if {$leadername ne ""} { set leadertypelist [tcl::dict::get $argstate $leadername -type] + set leader_clause_size [llength $leadertypelist] set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] set consumed [dict get $assign_d consumed] @@ -7242,12 +7794,17 @@ tcl::namespace::eval punk::args { } } - if {[llength $leadertypelist] == 1} { + if {$leader_clause_size == 1} { #set clauseval $ldr set clauseval [lindex $resultlist 0] } else { set clauseval $resultlist incr ldridx [expr {$consumed - 1}] + + #not quite right.. this sets the -type for all clauses - but they should run independently + #e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script") + #the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...? + tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries } @@ -7260,12 +7817,15 @@ tcl::namespace::eval punk::args { #} if {$leadername in $leadernames_received} { tcl::dict::lappend leaders_dict $leadername $clauseval + tcl::dict::lappend argument_clause_typestate $leadername $newtypelist } else { tcl::dict::set leaders_dict $leadername [list $clauseval] + tcl::dict::set argument_clause_typestate $leadername [list $newtypelist] } set leadername_multiple $leadername } else { tcl::dict::set leaders_dict $leadername $clauseval + tcl::dict::set argument_clause_typestate $leadername [list $newtypelist] set leadername_multiple "" incr nameidx } @@ -7332,6 +7892,7 @@ tcl::namespace::eval punk::args { } #----------------------------------------------------- + set validx 0 set valname_multiple "" set valnames_received [list] @@ -7357,6 +7918,7 @@ tcl::namespace::eval punk::args { set val [lindex $values $validx] if {$valname ne ""} { set valtypelist [tcl::dict::get $argstate $valname -type] + set clause_size [llength $valtypelist] ;#common case is clause_size == 1 set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] set consumed [dict get $assign_d consumed] @@ -7390,7 +7952,7 @@ tcl::namespace::eval punk::args { } #assert can_assign != 0, we have at least one value to assign to clause - if {[llength $valtypelist] == 1} { + if {$clause_size == 1} { #set clauseval $val set clauseval [lindex $resultlist 0] } else { @@ -7402,10 +7964,11 @@ tcl::namespace::eval punk::args { incr validx [expr {$consumed -1}] if {$validx > [llength $values]-1} { error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg + set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to $clause_size values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength $clause_size ] -argspecs $argspecs]] $msg } + #incorrect - we shouldn't update the default. see argument_clause_typestate dict of lists of -type tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries } @@ -7418,17 +7981,21 @@ tcl::namespace::eval punk::args { #} if {$valname in $valnames_received} { tcl::dict::lappend values_dict $valname $clauseval + tcl::dict::lappend argument_clause_typestate $valname $newtypelist } else { tcl::dict::set values_dict $valname [list $clauseval] + tcl::dict::set argument_clause_typestate $valname [list $newtypelist] } set valname_multiple $valname } else { tcl::dict::set values_dict $valname $clauseval + tcl::dict::set argument_clause_typestate $valname [list $newtypelist] ;#list protect set valname_multiple "" incr nameidx } lappend valnames_received $valname } else { + #unnamed if {$valname_multiple ne ""} { set valtypelist [tcl::dict::get $argstate $valname_multiple -type] if {[llength $valname_multiple] == 1} { @@ -7477,6 +8044,10 @@ tcl::namespace::eval punk::args { } } #----------------------------------------------------- + #JJJJJJ + #if {[dict size $argument_clause_typestate]} { + # puts ">>>>>[dict get $argspecs id] typestate $argument_clause_typestate" + #} if {$leadermax == -1} { #only check min @@ -7585,31 +8156,58 @@ tcl::namespace::eval punk::args { #check types,ranges,choices set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" + #puts "get_dict>>>>>>>> ---opts_and_values:$opts_and_values" + #puts " >>>>>>> ---lookup_optset :$lookup_optset" #puts "---argstate:$argstate" - #JJJ api_argname e.g -increasing|-SORTOPTION - tcl::dict::for {api_argname value_group} $opts_and_values { - if {[string match -* $api_argname]} { - if {[string first | $api_argname] > -1} { - #flag_ident style (grouped options with -parsekey) - lassign [split $api_argname |] f parsekey - if {[dict exists $lookup_optset $f]} { - set argname [dict get $lookup_optset $f] + #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION + tcl::dict::for {argname_or_ident value_group} $opts_and_values { + # + #parsekey: key used in resulting leaders opts values dictionaries + # often distinct from the full argname in the ARG_INFO structure + # + if {[string match -* $argname_or_ident]} { + #ident format only applies to options/flags + if {[string first | $argname_or_ident] > -1} { + #flag_ident style (grouped fullname of option with -parsekey) + lassign [split $argname_or_ident |] fullflag parsekey ;#we expect only a single pipe in ident form | + if {[dict exists $lookup_optset $fullflag]} { + set argname [dict get $lookup_optset $fullflag] + #idents should already have correct parsekey } else { - puts stderr "punk::args::get_dict unable to find $f in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" } } else { - if {[dict exists $lookup_optset $api_argname]} { + if {[dict exists $lookup_optset $argname_or_ident]} { #get full option name such as -fg|-foreground from non-alias name such as -foreground #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - set argname [dict get $lookup_optset $api_argname] + set argname [dict get $lookup_optset $argname_or_ident] + set pkoverride [Dict_getdef $argstate -parsekey ""] + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + #default parsekey: last element in argname without trailing = + set parsekey [string trimright [lindex [split $argname |] end] =] + } } else { - puts stderr "punk::args::get_dict unable to find $api_argname in $lookup_optset (value_group: $value_group)" + puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" } } } else { - set argname $api_argname + set argname $argname_or_ident + set pkoverride [Dict_getdef $argstate -parsekey ""] + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + #leader or value of form x|y has no special meaning and forms the parsekey in entirety by default. + set parsekey $argname + } } + #assert: argname is the key for the relevant argument info in the FORMS//ARG_INFO dict. (here each member available as $argstate) + #argname is usually the full name as specified in the definition: + #e.g -f|-path|--filename= + # (where the parsekey will be by default --filename, possibly overridden by -parsekey value) + #an example argname_or_compound for the above might be: -path|--filename + # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] @@ -7623,20 +8221,55 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set typelist [tcl::dict::get $thisarg -type] + set clause_size [llength $typelist] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] set validationtransform [tcl::dict::get $thisarg -validationtransform] #JJJJ + #if {$is_multiple} { + # set vlist $value_group + #} else { + # set vlist [list $value_group] + #} + ##JJJJ + #if {$clause_size == 1} { + # set vlist [list $vlist] + #} + + + #JJ 2025-07-25 + set vlist [list] + #vlist is a list of clauses. Each clause is a list of values of length $clause_size. + #The common case is clause_size 1 - but as we need to treat each clause as a list during validation - we need to list protect the clause when clause_size == 1. if {$is_multiple} { - set vlist $value_group + if {$clause_size == 1} { + foreach c $value_group { + lappend vlist [list $c] + } + } else { + set vlist $value_group + } } else { - set vlist [list $value_group] + if {$clause_size ==1} { + set vlist [list [list $value_group]] + } else { + set vlist [list $value_group] + } } - #JJJJ - if {[llength $typelist] == 1} { - set vlist [list $vlist] + set vlist_typelist [list] + if {[dict exists $argument_clause_typestate $argname]} { + #lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-? or ?defaulted-? + # args.test: parse_withdef_value_clause_missing_optional_multiple + set vlist_typelist [dict get $argument_clause_typestate $argname] + } else { + foreach v $vlist { + lappend vlist_typelist $typelist + } } + + + set vlist_original $vlist ;#retain for possible final strip_ansi #review - validationtransform @@ -7645,7 +8278,12 @@ tcl::namespace::eval punk::args { package require punk::ansi set vlist_check [list] foreach clause_value $vlist { - lappend vlist_check [punk::ansi::ansistrip $clause_value] + #lappend vlist_check [punk::ansi::ansistrip $clause_value] + set stripped [list] + foreach element $clause_value { + lappend stripped [punk::ansi::ansistrip $element] + } + lappend vlist_check $stripped } } else { #validate_ansistripped 0 @@ -7670,11 +8308,12 @@ tcl::namespace::eval punk::args { set argclass "Unknown argument" } } - set vlist_validate [list] - set vlist_check_validate [list] + set vlist_validate [list] + set vlist_check_validate [list] + set vlist_typelist_validate [list] #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$api_argname in $receivednames && $has_choices} { + if {$parsekey in $receivednames && $has_choices} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] @@ -7699,189 +8338,220 @@ tcl::namespace::eval punk::args { #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - set idx 0 ;# + set clause_index -1 ;# #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes #assert llength $vlist == llength [dict get $dname $argname] # (unless there was a default and the option wasn't specified) #J2 #set vlist_validate [list] #set vlist_check_validate [list] - foreach clause $vlist clause_check $vlist_check { - foreach e $clause e_check $clause_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } + foreach clause $vlist clause_check $vlist_check clause_typelist $vlist_typelist { + incr clause_index + set element_index -1 ;#element within clause - usually clause size is only 1 + foreach e $clause e_check $clause_check { + incr element_index + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set choices_test $allchoices + set v_test $c_check + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + #assert chosen will always get set + set choice_in_list 1 + } else { + #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } } else { - set chosen $bestmatch - set choice_in_list 1 + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$chosen eq "" || $chosen in $choiceprefixreservelist} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { set choice_in_list 0 - } else { - set choice_in_list 1 + set chosen "" } } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all + #override the optimistic existing val + #our existing values in $dname are not list-protected - so we need to check clause_size + if {$choice_in_list && !$choice_exact_match} { + set existing [tcl::dict::get [set $dname] $argname_or_ident] + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + #single choice allowed per clause-member + if {$is_multiple} { + if {$clause_size == 1} { + #no list wrapping of single element in $dname dict - so don't index into it with element_index + lset existing $element_index $chosen + } else { + lset existing $clause_index $element_index $chosen + } + tcl::dict::set $dname $argname_or_ident $existing + } else { + #test: choice_multielement_clause + lset existing $element_index $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing + if {$is_multiple} { + #puts ">>> existing $existing $choice_idx" + if {$clause_size == 1} { + #no list wrapping of single element in $dname dict - so don't index into it with element_index + lset existing $clause_index $choice_idx $chosen + } else { + lset existing $clause_index $element_index $choice_idx $chosen + } + tcl::dict::set $dname $argname_or_ident $existing + } else { + lset existing $element_index $choice_idx $chosen + tcl::dict::set $dname $argname_or_ident $existing + } } } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] } - } - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $clause_index $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + #JJJ + #lappend vlist_validate $c + #lappend vlist_check_validate $c_check } else { - set prefixmsg "" + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } else { + #choice is in list or matches default - no validation for this specific element in the clause + lset clause_typelist $element_index any } + incr choice_idx } - incr choice_idx + + } ;#end foreach e in clause + #jjj 2025-07-16 + #if not all clause_typelist are 'any' + if {[lsearch -not $clause_typelist any] > -1} { + #at least one element still needs validation + lappend vlist_validate $clause + lappend vlist_check_validate $clause_check + lappend vlist_typelist_validate $clause_typelist } - incr idx - } - } + + } ;#end foreach clause in vlist + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate + set vlist $vlist_validate + set vlist_check $vlist_check_validate + set vlist_typelist $vlist_typelist_validate } #todo - don't add to validation lists if not in receivednames - #if we have an optionset such as "-f|-x|-etc" api_argname is -etc - if {$api_argname ni $receivednames} { + #if we have an optionset such as "-f|-x|-etc"; the parsekey is -etc (unless it was overridden by -parsekey in definition) + if {$parsekey ni $receivednames} { set vlist [list] set vlist_check_validate [list] } else { @@ -7891,20 +8561,24 @@ tcl::namespace::eval punk::args { #set vlist_validate [list] #set vlist_check_validate [list] set tp [dict get $thisarg -type] - foreach clause_value $vlist clause_check $vlist_check { + set clause_size [llength $tp] + foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { #JJJJ + #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? if {$clause_value ni $vlist_validate} { - if {[llength $tp] ==1} { + if {$clause_size ==1} { #for -choicemultiple with default that could be a list use 'ni' #?? review! if {[lindex $clause_check 0] ne $defaultval} { lappend vlist_validate $clause_value lappend vlist_check_validate $clause_check + lappend vlist_typelist_validate $clause_typelist } } else { if {$clause_check ne $defaultval} { lappend vlist_validate $clause_value lappend vlist_check_validate $clause_check + lappend vlist_typelist_validate $clause_typelist } } } @@ -7930,6 +8604,7 @@ tcl::namespace::eval punk::args { } set vlist $vlist_validate set vlist_check $vlist_check_validate + set vlist_typelist $vlist_typelist_validate } } @@ -7982,8 +8657,8 @@ tcl::namespace::eval punk::args { #set typespec [lindex $typelist $clausecolumn] #todo - handle type-alternates e.g -type char|double #------------------------------------------------------------------------------------ - #_check_clausecolumn argname argclass thisarg thisarg_checks column type_expression clausevalues clausevalues_check - _check_clausecolumn2 $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $argspecs + #_check_clausecolumn argname argclass thisarg thisarg_checks column default_type_expression list_of_clauses list_of_clauses_check list_of_clauses_typelist + _check_clausecolumn $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $vlist_typelist $argspecs #------------------------------------------------------------------------------------ @@ -8002,25 +8677,25 @@ tcl::namespace::eval punk::args { if {[tcl::dict::get $thisarg -multiple]} { switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { - tcl::dict::set leaders_dict $argname $stripped_list + tcl::dict::set leaders_dict $argname_or_ident $stripped_list } option { - tcl::dict::set opts $argname $stripped_list + tcl::dict::set opts $argname_or_ident $stripped_list } value { - tcl::dict::set values_dict $argname $stripped_list + tcl::dict::set values_dict $argname_or_ident $stripped_list } } } else { switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] + tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] } option { - tcl::dict::set opts $argname [lindex $stripped_list 0] + tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] } value { - tcl::dict::set values_dict [lindex $stripped_list 0] + tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] } } } @@ -8030,6 +8705,7 @@ tcl::namespace::eval punk::args { set finalopts [dict create] dict for {o v} $opts { if {[string first | $o] > -1} { + #set parsekey [lindex [split $o |] end] dict set finalopts [lindex [split $o |] end] $v } else { dict set finalopts $o $v @@ -8738,6 +9414,26 @@ tcl::namespace::eval punk::args::lib { #[para] Secondary functions that are part of the API #[list_begin definitions] + #tcl86 compat for string is dict - but without -strict or -failindex options + if {[catch {string is dict {}} errM]} { + proc string_is_dict {args} { + #ignore opts + set str [lindex $args end] + if {[catch {[llength $str] len}]} { + return 0 + } + if {$len % 2 == 0} { + return 1 + } + return 0 + } + } else { + proc string_is_dict {args} { + string is dict {*}$args + } + } + + #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 6ca30aab..7e790265 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -290,7 +290,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { lappend PUNKARGS [list { @id -id ::parray - @cmd -name "Builtin: parray" -help\ + @cmd -name "Built-in: parray" -help\ "Prints on standard output the names and values of all the elements in the array arrayName, or just the names that match pattern (using the matching rules of string_match) and their values if pattern is given. @@ -307,7 +307,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::foreachLine - @cmd -name "Builtin: foreachLine" -help\ + @cmd -name "Built-in: foreachLine" -help\ "This reads in the text file named ${$I}filename${$NI} one line at a time (using system defaults for reading text files). It writes that line to the variable named by ${$I}varName${$NI} and then executes ${$I}body${$NI} for that line. The result value of ${$I}body${$NI} is @@ -324,7 +324,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::readFile - @cmd -name "Builtin: readFile" -help\ + @cmd -name "Built-in: readFile" -help\ "Reads in the file named in ${$I}filename${$NI} and returns its contents. The second argument says how to read in the file, either as ${$B}text${$N} (using the system defaults for reading text files) or as ${$B}binary${$N} (as uninterpreted bytes). @@ -340,7 +340,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::writeFile - @cmd -name "Builtin: writeFile" -help\ + @cmd -name "Built-in: writeFile" -help\ "Writes the contents to the file named in ${$I}filename${$NI}. The optional second argument says how to write to the file, either as ${$B}text${$N} (using the system defaults for writing text files) or as ${$B}binary${$N} (as uninterpreted bytes). @@ -362,7 +362,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { punk::args::define { @id -id ::tcl::info::args - @cmd -name "BUILTIN: tcl::info::args" -help\ + @cmd -name "Built-in: tcl::info::args" -help\ "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 @@ -370,7 +370,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::info::body - @cmd -name "BUILTIN: tcl::info::body" -help\ + @cmd -name "Built-in: tcl::info::body" -help\ "Returns the body procedure named ${$I}procname${$NI}." @values -min 1 -max 1 procname -type string -optional 0 @@ -378,7 +378,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::info::default - @cmd -name "BUILTIN: tcl::info::default" -help\ + @cmd -name "Built-in: tcl::info::default" -help\ "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. Otherwise, returns ${$B}0${$N}." @@ -390,7 +390,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::info::cmdtype - @cmd -name "Builtin: tcl::info::cmdtype" -help\ + @cmd -name "Built-in: tcl::info::cmdtype" -help\ "Returns the type of the command named ${$I}commandName${$NI}. Built-in types are: ${$B}alias${$N} @@ -424,7 +424,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::oo::InfoObject::call - @cmd -name "Builtin: oo::InfoObject::call" -help\ + @cmd -name "Built-in: oo::InfoObject::call" -help\ "Returns a description of the method implementations that are used to provide ${$I}object's${$NI} implementation of ${$I}method${$NI}. This consists of a list of lists of four elements, where each sublist consists of: @@ -465,7 +465,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @dynamic @id -id ::info - @cmd -name "Builtin: info" -help\ + @cmd -name "Built-in: info" -help\ "Information about the state of the Tcl interpreter" @leaders -min 1 -max 1 ${$DYN_INFO_SUBCOMMANDS} @@ -600,7 +600,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::time - @cmd -name "Builtin: time" -help\ + @cmd -name "Built-in: time" -help\ "Calls the Tcl interpreter count times to evaluate script (or once if count is not specified). It will then return a string of the form @@ -617,7 +617,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { lappend PUNKARGS [list { @id -id ::tcl::chan::blocked - @cmd -name "Builtin: tcl::chan::blocked" -help\ + @cmd -name "Built-in: tcl::chan::blocked" -help\ "This tests whether the last input operation on the channel called ${$I}channel${$NI} failed because it would otherwise have caused the process to block, and returns 1 if that was the case. It returns 0 otherwise. Note that this only ever returns 1 @@ -630,7 +630,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::close - @cmd -name "Builtin: tcl::chan::close" -help\ + @cmd -name "Built-in: tcl::chan::close" -help\ "Close and destroy the channel called channel. Note that this deletes all existing file-events registered on the channel. If the direction argument (which must be read or write or any unique abbreviation of them) is present, the channel will only be half-closed, so that it can @@ -684,7 +684,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::fconfigure - @cmd -name "Builtin: chan configure" -help\ + @cmd -name "Built-in: chan configure" -help\ "Query or set the configuration options of the channel named ${$I}channel${$NI} If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the command returns a list containing alternating option names and values for the @@ -752,7 +752,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::eof - @cmd -name "Builtin: tcl::chan::eof"\ + @cmd -name "Built-in: tcl::chan::eof"\ -summary\ "Check for end of file condition on channel"\ -help\ @@ -767,7 +767,7 @@ tcl::namespace::eval punk::args::tclcore { #event lappend PUNKARGS [list { @id -id ::tcl::chan::flush - @cmd -name "Builtin: tcl::chan::flush"\ + @cmd -name "Built-in: tcl::chan::flush"\ -summary\ "Flush pending output."\ -help\ @@ -782,7 +782,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::gets - @cmd -name "Builtin: tcl::chan::gets"\ + @cmd -name "Built-in: tcl::chan::gets"\ -summary\ "Read a line from channel."\ -help\ @@ -824,7 +824,7 @@ tcl::namespace::eval punk::args::tclcore { #pending lappend PUNKARGS [list { @id -id ::tcl::chan::pipe - @cmd -name "Builtin: tcl::chan::pipe"\ + @cmd -name "Built-in: tcl::chan::pipe"\ -summary\ "Create a standalone pipe."\ -help\ @@ -849,7 +849,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::pop - @cmd -name "Builtin: tcl::chan::pop"\ + @cmd -name "Built-in: tcl::chan::pop"\ -summary\ "Remove topmost channel transform."\ -help\ @@ -864,7 +864,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::puts - @cmd -name "Builtin: tcl::chan::puts"\ + @cmd -name "Built-in: tcl::chan::puts"\ -summary\ "Write to a channel."\ -help\ @@ -909,9 +909,73 @@ tcl::namespace::eval punk::args::tclcore { } + lappend PUNKARGS [list { + @id -id ::tcl::chan::read + @cmd -name "Built-in: tcl::chan::read"\ + -summary\ + "Read from a channel."\ + -help\ + "In the first form, the result will be the next numChars characters read from the channel named + channel; if numChars is omitted, all characters up to the point when the channel would signal a + failure (whether an end-of-file, blocked or other error condition) are read. In the second form + (i.e. when numChars has been omitted) the flag -nonewline may be given to indicate that any + trailing newline in the string that has been read should be trimmed. + If channel is in non-blocking mode, chan read may not read as many characters as requested: once + all available input has been read, the command will return the data that is available rather + than blocking for more input. If the channel is configured to use a multi-byte encoding, then + there may actually be some bytes remaining in the internal buffers that do not form a complete + character. These bytes will not be returned until a complete character is available or end-of-file + is reached. The -nonewline switch is ignored if the command returns before reaching the end of the + file. + + Chan read translates end-of-line sequences in the input into newline characters according to the + -translation option for the channel (see chan configure above for a discussion on the ways in + which chan configure will alter input). + + When reading from a serial port, most applications should configure the serial port channel to be + non-blocking, like this: + + chan configure channel -blocking 0 + + Then chan read behaves much like described above. Note that most serial ports are comparatively + slow; it is entirely possible to get a readable event for each character read from them. Care + must be taken when using chan read on blocking serial ports: + + chan read channel numChars + In this form chan read blocks until numChars have been received from the serial port. + chan read channel + In this form chan read blocks until the reception of the end-of-file character, see + chan configure -eofchar. If there no end-of-file character has been configured for the + channel, then chan read will block forever. + + If the encoding profile strict is in effect for the channel, the command will raise an exception + with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. + If the channel is in blocking mode, the error is thrown after advancing the file pointer to the + beginning of the invalid data. The successfully decoded leading portion of the data prior to the + error location is returned as the value of the -data key of the error option dictionary. If the + channel is in non-blocking mode, the successfully decoded portion of data is returned by the + command without an error exception being raised. A subsequent read will start at the invalid data + and immediately raise a EILSEQ POSIX error exception. Unlike the blocking channel case, the -data + key is not present in the error option dictionary. In the case of exception thrown due to encoding + errors, it is possible to introspect, and in some cases recover, by changing the encoding in use. + See ENCODING ERROR EXAMPLES later." + + @form -form readchars + @values -min 1 -max 2 + channel + numChars -type integer -optional 1 + + @form -form read + @opts + -nonewline -type none + @values -min 1 -max 1 + channel + + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { @id -id ::tcl::chan::seek - @cmd -name "Builtin: tcl::chan::seek"\ + @cmd -name "Built-in: tcl::chan::seek"\ -summary\ "Set channel access position as byte offset."\ -help\ @@ -950,7 +1014,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::tell - @cmd -name "Builtin: tcl::chan::tell"\ + @cmd -name "Built-in: tcl::chan::tell"\ -summary\ "Report channel access position as byte offset."\ -help\ @@ -968,7 +1032,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::truncate - @cmd -name "Builtin: tcl::chan::truncate"\ + @cmd -name "Built-in: tcl::chan::truncate"\ -summary\ "Truncate channel to specified length or current byte offset."\ -help\ @@ -991,7 +1055,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { lappend PUNKARGS [list { @id -id ::tcl::dict::append - @cmd -name "Builtin: tcl::dict::append" -help\ + @cmd -name "Built-in: tcl::dict::append" -help\ "This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existant @@ -1006,7 +1070,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::create - @cmd -name "Builtin: tcl::dict::create" -help\ + @cmd -name "Built-in: tcl::dict::create" -help\ "Return a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being followed by its associated value)" @@ -1016,7 +1080,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::exists - @cmd -name "Builtin: tcl::dict::exists" -help\ + @cmd -name "Built-in: tcl::dict::exists" -help\ "This returns a boolean value indicating whether the given key (or path of keys through a set of nested dictionaries) exists in the given dictionary value. This returns a true value exactly when ${$B}dict get${$N} on that path will @@ -1029,7 +1093,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::for - @cmd -name "Builtin: tcl::dict::for" -help\ + @cmd -name "Built-in: tcl::dict::for" -help\ "This command takes three arguments, the first a two-element list of variable names (for the key and value respectively of each mapping in the dictionary), the second the dictionary value to iterate across, and @@ -1052,7 +1116,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::dict::get - @cmd -name "Builtin: tcl::dict::get" -help\ + @cmd -name "Built-in: tcl::dict::get" -help\ "Given a dictionary value (first argument) and a key (second argument), this will retrieve the value for that key. Where several keys are supplied, the behaviour of the command shall be as if the result of ${$B}dict get $dictVal $key${$N} @@ -1081,7 +1145,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::dict::getdef - @cmd -name "Builtin: tcl::dict::getdef" -help\ + @cmd -name "Built-in: tcl::dict::getdef" -help\ "This behaves the same as ${$B}dict get${$N} (with at least one ${$I}key${$NI} argument), returning the value that the key path maps to in the dictionary ${$I}dictionaryValue${$NI}, except that instead of producing an error because the @@ -1099,14 +1163,14 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define [punk::args::resolved_def -override {@id { -id ::tcl::dict::getwithdefault } @cmd { - -name "Builtin: tcl::dict::getwithdefault" + -name "Built-in: tcl::dict::getwithdefault" }} ::tcl::dict::getdef] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::incr - @cmd -name "Builtin: tcl::dict::incr" -help\ + @cmd -name "Built-in: tcl::dict::incr" -help\ "This adds the given ${$I}increment${$NI} value (an integer that defaults to 1 if not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary @@ -1126,7 +1190,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::info - @cmd -name "Builtin: tcl::dict::info" -help\ + @cmd -name "Built-in: tcl::dict::info" -help\ "This returns information (intended for display to people) about the given dictionary though the format of this data is dependent on the implementation of the dictionary. For dictionaries that are implemented @@ -1139,7 +1203,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::keys - @cmd -name "Builtin: tcl::dict::keys" -help\ + @cmd -name "Built-in: tcl::dict::keys" -help\ "Return a list of all keys in the given dictionary value. If a pattern is supplied, only those keys that match it (according to the rules of ${$B}string match${$N}) will be returned. The returned keys will be in the order that they @@ -1152,7 +1216,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::lappend - @cmd -name "Builtin: tcl::dict::lappend" -help\ + @cmd -name "Built-in: tcl::dict::lappend" -help\ "This appends the given items to the list value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are @@ -1173,7 +1237,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::map - @cmd -name "Builtin: tcl::dict::map" -help\ + @cmd -name "Built-in: tcl::dict::map" -help\ "This command applies a transformation to each element of a dictionary, returning a new dictionary. It takes three arguments: the first is a two-element list of variable names (for the key and value respectively of @@ -1203,7 +1267,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::merge - @cmd -name "Builtin: tcl::dict::merge" -help\ + @cmd -name "Built-in: tcl::dict::merge" -help\ "Return a dictionary that contains the contents of each of the ${$I}dictionaryValue${$NI} arguments. Where two (or more) dictionaries contain a mapping for the same key, the resulting dictionary maps that @@ -1216,7 +1280,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::remove - @cmd -name "Builtin: tcl::dict::remove" -help\ + @cmd -name "Built-in: tcl::dict::remove" -help\ "Return a new dictionary that is a copy of an old one passed in as first argument except without mappings for each of the keys listed. It is legal for there to be no keys to remove, and it also legal for any of the keys @@ -1229,7 +1293,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::replace - @cmd -name "Builtin: tcl::dict::replace" -help\ + @cmd -name "Built-in: tcl::dict::replace" -help\ "Return a new dictionary that is a copy of an old one passed in as first argument except with some values different or some extra key/value pairs added. It is legal for this command to be called with no key/value pairs, @@ -1242,7 +1306,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::set - @cmd -name "Builtin: tcl::dict::set" -help\ + @cmd -name "Built-in: tcl::dict::set" -help\ "This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are @@ -1260,7 +1324,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::size - @cmd -name "Builtin: tcl::dict::size" -help\ + @cmd -name "Built-in: tcl::dict::size" -help\ "Return the number of key/value mappings in the given dictionary value." @values -min 1 -max 1 dictionaryValue -type dict @@ -1269,7 +1333,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::unset - @cmd -name "Builtin: tcl::dict::unset" -help\ + @cmd -name "Built-in: tcl::dict::unset" -help\ "This operation (the companion to ${$B}dict set${$NI}) takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable that does not contain a mapping for the given key. Where @@ -1288,7 +1352,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::update - @cmd -name "Builtin: tcl::dict::update" -help\ + @cmd -name "Built-in: tcl::dict::update" -help\ "Execute the Tcl script in ${$I}body${$NI} with the value for each ${$I}key${$NI} (as found by reading the dictionary value in ${$I}dictionaryVariable${$NI}) mapped to the variable ${$I}varName${$NI}. There may be multiple ${$I}key/varName${$NI} pairs. If a ${$I}key${$NI} does not have a @@ -1318,7 +1382,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::with - @cmd -name "Builtin: tcl::dict::with" -help\ + @cmd -name "Built-in: tcl::dict::with" -help\ "Execute the Tcl script in body with the value for each key in dictionaryVariable mapped (in a manner similarly to dict update) to a variable with the same name. Where one or more keys are available, these indicate a chain of nested dictionaries, with the innermost dictionary being the one opened out @@ -1356,7 +1420,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { lappend PUNKARGS [list { @id -id ::tcl::file::channels - @cmd -name "Builtin: tcl::file::channels" -help\ + @cmd -name "Built-in: tcl::file::channels" -help\ "If ${$I}pattern${$NI} is not specified, returns a list of names of all registered copen channels in this interpreter. If ${$I}pattern${$NI} is specified, only those names matching ${$I}pattern${$NI} are returned. @@ -1368,7 +1432,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::delete - @cmd -name "Builtin: tcl::file::delete" -help\ + @cmd -name "Built-in: tcl::file::delete" -help\ "Removes the file or directory specified by each ${$I}pathname${$NI} argument. Non-empty directories will be removed only if the ${$B}-force${$N} option is specified. When operating on symbolic links, the links themselves will be @@ -1390,7 +1454,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::copy - @cmd -name "Builtin: tcl::file::copy" -help\ + @cmd -name "Built-in: tcl::file::copy" -help\ "The first form makes a copy of the file or directory ${$I}source${$NI} under the pathname ${$I}target${$NI}. If ${$I}target${$NI} is an existing directory then the second form is used. The second form makes a copy inside ${$I}targetDir${$NI} of each ${$I}source${$NI} file listed. @@ -1424,7 +1488,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::executable - @cmd -name "Builtin: tcl::file::executable" -help\ + @cmd -name "Built-in: tcl::file::executable" -help\ "Returns ${$B}1${$N} if file ${$I}name${$NI} is executable by the current user, ${$B}0${$N} otherwise. On Windows, which does not have an executable attribute, the command treats all directories and any files with extensions ${$B}exe${$N}, ${$B}com${$N}, ${$B}cmd${$N} or ${$B}bat${$N} as executable." @@ -1434,7 +1498,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::exists - @cmd -name "Builtin: tcl::file::exists" -help\ + @cmd -name "Built-in: tcl::file::exists" -help\ "Returns ${$B}1${$N} if the file ${$I}name${$NI} exists and the current user has search privileges for the directories leading to it, ${$B}0${$N} otherwise." @values -min 0 -max 1 @@ -1443,7 +1507,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::extension - @cmd -name "Builtin: tcl::file::extension" -help\ + @cmd -name "Built-in: tcl::file::extension" -help\ "Returns all of the characters in ${$I}name${$NI} after and including the last dot in the last element of name. If there is no dot in the last element of ${$I}name${$NI} then returns the empty string." @@ -1453,7 +1517,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::home - @cmd -name "Builtin: tcl::file::home" -help\ + @cmd -name "Built-in: tcl::file::home" -help\ "If no argument is specified, the command returns the home directory of the current user. This is generally the value of the ${$B}$HOME${$N} environment variable except that on Windows platforms backslashes in the path are replaced by forward slashes. An error is raised if @@ -1468,7 +1532,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::isdirectory - @cmd -name "Builtin: tcl::file::isdirectory" -help\ + @cmd -name "Built-in: tcl::file::isdirectory" -help\ "Returns ${$B}1${$N} if the file name is a directory, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string @@ -1476,7 +1540,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::isfile - @cmd -name "Builtin: tcl::file::isfile" -help\ + @cmd -name "Built-in: tcl::file::isfile" -help\ "Returns ${$B}1${$N} if the file name is a regular file, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string @@ -1488,7 +1552,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::mkdir - @cmd -name "Builtin: tcl::file::mkdir" -help\ + @cmd -name "Built-in: tcl::file::mkdir" -help\ "Creates each directory specified. For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no @@ -1501,7 +1565,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::mtime - @cmd -name "Builtin: tcl::file::mtime" -help\ + @cmd -name "Built-in: tcl::file::mtime" -help\ "Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified. If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds @@ -1518,7 +1582,7 @@ tcl::namespace::eval punk::args::tclcore { #pathtype lappend PUNKARGS [list { @id -id ::tcl::file::readable - @cmd -name "Builtin: tcl::file::readable" -help\ + @cmd -name "Built-in: tcl::file::readable" -help\ "Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string @@ -1539,7 +1603,7 @@ tcl::namespace::eval punk::args::tclcore { #volumes lappend PUNKARGS [list { @id -id ::tcl::file::writable - @cmd -name "Builtin: tcl::file::writable" -help\ + @cmd -name "Built-in: tcl::file::writable" -help\ "Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string @@ -1551,7 +1615,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::mathfunc::abs - @cmd -name "Builtin: tcl::mathfunc::abs" -help\ + @cmd -name "Built-in: tcl::mathfunc::abs" -help\ "Returns the absolute value of ${$I}arg${$NI}. ${$I}Arg${$NI} may be either integer or floating-point, and the result is returned in the same form." @values -min 1 -max 1 @@ -1561,7 +1625,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::mathfunc::acos - @cmd -name "Builtin: tcl::mathfunc::acos" -help\ + @cmd -name "Built-in: tcl::mathfunc::acos" -help\ "Returns the arc cosine of ${$I}arg${$NI}, in the range [0,pi] radians. ${$I}Arg${$NI} should be in the range [-1,1]." @values -min 1 -max 1 @@ -1573,7 +1637,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::mathfunc::atan2 - @cmd -name "Builtin: tcl::mathfunc::atan2" -help\ + @cmd -name "Built-in: tcl::mathfunc::atan2" -help\ "Returns the arc tangent of ${$I}y/x${$NI}, in the range [-pi,pi] radians. ${$I}x${$NI} and ${$I}y${$NI} cannot both be 0. If ${$I}x${$NI} is greater than 0, this is equivalent to \"${$B}atan [expr {y/x}]${$N}\"." @@ -1586,7 +1650,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::namespace::origin - @cmd -name "Builtin: tcl::namespace::origin" -help\ + @cmd -name "Built-in: tcl::namespace::origin" -help\ "Returns the fully-qualified name of the original command to which the imported command command refers. When a command is imported into a namespace, a new command is created in that namespace that points to the @@ -1603,7 +1667,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::namespace::path - @cmd -name "Builtin: tcl::namespace::path" -help\ + @cmd -name "Built-in: tcl::namespace::path" -help\ "Returns the command resolution path of the current namespace. If namespaceList is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns @@ -1616,7 +1680,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { @id -id ::tcl::namespace::unknown - @cmd -name "Builtin: tcl::namespace::unknown" -help\ + @cmd -name "Built-in: tcl::namespace::unknown" -help\ "Sets or returns the unknown command handler for the current namespace. The handler is invoked when a command called from within the namespace cannot be found in the current namespace, the namespace's path nor in the global @@ -1631,7 +1695,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { @id -id ::tcl::namespace::which - @cmd -name "Builtin: tcl::namespace::which" -help\ + @cmd -name "Built-in: tcl::namespace::which" -help\ "Looks up name as either a command or variable and returns its fully-qulified name. For example, if name does not exist in the current namespace but does exist in the global namespace, this command returns a fully-qualified name in the global namespace. @@ -1653,7 +1717,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::process::status - @cmd -name "Builtin: tcl::process::status" -help\ + @cmd -name "Built-in: tcl::process::status" -help\ "Returns a dictionary mapping subprocess PIDs to their respective status. If ${$I}pids${$NI} is specified as a list of PIDs then the command only returns the status of the matching subprocesses if they exist. @@ -1691,7 +1755,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::process::purge - @cmd -name "Builtin: tcl::process::purge" -help\ + @cmd -name "Built-in: tcl::process::purge" -help\ "Cleans up all data associated with terminated subprocesses. If pids is specified as a list of PIDs then the command only cleans up data for the matching subprocesses if they exist. If a process listed is still @@ -1729,7 +1793,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { #test of @form @id -id ::after - @cmd -name "Builtin: after"\ + @cmd -name "Built-in: after"\ -summary\ "Execute a command after a time delay."\ -help\ @@ -1801,7 +1865,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @dynamic @id -id ::append - @cmd -name "Builtin: append"\ + @cmd -name "Built-in: append"\ -summary\ "Append to variable."\ -help\ @@ -1823,7 +1887,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::apply - @cmd -name "Builtin: apply"\ + @cmd -name "Built-in: apply"\ -summary\ {Apply an anonymous function.}\ -help\ @@ -1880,7 +1944,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @dynamic @id -id ::array - @cmd -name "Builtin: array"\ + @cmd -name "Built-in: array"\ -summary\ "Manipulate array variables"\ -help\ @@ -1897,7 +1961,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::array::default - @cmd -name "Builtin: array default"\ + @cmd -name "Built-in: array default"\ -summary\ "Manages the default value of the array."\ -help\ @@ -1909,7 +1973,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form exists @leaders - exists -type literal -help\ + exists -type literal(exists) -help\ "This returns a boolean value indicating whether a default value has been set for the array ${$I}arrayName${$NI}. Returns a false value if ${$I}arrayName${$NI} does not exist. Raises an error if ${$I}arrayName${$NI} @@ -1919,7 +1983,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form get @leaders - get -type literal -help\ + get -type literal(get) -help\ "This returns the current default value for the array ${$I}arrayName${$NI}. Raises an error if ${$I}arrayName${$NI} is an existing variable that is not an array, or if ${$I}arrayName${$NI} is an array without a default value." @@ -1928,7 +1992,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form set @leaders - set -type literal -help\ + set -type literal(set) -help\ "This sets the default value for the array ${$I}arrayName${$NI} to ${$I}value${$NI}. Returns the empty string. Raises an error if ${$I}arrayName${$NI} is an existing variable that is not an array, or if ${$I}arrayName${$NI} is an illegal name for an @@ -1940,7 +2004,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form unset @leaders - unset -type literal -help\ + unset -type literal(unset) -help\ "This removes the default value for the array ${$I}arrayName${$NI} and returns the empty string. Does nothing if ${$I}arrayName${$NI} does not have a default value. Raises an error if ${$I}arrayName${$NI} is an existing variable that is @@ -1959,7 +2023,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::break - @cmd -name "Builtin: break"\ + @cmd -name "Built-in: break"\ -summary\ "Abort looping command"\ -help\ @@ -1978,7 +2042,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::catch - @cmd -name "Builtin: catch"\ + @cmd -name "Built-in: catch"\ -summary\ "Evaluate script and trap exceptional returns."\ -help\ @@ -2055,7 +2119,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @dynamic @id -id ::concat - @cmd -name "Builtin: concat"\ + @cmd -name "Built-in: concat"\ -summary\ "Join lists together."\ -help\ @@ -2073,7 +2137,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::const - @cmd -name "Builtin: const"\ + @cmd -name "Built-in: const"\ -summary\ "Create and initialise a constant."\ -help\ @@ -2102,7 +2166,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::continue - @cmd -name "Builtin: continue"\ + @cmd -name "Built-in: continue"\ -summary\ "Skip to the next iteration of a loop."\ -help\ @@ -2120,7 +2184,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::eof - @cmd -name "Builtin: eof"\ + @cmd -name "Built-in: eof"\ -summary\ "Check for end of file condition on channel"\ -help\ @@ -2137,7 +2201,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::error - @cmd -name "Builtin: error"\ + @cmd -name "Built-in: error"\ -summary\ "Generate an error."\ -help\ @@ -2179,9 +2243,110 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl error]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::eval + @cmd -name "Built-in: eval"\ + -summary\ + "Evaluate a Tcl script."\ + -help\ + "${$B}Eval${$N} takes one or more arguments, which together comprise a Tcl script containing + one or more commands. ${$B}Eval${$N} concatenates all its arguments in the same fashion as the + ${$B}concat${$N} command, passes the concatenated string to the Tcl interpreter recursively, + and returns the result of that evaluation (or any error generated by it). + Note that the ${$B}list${$N} command quotes sequences of words in such a way that they are not + further expanded by the ${$B}eval${$N} command; for any values, $a, $b, and $c, these two lines + are effectively equivalent: + + eval [list $a $b $c] + $a $b $c + " + @values -min 1 -max -1 + arg -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl eval]"\ + {@examples -help { + Often, it is useful to store a fragment of a script in a variable and execute it later on + with extra values appended. This technique is used in a number of places throughout the Tcl + core (e.g. in ${$B}fcopy${$N}, ${$B}lsort${$N} and ${$B}trace${$N} command callbacks). This example shows how to do this + using core Tcl commands: + ${[punk::args::tclcore::argdoc::example { + set script { + puts "logging now" + lappend $myCurrentLogVar + } + set myCurrentLogVar log1 + # Set up a switch of logging variable part way through! + after 20000 set myCurrentLogVar log2 + + for {set i 0} {$i<10} {incr i} { + # Introduce a random delay + after [expr {int(5000 * rand())}] + update ;# Check for the asynch log switch + eval $script $i [clock clicks] + } + }]} + Note that in the most common case (where the script fragment is actually just a list of words + forming a command prefix), it is better to use {*}$script when doing this sort of invocation + pattern. It is less general than the eval command, and hence easier to make robust in practice. + The following procedure acts in a way that is analogous to the lappend command, except it + inserts the argument values at the start of the list in the variable: + ${[punk::args::tclcore::argdoc::example { + proc lprepend {varName args} { + upvar 1 $varName var + # Ensure that the variable exists and contains a list + lappend var + # Now we insert all the arguments in one go + set var [eval [list linsert $var 0] $args] + } + }]} + However, the last line would now normally be written without eval, like this: + ${[punk::args::tclcore::argdoc::example { + set var [linsert $var 0 {*}$args] + }]} + Or indeed like this: + ${[punk::args::tclcore::argdoc::example { + set var [list {*}$args {*}$var] + }]} + } + }] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::exit + @cmd -name "Built-in: exit"\ + -summary\ + "End the application."\ + -help\ + "Terminate the process, returning ${$I}returnCode${$NI} to the system as the exit status. + If ${$I}returnCode${$NI} is not specified then it default to 0." + @values -min 0 -max 1 + returnCode -type integer -default 0 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl exit]"\ + {@examples -help { + Since non-zero exit codes are usually interpreted as error cases by the calling process, + the exit command is an important part of signaling that something fatal has gone wrong. + This code fragment is useful in scripts to act as a general problem trap: + ${[punk::args::tclcore::argdoc::example { + proc main {} { + # ... put the real main code in here ... + } + + if {[catch {main} msg options]} { + puts stderr "unexpected script error: $msg" + if {[info exists env(DEBUG)]} { + puts stderr "---- BEGIN TRACE ----" + puts stderr [dict get $options -errorinfo] + puts stderr "---- END TRACE ----" + } + + # Reserve code 1 for "expected" error exits... + exit 2 + } + }]} + } + }] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::build-info - @cmd -name "Builtin: tcl::build-info"\ + @cmd -name "Built-in: tcl::build-info"\ -summary\ "Build info."\ -help\ @@ -2300,7 +2465,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::exec - @cmd -name "Builtin: exec"\ + @cmd -name "Built-in: exec"\ -summary\ "Invoke subprocesses."\ -help\ @@ -2340,7 +2505,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::expr - @cmd -name "Builtin: expr"\ + @cmd -name "Built-in: expr"\ -summary\ "Evaluate an expression."\ -help\ @@ -2369,7 +2534,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::for - @cmd -name "Builtin: for"\ + @cmd -name "Built-in: for"\ -summary\ "'For' loop"\ -help\ @@ -2405,10 +2570,9 @@ tcl::namespace::eval punk::args::tclcore { "Tcl script" } "@doc -name Manpage: -url [manpage_tcl for]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::foreach - @cmd -name "Builtin: foreach"\ + @cmd -name "Built-in: foreach"\ -summary\ "Iterate over all elements in one or more lists."\ -help\ @@ -2437,11 +2601,23 @@ tcl::namespace::eval punk::args::tclcore { body -type string -optional 0 -help\ "Tcl script" } "@doc -name Manpage: -url [manpage_tcl foreach]" ] - # -- --- --- --- - + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::gets + @cmd -name "Built-in: gets"\ + -summary\ + "Read a line from a channel"\ + -help\ + "The ${$B}gets${$N} command has been superceded by the ${$B}chan gets${$N} command + which supports the same syntax and optsion." + @values + channel + varName -optional 1 + } "@doc -name Manpage: -url [manpage_tcl gets]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::glob - @cmd -name "Builtin: glob"\ + @cmd -name "Built-in: glob"\ -summary\ "Return names of files that match patterns."\ -help\ @@ -2532,7 +2708,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::global - @cmd -name "Builtin: global"\ + @cmd -name "Built-in: global"\ -summary\ "Access global variables from procs."\ -help\ @@ -2563,7 +2739,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::if - @cmd -name "builtin: if"\ + @cmd -name "Built-in: if"\ -summary\ "Execute scripts conditionally."\ -help\ @@ -2587,7 +2763,7 @@ tcl::namespace::eval punk::args::tclcore { @leaders -min 0 -max 0 @values -min 2 -max -1 expr1 -type expr -optional 0 - then -type literal -optional 1 + then -type literal(then) -optional 1 body1 -type script -optional 0 #todo - punk::args variable-length striding by use of ?name? in -type list "elseif_clause" -type {literal(elseif) expr ?literal(then)? script} -optional 1 -multiple 1 @@ -2597,7 +2773,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::incr - @cmd -name "builtin: incr"\ + @cmd -name "Built-in: incr"\ -summary\ "Increment the value of a variable."\ -help\ @@ -2621,7 +2797,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @dynamic @id -id ::join - @cmd -name "Builtin: join"\ + @cmd -name "Built-in: join"\ -summary\ "Create a string by joining together list elements."\ -help\ @@ -2637,7 +2813,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lappend - @cmd -name "builtin: lappend"\ + @cmd -name "Built-in: lappend"\ -summary\ "Append list elements onto a variable."\ -help\ @@ -2663,7 +2839,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lassign - @cmd -name "builtin: lassign"\ + @cmd -name "Built-in: lassign"\ -summary\ "Assign list elements to variables."\ -help\ @@ -2683,7 +2859,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::ledit - @cmd -name "builtin: ledit"\ + @cmd -name "Built-in: ledit"\ -summary\ "Replace elements of a list stored in variable."\ -help\ @@ -2754,7 +2930,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lindex - @cmd -name "builtin: lindex"\ + @cmd -name "Built-in: lindex"\ -summary\ "Retrieve an element from a list."\ -help\ @@ -2793,7 +2969,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::linsert - @cmd -name "builtin: linsert"\ + @cmd -name "Built-in: linsert"\ -summary\ "Insert elements into a list."\ -help\ @@ -2822,7 +2998,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::list - @cmd -name "builtin: list"\ + @cmd -name "Built-in: list"\ -summary\ "Create a list."\ -help\ @@ -2841,7 +3017,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::llength - @cmd -name "builtin: llength"\ + @cmd -name "Built-in: llength"\ -summary\ "Count the number of elements in a list."\ -help\ @@ -2855,7 +3031,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lmap - @cmd -name "Builtin: lmap"\ + @cmd -name "Built-in: lmap"\ -summary\ "Iterate over all elements in one or more lists and collect results."\ -help\ @@ -2893,7 +3069,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lpop - @cmd -name "builtin: lpop"\ + @cmd -name "Built-in: lpop"\ -summary\ "Get and remove an element in a list."\ -help\ @@ -2920,7 +3096,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lrange - @cmd -name "builtin: lrange"\ + @cmd -name "Built-in: lrange"\ -summary\ "return one or more adjacent elements from a list."\ -help\ @@ -2942,7 +3118,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lrepeat - @cmd -name "builtin: lrepeat"\ + @cmd -name "Built-in: lrepeat"\ -summary\ "Build a list by repeating elements."\ -help\ @@ -2959,7 +3135,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lreplace - @cmd -name "builtin: lreplace"\ + @cmd -name "Built-in: lreplace"\ -summary\ "Replace elements in a list with new elements."\ -help\ @@ -2997,7 +3173,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lremove - @cmd -name "builtin: lremove"\ + @cmd -name "Built-in: lremove"\ -summary\ "Remove elements from a list by index."\ -help\ @@ -3020,7 +3196,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lreverse - @cmd -name "builtin: lreverse"\ + @cmd -name "Built-in: lreverse"\ -summary\ "Reverse the order of a list."\ -help\ @@ -3036,7 +3212,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lset - @cmd -name "builtin: lset"\ + @cmd -name "Built-in: lset"\ -summary\ "Change an element in a list."\ -help\ @@ -3105,7 +3281,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lseq - @cmd -name "builtin: lseq"\ + @cmd -name "Built-in: lseq"\ -summary\ "Build a numeric sequence returned as a list."\ -help\ @@ -3168,7 +3344,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::lsearch - @cmd -name "builtin: lsearch"\ + @cmd -name "Built-in: lsearch"\ -summary\ "See if a list contains a particular element."\ -help\ @@ -3274,7 +3450,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lsort - @cmd -name "builtin: lsort"\ + @cmd -name "Built-in: lsort"\ -summary\ "Sort the elements of a list."\ -help\ @@ -3394,7 +3570,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::proc - @cmd -name "builtin: proc"\ + @cmd -name "Built-in: proc"\ -summary\ "Create a Tcl procedure."\ -help\ @@ -3459,7 +3635,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::puts - @cmd -name "builtin: puts"\ + @cmd -name "Built-in: puts"\ -summary\ "Write to a channel."\ -help\ @@ -3472,11 +3648,73 @@ tcl::namespace::eval punk::args::tclcore { string -type string } "@doc -name Manpage: -url [manpage_tcl puts]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::pwd + @cmd -name "Built-in: pwd"\ + -summary\ + "Return the absolute path of the current working directory."\ + -help\ + "Returns the absolute path name of the current working directory. + (This is a process-wide value) + + ${$B}EXAMPLE${$N} + Sometimes it is useful to change to a known directory when running some external + command using exec, but it is important to keep the application usually running + in the directory that it was started in (unless the user specifies otherwise) + since that minimizes user confusion. The way to do this is to save the current + directory while the external command is being run: + ${[punk::args::tclcore::argdoc::example { + set tarFile [file normalize somefile.tar] + set savedDir [pwd] + cd /tmp + exec tar -xf $tarFile + cd $savedDir + }]}" + @leaders -min 0 -max 0 + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl pwd]"\ + {@examples -help { + Sometimes it is useful to change to a known directory when running some external + command using exec, but it is important to keep the application usually running + in the directory that it was started in (unless the user specifies otherwise) + since that minimizes user confusion. The way to do this is to save the current + directory while the external command is being run: + ${[punk::args::tclcore::argdoc::example { + set tarFile [file normalize somefile.tar] + set savedDir [pwd] + cd /tmp + exec tar -xf $tarFile + cd $savedDir + }]} + } + } + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::read + @cmd -name "Built-in: read"\ + -summary\ + "Read from a channel."\ + -help\ + "The ${$B}read${$N} command has been superceded by the ${$B}chan read${$N} command which supports + the same syntax and options." + @form -form read + @opts + -nonewline -type none + @values -min 1 -max 1 + channel + + @form -form readchars + @values -min 1 -max 2 + channel + numChars -type integer -optional 1 + } "@doc -name Manpage: -url [manpage_tcl read]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::rename - @cmd -name "builtin: rename"\ + @cmd -name "Built-in: rename"\ -summary\ "Rename or delete a command."\ -help\ @@ -3494,7 +3732,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::return - @cmd -name "builtin: return"\ + @cmd -name "Built-in: return"\ -summary\ "Return from a procedure, or set return code of script."\ -help\ @@ -3676,7 +3914,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::set - @cmd -name "builtin: set"\ + @cmd -name "Built-in: set"\ -summary\ "Read and write variables."\ -help\ @@ -3719,7 +3957,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::socket - @cmd -name "builtin: socket"\ + @cmd -name "Built-in: socket"\ -summary\ "Open a TCP network connection."\ -help\ @@ -3908,7 +4146,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::source - @cmd -name "builtin: source"\ + @cmd -name "Built-in: source"\ -summary\ "Evaluate a file or resource as a Tcl script."\ -help\ @@ -3954,7 +4192,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::split - @cmd -name "builtin: split"\ + @cmd -name "Built-in: split"\ -summary\ "Split a string into a proper Tcl list."\ -help\ @@ -3979,7 +4217,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::cat - @cmd -name "builtin: tcl::string::cat"\ + @cmd -name "Built-in: tcl::string::cat"\ -summary\ "Concatenate strings."\ -help\ @@ -3997,7 +4235,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::compare - @cmd -name "builtin: tcl::string::compare" -help\ + @cmd -name "Built-in: tcl::string::compare" -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns -1, 0, or 1, dpending on whether string1 is lexicographically lessthan, equal to, or greater than string2" @@ -4017,7 +4255,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::equal - @cmd -name "builtin: tcl::string::equal"\ + @cmd -name "Built-in: tcl::string::equal"\ -summary\ "Compare strings."\ -help\ @@ -4038,7 +4276,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::first - @cmd -name "builtin: tcl::string::first" -help\ + @cmd -name "Built-in: tcl::string::first" -help\ "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters in ${$I}needleString${$NI}. If found, return the index of the first character in the first such match within ${$I}haystackString${$NI}. If there is no match, then return -1. If startIndex is @@ -4061,7 +4299,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::index - @cmd -name "builtin: tcl::string::index" -help\ + @cmd -name "Built-in: tcl::string::index" -help\ "Returns the ${$I}charIndex${$NI}'th character of the ${$I}string${$NI} argument. A ${$I}charIndex${$NI} of 0 corresponds to the first character of the string. ${$I}charIndex${$NI} may be specified as described in the STRING INDICES section." @@ -4072,7 +4310,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::insert - @cmd -name "builtin: tcl::string::insert" -help\ + @cmd -name "Built-in: tcl::string::insert" -help\ "Returns a copy of string with insertString inserted at the index'th character. If index is start-relative, the first character inserted in the returned string will be at the specified index. @@ -4093,7 +4331,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::last - @cmd -name "builtin: tcl::string::last" -help\ + @cmd -name "Built-in: tcl::string::last" -help\ "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters in ${$I}needleString${$NI}. If found, return the index of the first character in the last such match within ${$I}haystackString${$NI}. If there is no match, then return -1. If lastIndex is @@ -4115,7 +4353,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::length - @cmd -name "builtin: tcl::string::length" -help\ + @cmd -name "Built-in: tcl::string::length" -help\ "Returns a decimal string giving the number of characters in ${$I}string${$NI}. Note that this is not necessarily the same as the number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), @@ -4126,7 +4364,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::map - @cmd -name "builtin: tcl::string::map" -help\ + @cmd -name "Built-in: tcl::string::map" -help\ "Replaces substrings in string based on the key-value pairs in ${$I}mapping${$NI}. ${$I}mapping${$NI} is a list of key value key value ... as in the form returned by ${$B}array get${$N}. Each instance of a key in the string will be replaced with its corresponding value. If ${$B}-nocase${$N} is @@ -4153,7 +4391,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::match - @cmd -name "builtin: tcl::string::match" -help\ + @cmd -name "Built-in: tcl::string::match" -help\ {See if pattern matches string; return 1 if it does, 0 if it does not. If -nocase is specified, then the pattern attempts to match against the string in a case insensitive manner. For the two strings to match, their contents must be identical except that the @@ -4181,7 +4419,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::range - @cmd -name "builtin: tcl::string::range" -help\ + @cmd -name "Built-in: tcl::string::range" -help\ "Returns a range of consecutive characters from ${$I}string${$NI}, starting with the character whose index is ${$I}first${$NI} and ending with the character whose index is ${$I}last${$NI} (using the forms described in ${$B}STRING INDICES${$N}). An index of ${$B}0${$N} refers to the first character of the string; an index of @@ -4197,7 +4435,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::repeat - @cmd -name "builtin: tcl::string::repeat"\ + @cmd -name "Built-in: tcl::string::repeat"\ -summary\ "Build a string by repeating elements."\ -help\ @@ -4210,7 +4448,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::replace - @cmd -name "builtin: tcl::string::replace" -help\ + @cmd -name "Built-in: tcl::string::replace" -help\ "Removes a range of consecutive characters from string, starting with the character whose index is first and ending with the character whose index is last (Using the forms described in STRING_INDICES). An index of 0 refers to the first @@ -4230,7 +4468,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::reverse - @cmd -name "builtin: tcl::string::reverse" -help\ + @cmd -name "Built-in: tcl::string::reverse" -help\ "Returns a string that is the same length as ${$I}string${$NI} but with its characters in reverse order." @values -min 1 -max 1 @@ -4239,48 +4477,57 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::tolower - @cmd -name "builtin: tcl::string::tolower" -help\ + @cmd -name "Built-in: tcl::string::tolower" -help\ "Returns a value equal to ${$I}string${$NI} except that all upper (or title) case case letters have - been converted to lower case." + been converted to lower case. + ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." @values -min 1 -max 3 string -type string first -type indexexpression -optional 1 -help\ - "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying." + "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying. + If ${$I}last${$NI} is ${$B}not${$N} specified, only the character at position ${$I}first${$NI} is converted, otherwise ${$I}last${$NI} refers to + the char index in the string to stop at (inclusive)." last -type indexexpression -optional 1 -help\ "If ${$I}last${$NI} is specified, it refers to the char index in the string to stop at (inclusive)." } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::totitle - @cmd -name "builtin: tcl::string::totitle" -help\ + @cmd -name "Built-in: tcl::string::totitle" -help\ "Returns a value equal to string except that the first character in string is converted to its Unicode title case variant (or upper case if there is no title case variant) and the - rest of the string is converted to lower case." + rest of the string is converted to lower case. + ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." @values -min 1 -max 3 string -type string first -type indexexpression -optional 1 -help\ - "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying." + "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying. + If ${$I}last${$NI} is ${$B}not${$N} specified, only the character at position ${$I}first${$NI} is converted, otherwise ${$I}last${$NI} refers to + the char index in the string to stop at (inclusive)." last -type indexexpression -optional 1 -help\ "If ${$I}last${$NI} is specified, it refers to the char index in the string to stop at (inclusive)." } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::toupper - @cmd -name "builtin: tcl::string::toupper" -help\ + @cmd -name "Built-in: tcl::string::toupper" -help\ "Returns a value equal to ${$I}string${$NI} except that all lower (or title) case case letters have - been converted to upper case." + been converted to upper case. + ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." @values -min 1 -max 3 string -type string first -type indexexpression -optional 1 -help\ - "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying." + "If ${$I}first${$NI} is specified, it refers to the first char index in the string to start modifying. + If ${$I}last${$NI} is ${$B}not${$N} specified, only the character at position ${$I}first${$NI} is converted, otherwise ${$I}last${$NI} refers to + the char index in the string to stop at (inclusive)." last -type indexexpression -optional 1 -help\ "If ${$I}last${$NI} is specified, it refers to the char index in the string to stop at (inclusive)." } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::trim - @cmd -name "builtin: tcl::string::trim" -help\ + @cmd -name "Built-in: tcl::string::trim" -help\ {Returns a value equal to ${$I}string${$NI} except that any leading or trailing characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -4290,7 +4537,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::trimleft - @cmd -name "builtin: tcl::string::trimleft" -help\ + @cmd -name "Built-in: tcl::string::trimleft" -help\ {Returns a value equal to ${$I}string${$NI} except that any leading characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -4300,7 +4547,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::trimright - @cmd -name "builtin: tcl::string::trimright" -help\ + @cmd -name "Built-in: tcl::string::trimright" -help\ {Returns a value equal to ${$I}string${$NI} except that any trailing characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -4312,7 +4559,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::wordend - @cmd -name "builtin: tcl::string::wordend" -help\ + @cmd -name "Built-in: tcl::string::wordend" -help\ "Returns the index of the character just after the last one in the word containing character ${$I}charIndex${$NI} of ${$I}string${$NI}. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) @@ -4328,7 +4575,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::wordstart - @cmd -name "builtin: tcl::string::wordstart" -help\ + @cmd -name "Built-in: tcl::string::wordstart" -help\ "Returns the index of the first character in the word containing character ${$I}charIndex${$NI} of ${$I}string${$NI}. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) @@ -4346,7 +4593,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define [punk::args::lib::tstr -return string { @id -id ::tcl::string::is - @cmd -name "builtin: tcl::string::is" -help\ + @cmd -name "Built-in: tcl::string::is" -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. " @leaders -min 1 -max 1 @@ -4508,7 +4755,7 @@ tcl::namespace::eval punk::args::tclcore { dict for {sclass slabel} $string_class_choicelabels { punk::args::define [string map [list %sc% $sclass %slabel% $slabel] { @id -id "::tcl::string::is %sc%" - @cmd -name "builtin: string is %sc%" -help\ + @cmd -name "Built-in: string is %sc%" -help\ {%slabel%} ${[punk::args::resolved_def -types opts ::tcl::string::is -*]} @values -min 1 -max 1 @@ -4519,7 +4766,7 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { punk::args::define { @id -id ::subst - @cmd -name "builtin: subst"\ + @cmd -name "Built-in: subst"\ -summary\ "Perform backslash, command, and variable substitutions."\ -help\ @@ -4572,7 +4819,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::switch - @cmd -name "builtin: switch"\ + @cmd -name "Built-in: switch"\ -summary\ "Evaluate one of several scripts, depending on a given value."\ -help\ @@ -4656,11 +4903,9 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl switch]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - punk::args::define { @id -id ::tailcall - @cmd -name "builtin: tailcall"\ + @cmd -name "Built-in: tailcall"\ -summary\ "Replace the current procedure with another command."\ -help\ @@ -4678,12 +4923,46 @@ tcl::namespace::eval punk::args::tclcore { command -type string arg -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl tailcall]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::throw + @cmd -name "Built-in: throw"\ + -summary\ + "Generate a machine-readable error."\ + -help\ + "This command causes the current evaluation to be unwound with an error. + The error created is described by the type and message arguments: type must + contain a list of words describing the error in a form that is + machine-readable (and which will form the error-code part of the result + dictionary), and message should contain text that is intended for display to + a human being. + The stack will be unwound until the error is trapped by a suitable catch or + try command. If it reaches the event loop without being trapped, it will be + reported through the bgerror mechanism. If it reaches the top level of script + evaluation in tclsh, it will be printed on the console before, in the + non-interactive case, causing an exit (the behavior in other programs will + depend on the details of how Tcl is embedded and used). + + By convention, the words in the type argument should go from most general to + most specific. + ${B}EXAMPLES${$N} + The following produces an error that is identical to that produced by expr + when trying to divide a value by zero. + ${[punk::args::tclcore::argdoc::example { + throw {ARITH DIVZERO {divide by zero}} {divide by zero} + }]}" + @values -min 2 -max 2 + type -type list + message -type string + } "@doc -name Manpage: -url [manpage_tcl throw]" + + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::trace - @cmd -name "builtin: trace"\ + @cmd -name "Built-in: trace"\ -summary\ "Monitor variable accesses, command usages and command executions."\ -help\ @@ -4705,7 +4984,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace add" - @cmd -name "builtin: trace add" -help\ + @cmd -name "Built-in: trace add" -help\ "" @form -synopsis "trace add type name ops ?args?" @leaders @@ -4721,7 +5000,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace add command" - @cmd -name "builtin: trace add command" -help\ + @cmd -name "Built-in: trace add command" -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is modified in one of the ways given by the list ops. Name will be resolved using the usual namespace resolution rules @@ -4768,7 +5047,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace add execution" - @cmd -name "builtin: trace add execution" -help\ + @cmd -name "Built-in: trace add execution" -help\ "Arrange for commandPrefix to be executed (with additional arguments) whenever command name is executed, with traces occurring at the points indicated by the list ops. Name will be resolved using the usual namespace @@ -4870,7 +5149,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id "::trace remove command" - @cmd -name "builtin: trace remove command" -help\ + @cmd -name "Built-in: trace remove command" -help\ "If there is a trace set on command name with the operations and command given by opList and commandPrefix, then the trace is removed, so that commandPrefix will never again be invoked. Returns an empty string. If @@ -4891,7 +5170,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::try - @cmd -name "builtin: try"\ + @cmd -name "Built-in: try"\ -summary\ "Trap and process errors and exceptions"\ -help\ @@ -5014,7 +5293,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::variable - @cmd -name "builtin: variable"\ + @cmd -name "Built-in: variable"\ -summary\ "Create and initialise a namespace variable."\ -help\ @@ -5050,7 +5329,7 @@ tcl::namespace::eval punk::args::tclcore { "name value" -type {string any} -optional 1 -multiple 1 name -type string -optional 1 - #In this case - we don't want name_value to display - as this is only used for documenting a builtin + #In this case - we don't want name_value to display - as this is only used for documenting a Built-in #For the case where an @arggroups is used also for parsing - the help should display the synopsis form #and also the name of the var in which it is placed. # e.g @@ -5072,7 +5351,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::vwait - @cmd -name "builtin: ::vwait"\ + @cmd -name "Built-in: ::vwait"\ -summary\ "Process events until a variable is written."\ -help\ @@ -5309,7 +5588,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::unset - @cmd -name "Builtin: unset"\ + @cmd -name "Built-in: unset"\ -summary\ {Delete variables.}\ -help\ @@ -5334,10 +5613,62 @@ tcl::namespace::eval punk::args::tclcore { @values -min 0 -max -1 name -type string -multiple 1 -optional 1 } "@doc -name Manpage: -url [manpage_tcl upvar]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::update + @cmd -name "Built-in: update"\ + -summary\ + {Process pending events and idle callbacks.}\ + -help\ + "This command is used to bring the application “up to date” by entering the + event loop repeatedly until all pending events (including idle callbacks) + have been processed. + If the idletasks keyword is specified as an argument to the command, then no + new events or errors are processed; only idle callbacks are invoked. This + causes operations that are normally deferred, such as display updates and + window layout calculations, to be performed immediately. + + The update idletasks command is useful in scripts where changes have been + made to the application's state and you want those changes to appear on the + display immediately, rather than waiting for the script to complete. Most + display updates are performed as idle callbacks, so update idletasks will + cause them to run. However, there are some kinds of updates that only happen + in response to events, such as those triggered by window size changes; these + updates will not occur in update idletasks. + + The update command with no options is useful in scripts where you are + performing a long-running computation but you still want the application to + respond to events such as user interactions; if you occasionally call update + then user input will be processed during the next call to update." + @leaders -min 0 -max 0 + @opts + -idletasks -type none + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl update]"\ + {@examples -help { + Run computations for about a second and then finish: + ${[punk::args::tclcore::argdoc::example { + set x 1000 + set done 0 + after 1000 set done 1 + while {!$done} { + # A very silly example! + set x [expr {log($x) ** 2.8}] + + # Test to see if our time-limit has been hit. This would + # also give a chance for serving network sockets and, if + # the Tk package is loaded, updating a user interface. + update + } + }]} + } + }] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::uplevel - @cmd -name "Builtin: uplevel"\ + @cmd -name "Built-in: uplevel"\ -summary\ "Execute a script in a different stack frame."\ -help\ @@ -5393,7 +5724,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::upvar - @cmd -name "Builtin: upvar"\ + @cmd -name "Built-in: upvar"\ -summary\ {Create link to variable in a different stack frame.}\ -help\ @@ -5456,7 +5787,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::while - @cmd -name "Builtin: while"\ + @cmd -name "Built-in: while"\ -summary\ {Execute script repeatedly as long as a condition is met.}\ -help\ @@ -5507,7 +5838,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib adler32" - @cmd -name "builtin: ::zlib adler32"\ + @cmd -name "Built-in: ::zlib adler32"\ -summary\ "Compute Adler-32 checksum."\ -help\ @@ -5523,7 +5854,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib crc32" - @cmd -name "builtin: ::zlib crc32"\ + @cmd -name Built-in: ::zlib crc32"\ -summary\ "Compute CRC-32 checksum."\ -help\ @@ -5539,7 +5870,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib compress" - @cmd -name "builtin: ::zlib compress"\ + @cmd -name "Built-in: ::zlib compress"\ -summary\ "Compress with zlib-format."\ -help\ @@ -5554,7 +5885,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib decompress" - @cmd -name "builtin: ::zlib decompress"\ + @cmd -name "Built-in: ::zlib decompress"\ -summary\ "Decompress zlib-format."\ -help\ @@ -5568,7 +5899,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib deflate" - @cmd -name "builtin: ::zlib deflate" -help\ + @cmd -name "Built-in: ::zlib deflate" -help\ "Returns the raw compressed binary data of the binary string in ${$I}string${$NI}. If present, ${$I}level${$NI} gives the compression level to use (from 0, which is uncompressed, to 9, maximally compressed)." @@ -5579,7 +5910,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib push" - @cmd -name "builtin: ::zlib push"\ + @cmd -name "Built-in: ::zlib push"\ -summary\ "Push a compressing/decompressing transform onto a channel."\ -help\ @@ -5680,7 +6011,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gunzip" - @cmd -name "builtin: ::zlib gunzip"\ + @cmd -name "Built-in: ::zlib gunzip"\ -summary\ "Decompress gzip format."\ -help\ @@ -5714,7 +6045,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gzip" - @cmd -name "builtin: ::zlib gzip"\ + @cmd -name "Built-in: ::zlib gzip"\ -summary\ "Compress with gzip format."\ -help\ @@ -5782,7 +6113,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::zlib - @cmd -name "builtin: ::zlib"\ + @cmd -name "Built-in: ::zlib"\ -summary\ "Zlib library compression and decompression operations."\ -help\ @@ -5837,7 +6168,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id ::zipfs - @cmd -name "builtin: ::zipfs"\ + @cmd -name "Built-in: ::zipfs"\ -summary\ "Mount and work with ZIP files within Tcl."\ -help\ @@ -5862,7 +6193,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::canonical - @cmd -name "builtin: ::zipfs::canonical" -help\ + @cmd -name "Built-in: ::zipfs::canonical" -help\ "This takes the name of a file, ${$I}filename${$NI}, and produces where it would be mapped into a zipfs mount as its result. If specified, mountpoint says within which mount the mapping will be done; if omitted, the main root of @@ -5875,7 +6206,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::exists - @cmd -name "builtin: ::zipfs::exists" -help\ + @cmd -name "Built-in: ::zipfs::exists" -help\ "Return 1 if the given filename exists in the mounted zipfs and 0 if it does not." @leaders -min 0 -max 0 @values -min 1 -max 1 @@ -5884,7 +6215,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::find - @cmd -name "builtin: ::zipfs::find" -help\ + @cmd -name "Built-in: ::zipfs::find" -help\ "Returns the list of paths under directory ${$I}directoryName${$NI} which need not be within a zipfs mounted archive. The paths are prefixed with ${$I}directoryName${$NI}. This command is also used by the ${$B}zipfs mkzip${$N} and @@ -5896,7 +6227,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::info - @cmd -name "builtin: ::zipfs::info" -help\ + @cmd -name "Built-in: ::zipfs::info" -help\ "Return information about the given ${$I}file${$NI} in the mounted zipfs. The information consists of: 1. the name of the ZIP archive file that contains the file, @@ -5915,7 +6246,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::list - @cmd -name "builtin: ::zipfs::list" -help\ + @cmd -name "Built-in: ::zipfs::list" -help\ "If pattern is not specified, the command returns a list of files across all zipfs mounted archives. If pattern is specified, only those paths matching the pattern are returned. By default, or with the -glob option, @@ -5936,7 +6267,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkimg - @cmd -name "builtin: ::zipfs::lmkimg" -help\ + @cmd -name "Built-in: ::zipfs::lmkimg" -help\ "This command is like ${$B}zipfs mkimg${$N}, but instead of an input directory, ${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files to be copied into the archive in the image, and the even elements are @@ -5951,7 +6282,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkzip - @cmd -name "builtin: ::zipfs::lmkzip" -help\ + @cmd -name "Built-in: ::zipfs::lmkzip" -help\ "This command is like ${$B}zipfs mkzip${$N}, but instead of an input directory, ${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files to be copied into the archive, and the even elements are their respective @@ -5965,7 +6296,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mount - @cmd -name "builtin: ::zipfs::mount" -help\ + @cmd -name "Built-in: ::zipfs::mount" -help\ "The ${$B}zipfs mount${$N} command mounts ZIP archives as Tcl virtual file systems and returns information about current mounts. @@ -6010,7 +6341,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mountdata - @cmd -name "builtin: ::zipfs::mountdata" -help\ + @cmd -name "Built-in: ::zipfs::mountdata" -help\ "Mounts the ZIP archive content ${$I}data${$NI} as a Tcl virtual filesystem at ${$I}mountpoint${$NI}." @leaders -min 0 -max 0 @values -min 1 -max 1 @@ -6020,7 +6351,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkzip - @cmd -name "builtin: ::zipfs::mkzip"\ + @cmd -name "Built-in: ::zipfs::mkzip"\ -summary\ "Create a ZIP archive."\ -help\ @@ -6043,7 +6374,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkimg - @cmd -name "builtin: ::zipfs::mkimg" -help\ + @cmd -name "Built-in: ::zipfs::mkimg" -help\ "Creates an image (potentially a new executable file) similar to ${$B}zipfs mkzip${$N}; see that command for a description of most parameters to this command, as they behave identically here. If outfile exists, it will be silently @@ -6085,7 +6416,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkkey - @cmd -name "builtin: ::zipfs::mkzip" -help\ + @cmd -name "Built-in: ::zipfs::mkzip" -help\ "Given the clear text ${$I}password${$NI} argument, an obfuscated string version is returned with the same format used in the ${$B}zipfs mkimg${$N} command." @leaders -min 0 -max 0 @@ -6095,7 +6426,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::root - @cmd -name "builtin: ::zipfs::root" -help\ + @cmd -name "Built-in: ::zipfs::root" -help\ "Returns a constant string which indicates the mount point for zipfs volumes for the current platform. User should not rely on the mount point being the same constant string for all platforms." @@ -6106,7 +6437,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::unmount - @cmd -name "builtin: ::zipfs::unmount" -help\ + @cmd -name "Built-in: ::zipfs::unmount" -help\ "Unmounts a previously mounted ZIP archive mounted to ${$I}mountpoint${$NI}. The command will fail with an error exception if there are any files within the mounted archive are open." diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index 3a5f25b0..8d5a5dca 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -449,7 +449,7 @@ tcl::namespace::eval punk::config { Accepts globs eg XDG*" @leaders -min 1 -max 1 #todo - load more whichconfig choices? - whichconfig -type string -choices {config startup-configuration running-configuration} + whichconfig -type any -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 }] @@ -495,7 +495,7 @@ tcl::namespace::eval punk::config { @cmd -name punk::config::configure -help\ "Get/set configuration values from a config" @leaders -min 1 -max 1 - whichconfig -type string -choices {defaults startup-configuration running-configuration} + whichconfig -type any -choices {defaults startup-configuration running-configuration} @values -min 0 -max 2 key -type string -optional 1 newvalue -optional 1 diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 5ed85ce7..6bd5aeb1 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -347,7 +347,7 @@ tcl::namespace::eval punk::lib::compat { proc ledit {lvar first last args} { upvar $lvar l #use lindex_resolve to support for example: ledit lst end+1 end+1 h i - set fidx [punk::lib::lindex_resolve $l $first] + set fidx [punk::lib::lindex_resolve [llength $l] $first] switch -exact -- $fidx { -3 { #index below lower bound @@ -363,7 +363,7 @@ tcl::namespace::eval punk::lib::compat { set pre [lrange $l 0 $first-1] } } - set lidx [punk::lib::lindex_resolve $l $last] + set lidx [punk::lib::lindex_resolve [llength $l] $last] switch -exact -- $lidx { -3 { #index below lower bound @@ -741,14 +741,15 @@ namespace eval punk::lib { proc lswap {lvar a z} { upvar $lvar l - if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { + set len [llength $l] + if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} { #lindex_resolve_basic returns only -1 if out of range #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred #(e.g using: lswap mylist end-2 end on a two element list) #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) - set a_index [lindex_resolve $l $a] + set a_index [lindex_resolve $len $a] set a_msg "" switch -- $a_index { -2 { @@ -758,7 +759,7 @@ namespace eval punk::lib { set a_msg "1st supplied index $a is below the lower bound for the list (0)" } } - set z_index [lindex_resolve $l $z] + set z_index [lindex_resolve $len $z] set z_msg "" switch -- $z_index { -2 { @@ -1514,7 +1515,7 @@ namespace eval punk::lib { if {![regexp $re_idxdashidx $p _match a b]} { error "unrecognised pattern $p" } - set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds if {${lower_resolve} == -2} { ##x @@ -1527,7 +1528,7 @@ namespace eval punk::lib { } else { set lower $lower_resolve } - set upper [punk::lib::lindex_resolve $dval $b] + set upper [punk::lib::lindex_resolve [llength $dval] $b] if {$upper == -3} { ##x #upper bound is below list range - @@ -1880,7 +1881,8 @@ namespace eval punk::lib { if {$last_hidekey} { append result \n } - append result [textblock::join_basic -- $kblock $sblock $vblock] \n + #append result [textblock::join_basic -- $kblock $sblock $vblock] \n + append result [textblock::join_basic_raw $kblock $sblock $vblock] \n } set last_hidekey $hidekey incr kidx @@ -2240,18 +2242,19 @@ namespace eval punk::lib { } } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side + #REVIEW: This shouldn't really need the list itself - just the length would suffice punk::args::define { @id -id ::punk::lib::lindex_resolve @cmd -name punk::lib::lindex_resolve\ -summary\ - "Resolve an indexexpression to an integer based on supplied list."\ + "Resolve an indexexpression to an integer based on supplied list or string length."\ -help\ - "Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 - to the actual integer index for the supplied list, or to a negative value below -1 indicating - whether the index was below or above the range of possible indices for the list. + "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 + to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating + whether the index was below or above the range of possible indices for the length supplied. - Users may define procs which accept a list index and wish to accept the forms understood by Tcl. + Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. This means the proc may be called with something like $x+2 end-$y etc Sometimes the actual integer index is desired. @@ -2261,33 +2264,33 @@ namespace eval punk::lib { a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote - out of range at either end of the list - Otherwise it will return an integer corresponding to the position in the list. - This is in stark contrast to Tcl list function indices which will return empty strings for out of + out of range at either end of the list/string. + Otherwise it will return an integer corresponding to the position in the data. + This is in stark contrast to Tcl list/string function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. - Like Tcl list commands - it will produce an error if the form of the index is not acceptable - For empty lists, end and end+x indices are considered to be out of bounds on the upper side + Like Tcl list commands - it will produce an error if the form of the index is not acceptable. + For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr " @values -min 2 -max 2 - list -type list + datalength -type integer index -type indexexpression } - proc lindex_resolve {list index} { + proc lindex_resolve {len index} { #*** !doctools - #[call [fun lindex_resolve] [arg list] [arg index]] - #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list - #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. + #[call [fun lindex_resolve] [arg len] [arg index]] + #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length + #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. #[para]This means the proc may be called with something like $x+2 end-$y etc #[para]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list + #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string #[para]Otherwise it will return an integer corresponding to the position in the list. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable @@ -2298,12 +2301,16 @@ namespace eval punk::lib { # #review # return ??? #} + if {![string is integer -strict $len]} { + #<0 ? + error "lindex_resolve len must be an integer" + } set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { #can match +i -i if {$index < 0} { return -3 - } elseif {$index >= [llength $list]} { + } elseif {$index >= $len} { return -2 } else { #integer may still have + sign - normalize with expr @@ -2320,7 +2327,7 @@ namespace eval punk::lib { } } else { #index is 'end' - set index [expr {[llength $list]-1}] + set index [expr {$len-1}] if {$index < 0} { #special case - 'end' with empty list - treat end like a positive number out of bounds return -2 @@ -2329,7 +2336,7 @@ namespace eval punk::lib { } } if {$offset == 0} { - set index [expr {[llength $list]-1}] + set index [expr {$len-1}] if {$index < 0} { return -2 ;#special case as above } else { @@ -2337,7 +2344,7 @@ namespace eval punk::lib { } } else { #by now, if op = + then offset = 0 so we only need to handle the minus case - set index [expr {([llength $list]-1) - $offset}] + set index [expr {($len-1) - $offset}] } if {$index < 0} { return -3 @@ -2362,33 +2369,32 @@ namespace eval punk::lib { } if {$index < 0} { return -3 - } elseif {$index >= [llength $list]} { + } elseif {$index >= $len} { return -2 } return $index } } } - proc lindex_resolve_basic {list index} { + proc lindex_resolve_basic {len index} { #*** !doctools - #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[call [fun lindex_resolve_basic] [arg len] [arg index]] #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] returns -1 for out of range at either end, or a valid integer index #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound - #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 #[para] For pure integer indices the performance should be equivalent - #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ - # - which - #for {set i 0} {$i < [llength $list]} {incr i} { - # lappend indices $i - #} + if {![string is integer -strict $len]} { + error "lindex_resolve_basic len must be an integer" + } + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { #can match +i -i #avoid even the lseq overhead when the index is simple - if {$index < 0 || ($index >= [llength $list])} { + if {$index < 0 || ($index >= $len)} { #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. return -1 } else { @@ -2396,13 +2402,15 @@ namespace eval punk::lib { return [expr {$index}] } } - if {[llength $list]} { - set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + if {$len > 0} { + #For large len - this is a wasteful allocation if no true lseq available in Tcl version. + #lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW) + set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback. } else { - set indices [list] + set testlist [list] + #we want to call 'lindex' even in this case - to get the appropriate error message } - set idx [lindex $indices $index] + set idx [lindex $testlist $index] if {$idx eq ""} { #we have no way to determine if out of bounds is at lower vs upper end return -1 @@ -2421,6 +2429,81 @@ namespace eval punk::lib { } } + proc string_splitbefore {str index} { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -2 { + return [list $str ""] + } + -3 { + return [list "" $str] + } + } + } + return [list [string range $str 0 $index-1] [string range $str $index end]] + #scan %s stops at whitespace - not useful here. + #scan $s %${p}s%s + } + proc string_splitbefore_indices {str args} { + set parts [list $str] + set sizes [list [string length $str]] + set s 0 + foreach index $args { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -2 { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + -3 { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + } + } + if {$index <= 0} { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + if {$index >= [string length $str]} { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + set i -1 + set a 0 + foreach sz $sizes { + incr i + if {$a + $sz > $index} { + set p [lindex $parts $i] + #puts "a:$a index:$index" + if {$a == $index} { + break + } + ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] + ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] + break + } + incr a $sz + } + #puts "->parts:$parts" + #puts "->sizes:$sizes" + } + return $parts + } proc K {x y} {return $x} #*** !doctools @@ -3250,8 +3333,7 @@ namespace eval punk::lib { #Each resulting line should have a reset of some type at start and a pure-reset at end to stop #see if we can find an ST sequence that most terminals will not display for marking sections? if {$opt_ansireplays} { - #package require punk::ansi - + ;#package require punk::ansi if {$opt_ansiresets} { set RST "\x1b\[0m" } else { diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index 53d212c8..2958643b 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -129,7 +129,6 @@ tcl::namespace::eval punk::libunknown { #whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files } - #variable paths upvar ::tcl::tm::paths paths #variable pkgpattern @@ -475,6 +474,9 @@ tcl::namespace::eval punk::libunknown { #question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? set before_dict [dict create] + #J2 + #siblings that have been affected by source scripts - need to retest ifneeded scripts at end for proper ordering. + set refresh_dict [dict create] #Note that autopath is being processed from the end to the front #ie last lappended first. This means if there are duplicate versions earlier in the list, @@ -487,6 +489,7 @@ tcl::namespace::eval punk::libunknown { while {[llength $use_path]} { set dir [lindex $use_path end] + # Make sure we only scan each directory one time. if {[info exists tclSeenPath($dir)]} { set use_path [lrange $use_path 0 end-1] @@ -526,7 +529,6 @@ tcl::namespace::eval punk::libunknown { #if {$has_zipfs && [string match $zipfsroot* $dir]} { #static auto_path dirs if {!$must_scan} { - #can avoid scan if added via this path in any epoch if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. @@ -551,7 +553,13 @@ tcl::namespace::eval punk::libunknown { #(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) set sourced 0 + set just_added [dict create] + set just_changed [dict create] #set sourced_files [list] + + #J2 + #set can_skip_sourcing 0 + if {!$can_skip_sourcing} { #Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. #this will stop us rescanning everything properly by doing a 'package require nonexistant' @@ -577,7 +585,7 @@ tcl::namespace::eval punk::libunknown { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - #if {[string match //zipfs* $file]} { + #if {[string match //zipfs*registry* $file]} { # puts stderr "----->0 sourcing zipfs file $file" #} incr sourced ;#count as sourced even if source fails; keep before actual source action @@ -642,15 +650,16 @@ tcl::namespace::eval punk::libunknown { } set after_pkgs [package names] - set just_added [dict create] #puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]" if {[llength $after_pkgs] > [llength $before_pkgs]} { foreach a $after_pkgs { foreach v [package versions $a] { if {![dict exists $before_dict $a $v]} { dict set just_added $a $v 1 + set iscript [package ifneeded $a $v] + #J2 #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v] - dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v e$pkg_epoch + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v [dict create e $pkg_epoch scr $iscript] if {$must_scan} { dict unset epoch pkg untracked $a } @@ -693,18 +702,20 @@ tcl::namespace::eval punk::libunknown { #The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it) # dict for {bp bpversionscripts} $before_dict { - if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} { - #puts -nonewline . - continue - } + #if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} { + # #puts -nonewline . + # continue + #} dict for {bv bscript} $bpversionscripts { set nowscript [package ifneeded $bp $bv] if {$bscript ne $nowscript} { #ifneeded script has changed. The same version of bp was supplied on this path. #As it's processed later - it will be the one in effect. #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv] - dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv e$pkg_epoch + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv [dict create e $pkg_epoch scr $nowscript] dict set before_dict $bp $bv $nowscript + dict set just_changed $bp $bv 1 + #j2 if {$must_scan} { dict unset epoch pkg untracked $bp } @@ -806,7 +817,50 @@ tcl::namespace::eval punk::libunknown { } } set old_path $auto_path + + dict for {pkg versions} $just_changed { + foreach v [dict keys $versions] { + dict set refresh_dict $pkg $v 1 + } + } + dict for {pkg versions} $just_added { + foreach v [dict keys $versions] { + dict set refresh_dict $pkg $v 1 + } + } } + #refresh ifneeded scripts for just_added/just_changed + #review: searchpaths are in auto_path order - earliest has precedence for any particular pkg-version + set e [dict get $epoch pkg current] + set pkgvdone [dict create] + set dict_added [dict get $epoch pkg epochs $e added] + #keys are in reverse order due to tclPkgUnknown processing order + set ordered_searchpaths [lreverse [dict keys $dict_added]];# orderd as in auto_path + + dict for {pkg versiond} $refresh_dict { + set versions [dict keys $versiond] + foreach searchpath $ordered_searchpaths { + set addedinfo [dict get $dict_added $searchpath] + set vidx -1 + foreach v $versions { + incr vidx + if {[dict exists $addedinfo $pkg $v]} { + ledit versions $vidx $vidx + set iscript [dict get $addedinfo $pkg $v scr] + if {[package ifneeded $pkg $v] ne $iscript} { + #puts "---->refreshing $pkg $v using path:$searchpath" + package ifneeded $pkg $v $iscript + #dict set pkgvdone $pkg $v 1 + } + } + } + if {[llength $versions] == 0} { + break + } + } + } + + #puts "zipfs_tclPkgUnknown DONE" } variable last_auto_path @@ -1091,7 +1145,7 @@ tcl::namespace::eval punk::libunknown { set callerposn [lsearch $args -caller] if {$callerposn > -1} { set caller [lindex $args $callerposn+1] - puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m" + #puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m" #puts stderr "punk::libunknown::init auto_path : $::auto_path" #puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]" } @@ -1176,15 +1230,15 @@ tcl::namespace::eval punk::libunknown { #update the epoch info with where the tm versions came from #(not tracking version numbers in epoch - just package to the indexbase) foreach vdata $versionlist { - lassign $vdata v _t type _index index _indexbase indexbase + lassign $vdata v _t type _index index _indexbase indexbase _script iscript if {$type eq "tm"} { if {![dict exists $epoch tm epochs 0 added $indexbase]} { #dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]] - dict set epoch tm epochs 0 added $indexbase $p $v e0 + dict set epoch tm epochs 0 added $indexbase $p $v [dict create e 0 scr $iscript] } else { set idxadded [dict get $epoch tm epochs 0 added $indexbase] #dict set idxadded $p [dict create e 0 v $v] - dict set idxadded $p $v e0 + dict set idxadded $p $v [dict create e 0 scr $iscript] dict set epoch tm epochs 0 added $indexbase $idxadded } dict unset epoch tm untracked $p @@ -1395,7 +1449,9 @@ tcl::namespace::eval punk::libunknown { #} if {![interp issafe]} { + #J2 package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + #package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} } } @@ -1426,10 +1482,26 @@ tcl::namespace::eval punk::libunknown { dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path] } - #set pkg_added [punk::lib::showdict [dict get $epoch pkg epochs $pkg_epoch added] */$pkgname] - set pkg_added [punk::lib::showdict $r_added */$pkgname] - set title "PKG epoch $pkg_epoch - added" - set added [textblock::frame -title $title $pkg_added] + #set pkg_added [punk::lib::showdict $r_added */$pkgname] + #set added [textblock::frame -title $title $pkg_added] + set rows [list] + dict for {path pkgs} $r_added { + set c1 $path + set c2 [dict size $pkgs] + set c3 "" + if {[dict exists $pkgs $pkgname]} { + set vdict [dict get $pkgs $pkgname] + dict for {v data} $vdict { + set scriptlen [string length [dict get $data scr]] + append c3 "$v epoch[dict get $data e] ifneededchars:$scriptlen" \n + } + } + set r [list $path $c2 $c3] + lappend rows $r + } + set title "[punk::ansi::a+ green] PKG epoch $pkg_epoch - added [punk::ansi::a]" + set added [textblock::table -title $title -headers [list Path Pkgcount $pkgname] -rows $rows] + set pkg_row $added diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 99571988..09f8bfba 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -177,10 +177,10 @@ tcl::namespace::eval punk::ns { } else { set fq_nspath $nspath } - if {[catch {nseval_ifexists $fq_nspath {}}]} { - return 0 - } else { + if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} { return 1 + } else { + return 0 } } @@ -758,7 +758,7 @@ tcl::namespace::eval punk::ns { } set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { - return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { return [dict get $marks $type] } @@ -1068,7 +1068,7 @@ tcl::namespace::eval punk::ns { } else { } if {$cmd in $imported} { - set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"] + set prefix [overtype::right $prefix "-[a+ yellow bold]I[a]"] } } if {$cmd in $usageinfo} { @@ -1076,7 +1076,8 @@ tcl::namespace::eval punk::ns { } else { set u "" } - set cmd$i "${prefix} $c$cmd_display$u" + #set cmd$i "${prefix} $c$cmd_display$u" + set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $c $cmd_display]$u" #set c$i $c set c$i "" lappend seencmds $cmd @@ -3682,6 +3683,21 @@ tcl::namespace::eval punk::ns { comment inserted to display information such as the namespace origin. Such a comment begins with #corp#." @opts + -syntax -default basic -choices {none basic}\ + -choicelabels { + none\ + " Plain text output" + basic\ + " Comment and bracket highlights. + This is a basic colourizer - not + a full Tcl syntax highlighter." + }\ + -help\ + "Type of syntax highlighting on result. + Note that -syntax none will always return a proper Tcl + List: proc + - but a syntax highlighter may return a string that + is not a Tcl list." @values -min 1 -max -1 commandname -help\ "May be either the fully qualified path for the command, @@ -3690,7 +3706,8 @@ tcl::namespace::eval punk::ns { } proc corp {args} { set argd [punk::args::parse $args withid ::punk::ns::corp] - set path [dict get $argd values commandname] + set path [dict get $argd values commandname] + set syntax [dict get $argd opts -syntax] #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { @@ -3775,7 +3792,19 @@ tcl::namespace::eval punk::ns { lappend argl $a } #list proc [nsjoin ${targetns} $name] $argl $body - list proc $resolved $argl $body + switch -- $syntax { + basic { + #rudimentary colourising only + set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] + set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body] + #ansi colourised items in list format may not always have desired string representation (list escaping can occur) + #return as a string - which may not be a proper Tcl list! + return "proc $resolved {$argl} {\n$body\n}" + } + } + list proc $resolved $argl $body } diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index f13a4304..8d6ebc75 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -194,7 +194,7 @@ tcl::namespace::eval punk::packagepreference { if {!$is_exact && [llength $vwant] <= 1 } { #required version unspecified - or specified singularly set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] - if {[llength $available_versions] > 1} { + if {[llength $available_versions] >= 1} { # --------------------------------------------------------------- #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all @@ -202,9 +202,11 @@ tcl::namespace::eval punk::packagepreference { set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" - lassign $pkgloadedinfo path name - set lcpath [string tolower $path] + if {[llength $available_versions] > 1} { + puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available" + } + lassign $pkgloadedinfo loaded_path name + set lc_loadedpath [string tolower $loaded_path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. set lcpath_to_version [dict create] foreach av $available_versions { @@ -212,17 +214,19 @@ tcl::namespace::eval punk::packagepreference { #ifneeded script not always a valid tcl list if {![catch {llength $scr} scrlen]} { if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { + #a basic 'load ' statement dict set lcpath_to_version [string tolower [lindex $scr 1]] $av } } } - if {[dict exists $lcpath_to_version $lcpath]} { - set lversion [dict get $lcpath_to_version $lcpath] + if {[dict exists $lcpath_to_version $lc_loadedpath]} { + set lversion [dict get $lcpath_to_version $lc_loadedpath] } else { #fallback to a best effort guess based on the path - set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] + set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg] } + #puts "====lcpath_to_version: $lcpath_to_version" if {$lversion ne ""} { #name matches pkg #hack for known dll version mismatch @@ -232,8 +236,40 @@ tcl::namespace::eval punk::packagepreference { if {[llength $vwant] == 1} { #todo - still check vsatisfies - report a conflict? review } - return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + try { + set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + } trap {} {emsg eopts} { + #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry + #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown + #May be obsolete.. issue still not clear + + #A hack for 'couldn't open "": permission denied' + #This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls. + #exact cause unknown. + #e.g + #%package ifneeded registry 1.3.7 + #- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry + #%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry + #couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied + + #a subsequent load of the path used in the error message works. + + #if {[string match "couldn't open \"*\": permission denied" $emsg]} {} + if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} { + #Since this is a hack that shouldn't be required - be noisy about it. + puts stderr ">>> $emsg" + puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath" + return [load $newpath $pkg] + } else { + #puts stderr "??? $emsg" + #dunno - re-raise + return -options $eopts $emsg + } + } + return $result } + #else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path" } } } @@ -291,6 +327,7 @@ tcl::namespace::eval punk::packagepreference { #we should be able to load more specific punk::args pkg based on result of [package present $pkg] catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant + #j2 $COMMANDSTACKNEXT require punk::args::$dp } } diff --git a/src/modules/punk/pipe-999999.0a1.0.tm b/src/modules/punk/pipe-999999.0a1.0.tm index 22cdc090..555a5996 100644 --- a/src/modules/punk/pipe-999999.0a1.0.tm +++ b/src/modules/punk/pipe-999999.0a1.0.tm @@ -373,6 +373,7 @@ tcl::namespace::eval punk::pipe::lib { if {$end_var_posn > 0} { #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. #lassign [scan $token %${end_var_posn}s%s] var spec + #lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec set var [string range $token 0 $end_var_posn-1] set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec } else { @@ -430,7 +431,7 @@ tcl::namespace::eval punk::pipe::lib { } #if {[string length $token]} { - # #lappend varlist [splitstrposn $token $end_var_posn] + # #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn] # set var $token # set spec "" # if {$end_var_posn > 0} { diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 07006fba..52d2f6ea 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -2472,7 +2472,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set h [textblock::height $text] set promptcol [string repeat $resultprompt\n $h] set promptcol [string range $promptcol 0 end-1] - rputs [textblock::join_basic -- $promptcol $text] + #rputs [textblock::join_basic -- $promptcol $text] + rputs [textblock::join_basic_raw $promptcol $text] #puts -nonewline stdout $text } @@ -2530,7 +2531,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set promptcol [string repeat $resultprompt\n $h] set promptcol [string range $promptcol 0 end-1] #promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join - rputs [textblock::join_basic -- $promptcol $result] + #rputs [textblock::join_basic -- $promptcol $result] + rputs [textblock::join_basic_raw $promptcol $result] #orig #rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] diff --git a/src/modules/shellfilter-0.2.tm b/src/modules/shellfilter-0.2.tm index df7234b7..61120a63 100644 --- a/src/modules/shellfilter-0.2.tm +++ b/src/modules/shellfilter-0.2.tm @@ -735,6 +735,7 @@ namespace eval shellfilter::chan { variable o_encbuf ;#buffering for partial encoding bytes variable o_colour variable o_do_colour + variable o_do_colourlist variable o_do_normal variable o_is_junction variable o_codestack @@ -747,11 +748,17 @@ namespace eval shellfilter::chan { set settingsdict [tcl::dict::get $tf -settings] if {[tcl::dict::exists $settingsdict -colour]} { set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] + #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence + #while some terminals may handle these extended attributes even when merged - we need to cater for those that + #don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without + #affecting the interpretation of the other codes. + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour] set o_do_normal [punk::ansi::a] } else { set o_colour {} set o_do_colour "" + set o_do_colourlist {} set o_do_normal "" } set o_codestack [list] @@ -793,11 +800,11 @@ namespace eval shellfilter::chan { set o_codestack [list] } else { #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt } } default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt } } #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { @@ -864,11 +871,11 @@ namespace eval shellfilter::chan { set o_codestack [list] } else { #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt } } default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt } } #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { @@ -957,12 +964,12 @@ namespace eval shellfilter::chan { set o_codestack [list] } else { #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf } } default { #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf } } #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { @@ -987,12 +994,12 @@ namespace eval shellfilter::chan { set o_codestack [list] } else { #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf } } default { #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf } } set o_buffered "" diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test index 8b4fed66..cfe00d9b 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test @@ -131,6 +131,45 @@ namespace eval ::testspace { {0 a 1 b 2 c} {3 d} ] + test parse_withdef_leaderclause_trailing_optional_members_followed_by_value {Test that last leader clause with optional members works with following required value}\ + -setup $common -body { + set argd [punk::args::parse {a z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend result [dict get $argd leaders] + set argd [punk::args::parse {a 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend result [dict get $argd leaders] + set argd [punk::args::parse {a 1 2 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend result [dict get $argd leaders] + }\ + -cleanup { + }\ + -result [list\ + {ldr {a {} {}}}\ + {ldr {a 1 {}}}\ + {ldr {a 1 2}}\ + ] + test parse_withdef_leaderclause_trailing_optional_members_followed_by_optional_leader_and_value {Test that last leader clause with optional members works with following required value}\ + -setup $common -body { + set argd [punk::args::parse {x y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 2 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend result [dict get $argd leaders] + }\ + -cleanup { + }\ + -result [list\ + {ldr {x {} {}} ldr2 y}\ + {ldr {x 1 {}}}\ + {ldr {x 1 {}} ldr2 y}\ + {ldr {x 1 2} ldr2 y}\ + ] + test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\ -setup $common -body { set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}] @@ -191,6 +230,40 @@ namespace eval ::testspace { {elseifclause {elseif 1 {} x}} ] + test parse_withdef_value_clause_missing_optional_multiple {test -multiple true clauses with optional members}\ + -setup $common -body { + #this test is applicable to situations such as the elseif clause in the ::if definition: + #e.g literal(elseif) expr ?literal(then)? script + #the 'then' needs to be omitable arbitrarily in a list of elseif clauses + + #first test with all values supplied + set argd [punk::args::parse {x 1 y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend result [dict get $argd values] + + #missing value in second instance only + set argd [punk::args::parse {x 1 y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend result [dict get $argd values] + + #missing value in first instance only + #this can trigger a problem whereby the missing value in the first instance (which is empty string) gets processed in validation against 'int' and fails. + #(updating of required type to a validationless value such as ... ?omitted-int? ... needs to be tied to specific clause instances) + set argd [punk::args::parse {x y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend result [dict get $argd values] + + #for completeness - no optional values supplid + set argd [punk::args::parse {x y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend result [dict get $argd values] + + }\ + -cleanup { + }\ + -result [list\ + {triple {{x 1 y} {x 2 y}}}\ + {triple {{x 1 y} {x {} y}}}\ + {triple {{x {} y} {x 2 y}}}\ + {triple {{x {} y} {x {} y}}}\ + ] + test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\ -setup $common -body { set argd [punk::args::parse {1 2 x 1 y} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}] @@ -213,6 +286,7 @@ namespace eval ::testspace { {arg {1 2} X {x 1} Y {y 2}} ] + #todo - test L1 parsed to Lit1 not arg #punk::args::parse {x y L1} withdef @values (arg -multiple 1) {lit1 -type literal(L1) -optional 1} {lit2 -type literal(L2) -optional 1} @@ -251,10 +325,10 @@ namespace eval ::testspace { #see for example ::tcl::dict::create which has a clause length of 2 if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -type {any any any} -multiple 0}} emsg eopts]} { set expected [dict get $eopts -errorcode] - if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "clausevaluelength"} { + if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "missingrequiredvalue"} { lappend result "RECEIVED_EXPECTED_ERROR" } else { - lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {clausevaluelength ...} ..." + lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {missingrequiredvalue ...} ..." } } else { lappend result "MISSING_REQUIRED_ERROR" @@ -279,18 +353,6 @@ namespace eval ::testspace { {-direction u} ] - test parse_withdef_choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\ - -setup $common -body { - set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}] - lappend result [dict get $argd values] - }\ - -cleanup { - }\ - -result [list\ - {X {aa {cc aa} {aa bb cc}}} - ] - #todo - decide on whether -choicemultiple should disallow duplicates in result by default - test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ -setup $common -body { set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}] @@ -356,4 +418,7 @@ namespace eval ::testspace { -result [list\ {A a} {A 11} ] + + + } \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test new file mode 100644 index 00000000..59bfde73 --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test @@ -0,0 +1,158 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test choices_typeignored_when_choice_in_list {Test that -type is not validated for a value that matches a choice}\ + -setup $common -body { + #1 abbreviated choice + set argd [punk::args::parse {li} withdef @values {frametype -type dict -choices {heavy light arc}}] + lappend result [dict get $argd values] + + #2 exact match for a choice + set argd [punk::args::parse {light} withdef @values {frametype -type dict -choices {heavy light arc}}] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {frametype light}\ + {frametype light}\ + ] + + test choices_type_validation_choicerestricted1 {Test that -type is validated for value outside of choicelist based on -choicerestricted}\ + -setup $common -body { + + set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}}] + lappend result [dict get $argd values] + + if {[catch { + punk::args::parse {z} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}} + }]} { + lappend result "ok_got_expected_error1" + } else { + lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" + } + + #when -choicerestricted - value matching -type still shouldn't pass + if {[catch { + set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 1 -choices {heavy light arc}}] + }]} { + lappend result "ok_got_expected_error2" + } else { + lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" + } + }\ + -cleanup { + }\ + -result [list\ + {frametype 11}\ + ok_got_expected_error1\ + ok_got_expected_error2\ + ] + + test choices_type_validation_choicerestricted2 {Test that -type dict is validated for value outside of choicelist based on -choicerestricted}\ + -setup $common -body { + #same as choices_type_validation_choicrestricted1 - but with a more complex type 'dict' - tests list protection is correct + set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}}] + lappend result [dict get $argd values] + + if {[catch { + punk::args::parse {z} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}} + }]} { + lappend result "ok_got_expected_error1" + } else { + lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" + } + + #when -choicerestricted - value matching -type dict still shouldn't pass + if {[catch { + set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 1 -choices {heavy light arc}}] + }]} { + lappend result "ok_got_expected_error2" + } else { + lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" + } + }\ + -cleanup { + }\ + -result [list\ + {frametype {hl -}}\ + ok_got_expected_error1\ + ok_got_expected_error2\ + ] + + test choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\ + -setup $common -body { + set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {X {aa {cc aa} {aa bb cc}}} + ] + #todo - decide on whether -choicemultiple should disallow duplicates in result by default + + + test choice_multielement_clause {test -choice with a clause-length greater than 1}\ + -setup $common -body { + #The same -choices list always applies to each member of -type - which isn't always ideal for a multi-element clause + #for a clause where each element has a different choiceset - we would need to introduce a more complex -typechoices option + #(or use a -parsekey mechanism on leaders/values to group them) + + #test all combinations of prefix and complete for 2 entries + set argd [punk::args::parse {light heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] + lappend result [dict get $argd values] + set argd [punk::args::parse {li heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] + lappend result [dict get $argd values] + set argd [punk::args::parse {li he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] + lappend result [dict get $argd values] + set argd [punk::args::parse {light he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {leftright {light heavy}}\ + {leftright {light heavy}}\ + {leftright {light heavy}}\ + {leftright {light heavy}}\ + ] + + test choice_multielement_clause_unrestricted {test -choice with a clause-length greater than 1 and values outside of choicelist}\ + -setup $common -body { + #1 both values outside of -choices + set argd [punk::args::parse {11 x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + # + set argd [punk::args::parse {11 arc} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + # + set argd [punk::args::parse {11 a} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + # + set argd [punk::args::parse {heavy x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + # + set argd [punk::args::parse {h x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + # + set argd [punk::args::parse {a h} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {leftright {11 x}}\ + {leftright {11 arc}}\ + {leftright {11 arc}}\ + {leftright {heavy x}}\ + {leftright {heavy x}}\ + {leftright {arc heavy}}\ + ] +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/opts.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/opts.test new file mode 100644 index 00000000..51c0eb7e --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/opts.test @@ -0,0 +1,76 @@ + +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test opts_longoptvalue {Test -alt|--longopt= can accept value as longopt}\ + -setup $common -body { + set argd [punk::args::parse {--filename=abc} withdef @opts {-f|--filename= -default spud -type string}] + lappend result [dict get $argd opts];#name by default should be last flag alternative (stripped of =) ie "--filename" + }\ + -cleanup { + }\ + -result [list\ + {--filename abc}\ + ] + + test opts_longoptvalue_alternative {Test -alt|--longopt= can accept value as spaced argument to given alternative}\ + -setup $common -body { + #test full name of alt flag + set argd [punk::args::parse {-fx xyz} withdef @opts {-fx|--filename= -default spud -type string}] + lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" + #test prefixed version of flag + set argd [punk::args::parse {-f xyz} withdef @opts {-fx|--filename= -default spud -type string}] + lappend result [dict get $argd opts] + }\ + -cleanup { + }\ + -result [list\ + {--filename xyz}\ + {--filename xyz}\ + ] + + test opts_longoptvalue_alternative_noninterference {Test -alt|--longopt= can accept longopt values as normal }\ + -setup $common -body { + #test full name of longopt + set argd [punk::args::parse {--filename=xyz} withdef @opts {-fx|--filename= -default spud -type string}] + lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" + #test prefixed version of longopt + set argd [punk::args::parse {--file=xyz} withdef @opts {-fx|--filename= -default spud -type string}] + lappend result [dict get $argd opts] + }\ + -cleanup { + }\ + -result [list\ + {--filename xyz}\ + {--filename xyz}\ + ] + + test opts_longoptvalue_choice {Test --longopt= works wiith -choices}\ + -setup $common -body { + #prefixed choice with and without prefixed flagname + set argd [punk::args::parse {--filename=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] + lappend opts [dict get $argd opts] + set argd [punk::args::parse {--file=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] + lappend opts [dict get $argd opts] + #unprefixed choice with and without prefixed flagname + set argd [punk::args::parse {--filename=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] + lappend opts [dict get $argd opts] + set argd [punk::args::parse {--file=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] + lappend opts [dict get $argd opts] + + }\ + -cleanup { + }\ + -result [list\ + {--filename xyz}\ + {--filename xyz}\ + {--filename xyz}\ + {--filename xyz}\ + ] +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/synopsis.test#..+args+synopsis.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/synopsis.test#..+args+synopsis.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 9ced0bea..7ea386a0 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -2313,7 +2313,8 @@ tcl::namespace::eval textblock { #JMN #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic - set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + #set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + set spanned_frame [textblock::join_basic_raw {*}$spanned_parts] if {$spans_to_rhs} { if {$cidx == 0} { @@ -2382,7 +2383,8 @@ tcl::namespace::eval textblock { } else { #this_span == 1 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] + #set spanned_frame [textblock::join_basic -- $header_cell_startspan] + set spanned_frame [textblock::join_basic_raw $header_cell_startspan] } @@ -4011,7 +4013,8 @@ tcl::namespace::eval textblock { set body_build "" } else { #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] + #set body_build [textblock::join_basic -- {*}$body_blocks] + set body_build [textblock::join_basic_raw {*}$body_blocks] } if {$headerheight > 0} { set table [tcl::string::cat $header_build \n $body_build] @@ -4662,7 +4665,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + #set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + set row [textblock::join_basic_raw {*}[lrepeat $blockwidth $charblock]] } else { set row $charblock } @@ -4780,7 +4784,8 @@ tcl::namespace::eval textblock { if {"noreset" in $colour} { return [textblock::join_basic -ansiresets 0 -- {*}$clist] } else { - return [textblock::join_basic -- {*}$clist] + #return [textblock::join_basic -- {*}$clist] + return [textblock::join_basic_raw {*}$clist] } } elseif {"rainbow" in $colour} { #direction must be horizontal @@ -5037,19 +5042,20 @@ tcl::namespace::eval textblock { -width ""\ -overflow 0\ -within_ansi 0\ + -return block\ ] #known_samewidth of empty string means we don't know either way, 0 is definitely 'ragged', 1 is definitely homogenous #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { - -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { + -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi - -return { tcl::dict::set opts $k $v } default { + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0? ?-return block|list?" error "textblock::pad unrecognised option '$k'. Usage: $usage" } } @@ -5195,96 +5201,110 @@ tcl::namespace::eval textblock { set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { - if {$pt ne ""} { - set has_nl [expr {[tcl::string::last \n $pt]>=0}] - if {$has_nl} { + if {$pt eq ""} { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } elseif {[tcl::string::last \n $pt]==-1} { + lappend line_chunks $pt + if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + incr line_len [punk::char::grapheme_width_cached $pt] ;#memleak - REVIEW + } + } else { + #set has_nl [expr {[tcl::string::last \n $pt]>=0}] + #if {$has_nl} { set pt [tcl::string::map [list \r\n \n] $pt] set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl + #} else { + # set partlines [list $pt] + #} + #set last [expr {[llength $partlines]-1}] + #set p -1 + foreach pl [lrange $partlines 0 end-1] { + #incr p + lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline. #incr line_len [punk::char::ansifreestring_width $pl] + #if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { + # incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + #} + #do padding if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + set missing [expr {$width - $line_len}] + } else { + set missing [expr {$width - $datawidth}] } - if {$p != $last} { - #do padding - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - set missing [expr {$width - $line_len}] - } else { - set missing [expr {$width - $datawidth}] - } - if {$missing > 0} { - #commonly in a block - many lines will have the same pad - cache based on missing + if {$missing > 0} { + #commonly in a block - many lines will have the same pad - cache based on missing - #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - dict set pad_cache $missing $pad + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] } - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { lappend line_chunks $pad } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] } - l-1 { + } + l-2 { + if {$lnum == 0} { if {[lindex $line_chunks 0] eq ""} { set line_chunks [linsert $line_chunks 2 $pad] } else { set line_chunks [linsert $line_chunks 0 $pad] } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } + } else { + set line_chunks [linsert $line_chunks 0 $pad] } } } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum } - incr p + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" + #deal with last part zzz of xxx\nyyy\nzzz - not yet a complete line + set pl [lindex $partlines end] + lappend line_chunks $pl ;#we need to lappend because there can already be some pt and ansi entries for the current line from previous {pt ansi} values where pt had no newline. + if {$pl ne "" && ($known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq "")} { + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + } + } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len + #- review - ansi codes with visible content? + #- There shouldn't be any, even though for example some terminals display PM content + #e.g OSC 8 is ok as it has the uri 'inside' the ansi sequence, but that's ok because the displayable part is outside and is one of our pt values from split_codes. } } #pad last line @@ -5343,7 +5363,11 @@ tcl::namespace::eval textblock { } } lappend lines [::join $line_chunks ""] - return [::join $lines \n] + if {[tcl::dict::get $opts -return] eq "block"} { + return [::join $lines \n] + } else { + return $lines + } } #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single @@ -5620,6 +5644,33 @@ tcl::namespace::eval textblock { } return [::join $outlines \n] } + proc ::textblock::join_basic_raw {args} { + #no options. -*, -- are legimate blocks + set blocklists [lrepeat [llength $args] ""] + set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc + set i -1 + foreach b $args { + incr i + if {[punk::ansi::ta::detect $b]} { + #-ansireplays 1 quite expensive e.g 7ms in 2024 + set blines [punk::lib::lines_as_list -ansireplays 1 -ansiresets auto -- $b] + } else { + set blines [split $b \n] + } + lset blocklengths $i [llength $blines] + lset blocklists $i $blines + } + set rowcount [tcl::mathfunc::max {*}$blocklengths] + set outlines [lrepeat $rowcount ""] + for {set r 0} {$r < $rowcount} {incr r} { + set row "" + foreach blines $blocklists { + append row [lindex $blines $r] + } + lset outlines $r $row + } + return [::join $outlines \n] + } proc ::textblock::join_basic2 {args} { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner @@ -5704,9 +5755,12 @@ tcl::namespace::eval textblock { } set idx 0 - set blocklists [list] + #set blocklists [list] + set blocklists [lrepeat [llength $blocks] ""] set rowcount 0 + set bidx -1 foreach b $blocks { + incr bidx #we need the width of a rendered block for per-row renderline calls or padding #we may as well use widthinfo to also determine raggedness state to pass on to pad function #set bwidth [width $b] @@ -5723,18 +5777,21 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $b]} { # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] - set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + #set blines [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + set blines [textblock::pad $replay_block -return lines -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] } else { #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + #set blines [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] + set blines [textblock::pad $b -return lines -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] } - set rowcount [expr {max($rowcount,[llength $bl])}] - lappend blocklists $bl + set rowcount [expr {max($rowcount,[llength $blines])}] + #lappend blocklists $bl + lset blocklists $bidx $blines set width($idx) $bwidth incr idx } - set outlines [list] + set outlines [lrepeat $rowcount ""] for {set r 0} {$r < $rowcount} {incr r} { set row "" for {set c 0} {$c < [llength $blocklists]} {incr c} { @@ -5744,7 +5801,8 @@ tcl::namespace::eval textblock { } append row $cell } - lappend outlines $row + #lappend outlines $row + lset outlines $r $row } return [::join $outlines \n] } @@ -6224,9 +6282,11 @@ tcl::namespace::eval textblock { set spec [string map [list $::textblock::frametypes] { @id -id ::textblock::framedef @cmd -name textblock::framedef\ + -summary "Return frame graphical elements as a dictionary."\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." - + @leaders -min 0 -max 0 + @opts -joins -default "" -type list\ -help "List of join directions, any of: up down left right or those combined with another frametype e.g left-heavy down-light." @@ -6234,7 +6294,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 -max -1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -8566,7 +8626,8 @@ tcl::namespace::eval textblock { #puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner" if {$opt_ansibase ne ""} { if {[punk::ansi::ta::detect $cache_inner]} { - set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner] + #set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner] + set cache_inner [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $cache_inner] } else { set cache_inner "$opt_ansibase$cache_inner\x1b\[0m" } @@ -8597,7 +8658,8 @@ tcl::namespace::eval textblock { #JMN test #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW #set cache_body [textblock::join -- {*}$cache_bodyparts] - set cache_body [textblock::join_basic -- {*}$cache_bodyparts] + #set cache_body [textblock::join_basic -- {*}$cache_bodyparts] + set cache_body [textblock::join_basic_raw {*}$cache_bodyparts] append fscached $cache_body #append fs $body @@ -8658,7 +8720,8 @@ tcl::namespace::eval textblock { set contents_has_ansi [punk::ansi::ta::detect $contents] if {$opt_ansibase ne ""} { if {$contents_has_ansi} { - set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents] + #set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents] + set contents [punk::ansi::ansiwrap_raw $opt_ansibase "" "" $contents] } else { set contents "$opt_ansibase$contents\x1b\[0m" set contents_has_ansi 1