Browse Source

misc fixups, punk::args usage table in error msg

master
Julian Noble 5 months ago
parent
commit
1b85cb9a37
  1. 26
      src/modules/argparsingtest-999999.0a1.0.tm
  2. 111
      src/modules/flagfilter-0.3.tm
  3. 3
      src/modules/punk-0.1.tm
  4. 96
      src/modules/punk/args-999999.0a1.0.tm
  5. 4
      src/modules/punk/char-999999.0a1.0.tm
  6. 8
      src/modules/punk/console-999999.0a1.0.tm
  7. 2
      src/modules/punk/du-999999.0a1.0.tm
  8. 13
      src/modules/punk/fileline-999999.0a1.0.tm
  9. 151
      src/modules/punk/lib-999999.0a1.0.tm
  10. 29
      src/modules/punk/mix/commandset/module-999999.0a1.0.tm
  11. 2
      src/modules/punk/mix/templates-999999.0a1.0.tm

26
src/modules/argparsingtest-999999.0a1.0.tm

@ -115,7 +115,7 @@ namespace eval argparsingtest {
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
-x a\
-x ""\
-y b\
-z c\
-1 1\
@ -139,7 +139,7 @@ namespace eval argparsingtest {
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
-x a\
-x ""\
-y b\
-z c\
-1 1\
@ -164,7 +164,7 @@ namespace eval argparsingtest {
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
-x a\
-x ""\
-y b\
-z c\
-1 1\
@ -191,7 +191,7 @@ namespace eval argparsingtest {
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
-x a\
-x ""\
-y b\
-z c\
-1 1\
@ -209,7 +209,7 @@ namespace eval argparsingtest {
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
-x a\
-x ""\
-y b\
-z c\
-1 1\
@ -235,7 +235,7 @@ namespace eval argparsingtest {
-show_edge -default \uFFEF -type string
-show_seps -default \uFFEF -type string
-join -type none -multiple 1
-x -default a -type string
-x -default "" -type string
-y -default b -type string
-z -default c -type string
-1 -default 1 -type boolean
@ -249,12 +249,12 @@ namespace eval argparsingtest {
set argd [punk::args::get_dict {
*proc -name argtest4 -description "test of punk::args::get_dict comparative performance"
*opts -anyopts 0
-return -default string -type string
-return -default string -type string -choices {string object} -help "return type"
-frametype -default \uFFEF -type string
-show_edge -default \uFFEF -type string
-show_seps -default \uFFEF -type string
-join -type none -multiple 1
-x -default a -type string
-x -default "" -type string
-y -default b -type string
-z -default c -type string
-1 -default 1 -type boolean -validate_without_ansi true
@ -273,7 +273,7 @@ namespace eval argparsingtest {
{-show_edge \uFFEF "show table outer borders"}
{-show_seps \uFFEF "show separators"}
{-join "solo option"}
{-x a "x val"}
{-x "" "x val"}
{-y b "y val"}
{-z c "z val"}
{-1 1 "1val"}
@ -296,7 +296,7 @@ namespace eval argparsingtest {
{show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"}
{join "join the things"}
{x.arg a "arg x"}
{x.arg "" "arg x"}
{y.arg b "arg y"}
{z.arg c "arg z"}
{1.arg 1 "arg 1"}
@ -314,7 +314,7 @@ namespace eval argparsingtest {
{show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"}
{join "join the things"}
{x.arg a "arg x"}
{x.arg "" "arg x"}
{y.arg b "arg y"}
{z.arg c "arg z"}
{1.boolean 1 "arg 1"}
@ -333,7 +333,7 @@ namespace eval argparsingtest {
{ -frametype string \uFFEF }
{ -show_edge string \uFFEF }
{ -show_seps string \uFFEF }
{ -x string a }
{ -x string "" }
{ -y string b }
{ -z string c }
{ -1 boolean 1 }
@ -354,7 +354,7 @@ namespace eval argparsingtest {
{-show_edge -type string -default \uFFEF}
{-show_seps -type string -default \uFFEF}
{-join -type none -multiple}
{-x -type string -default a}
{-x -type string -default ""}
{-y -type string -default b}
{-z -type string -default c}
{-1 -type boolean -default 1}

111
src/modules/flagfilter-0.3.tm

@ -101,7 +101,7 @@ namespace eval flagfilter {
if {$a eq "--"} {
break
}
if {$a in [dict keys $solodict]} {
if {[dict exists $solodict $a]} {
set last_was_flag 0
if {[dict exists $solo_accumulator $a]} {
set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]]
@ -373,7 +373,7 @@ namespace eval flagfilter {
# mashopt cannot be in both singleopts and pairopts. (NAND)
foreach l $flagletters {
if {-$l in $pairopts} {
if {"$-l" in $mashopts} {
if {"-$l" in $mashopts} {
#need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg.
# We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt
break
@ -561,7 +561,7 @@ namespace eval flagfilter {
if {$f in $solos} {
return 0
}
if {$f in [list "-" "--"]} {
if {$f in {- --}} {
return 0
}
#longopts (--x=blah) and alternative --x blah
@ -617,7 +617,7 @@ namespace eval flagfilter {
variable o_codemap
variable o_flagcategory
constructor {values} {
set o_codemap [list \
set o_codemap [dict create \
operand op \
flagvalue fv \
soloflag so \
@ -627,7 +627,19 @@ namespace eval flagfilter {
]
set o_flagcategory [list "flag" "flagvalue" "soloflag"]
set o_values $values
set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6
#set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6
#lsearch -all <list> * is fast for very small lists - but lseq wins from size around 30+
if {[llength $values]} {
if {[llength $values] < 30} {
#common case is short lists - but we don't want to penalize large lists
set o_remaining [lsearch -all $values *]
} else {
#punk::lib::range wraps lseq if available
set o_remaining [punk::lib::range 0 [llength $values]-1]
}
} else {
set o_remaining [list]
}
set o_allocated [list]
set o_map [list]
foreach posn $o_remaining {
@ -703,11 +715,14 @@ namespace eval flagfilter {
dict for {k vinfo} $o_map {
lassign $vinfo class type val
if {[string match $classmatch $class]} {
if {$type ni [list flag flagvalue soloflag]} {
switch -- $type {
flag - flagvalue - soloflag {}
default {
lappend resultlist $val
}
}
}
}
return $resultlist
}
@ -716,11 +731,13 @@ namespace eval flagfilter {
dict for {k vinfo} $o_map {
lassign $vinfo class type val
if {[string match $classmatch $class]} {
if {$type in [list flag flagvalue soloflag]} {
switch -- $type {
flag - flagvalue - soloflag {
lappend list_flagged $val
}
}
}
}
return $list_flagged
}
@ -775,16 +792,20 @@ namespace eval flagfilter {
return $all_flagged
}
method typedrange_class_type_from_arg {argclass argtype} {
#set o_flagcategory [list "flag" "flagvalue" "soloflag"]
if {$argclass eq "unallocated"} {
if {$argtype in $o_flagcategory} {
switch -- $argtype {
flag - flagvalue - soloflag {
return [list unallocated flagtype]
} else {
}
default {
if {![string length $argtype]} {
#should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the .
set argtype UNKNOWN
}
return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions
}
}
} else {
return [list $argclass argtype] ;# e.g command something
}
@ -916,7 +937,10 @@ namespace eval flagfilter {
append remline [overtype::left $col "."]
} else {
set tp [lindex [dict get $o_map $vidx] 1]
set tp [string map $o_codemap $tp]
#set tp [string map $o_codemap $tp]
if {[dict exists $o_codemap $tp]} {
set tp [dict get $o_codemap $tp]
}
append remline [overtype::left $col $tp]
}
}
@ -935,7 +959,10 @@ namespace eval flagfilter {
dict for {vidx info} $o_map {
lassign $info class type v
if {($c eq $class) || [string equal -length [string length "$c."] "$c." $class]} {
set tp [string map $o_codemap $type]
#set tp [string map $o_codemap $type]
if {[dict exists $o_codemap $type]} {
set tp [dict get $o_codemap $type]
}
append cline [overtype::left $col $tp]
} else {
append cline [overtype::left $col "."]
@ -951,7 +978,10 @@ namespace eval flagfilter {
append aline [overtype::left $col "."]
} else {
set tp [lindex [dict get $o_map $vidx] 1]
set tp [string map $o_codemap $tp]
#set tp [string map $o_codemap $tp]
if {[dict exists $o_codemap $tp]} {
set tp [dict get $o_codemap $tp]
}
append aline [overtype::left $col $tp]
}
}
@ -1389,7 +1419,7 @@ namespace eval flagfilter {
set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"]
return [list \
return [dict create \
listremaining $unconsumed_flags_and_values \
parseerrors $argerrors \
parsestatus $parsestatus \
@ -1463,7 +1493,7 @@ namespace eval flagfilter {
#not even flaglike
return 1
}
if {$f in [list "-" "--"]} {
if {$f in {- --}} {
return 1
}
}
@ -1557,24 +1587,16 @@ namespace eval flagfilter {
set o_pairopts [list]
set o_longopts [list]
if {[dict exists $o_pinfo mashopts]} {
foreach m [dict get $o_pinfo mashopts] {
lappend o_mashopts $m
}
lappend o_mashopts {*}[dict get $o_pinfo mashopts]
}
if {[dict exists $o_pinfo singleopts]} {
foreach s [dict get $o_pinfo singleopts] {
lappend o_singleopts $s
}
lappend o_singleopts {*}[dict get $o_pinfo singleopts]
}
if {[dict exists $o_pinfo pairopts]} {
foreach po [dict get $o_pinfo pairopts] {
lappend o_pairopts $po
}
lappend o_pairopts {*}[dict get $o_pinfo pairopts]
}
if {[dict exists $o_pinfo longopts]} {
foreach l [dict get $o_pinfo longopts] {
lappend o_longopts $l
}
lappend o_longopts {*}[dict get $o_pinfo longopts]
}
}
@ -1701,16 +1723,17 @@ namespace eval flagfilter {
if {[my can_match $a]} {
return 0
}
if {$a in [list "-" "--"]} {
if {$a in {- --}} {
#specials not defined as solos
return 0
}
if {$o_name eq "global"} {
}
if {$o_name eq "tail_processor"} {
} elseif {$o_name eq "tail_processor"} {
}
if {$a in $o_singleopts} {
return 1
}
@ -1782,6 +1805,7 @@ namespace eval flagfilter {
if {[my is_sub]} {
#this spec is a sub
set subopts [my get_opts]
#does order matter? could use struct::set union ?
foreach m [dict get $subopts mashopts] {
if {$m ni $mashopts} {
lappend mashopts $m
@ -1822,12 +1846,10 @@ namespace eval flagfilter {
proc get_command_info {cmdname cspecs} {
foreach item $cspecs {
lassign $item cmd specinfo
if {$cmd eq $cmdname} {
if {[dict exists $specinfo dispatch]} {
if {$cmd eq $cmdname && [dict exists $specinfo dispatch]} {
return $specinfo
}
}
}
return [list]
}
#### check_flags
@ -2103,13 +2125,11 @@ namespace eval flagfilter {
#puts stderr " check_flags - temporary disable of checking for invalid flags"
set pairflagged $flagged_list
foreach {f v} $pairflagged {
if {$f ni $acceptextra} {
if {$f ni $known_flags} {
if {$f ni $acceptextra && $f ni $known_flags} {
lappend invalid_flags $f
}
}
}
}
if {[llength $invalid_flags]} {
do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'"
}
@ -2176,7 +2196,7 @@ namespace eval flagfilter {
do_debug 2 $debugc "commandinfo for $parentname: $commandinfo"
set command [dict get $dispatchrecord command]
#support for %x% placeholders in dispatchrecord command
set command [string map [list %match% %matched%] $command] ;#alias
set command [string map {%match% %matched%} $command] ;#alias
set command [string map [list %matched% [dict get $dispatchrecord matched]] $command]
set argnum_indices [regexp -indices -all -inline $re_argnum $command]
@ -2222,11 +2242,12 @@ namespace eval flagfilter {
set matched_opts [list]
set matched_in_order [list]
set prefix "${parentname}."
set prefixlen [string length $prefix]
foreach {k v} $argvals {
#puts "$$$$ $k"
if {[string equal -length [string length $prefix] $prefix $k]} {
if {[string equal -length $prefixlen $prefix $k]} {
#key is prefixed with "commandname."
set k [string replace $k 0 [string length $prefix]-1]
set k [string replace $k 0 $prefixlen-1]
}
#todo - -- ?
if {[string match -* $k]} {
@ -2548,9 +2569,10 @@ namespace eval flagfilter {
} else {
set tail_unallocated [list]
}
set extraflags [list]
#set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated]
#dict merge based operation can't work if there are solo_flags
#set extraflags [list]
set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated]
#dict merge based operation can't work if there are solo_flags?
#review
if {[llength $tail_unallocated]} {
for {set i $a} {$i <=$b} {incr i} {
set arginfo [dict get $classifications $i]
@ -2597,10 +2619,11 @@ namespace eval flagfilter {
for {set i $a} {$i <=$b} {incr i} {
set arginfo [dict get $classifications $i]
lassign $arginfo class ftype v
if {$ftype eq "flag"} {
switch -- $ftype {
flag - flagvalue {
lappend extraflags $v
}
if {$ftype eq "soloflag"} {
soloflag {
lappend extraflags $v
if {[dict exists $defaults $v]} {
lappend extraflags [dict get $defaults $v]
@ -2608,8 +2631,6 @@ namespace eval flagfilter {
lappend extraflags 1
}
}
if {$ftype eq "flagvalue"} {
lappend extraflags $v
}
}
foreach {k v} [dict get $defaults] {

3
src/modules/punk-0.1.tm

@ -4603,7 +4603,8 @@ namespace eval punk {
know {[expr $args] || 1} {tailcall expr $args}
#it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc
know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} {punk::lib:range $from $to}
#punk::lib::range is defined as a wrapper to lseq if it is available (8.7+)
know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to}
#NOTE:

96
src/modules/punk/args-999999.0a1.0.tm

@ -427,7 +427,7 @@ tcl::namespace::eval punk::args {
dict - dictionary {
set v dict
}
any - ansistring {
none - any - ansistring {
}
default {
@ -566,6 +566,7 @@ tcl::namespace::eval punk::args {
}
}
-default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE {
#review -solo 1 vs -type none ?
tcl::dict::set spec_merged $spec $specval
}
default {
@ -663,8 +664,51 @@ tcl::namespace::eval punk::args {
return $caller
}
proc err {msg args} {
proc arg_error {msg spec_dict {badarg ""}} {
set errmsg $msg
if {![catch {package require textblock}]} {
append errmsg \n
set t [textblock::class::table new [a+ web-yellow]Usage[a]]
$t add_column -headers {Arg}
$t add_column -headers {Type}
$t add_column -headers {Default}
set c_default [a+ web-white Web-limegreen]
set c_badarg [a+ web-crimson]
foreach arg [dict get $spec_dict opt_names] {
set arginfo [dict get $spec_dict arg_info $arg]
if {[dict exists $arginfo -default]} {
#set default $c_default[dict get $arginfo -default]
set default [dict get $arginfo -default]
} else {
set default ""
}
$t add_row [list $arg [dict get $arginfo -type] $default]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg
}
}
foreach arg [dict get $spec_dict val_names] {
set arginfo [dict get $spec_dict arg_info $arg]
if {[dict exists $arginfo -default]} {
set default [dict get $arginfo -default]
} else {
set default ""
}
$t add_row [list $arg [dict get $arginfo -type] $default]
if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg
}
}
$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow]
append errmsg [$t print]
} else {
#todo - something boring
}
error $errmsg
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
@ -761,12 +805,12 @@ tcl::namespace::eval punk::args {
set a [lindex $arglist $i]
if {![tcl::string::match -* $a]} {
#we can't treat as first positional arg - as it comes before the eopt indicator --
error "punk::args::get_dict bad options for [Get_caller]. Expected flag (leading -) at position $i got:$rawargs"
arg_error "punk::args::get_dict bad options for [Get_caller]. Expected flag (leading -) at position $i got:$rawargs" $argspecs
}
#TODO!
if {[tcl::dict::get $arg_info $a -type] ne "none"} {
if {[incr i] > $maxidx} {
error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $a which is not marked with -solo 1"
arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $a which is not marked with -solo 1" $argspecs $a
}
}
lappend flagsreceived $a ;#dups ok
@ -798,7 +842,7 @@ tcl::namespace::eval punk::args {
}
#incr i to skip flagval
if {[incr i] > $maxidx} {
error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none"
arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt
}
} else {
#type none (solo-flag)
@ -828,7 +872,7 @@ tcl::namespace::eval punk::args {
}
lappend flagsreceived $a ;#adhoc flag as supplied
if {[incr i] > $maxidx} {
error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none"
arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a
}
} else {
#review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none
@ -845,7 +889,7 @@ tcl::namespace::eval punk::args {
} else {
#delay Get_caller so only called in the unhappy path
set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt]
error $errmsg
arg_error $errmsg $argspecs $fullopt
}
}
}
@ -892,14 +936,14 @@ tcl::namespace::eval punk::args {
if {$val_max == -1} {
#only check min
if {$num_values < $val_min} {
error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min"
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs
}
} else {
if {$num_values < $val_min || $num_values > $val_max} {
if {$val_min == $val_max} {
error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min"
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs
} else {
error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive"
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs
}
}
}
@ -926,10 +970,10 @@ tcl::namespace::eval punk::args {
#}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength [set missing [punk::lib::ldiff $opt_required $flagsreceived]]]} {
error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form"
arg_error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" $argspecs
}
if {[llength [set missing [punk::lib::ldiff $val_required $valnames_received]]]} {
error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present"
arg_error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" $argspecs
}
@ -1009,13 +1053,13 @@ tcl::namespace::eval punk::args {
-minlen {
# -1 for disable is as good as zero
if {[tcl::string::length $e_check] < $checkval} {
error "Option $argname for [Get_caller] requires string with -minlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'"
arg_error "Option $argname for [Get_caller] requires string with -minlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs $argname
}
}
-maxlen {
if {$checkval ne "-1"} {
if {[tcl::string::length $e_check] > $checkval} {
error "Option $argname for [Get_caller] requires string with -maxlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'"
arg_error "Option $argname for [Get_caller] requires string with -maxlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs $argname
}
}
}
@ -1032,16 +1076,16 @@ tcl::namespace::eval punk::args {
lassign [tcl::dict::get $thisarg -range] low high
foreach e $vlist e_check $vlist_check {
if {![tcl::string::is integer -strict $e_check]} {
error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'"
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname
}
if {$e_check < $low || $e_check > $high} {
error "Option $argname for [Get_caller] must be integer between $low and $high. Received: '$e'"
arg_error "Option $argname for [Get_caller] must be integer between $low and $high. Received: '$e'" $argspecs $argname
}
}
} else {
foreach e_check $vlist_check {
if {![tcl::string::is integer -strict $e_check]} {
error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'"
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs $argname
}
}
}
@ -1060,7 +1104,7 @@ tcl::namespace::eval punk::args {
#todo - small-value double comparisons with error-margin? review
lassign $checkval low high
if {$e_check < $low || $e_check > $high} {
error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'"
arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs $argname
}
}
}
@ -1071,14 +1115,14 @@ tcl::namespace::eval punk::args {
bool {
foreach e_check $vlist_check {
if {![tcl::string::is boolean -strict $e_check]} {
error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'"
arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs $argname
}
}
}
dict {
foreach e_check $vlist_check {
if {[llength $e_check] %2 != 0} {
error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'"
arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs $argname
}
}
}
@ -1097,7 +1141,7 @@ tcl::namespace::eval punk::args {
xdigit {
foreach e $vlist e_check $vlist_check {
if {![tcl::string::is $type $e_check]} {
error "Option $argname for [Get_caller] requires type '$type'. Received: '$e'"
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" $argspecs $argname
}
}
}
@ -1108,19 +1152,19 @@ tcl::namespace::eval punk::args {
foreach e $vlist e_check $vlist_check {
if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} {
#what about special file names e.g on windows NUL ?
error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory"
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs $argname
}
}
if {$type eq "existingfile"} {
foreach e $vlist e_check $vlist_check {
if {![file exists $e_check]} {
error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file"
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs $argname
}
}
} elseif {$type eq "existingdirectory"} {
foreach e $vlist e_check $vlist_check {
if {![file isdirectory $e_check]} {
error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory"
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs $argname
}
}
}
@ -1128,7 +1172,7 @@ tcl::namespace::eval punk::args {
char {
foreach e $vlist e_check $vlist_check {
if {[tcl::string::length $e_check] != 1} {
error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character"
arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs $argname
}
}
}
@ -1148,7 +1192,7 @@ tcl::namespace::eval punk::args {
set choices_test $choices
}
if {$v_test ni $choices_test} {
error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'"
arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname
}
}
}

4
src/modules/punk/char-999999.0a1.0.tm

@ -1990,7 +1990,9 @@ tcl::namespace::eval punk::char {
#\uFFEFBOM/ ZWNBSP and others that should be zero width
#todo - work out proper way to mark/group zero width.
set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text]
#set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text]
set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text]
#\uFFEF tends to print as 1 length replacement char - REVIEW
# -- --- --- --- --- --- ---
#we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f

8
src/modules/punk/console-999999.0a1.0.tm

@ -20,10 +20,10 @@
package require punk::ansi
if {"windows" eq $::tcl_platform(platform)} {
#package require zzzload
#zzzload::pkg_require twapi
}
#if {"windows" eq $::tcl_platform(platform)} {
# #package require zzzload
# #zzzload::pkg_require twapi
#}
#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt
#https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session

2
src/modules/punk/du-999999.0a1.0.tm

@ -1024,7 +1024,7 @@ namespace eval punk::du {
dict set effective_opts -with_times $timed_types
dict set effective_opts -with_sizes $sized_types
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times $alltimes flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors]
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors]
}
#we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files

13
src/modules/punk/fileline-999999.0a1.0.tm

@ -1650,16 +1650,19 @@ namespace eval punk::fileline::system {
#gets very slow (comparitively) with large resultsets
proc _range_spans_chunk_boundaries_tcl {start end chunksize args} {
if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly
set defaults [dict create\
set opts [dict create\
-offset 0\
]
set known_opts [dict keys $defaults]
foreach {k v} $args {
if {$k ni $known_opts} {
error "unknown option '$k'. Known options: $known_opts"
switch -- $k {
-offset {
dict set opts $k $v
}
default {
error "unknown option '$k'. Known options: [dict keys $opts]"
}
}
}
set opts [dict merge $defaults $args]
# -- --- --- ---
set opt_offset [dict get $opts -offset]
# -- --- --- ---

151
src/modules/punk/lib-999999.0a1.0.tm

@ -335,15 +335,66 @@ namespace eval punk::lib {
#[para] Core API functions for punk::lib
#[list_begin definitions]
proc range {from to args} {
if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster for larger ranges
return [lseq $from $to]
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#support minimal set from to
proc range {from to} {
lseq $from $to
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
proc range {from to} {
set to [offset_expr $to]
set from [offset_expr $from]
if {$to > $from} {
set count [expr {($to -$from) + 1}]
if {$from == 0} {
return [lsearch -all [lrepeat $count 0] *]
} else {
incr from -1
return [lmap v [lrepeat $count 0] {incr from}]
}
#slower methods.
#2)
#set i -1
#set L [lrepeat $count 0]
#lmap v $L {lset L [incr i] [incr from];lindex {}}
#return $L
#3)
#set L {}
#for {set i 0} {$i < $count} {incr i} {
# lappend L [incr from]
#}
#return $L
} elseif {$from > $to} {
set count [expr {$from - $to} + 1]
#1)
if {$to == 0} {
return [lreverse [lsearch -all [lrepeat $count 0] *]]
} else {
incr from
return [lmap v [lrepeat $count 0] {incr from -1}]
}
#2)
#set i -1
#set L [lrepeat $count 0]
#lmap v $L {lset L [incr i] [incr from -1];lindex {}}
#return $L
#3)
#set L {}
#for {set i 0} {$i < $count} {incr i} {
# lappend L [incr from -1]
#}
#return $L
} else {
return [list $from]
}
}
}
proc is_list_all_in_list {small large} {
package require struct::list
package require struct::set
@ -358,14 +409,53 @@ namespace eval punk::lib {
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::list has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other.
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
set result {}
foreach item $fromlist {
if {$item ni $removeitems} {
lappend result $item
}
}
return $result
}
proc ldiff2 {fromlist removeitems} {
set doomed [list]
foreach item $removeitems {
lappend doomed {*}[lsearch -all -exact $fromlist $item]
}
lremove $fromlist {*}$doomed
}
#non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B
#consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference
#also struct::set difference with critcl is faster
proc setdiff {A B} {
if {[llength $A] == 0} {return {}}
set d [dict create]
foreach x $A {dict set d $x {}}
foreach x $B {dict unset d $x}
return [dict keys $d]
}
#bulk dict remove is slower than a foreach with dict unset
#proc setdiff2 {fromlist removeitems} {
# #if {[llength $fromlist] == 0} {return {}}
# set d [dict create]
# foreach x $fromlist {
# dict set d $x {}
# }
# return [dict keys [dict remove $d {*}$removeitems]]
#}
#array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that)
proc setdiff_unordered {A B} {
if {[llength $A] == 0} {return {}}
array set tmp {}
foreach x $A {::set tmp($x) .}
foreach x $B {catch {unset tmp($x)}}
return [array names tmp]
}
package require struct::set
if {[struct::set equal [struct::set union {a a} {}] {a}]} {
proc lunique_unordered {list} {
@ -373,12 +463,22 @@ namespace eval punk::lib {
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
#we could also test a sequence of: struct::set add
proc lunique_unordered {list} {
tailcall lunique $list
}
}
#order-preserving
proc lunique {list} {
set new {}
foreach item $list {
if {$item ni $new} {
lappend new $item
}
}
return $new
}
proc lunique2 {list} {
set doomed [list]
#expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?)
for {set i 0} {$i < [llength $list]} {} {
@ -388,30 +488,6 @@ namespace eval punk::lib {
}
lremove $list {*}$doomed
}
proc lunique1 {list} {
set doomed [list]
#expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?)
set i 0
foreach item $list {
if {$i in $doomed} {
incr i
continue
}
lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end]
incr i
}
puts --->doomed:$doomed
lremove $list {*}$doomed
}
proc lunique2 {list} {
set new {}
foreach item $list {
if {$item ni $new} {
lappend new $item
}
}
return $new
}
#The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env
proc lmapflat_closure {varnames list script} {
set result [list]
@ -537,6 +613,23 @@ namespace eval punk::lib {
# return "ok"
#}
#supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features
#safe in that we don't evaluate the expression as a string.
proc offset_expr {expression} {
set expression [tcl::string::map {_ {}} $expression]
if {[tcl::string::is integer -strict $expression]} {
return [expr {$expression}]
}
if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} {
if {$op eq "-"} {
return [expr {$a - $b}]
} else {
return [expr {$a + $b}]
}
} else {
error "bad expression '$expression': must be integer?\[+-\]integer?"
}
}
proc lindex_resolve {list index} {
#*** !doctools
@ -554,7 +647,7 @@ namespace eval punk::lib {
if {![llength $list]} {
return -1
}
set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000
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} {

29
src/modules/punk/mix/commandset/module-999999.0a1.0.tm

@ -129,18 +129,25 @@ namespace eval punk::mix::commandset::module {
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations"
}
}
proc new {module args} {
proc new {args} {
set year [clock format [clock seconds] -format %Y]
set defaults [list\
-project \uFFFF\
-version \uFFFF\
-license <unspecified>\
-template punk.module\
-type \uFFFF\
-force 0\
-quiet 0\
]
set opts [dict merge $defaults $args]
set moduletypes [punk::mix::cli::lib::module_types]
set argspecs [subst {
-project -default \uFFFF
-version -default \uFFFF
-license -default <unspecified>
-template -default punk.module
-type -default \uFFFF -choices {$moduletypes}
-force -default 0 -type boolean
-quiet -default 0 -type boolean
*values -min 1 -max 1
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]
#todo - review compatibility between -template and -type
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)

2
src/modules/punk/mix/templates-999999.0a1.0.tm

@ -59,7 +59,7 @@ namespace eval punk::mix::templates {
oo::objdefine provider {
method register {{capabilityname_glob *}} {
#puts registering punk::mix::templates $capabilityname
next
next $capabilityname_glob
}
method capabilities {} {
next

Loading…
Cancel
Save