From 1b85cb9a3706aae3c59c6c0441af889633e6d2f4 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 19 Jun 2024 06:07:55 +1000 Subject: [PATCH] misc fixups, punk::args usage table in error msg --- src/modules/argparsingtest-999999.0a1.0.tm | 26 +- src/modules/flagfilter-0.3.tm | 445 +++++++++--------- src/modules/natsort-0.1.1.6.tm | 6 +- src/modules/punk-0.1.tm | 3 +- src/modules/punk/args-999999.0a1.0.tm | 96 +++- src/modules/punk/char-999999.0a1.0.tm | 4 +- src/modules/punk/console-999999.0a1.0.tm | 8 +- src/modules/punk/du-999999.0a1.0.tm | 2 +- src/modules/punk/fileline-999999.0a1.0.tm | 13 +- src/modules/punk/lib-999999.0a1.0.tm | 159 +++++-- .../mix/commandset/module-999999.0a1.0.tm | 29 +- .../punk/mix/templates-999999.0a1.0.tm | 2 +- 12 files changed, 482 insertions(+), 311 deletions(-) diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 8e9720e..b2e41c5 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/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} diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-0.3.tm index c6064ea..007a66b 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/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]] @@ -228,23 +228,23 @@ namespace eval flagfilter { dictformat_rec $dict "" " " } proc dictformat_rec {dict indent indentstring} { - # unpack this dimension - set is_empty 1 - dict for {key value} $dict { - set is_empty 0 - if {[isdict $value]} { - append result "$indent[list $key]\n$indent\{\n" - append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" - append result "$indent\}\n" - } else { - append result "$indent[list $key] [list $value]\n" - } - } - if {$is_empty} { - #experimental.. - append result "$indent\n" - #append result "" - } + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } return $result } #-------------------------------------------------------------------------- @@ -252,96 +252,96 @@ namespace eval flagfilter { #solo 'category' includes longopts with value #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) proc is_this_flag_solo {f solos objp} { - if {![string match -* $f]} { - #not even flaglike - return 0 - } + if {![string match -* $f]} { + #not even flaglike + return 0 + } - if {$f in $solos} { - #review! - global -soloflags shouldn't override the requirements of a commandprocessor! - #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. - #todo - this may need to reference v_map and current position in scanlist to do properly - return 1 - } - if {$f eq "-"} { - #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) - return 0 - } - if {$f eq "--"} { - #this is it's own type endofoptions - return 0 - } + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } - set p_opts [$objp get_combined_opts] + set p_opts [$objp get_combined_opts] - set mashopts [dict get $p_opts mashopts] - set singleopts [dict get $p_opts singleopts] - set pairopts [dict get $p_opts pairopts] - set longopts [dict get $p_opts longopts] + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] - if {$f in $singleopts} { - return 1 - } + if {$f in $singleopts} { + return 1 + } - #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand - #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly - if {"any" in $singleopts} { - return 1 - } - if {[string first "=" $f] >=1} { - if {"any" in $longopts} { - return 1 - } - #todo foreach longopt - split on = and search - } + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } - #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now - if {($f in $pairopts) && ($f ni $mashopts)} { - return 0 - } - #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? - #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) - #last part of mash may actually be the value too. which complicates things - #linux ls seems to do this for example: - # ls -w 0 - # ls -lw 0 - # ls -lw0 - # also man.. e.g - # man -Tdvi - # man -Hlynx - # man -H - # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) - # see also comments in is_this_flag_mash - # + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # - set flagletters [split [string range $f 1 end] ""] - set posn 1 - set is_solo 1 ;#default assumption to disprove - #trailing letters may legitimately not be in mashopts if they are part of a mashed value - #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing - foreach l $flagletters { - if {"-$l" ni $mashopts} { - #presumably an ordinary flag not-known to us - return 0 - } else { - if {"-$l" in $pairopts} { - if {$posn == [llength $flagletters]} { - #in pairopts and mash - but no value for it in the mash - thefore not a solo - return 0 + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters } else { - #entire tail is the value - this letter is effectively solo + #can take a value! but not if at very end of mash. Either way This is a solo return 1 } - } elseif {"-$l" in $singleopts} { - #not allowed to take a value - keep processing letters - } else { - #can take a value! but not if at very end of mash. Either way This is a solo - return 1 } } - } - return $is_solo + return $is_solo } #todo? support global (non-processor specific) mash list? -mashflags ? proc is_this_flag_mash {f objp} { @@ -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 @@ -449,43 +449,43 @@ namespace eval flagfilter { proc add_dispatch_raw {recordvar parentname v} { upvar $recordvar drecord if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname raw] - lappend dispatchinfo $v - dict set drecord $parentname raw $dispatchinfo + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo } } proc add_dispatch_argument {recordvar parentname k v} { upvar $recordvar drecord if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname arguments] - lappend dispatchinfo $k $v ;#e.g -opt 1 - dict set drecord $parentname arguments $dispatchinfo + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo } } proc lsearch-all-stride-2 {l search} { - set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] - return [lsearch -all -inline -not $posns x] + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] } proc update_dispatch_argument {recordvar parentname k v} { upvar $recordvar drecord if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname arguments] - #can't assume there aren't repeat values e.g -v -v - #dict set dispatchinfo $k $v - if {[package vcompare [info tclversion] 8.7a5] >= 0} { - set posns [lsearch -all -stride 2 $dispatchinfo $k] - } else { - set posns [lsearch-all-stride-2 $dispatchinfo $k] - } - set lastitem [lindex $posns end] - if {[string length $lastitem]} { - set val_idx [expr {$lastitem + 1}] - set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK - dict set drecord $parentname arguments $dispatchinfo - } else { - error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" - } - #dict set drecord $parentname $dispatchinfo + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo } } @@ -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,17 +617,29 @@ namespace eval flagfilter { variable o_codemap variable o_flagcategory constructor {values} { - set o_codemap [list \ - operand op \ - flagvalue fv \ - soloflag so \ - flag fl \ - unallocated un \ - endofoptions eo \ + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ ] 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 * 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,8 +715,11 @@ 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]} { - lappend resultlist $val + switch -- $type { + flag - flagvalue - soloflag {} + default { + lappend resultlist $val + } } } } @@ -716,8 +731,10 @@ 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]} { - lappend list_flagged $val + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } } } } @@ -775,15 +792,19 @@ 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} { - return [list unallocated flagtype] - } else { - 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 + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + 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 } - return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions } } else { return [list $argclass argtype] ;# e.g command something @@ -916,17 +937,20 @@ 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] } } set cmdlist [list] dict for {vidx info} $o_map { if {[lindex $info 0] ne "unallocated"} { - set c [lindex [split [lindex $info 0] .] 0] - if {$c ni $cmdlist} { - lappend cmdlist $c - } + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } } } set clinelist [list] @@ -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,27 +1419,27 @@ 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 \ - flagged $all_flagged_plus \ - flaggedlist $all_flagged_list \ - flaggedremaining $remaining_flagged \ - flaggedlistremaining $remaining_flagged_list \ - unflagged $unflagged \ - unflaggedlist $unflagged_list \ - unflaggedremaining $remaining_unflagged \ - unflaggedlistremaining $unflagged_list_remaining \ - flaggednew $extra_flags_from_positionals \ - arglist [concat $unflagged_list_in_processing_order $all_flagged] \ - arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ - impliedflagged $implied_flagged \ - impliedunflagged $implied_unflagged \ - dispatch $dispatch \ - classifications [$VMAP get_map] \ - gridstring "\n[$VMAP grid]" \ - vmapobject "flagfilter::VMAP_$runid" \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ ] } @@ -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 @@ -1821,12 +1845,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]} { - return $specinfo + lassign $item cmd specinfo + if {$cmd eq $cmdname && [dict exists $specinfo dispatch]} { + return $specinfo } - } } return [list] } @@ -2103,10 +2125,8 @@ 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} { - lappend invalid_flags $f - } + if {$f ni $acceptextra && $f ni $known_flags} { + lappend invalid_flags $f } } } @@ -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,20 +2619,19 @@ 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"} { - lappend extraflags $v - } - if {$ftype eq "soloflag"} { - lappend extraflags $v - if {[dict exists $defaults $v]} { - lappend extraflags [dict get $defaults $v] - } else { - lappend extraflags 1 + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v } - } - if {$ftype eq "flagvalue"} { - lappend extraflags $v - } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } } foreach {k v} [dict get $defaults] { if {$k ni $extraflags} { diff --git a/src/modules/natsort-0.1.1.6.tm b/src/modules/natsort-0.1.1.6.tm index 92bb7e7..9509f55 100644 --- a/src/modules/natsort-0.1.1.6.tm +++ b/src/modules/natsort-0.1.1.6.tm @@ -1712,9 +1712,9 @@ namespace eval natsort { set debug [dict get $args -debug] - set collate [dict get $args -collate] - set db [dict get $args -db] - set winlike [dict get $args -winlike] + set collate [dict get $args -collate] + set db [dict get $args -db] + set winlike [dict get $args -winlike] set topchars [dict get $args -topchars] diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index fbadc29..b387f41 100644 --- a/src/modules/punk-0.1.tm +++ b/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: diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 589ab69..659af98 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/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 } } } diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 9bf6ffa..a87ef47 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/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 diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 29926f4..b9625b3 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/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 diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index fb958eb..4ac59be 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/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 diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 3c5339e..8691745 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/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] # -- --- --- --- diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 5472295..6b64ccf 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/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] + if {[info commands lseq] ne ""} { + #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] + } } - set count [expr {($to -$from) + 1}] - incr from -1 - return [lmap v [lrepeat $count 0] {incr 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 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} { diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 0428c74..c5387b4 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/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 \ - -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 + -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) diff --git a/src/modules/punk/mix/templates-999999.0a1.0.tm b/src/modules/punk/mix/templates-999999.0a1.0.tm index e109469..0f73081 100644 --- a/src/modules/punk/mix/templates-999999.0a1.0.tm +++ b/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