#solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts)
#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} {
proc is_this_flag_solo {f solos objp} {
if {![string match -* $f]} {
if {![string match -* $f]} {
#not even flaglike
#not even flaglike
return 0
return 0
}
}
if {$f in $solos} {
if {$f in $solos} {
#review! - global -soloflags shouldn't override the requirements of a commandprocessor!
#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..
#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
#todo - this may need to reference v_map and current position in scanlist to do properly
return 1
return 1
}
}
if {$f eq "-"} {
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)
#unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match)
return 0
return 0
}
}
if {$f eq "--"} {
if {$f eq "--"} {
#this is it's own type endofoptions
#this is it's own type endofoptions
return 0
return 0
}
}
set p_opts [$objp get_combined_opts]
set p_opts [$objp get_combined_opts]
set mashopts [dict get $p_opts mashopts]
set mashopts [dict get $p_opts mashopts]
set singleopts [dict get $p_opts singleopts]
set singleopts [dict get $p_opts singleopts]
set pairopts [dict get $p_opts pairopts]
set pairopts [dict get $p_opts pairopts]
set longopts [dict get $p_opts longopts]
set longopts [dict get $p_opts longopts]
if {$f in $singleopts} {
if {$f in $singleopts} {
return 1
return 1
}
}
#"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand
#"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
#examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly
if {"any" in $singleopts} {
if {"any" in $singleopts} {
return 1
return 1
}
}
if {[string first "=" $f] >=1} {
if {[string first "=" $f] >=1} {
if {"any" in $longopts} {
if {"any" in $longopts} {
return 1
return 1
}
}
#todo foreach longopt - split on = and search
#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
#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)} {
if {($f in $pairopts) && ($f ni $mashopts)} {
return 0
return 0
}
}
#todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash?
#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)
#(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
#last part of mash may actually be the value too. which complicates things
#linux ls seems to do this for example:
#linux ls seems to do this for example:
# ls -w 0
# ls -w 0
# ls -lw 0
# ls -lw 0
# ls -lw0
# ls -lw0
# also man.. e.g
# also man.. e.g
# man -Tdvi
# man -Tdvi
# man -Hlynx
# man -Hlynx
# man -H
# 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)
# - 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
# see also comments in is_this_flag_mash
#
#
set flagletters [split [string range $f 1 end] ""]
set flagletters [split [string range $f 1 end] ""]
set posn 1
set posn 1
set is_solo 1 ;#default assumption to disprove
set is_solo 1 ;#default assumption to disprove
#trailing letters may legitimately not be in mashopts if they are part of a mashed value
#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
#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 {
foreach l $flagletters {
if {"-$l" ni $mashopts} {
if {"-$l" ni $mashopts} {
#presumably an ordinary flag not-known to us
#presumably an ordinary flag not-known to us
return 0
return 0
} else {
} else {
if {"-$l" in $pairopts} {
if {"-$l" in $pairopts} {
if {$posn == [llength $flagletters]} {
if {$posn == [llength $flagletters]} {
#in pairopts and mash - but no value for it in the mash - thefore not a solo
#in pairopts and mash - but no value for it in the mash - thefore not a solo
return 0
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 {
} 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
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 ?
#todo? support global (non-processor specific) mash list? -mashflags ?
proc is_this_flag_mash {f objp} {
proc is_this_flag_mash {f objp} {
@ -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
@ -449,43 +449,43 @@ namespace eval flagfilter {
proc add_dispatch_raw {recordvar parentname v} {
proc add_dispatch_raw {recordvar parentname v} {
upvar $recordvar drecord
upvar $recordvar drecord
if {[dict exists $drecord $parentname]} {
if {[dict exists $drecord $parentname]} {
set dispatchinfo [dict get $drecord $parentname raw]
set dispatchinfo [dict get $drecord $parentname raw]
lappend dispatchinfo $v
lappend dispatchinfo $v
dict set drecord $parentname raw $dispatchinfo
dict set drecord $parentname raw $dispatchinfo
}
}
}
}
proc add_dispatch_argument {recordvar parentname k v} {
proc add_dispatch_argument {recordvar parentname k v} {
upvar $recordvar drecord
upvar $recordvar drecord
if {[dict exists $drecord $parentname]} {
if {[dict exists $drecord $parentname]} {
set dispatchinfo [dict get $drecord $parentname arguments]
set dispatchinfo [dict get $drecord $parentname arguments]
lappend dispatchinfo $k $v ;#e.g -opt 1
lappend dispatchinfo $k $v ;#e.g -opt 1
dict set drecord $parentname arguments $dispatchinfo
dict set drecord $parentname arguments $dispatchinfo
}
}
}
}
proc lsearch-all-stride-2 {l search} {
proc lsearch-all-stride-2 {l search} {
set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}]
set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}]
return [lsearch -all -inline -not $posns x]
return [lsearch -all -inline -not $posns x]
}
}
proc update_dispatch_argument {recordvar parentname k v} {
proc update_dispatch_argument {recordvar parentname k v} {
upvar $recordvar drecord
upvar $recordvar drecord
if {[dict exists $drecord $parentname]} {
if {[dict exists $drecord $parentname]} {
set dispatchinfo [dict get $drecord $parentname arguments]
set dispatchinfo [dict get $drecord $parentname arguments]
#can't assume there aren't repeat values e.g -v -v
#can't assume there aren't repeat values e.g -v -v
#dict set dispatchinfo $k $v
#dict set dispatchinfo $k $v
if {[package vcompare [info tclversion] 8.7a5] >= 0} {
if {[package vcompare [info tclversion] 8.7a5] >= 0} {
set posns [lsearch -all -stride 2 $dispatchinfo $k]
set posns [lsearch -all -stride 2 $dispatchinfo $k]
#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, especially for larger ranges
#tcl 8.7+ lseq significantly faster for larger ranges
#support minimal set from to
return [lseq $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 {}}
#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} {
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)
