set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $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)
# mashopt cannot be in both singleopts and pairopts. (NAND)
foreach l $flagletters {
foreach l $flagletters {
if {-$l in $pairopts} {
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.
#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
# We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt
break
break
@ -561,7 +561,7 @@ namespace eval flagfilter {
if {$f in $solos} {
if {$f in $solos} {
return 0
return 0
}
}
if {$f in [list "-" "--"]} {
if {$f in {- --}} {
return 0
return 0
}
}
#longopts (--x=blah) and alternative --x blah
#longopts (--x=blah) and alternative --x blah
@ -617,7 +617,7 @@ namespace eval flagfilter {
variable o_codemap
variable o_codemap
variable o_flagcategory
variable o_flagcategory
constructor {values} {
constructor {values} {
set o_codemap [list \
set o_codemap [dict create \
operand op \
operand op \
flagvalue fv \
flagvalue fv \
soloflag so \
soloflag so \
@ -627,7 +627,19 @@ namespace eval flagfilter {
]
]
set o_flagcategory [list "flag" "flagvalue" "soloflag"]
set o_flagcategory [list "flag" "flagvalue" "soloflag"]
set o_values $values
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]
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
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
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 {
} 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
#review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
#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]]]} {
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]]]} {
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
if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} {
if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} {
#what about special file names e.g on windows NUL ?
#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"} {
if {$type eq "existingfile"} {
foreach e $vlist e_check $vlist_check {
foreach e $vlist e_check $vlist_check {
if {![file exists $e_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"} {
} elseif {$type eq "existingdirectory"} {
foreach e $vlist e_check $vlist_check {
foreach e $vlist e_check $vlist_check {
if {![file isdirectory $e_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
#tcl 8.7+ lseq significantly faster for larger ranges
#tcl 8.7+ lseq significantly faster, especially for larger ranges
return [lseq $from $to]
#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}]
set count [expr {($to -$from) + 1}]
if {$from == 0} {
return [lsearch -all [lrepeat $count 0] *]
} else {
incr from -1
incr from -1
return [lmap v [lrepeat $count 0] {incr from}]
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 {}}
#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} {
proc is_list_all_in_list {small large} {
package require struct::list
package require struct::list
package require struct::set
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
#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,
#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} {
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
#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
#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} {
proc lmapflat_closure {varnames list script} {
set result [list]
set result [list]
@ -537,6 +613,23 @@ namespace eval punk::lib {
# return "ok"
# 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} {
proc lindex_resolve {list index} {
#*** !doctools
#*** !doctools
@ -554,7 +647,7 @@ namespace eval punk::lib {
if {![llength $list]} {
if {![llength $list]} {
return -1
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
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations"
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 year [clock format [clock seconds] -format %Y]
set defaults [list\
set moduletypes [punk::mix::cli::lib::module_types]
-project \uFFFF\
set argspecs [subst {
-version \uFFFF\
-project -default \uFFFF
-license <unspecified>\
-version -default \uFFFF
-template punk.module\
-license -default <unspecified>
-type \uFFFF\
-template -default punk.module
-force 0\
-type -default \uFFFF -choices {$moduletypes}
-quiet 0\
-force -default 0 -type boolean
]
-quiet -default 0 -type boolean
set opts [dict merge $defaults $args]
*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
#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)
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)
