You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2670 lines
120 KiB
2670 lines
120 KiB
#package provide flagfilter [namespace eval flagfilter {list [variable version 0.2.3]$version}] |
|
#package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}] |
|
# |
|
#package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}] |
|
package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] |
|
|
|
#Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. |
|
# - we can't know if a flag -x --x etc is expecting a parameter or not. |
|
#0.2.2 2023-03 JN - added %match% placeholder support. Can be added to the dispatch command to tell it what command was actually matched. e.g tell xxx.tcl script that it was xxx.tcl when we matched on *.tcl |
|
|
|
|
|
namespace eval flagfilter { |
|
package require oolib ;# make 'oolib::collection new' available |
|
|
|
proc do_errorx {msg {code 1}} { |
|
if {$::tcl_interactive} { |
|
error $msg |
|
} else { |
|
puts stderr "|>err $msg" |
|
exit $code |
|
} |
|
} |
|
|
|
proc do_error {msg {then error}} { |
|
set levels [list debug info notice warn error critical alert emergency] |
|
#note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call |
|
#this is not just a 'logging' call even though it has syslog-like level descriptors |
|
lassign $then type code |
|
if {$code eq ""} { |
|
set code 1 |
|
} |
|
set type [string tolower $type] |
|
if {$type in [concat $levels exit]} { |
|
puts -nonewline stderr "|$type> $msg\n" |
|
} else { |
|
puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit <numericcode>'\n" |
|
} |
|
flush stderr |
|
if {$::tcl_interactive} { |
|
#may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging |
|
if {[string tolower $type] eq "exit"} { |
|
puts -nonewline stderr " (exit suppressed due to tcl_interactive - raising error instead)\n" |
|
if {![string is digit -strict $code]} { |
|
puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be: 'exit <numericcode>'\n" |
|
} |
|
} |
|
flush stderr |
|
return -code error $msg |
|
} else { |
|
if {$type ne "exit"} { |
|
return -code error $msg |
|
} else { |
|
if {[string is digit -strict $code]} { |
|
exit $code |
|
} else { |
|
puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit <numericcode>'\n" |
|
flush stderr |
|
return -code error $msg |
|
} |
|
} |
|
} |
|
} |
|
proc scriptdir {} { |
|
set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] |
|
if {[file isdirectory $possibly_linked_script]} { |
|
return $possibly_linked_script |
|
} else { |
|
return [file dirname $possibly_linked_script] |
|
} |
|
} |
|
|
|
} |
|
|
|
package require overtype |
|
|
|
|
|
namespace eval flagfilter { |
|
namespace export get_one_flag_value |
|
#review. Tcl can handle args like: {-a -val1 -b -val2} as long as they pair up. |
|
#this will ignore flag-like values if they follow a -flag |
|
# positional values that happen to start with - can still cause issues |
|
#get_flagged_only can return an unpaired list if there are solos, or if it finds no value for the last flaglike element |
|
# e.g from input {something -x -y -z} we will get {-x -y -z} |
|
# |
|
# |
|
|
|
#flagfilter::get_flagged_only may not always get things right when looking at a values list with command processors |
|
#Even if all solos from commands are supplied in solodict - a flag might be solo only in the context of a particualar commandset |
|
#The proper way to get flagged values from an arglist is to run the full parser. |
|
#This then should be restricted to use for a specific subset of args where the supplied solodict is known to apply |
|
proc get_flagged_only {arglist solodict} { |
|
#solodict - solo flags with defaults |
|
set solo_accumulator [dict create] ;#if multiple instances of solo flag found - append defaults to the value to form a list as long as the number of occurrences |
|
#puts ">>>get_flagged_only input $arglist solodict:'$solodict'" |
|
set result [list] |
|
set last_was_flag 0 |
|
set result [list] |
|
set a_idx 0 |
|
set end_of_options 0 |
|
foreach a $arglist { |
|
if {$a eq "--"} { |
|
break |
|
} |
|
if {$a in [dict keys $solodict]} { |
|
set last_was_flag 0 |
|
if {[dict exists $solo_accumulator $a]} { |
|
set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] |
|
} else { |
|
set soloval [dict get $solodict $a] |
|
} |
|
dict set solo_accumulator $a $soloval |
|
#we need to keep order of first appearance |
|
set idx [lsearch $result $a] |
|
if {$idx < 0} { |
|
lappend result $a $soloval |
|
} else { |
|
lset result $idx+1 $soloval |
|
} |
|
} else { |
|
if {!$last_was_flag} { |
|
if {$a eq "--"} { |
|
|
|
} else { |
|
if {[lindex $arglist $a_idx-1] eq "--"} { |
|
#end of options processing - none of the remaining are considered flags/options no matter what they look like |
|
set last_was_flag 0 |
|
break |
|
} else { |
|
if {[string match -* $a]} { |
|
set last_was_flag 1 |
|
lappend result $a ;#flag |
|
} else { |
|
#last wasnt, this isn't - don't output |
|
set last_was_flag 0 |
|
} |
|
} |
|
} |
|
} else { |
|
#we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. |
|
if {$a eq "--"} { |
|
#last was flag |
|
set last_was_flag 0 |
|
} else { |
|
lappend result $a ;#value |
|
set last_was_flag 0 |
|
} |
|
} |
|
} |
|
incr a_idx |
|
} |
|
if {([llength $result] % 2) != 0} { |
|
set last [lindex $result end] |
|
if {[string match -* $last] && ($last ni [dict keys $solodict])} { |
|
lappend result 1 |
|
} |
|
} |
|
#puts ">>>get_flagged_only returning $result" |
|
return $result |
|
} |
|
|
|
|
|
## get_one_paired_flag_value |
|
#best called with 'catch' unless flag known to be in arglist |
|
#raises an error if no position available after the flag to retrieve value |
|
#raises an error if flag not like -something |
|
#raises an error if flag not found in list |
|
proc get_one_paired_flag_value {arglist flag} { |
|
if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { |
|
#regexp excludes plain - and -- |
|
#if {![string match -* $flag]} {} |
|
error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" |
|
} |
|
set cindex [lsearch $arglist $flag] |
|
if {$cindex >= 0} { |
|
set valueindex [expr {$cindex + 1}] |
|
if {$valueindex < [llength $arglist]} { |
|
#puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" |
|
return [lindex $arglist $valueindex] |
|
} else { |
|
error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" |
|
} |
|
} else { |
|
error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" |
|
} |
|
} |
|
} |
|
|
|
namespace eval flagfilter::obj { |
|
|
|
} |
|
|
|
|
|
namespace eval flagfilter { |
|
variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. |
|
#used as a basis for some object-instance names etc |
|
proc get_new_runid {} { |
|
variable run_counter |
|
if {[catch {package require Thread}]} { |
|
set tid 0 |
|
} else { |
|
set tid [thread::id] |
|
} |
|
return "ff-[pid]-${tid}-[incr run_counter]" |
|
} |
|
|
|
namespace export check_flags |
|
proc do_debug {lvl debugconfig msg} { |
|
if {$lvl <= [dict get $debugconfig -debugargs]} { |
|
foreach ln [split $msg \n] { |
|
puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" |
|
flush stderr |
|
} |
|
} |
|
} |
|
|
|
#---------------------------------------------------------------------- |
|
# DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed |
|
#wiki.tcl-lang.org/page/dict+tips+and+tricks |
|
proc isdict {v} { |
|
if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { |
|
return [expr {!([llength $v] % 2)}] |
|
} else { |
|
return [string match "value is a dict *" [::tcl::unsupported::representation $v]] |
|
} |
|
} |
|
|
|
proc dict_format {dict} { |
|
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 "" |
|
} |
|
return $result |
|
} |
|
#-------------------------------------------------------------------------- |
|
|
|
#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 {$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 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 |
|
} |
|
|
|
#"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 |
|
# |
|
|
|
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 { |
|
#can take a value! but not if at very end of mash. Either way This is a solo |
|
return 1 |
|
} |
|
} |
|
} |
|
return $is_solo |
|
} |
|
#todo? support global (non-processor specific) mash list? -mashflags ? |
|
proc is_this_flag_mash {f objp} { |
|
if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { |
|
#not even flaglike |
|
return 0 |
|
} |
|
set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc |
|
|
|
#we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash |
|
set singleopts pdict get $optinfo singleopts] |
|
if {$f in $singleopts} { |
|
return 0 |
|
} |
|
|
|
set pairopts [dict get $optinfo pairopts] |
|
if {$f in [dict keys $pairopts]} { |
|
#here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) |
|
return 0 |
|
} |
|
set mashopts [dict get $optinfo mashopts] |
|
set flagletters [split [string range $f 1 end] ""] |
|
set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value |
|
# .. in which case value could be at the tail of the mash.. or be the next arg in the list |
|
# We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value |
|
# (ie such a mashopt is a solo that can take a value only as a mashtail) |
|
# presence in pairopts indicates a mashflag must have a value |
|
# presense in singleopts indicates mashflag takes no value ever. |
|
# mashopt cannot be in both singleopts and pairopts. (NAND) |
|
foreach l $flagletters { |
|
if {-$l in $pairopts} { |
|
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 |
|
} else { |
|
#we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash |
|
set is_mash 0 |
|
} |
|
} elseif {"-$l" in $singleopts} { |
|
#singleopt & mashopt - cannot take a value, mashed or otherwise |
|
if {"-$l" ni $mashopts} { |
|
set is_mash 0 |
|
} |
|
} else { |
|
if {"-$l" ni $mashopts} { |
|
set is_mash 0 |
|
} else { |
|
#present only in mashopts - can take a value, but only immediately following in the mash |
|
break |
|
} |
|
} |
|
} |
|
return $is_mash |
|
} |
|
proc is_this_flag_for_me {f objp cf_args} { |
|
set processorname [$objp name] |
|
set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc |
|
|
|
if {$processorname in [list "tail_processor"]} { |
|
return 1 |
|
} |
|
if {$processorname in [list "global"]} { |
|
#todo - mashflags for global? |
|
set defaults [dict get $cf_args -defaults] |
|
set extras [dict get $cf_args -extras] |
|
set soloflags [dict get $cf_args -soloflags] |
|
if {$f in [concat $extras $soloflags [dict keys $defaults]]} { |
|
return 1 |
|
} |
|
} |
|
|
|
set singleopts [dict get $optinfo singleopts] |
|
if {"any" in [string tolower $singleopts]} { |
|
#review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? |
|
return 1 |
|
} |
|
set pairopts [dict get $optinfo pairopts] |
|
set allopts [concat $singleopts [dict keys $pairopts]] |
|
if {$f in $allopts} { |
|
return 1 |
|
} |
|
|
|
#process mashopts last |
|
set mashopts [dict get $optinfo mashopts] |
|
if {"any" in [string tolower $mashopts]} { |
|
#if 'all' in mashopts - it can eat anything - review - is this even useful? |
|
return 1 |
|
} else { |
|
set flagletters [split [string range $f 1 end] ""] |
|
set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash |
|
foreach l $flagletters { |
|
if {"-$l" ni $mashopts} { |
|
set is_mash 0 |
|
} |
|
} |
|
return $is_mash |
|
} |
|
|
|
return 0 |
|
} |
|
|
|
|
|
|
|
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 |
|
} |
|
} |
|
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 |
|
} |
|
} |
|
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] |
|
} |
|
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 |
|
} |
|
} |
|
|
|
#Note the difference between this and is_command_match. |
|
#Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters |
|
#Note that this isn't a general test to be applied to the entire argument list. |
|
# - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor |
|
# so this test only applies during the ordered examination of args |
|
proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { |
|
set cmdinfo [lindex $cspec 1] |
|
if {$cmdinfo eq "tail_processor"} { |
|
return 1 |
|
} |
|
if {$cmdinfo eq "global"} { |
|
set defaults [dict get $cf_args -defaults] |
|
set soloflags [dict get $cf_args -soloflags] |
|
set extras [dict get $cf_args -extras] |
|
if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { |
|
return 1 |
|
} |
|
} |
|
if {![dict exists $cmdinfo match]} { |
|
return 1 |
|
} |
|
set matchspeclist [dict get $cmdinfo match] |
|
foreach matchspec $matchspeclist { |
|
if {[regexp -- $matchspec $flag]} { |
|
return 1 |
|
} |
|
} |
|
#only block it if there was a match pattern specified but it didn't match |
|
return 0 |
|
} |
|
#Note - returns false for a cspec that has no match specified. |
|
#A command/subcommand with no match specification is allowed to allocate any value - so be careful with this |
|
# - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. |
|
proc is_command_match {flag cspec} { |
|
set pinfo [lindex $cspec 1] |
|
if {[dict exists $pinfo match]} { |
|
set matchspeclist [dict get $pinfo match] |
|
foreach matchspec $matchspeclist { |
|
if {[regexp -- $matchspec $flag]} { |
|
return 1 |
|
} |
|
} |
|
return 0 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
proc is_command_match_any {f commandprocessors} { |
|
foreach comspec $commandprocessors { |
|
lassign $comspec cmdname cmdinfo |
|
if {[dict exists $cmdinfo match]} { |
|
set matchlist [dict get $cmdinfo match] |
|
foreach matchspec $matchlist { |
|
if {[regexp -- $matchspec $f]} { |
|
#actually a command |
|
return true |
|
} |
|
} |
|
} |
|
} |
|
return false |
|
} |
|
|
|
#determine if f is potentially a flag that takes a parameter from the next argument. |
|
#e.g --x=y (longopt) does not consume following arg but --something *might* |
|
proc is_candidate_toplevel_param_flag {f solos commandprocessors} { |
|
if {[is_command_match_any $f $commandprocessors]} { |
|
return false |
|
} |
|
if {$f in $solos} { |
|
return 0 |
|
} |
|
if {$f in [list "-" "--"]} { |
|
return 0 |
|
} |
|
#longopts (--x=blah) and alternative --x blah |
|
#possibly also -x=blah |
|
if {[string match -* $f]} { |
|
if {[string first "=" $f]>1} { |
|
return 0 |
|
} |
|
} |
|
return [expr {[string match -* $f]}] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#review - should we be using control::assert here? |
|
#It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? |
|
#todo - show caller info |
|
proc assert_equal {a b} { |
|
if {![expr {$a eq $b}]} { |
|
error "assert_equal $a $b" |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map |
|
#1 2 3 4 5 6 ;#original list posns example |
|
# 2 6 ;#map_remaining example (scanlist) |
|
#1 3 4 5 ;#map_allocated example |
|
#{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example |
|
oo::class create class_vmap { |
|
variable o_map |
|
variable o_remaining |
|
variable o_allocated |
|
variable o_values |
|
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_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_allocated [list] |
|
set o_map [list] |
|
foreach posn $o_remaining { |
|
lappend o_map $posn unallocated |
|
} |
|
} |
|
method load {values rem alloc map} { |
|
set o_values $values |
|
set o_remaining $rem |
|
set o_allocated $alloc |
|
set o_map $map |
|
} |
|
method copy_to {obj} { |
|
$obj load $o_values $o_remaining $o_allocated $o_map |
|
} |
|
method update_map_from {obj} { |
|
#very basic sanity check first |
|
if {[llength $o_values] ne [llength [$obj get_values]]} { |
|
error "[self class].update_map_from cannot update. length of values mismatch" |
|
} |
|
|
|
set newmap [$obj get_map] |
|
} |
|
|
|
method get_codemap {} { |
|
return $o_codemap |
|
} |
|
method get_values {} { |
|
return $o_values |
|
} |
|
method get_remaining {} { |
|
return $o_remaining |
|
} |
|
method get_allocated {} { |
|
return $o_allocated |
|
} |
|
method get_map {} { |
|
return $o_map |
|
} |
|
method argnum_from_remaining_posn {scanlist_posn} { |
|
set vidx [lindex $o_remaining $scanlist_posn] |
|
if {![string is digit -strict $vidx]} { |
|
return -code error "[self class].argnum_from_remaining_posn cannot determine argnum from scanlist position:$scanlist_posn using unallocated list:'$o_remaining'" |
|
} |
|
return $vidx |
|
} |
|
|
|
method allocate {objp argnum type value} { |
|
set processorname [$objp name] |
|
if {$processorname eq "tail_processor"} { |
|
set owner "unallocated" |
|
} else { |
|
set owner [$objp parentname] |
|
} |
|
if {$argnum > [llength $o_values]-1} { |
|
return -code error "[self class].allocate cannot allocate argnum:$argnum. Only [llength $o_values] items in value list" |
|
} |
|
if {$argnum in $o_allocated} { |
|
return -code error "[self class].allocate already allocated '$processorname' argnum:'$argnum' type:'$type' val:'$value' remaining:$o_remaining allocated:$o_allocated map:$o_map" |
|
} |
|
lappend o_allocated $argnum |
|
set o_allocated [lsort -dictionary $o_allocated] |
|
dict set o_map $argnum [list $owner $type $value] |
|
set scanlist_posn [lsearch $o_remaining $argnum] |
|
set o_remaining [lreplace $o_remaining[set o_remaining {}] $scanlist_posn $scanlist_posn] ;#inlineK |
|
|
|
|
|
|
|
} |
|
|
|
method get_list_unflagged_by_class {classmatch} { |
|
set resultlist [list] |
|
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 |
|
} |
|
} |
|
} |
|
return $resultlist |
|
} |
|
|
|
method get_list_flagged_by_class {classmatch} { |
|
set list_flagged [list] |
|
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 |
|
} |
|
} |
|
} |
|
return $list_flagged |
|
} |
|
|
|
method get_merged_flagged_by_class {classmatch} { |
|
variable flagcategory |
|
set all_flagged [list] |
|
set seenflag [dict create] ;#key = -flagname val=earliest vindex |
|
dict for {k vinfo} $o_map { |
|
lassign $vinfo class type val |
|
if {[string match $classmatch $class]} { |
|
set a [llength $all_flagged] ;#index into all_flagged list we are building |
|
switch -- $type { |
|
soloflag { |
|
if {[dict exists $seenflag $val]} { |
|
set seenindex [dict get $seenflag $val] |
|
set seenindexplus [expr {$seenindex+1}] |
|
set existingvals [lindex $all_flagged $seenindexplus] |
|
lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? |
|
lset all_flagged $seenindexplus $existingvals |
|
} else { |
|
dict set seenflag $val $a |
|
lappend all_flagged $val 1 |
|
} |
|
} |
|
flag { |
|
if {![dict exists $seenflag $val]} { |
|
dict set seenflag $val $a |
|
lappend all_flagged $val |
|
} |
|
#no need to do anything if already seen - flagvalue must be next, and it will work out where to go. |
|
} |
|
flagvalue { |
|
set idxflagfor [expr {$k -1}] |
|
set flagforinfo [dict get $o_map $idxflagfor] |
|
lassign $flagforinfo ffclass fftype ffval |
|
#jn "--" following a flag could result in us getting here accidentaly.. review |
|
set seenindex [dict get $seenflag $ffval] |
|
if {$seenindex == [expr {$a-1}]} { |
|
#usual case - this is a flagvalue following the first instance of the flag |
|
lappend all_flagged $val |
|
} else { |
|
#write the value back to the seenindex+1 |
|
set seenindexplus [expr {$seenindex+1}] |
|
set existingvals [lindex $all_flagged $seenindexplus] |
|
lappend existingvals $val ;#we keep multiples as a list |
|
lset all_flagged $seenindexplus $existingvals |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $all_flagged |
|
} |
|
method typedrange_class_type_from_arg {argclass argtype} { |
|
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 |
|
} |
|
return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions |
|
} |
|
} else { |
|
return [list $argclass argtype] ;# e.g command something |
|
} |
|
} |
|
|
|
method get_ranges_from_classifications {classifications} { |
|
#puts stderr "get_ranges_from_classifications $classifications" |
|
#examine classifications and create a list of ranges |
|
set ranges [list];# e.g [list {unallocated 0 4} {cmd1 5 7} {unallocated 8 8} {cmd2 9 9} {cmd3 10 10} {unallocated 11 15}] |
|
set seen_commands [list] |
|
dict for {posn arginfo} $classifications { |
|
set is_new_cmd 0 |
|
set is_sub_cmd 0 |
|
set is_continuation 0 |
|
set rangename [lindex $ranges end 0] |
|
set alloc [lindex $arginfo 0] ;#e.g of form 0 {unallocated operand} 1 {lscmd operand} 2 {lscmd soloflag} 3 {lscmd.dir operand} 4 {unallocated flag} |
|
set cmdname "" |
|
if {$alloc ne "unallocated"} { |
|
if {$alloc ni $seen_commands} { |
|
if {![llength $seen_commands]} { |
|
set cmdname $alloc |
|
set is_new_cmd 1 |
|
} else { |
|
set tail [lindex $seen_commands end] |
|
if {$tail eq "unallocated"} { |
|
set cmdname $alloc |
|
set is_new_cmd 1 |
|
} else { |
|
if {[string first . $alloc] >= 0} { |
|
set prefixcheck [lindex [split $alloc .] 0] |
|
if {![string equal -length [string length $prefixcheck] $prefixcheck $tail]} { |
|
#this is not unallocated, not a subcommand of the previous seen ie new command |
|
set cmdname $alloc |
|
set is_new_cmd 1 |
|
} else { |
|
set cmdname $prefixcheck |
|
set is_sub_cmd 1 |
|
set is_continuation 1 |
|
} |
|
} else { |
|
set cmdname $alloc |
|
set is_new_cmd 1 |
|
} |
|
} |
|
} |
|
} else { |
|
set cmdname $alloc |
|
set is_continuation 1 |
|
} |
|
if {$is_continuation} { |
|
lassign [lindex $ranges end] _cmd n a b |
|
set ranges [lrange $ranges 0 end-1] |
|
lappend ranges [list command $n $a [incr b]] |
|
flagfilter::assert_equal $b $posn |
|
} elseif {$is_new_cmd} { |
|
lappend seen_commands $alloc |
|
if {$rangename eq ""} { |
|
lappend ranges [list command $cmdname $posn $posn] |
|
} else { |
|
lassign [lindex $ranges end] _cmd n a b |
|
lappend ranges [list command $cmdname [incr b] $posn] |
|
flagfilter::assert_equal $b $posn |
|
} |
|
} else { |
|
error "coding error during dispatch" |
|
} |
|
} else { |
|
if {$rangename eq ""} { |
|
lappend ranges [list unallocated mixed 0 0] |
|
} else { |
|
lassign [lindex $ranges end] class n a b |
|
if {$class eq "unallocated"} { |
|
#continuation - extend |
|
set ranges [lrange $ranges 0 end-1] |
|
lappend ranges [list unallocated mixed $a [incr b]] |
|
} else { |
|
#change from allocated to unallocated |
|
lappend ranges [list unallocated mixed [incr b] $posn] |
|
flagfilter::assert_equal $b $posn |
|
} |
|
} |
|
} |
|
} |
|
set rangesbytype [list] |
|
foreach oldrange $ranges { |
|
lassign $oldrange oldrangeclass oldrangetype A B ;#A,B for original range bounds, a,b for bounds of sub-ranges we are creating |
|
set last_type "" |
|
set newrangelist [list] |
|
set inner_range [list 0 0] |
|
if {$oldrangeclass ne "unallocated"} { |
|
#pass through - user can split commands further themselves by referencing the classifications map where each arg position is listed |
|
set last_type $oldrangeclass ;#note the deliberate slight misuse - we are using the 'class' here rather than the type as we aren't looking at types within a command range |
|
lappend rangesbytype $oldrange |
|
} else { |
|
#puts stdout "???????????????????????????????????????????????A$A B$B examining old range:'$oldrange'" |
|
for {set i $A} {$i <= $B} {incr i} { |
|
lassign [lindex $rangesbytype end] last_class last_type a b ;#enough just to use the type without the class |
|
set a_info [dict get $classifications $i] |
|
lassign $a_info argclass argtype v |
|
lassign [my typedrange_class_type_from_arg $argclass $argtype] newrangeclass newrangetype |
|
if {$last_type eq ""} { |
|
lappend rangesbytype [list "unallocated" $newrangetype 0 0] |
|
} else { |
|
if {$last_type eq $newrangetype} { |
|
set rangesbytype [lrange $rangesbytype 0 end-1] |
|
lappend rangesbytype [list $last_class $last_type $a $i] |
|
} else { |
|
lappend rangesbytype [list $newrangeclass $newrangetype $i $i] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
return [list -ranges $ranges -rangesbytype $rangesbytype] |
|
} |
|
|
|
method grid {} { |
|
set posns [dict keys $o_map] |
|
set col1 [string repeat " " 15] |
|
set col [string repeat " " 4] |
|
set pline "[overtype::left $col1 {var indices}] " |
|
foreach p $posns { |
|
append pline [overtype::left $col $p] |
|
} |
|
set remline "[overtype::left $col1 {unallocated}] " |
|
foreach vidx $posns { |
|
if {$vidx ni $o_remaining} { |
|
append remline [overtype::left $col "."] |
|
} else { |
|
set tp [lindex [dict get $o_map $vidx] 1] |
|
set tp [string map $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 clinelist [list] |
|
foreach c $cmdlist { |
|
set cline "[overtype::left $col1 $c] " |
|
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] |
|
append cline [overtype::left $col $tp] |
|
} else { |
|
append cline [overtype::left $col "."] |
|
} |
|
} |
|
lappend clinelist $cline |
|
} |
|
|
|
|
|
set aline "[overtype::left $col1 {allocated}] " |
|
foreach vidx $posns { |
|
if {$vidx ni $o_allocated} { |
|
append aline [overtype::left $col "."] |
|
} else { |
|
set tp [lindex [dict get $o_map $vidx] 1] |
|
set tp [string map $o_codemap $tp] |
|
append aline [overtype::left $col $tp] |
|
} |
|
} |
|
|
|
return "$pline\n$remline\n[join $clinelist \n]\n$aline\n" |
|
} |
|
|
|
} |
|
|
|
|
|
#!todo - check if -commandprocessors members will collide with existing -flags in values before moving them |
|
#!todo - skip optional sub-flag value if the next arg following its parent is a flag i.e proper handling of -commandprocessors {cmd {cmd sub "default}} when only cmd supplied. |
|
#!important to fix. At the moment it could eat a further unflagged item in values later in the list which was intended for a different -commandprocessors member! |
|
#add support for -commandprocessors {-cmd {-cmd -othercmd "default"}} to be a safe way to specify a linked -flag move that does the same. |
|
proc allocate_arguments {PROCESSORS solos values cf_args caller} { |
|
set runid [lindex [split [namespace tail $PROCESSORS] _] 1] ;# objname is of form PROCESSORS_pid-threadid-counter where "PROCESSORS_" is a literal |
|
#puts stderr ">>>>>>> solos: $solos" |
|
dict set debugc -debugargs [dict get $cf_args -debugargs] |
|
dict set debugc -source "allocate_arguments $caller" |
|
|
|
set defaults [dict get $cf_args -defaults] |
|
|
|
set cmdprocessor_records [$PROCESSORS get_commandspecs] |
|
|
|
|
|
set sep "\uFFFE" ;#argument-subargument separator (choose something else if this causes problems.. but we want something unlikely (or preferably impossible?) to be in a commandline, ideally a single character, and which at least shows something on screen during debug) |
|
set sepstr "\\uFFFE" ;#for human readable error msg |
|
#\u001E was tried and doesn't output on some terminals) |
|
|
|
set remaining_unflagged [dict create] |
|
|
|
set extra_flags_from_positionals [list] ;#values moved to -values |
|
set moved_to_flagged [dict create] |
|
|
|
#implied_ are values supplied from defaults when a flag or operand was not found |
|
set implied_flagged [list] |
|
set implied_unflagged [list] |
|
|
|
|
|
set dispatch [dict create] |
|
#sanitize and raise error if sep somehow in values |
|
if {[string first $sep $cmdprocessor_records] >= 0} { |
|
do_error "allocate_arguments flags error separator '$sep' ($sepstr) found in values " |
|
} |
|
#-------------------------------------- |
|
set VMAP [flagfilter::class_vmap create flagfilter::VMAP_$runid $values] |
|
#-------------------------------------- |
|
|
|
set unconsumed_flags_and_values [list] |
|
set unflagged [dict create] |
|
|
|
###################### |
|
#main -commandprocessors loop which scans the valuelist |
|
set values_index 0 ;#track where we are up to as we allocate values to unflagged elements |
|
set source_values $values ;#start with all including -flagged |
|
|
|
#todo - get rid of most of these flags last_x_was etc - and just do lookups into the v_map |
|
# as this will probably involve *lots* of small functiona calls - keep this boolean version and check for performance issues. |
|
set a_index 0 |
|
set is_args_flag 0 |
|
set last_arg_was_paramflag 0 ;#a flag that expects a parameter to follow |
|
set last_arg_was_solo 0 |
|
set solo_flags [dict keys $solos] ;#solos is a dict of -flag <defaultval> (preprocessed) |
|
set end_of_options 0 |
|
set end_of_options_index -1 ;#as later processors can rescan - we need to make sure they only look at arguments after this point |
|
set last_p_found [dict create by "" index "" item ""] |
|
set sequence 0 |
|
set argerrors [list] ;#despite being a list - we will break out at first entry and return for now. |
|
set parsestatus "ok" |
|
set LAUNCHED [oolib::collection create col_processors_launched_$runid] |
|
set MATCHED [oolib::collection create col_processors_matched_$runid] |
|
oo::objdefine col_processors_matched_$runid { |
|
method test {} { |
|
return 1 |
|
} |
|
} |
|
|
|
#set objp [$PROCESSORS object_from_record $p] ;#temp convenience |
|
|
|
foreach objp [$PROCESSORS items] { |
|
set objparent [$objp parent] |
|
$LAUNCHED add $objp [$objp name] |
|
set p [$objp get_def] ;#individual record e.g {mycmd {match run singleopts {-x}}} or {tail_processor {}} |
|
|
|
lassign $p parentname pinfo |
|
set is_sub [$objp is_sub] ;#is subargument - should look to see if last related spec got a value and abort if not. |
|
set is_p_flag [$objp is_flag] ;#sub can be a flag even if parent isn't |
|
set processorname [$objp name] |
|
if {[$objp is_sub]} { |
|
if {![[$objp parent] found_match]} { |
|
continue |
|
} |
|
set p_sub [dict get $pinfo sub] |
|
} |
|
do_debug 3 $debugc " =========================>> p $p sequence:$sequence a_index $a_index" |
|
|
|
if {$processorname in [list "global" "tail_processor"]} { |
|
dict set last_p_found by $processorname |
|
#dict set last_p_found index $a_index |
|
#dict set last_p_found item $a |
|
} |
|
# -format {x {sub y default "default"}} means y is dependent on x being present and shouldn't eat if the next value isn't flaglike |
|
# -format {-x {sub -y}} does the same for moving positionals to the flagged list. |
|
|
|
|
|
#set remaining_values [lrange $source_values $a_index end] |
|
##################################### |
|
# full rescans for later processors |
|
set remaining_values $source_values ;#source_values shrinks as commands take arguments |
|
set a_index 0 |
|
##################################### |
|
|
|
do_debug 3 $debugc "-------->________>p '$processorname' remaining vals $remaining_values" |
|
|
|
#!todo - use v_map as an extra determinant to stop sequence for a command-set. (don't extend beyond where args have already been snipped by another command) |
|
if {[$objp name] eq "tail_processor"} { |
|
set mapcopy [flagfilter::class_vmap new {}] ;#no need to supply values as we are copying data from $VMAP |
|
$VMAP copy_to $mapcopy |
|
$objp set_map_object $mapcopy |
|
} else { |
|
$objp set_map_object $VMAP |
|
} |
|
foreach a $remaining_values { |
|
set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] |
|
if {![string is integer -strict $argnum]} { |
|
error "arg '$a' scan_index:$a_index - calculated argnum:'$argnum' is invalid" |
|
|
|
} |
|
set sub_operand 0 |
|
do_debug 3 $debugc "$argnum >eoptions_idx:$end_of_options_index a_index:$a_index __________________________________________________________a $a" |
|
if {$end_of_options_index > -1} { |
|
set end_of_options [expr {$a_index >= $end_of_options_index}] |
|
} |
|
|
|
#review - data with leading - may be unintentionally interpreted as a flag |
|
if {[string trim $a] eq "--"} { |
|
#generally means end of options processing.. |
|
#review - pass -- through?? |
|
set last_arg_was_paramflag 0 ;#we don't treat first arg following end_of_options as belonging to the flag! - it is potentially an operand to the command |
|
set is_solo_flag 0 |
|
set end_of_options 1 |
|
set end_of_options_index $a_index |
|
#if {[lindex $p 0] eq "tail_processor"} { |
|
$objp allocate $argnum "endofoptions" $a |
|
set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK |
|
incr a_index -1 |
|
#} |
|
} else { |
|
if {($last_arg_was_paramflag) && ([$objp arg_is_defined_solo_to_me $a])} { |
|
#last flag expecting param - but this flag *known* to be solo |
|
#keep it simple and break out at first solo_flag related error ...unless it is trailing flag in the list |
|
lappend argerrors [list flagerror solo_flag_following_non_solo_flag bad_flag $a] |
|
set last_arg_was_solo 1 |
|
break |
|
} |
|
#set is_solo_flag [expr {($a in $solo_flags)}] |
|
#set is_solo_flag [is_this_flag_solo $a $solo_flags $objp] |
|
set is_solo_flag [$objp arg_is_defined_solo_to_me $a] |
|
|
|
if {!$end_of_options} { |
|
if {!$last_arg_was_paramflag} { |
|
if {!$is_solo_flag} { |
|
set is_args_flag [is_candidate_toplevel_param_flag $a $solo_flags $cmdprocessor_records] |
|
#set is_args_flag [string match -* $a] |
|
} |
|
if {$is_args_flag || $is_solo_flag} { |
|
if {[dict get $last_p_found by] eq $processorname} { |
|
if {![is_this_flag_for_me $a $objp $cf_args]} { |
|
if {$processorname ne "globalXXX"} { |
|
do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit an unrecognized option: $a" |
|
break |
|
} |
|
} |
|
} |
|
} |
|
} else { |
|
#last was flag expecting a param |
|
set is_args_flag 0 |
|
set is_solo_flag 0 |
|
} |
|
} else { |
|
#end_of_options - ignore solo and other flags now. |
|
set is_args_flag 0 |
|
set is_solo_flag 0 |
|
set last_arg_was_paramflag 0 |
|
|
|
} |
|
|
|
#puts stderr "!!!!!!!!!!!!!!!!!!1 here is_args_flag:$is_args_flag" |
|
do_debug 3 $debugc " >________>________>is_p_flag: $is_p_flag last_arg_was_paramflag:$last_arg_was_paramflag is_args_flag:$is_args_flag is_solo: $is_solo_flag (soloflags:$solo_flags) a:$a " |
|
if {!$is_args_flag && !$is_solo_flag } { |
|
|
|
if {!$last_arg_was_paramflag} { |
|
if {[dict get $last_p_found by] eq $processorname} { |
|
if {$processorname ne "tail_processor"} { |
|
#we already found our unflagged value - and now we've hit another - time to break and hand it to a subcommand processor if any |
|
do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit another value: $a" |
|
break |
|
} |
|
} |
|
set sequence_ok 1 ;#default assumption |
|
set can_allocate [can_this_commandspec_allocate_this_arg $a $p $cf_args] |
|
|
|
if {$can_allocate} { |
|
if {$is_sub} { |
|
#!todo - use v_map as sequence terminator |
|
#check if our find is in sequence |
|
#we are only hunting non-flagged items and the the previous finder removes 1 from the source_values list |
|
#therefore the a_index of our find should be the same if we are processing the very next argument. |
|
#we have already checked that it was a related entity which found the last one. |
|
#todo - review if it matters when parents/siblings don't eat all the way up to the next -flag. |
|
#todo - implement a 'gather' key to keep eating in sequence and accumulate the values as a list |
|
if {$a_index > [dict get $last_p_found index]} { |
|
do_debug 3 $debugc "OUT OF SEQUENCE a_index:$a_index vs last_found index:[dict get $last_p_found index], $processorname disengaging - ignoring value $a and leaving it to the next processor" |
|
set last_arg_was_paramflag 0 |
|
do_debug 3 $debugc "<--- breaking --->" |
|
break |
|
} elseif {$a_index < [dict get $last_p_found index]} { |
|
#too early.... found something before previous match |
|
do_debug 3 $debugc "+++++++++++++++out of sequence $processorname - too early.. keeping scanning" |
|
set sequence_ok 0 |
|
} |
|
if {$sequence_ok} { |
|
set sub_operand 1 |
|
} |
|
} |
|
} |
|
|
|
if {$can_allocate && $sequence_ok} { |
|
#found a non-flagged value in the argumentlist to either reallocate to flagged values or to positional values |
|
if {[dict exists $pinfo dispatch]} { |
|
if {!$is_sub} { |
|
#this must be the arg that caused the match |
|
dict set dispatch $parentname [list command [dict get $pinfo dispatch] matched $a arguments [list] raw [list]] |
|
} else { |
|
#todo |
|
lappend argerrors [list unsupported_dispatch $processorname] |
|
} |
|
} |
|
if {$sub_operand} { |
|
if {[dict exists $dispatch $parentname]} { |
|
#todo - defaults? |
|
add_dispatch_argument "dispatch" $parentname $processorname $a |
|
add_dispatch_raw "dispatch" $parentname $a |
|
} else { |
|
#warning? |
|
#lappend argerrors [list subcommand_unable_to_add_operand $processorname] |
|
do_debug 3 $debugc "subcommand $processorname aborting scanning because parent command wasn't activated" |
|
break |
|
} |
|
} |
|
do_debug 2 $debugc " >+++++++>++++++++>++++++++>setting $processorname [if {$is_p_flag} {list -} {}]value $a" |
|
if {$processorname eq "tail_processor"} { |
|
set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] |
|
set argname arg$argnum |
|
lappend remaining_unflagged $argname $a |
|
lappend unconsumed_flags_and_values $a |
|
dict set unflagged $argname $a |
|
} elseif {$is_p_flag} { |
|
$objp set_matched_argument $argnum $a |
|
if {$is_sub} { |
|
dict set extra_flags_from_positionals $p_sub $a |
|
} else { |
|
dict set extra_flags_from_positionals $parentname $a |
|
} |
|
lappend moved_to_flagged $processorname $a |
|
#if has dependent commands ? - check for deep subcommand match? |
|
} else { |
|
$objp set_matched_argument $argnum $a |
|
#lappend positional_values $a |
|
dict set unflagged $processorname $a |
|
} |
|
do_debug 4 $debugc " >________>________>________>source_values :'$source_values'" |
|
do_debug 3 $debugc " >________>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" |
|
|
|
#---------------------------- |
|
dict set last_p_found by $processorname |
|
dict set last_p_found index $a_index |
|
dict set last_p_found item $a |
|
#------------------------------ |
|
$objp allocate $argnum "operand" $a |
|
set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK |
|
incr values_index ;#only increment when we allocate a value to one of the members of -commandprocessors |
|
set last_arg_was_paramflag 0 |
|
if {$processorname ne "tail_processor"} { |
|
#don't break until we hit an unrecognized flag or another unflagged value |
|
incr a_index -1 |
|
#don't increment a_index before break, because we have shortened the list by 1. |
|
#do_debug 3 $debugc "----breaking---" |
|
#break |
|
} else { |
|
#decrement to compensate for shortened list because tail_processor continues to end |
|
incr a_index -1 |
|
} |
|
} |
|
|
|
} else { |
|
#last_arg_was_paramflag |
|
set lastarg [dict get $last_p_found item] |
|
#puts stdout "+++ lastarg: $lastarg source_values: [dict get $last_p_found source_values] a_index: $a_index" |
|
if {$processorname eq "tail_processor"} { |
|
lappend unconsumed_flags_and_values $a |
|
} |
|
if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $lastarg $objp $cf_args]} { |
|
update_dispatch_argument "dispatch" $parentname $lastarg $a |
|
add_dispatch_raw "dispatch" $parentname $a |
|
dict set last_p_found by $processorname |
|
dict set last_p_found index $a_index |
|
dict set last_p_found item $a |
|
$objp allocate $argnum "flagvalue" $a |
|
set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK |
|
incr a_index -1 |
|
} |
|
set last_arg_was_paramflag 0 |
|
} |
|
} else { |
|
# is a flag of some sort ({!$is_args_flag && !$is_solo_flag} = false) |
|
if {$processorname eq "tail_processor"} { |
|
lappend unconsumed_flags_and_values $a |
|
} |
|
if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $a $objp $cf_args]} { |
|
if {$is_solo_flag} { |
|
add_dispatch_argument "dispatch" $parentname $a 1 |
|
add_dispatch_raw "dispatch" $parentname $a |
|
set last_arg_was_solo 1 |
|
set last_arg_was_paramflag 0 |
|
$objp allocate $argnum "soloflag" $a |
|
} else { |
|
add_dispatch_argument "dispatch" $parentname $a "<pending>" |
|
add_dispatch_raw "dispatch" $parentname $a |
|
set last_arg_was_solo 0 |
|
set last_arg_was_paramflag 1 |
|
$objp allocate $argnum "flag" $a |
|
} |
|
dict set last_p_found by $processorname |
|
dict set last_p_found index $a_index |
|
dict set last_p_found item $a |
|
do_debug 4 $debugc " >2_______>________>________>source_values :'$source_values'" |
|
do_debug 3 $debugc " >2_______>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" |
|
set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK |
|
incr a_index -1 |
|
} else { |
|
#auto alternate based on last value.. unless end_of_options |
|
if {!$end_of_options} { |
|
if {$a in $solo_flags} { |
|
set last_arg_was_solo 1 |
|
set last_arg_was_paramflag 0 |
|
} else { |
|
set last_arg_was_paramflag 1 |
|
} |
|
} |
|
if {$a_index eq ([llength $source_values]-1)} { |
|
#puts "XXXXXXXXXXXXXXXXXXX $a_index source_values:'$source_values'" |
|
#if at end of list don't retain any last..was info. |
|
set last_arg_was_solo 0 |
|
set last_arg_was_paramflag 0 |
|
} |
|
#skip - don't eat |
|
} |
|
} |
|
} |
|
incr a_index |
|
} |
|
|
|
if {![$objp found_match]} { |
|
|
|
#after break - we have retained vars: $parent, $sub_operand $pinfo $processorname etc |
|
#didn't find an unflagged var - set a default if one was specified. |
|
#do nothing otherwise - check_args will determine if it was -required etc. |
|
#review - should only apply if parent cmd found something? |
|
if {[dict exists $pinfo default]} { |
|
set defaultval [dict get $pinfo default] |
|
if {$is_p_flag} { |
|
if {$is_sub} { |
|
dict set extra_flags_from_positionals $p_sub $defaultval |
|
} else { |
|
dict set extra_flags_from_positionals $processorname $defaultval |
|
} |
|
#lappend moved_to_flagged $processorname $defaultval |
|
lappend implied_flagged $processorname $defaultval |
|
do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval implied_flagged: $implied_flagged " |
|
} else { |
|
lappend implied_unflagged $processorname $defaultval |
|
dict set unflagged $processorname $defaultval |
|
do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval moved_to_flagged: $moved_to_flagged " |
|
} |
|
|
|
if {$is_sub && !$sub_operand} { |
|
if {[dict exists $dispatch $parentname]} { |
|
add_dispatch_argument "dispatch" $parentname $processorname $defaultval |
|
} else { |
|
lappend argerrors [list subcommand_unable_to_add_default_operand $processorname $defaultval] |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {[$objp name] eq "tail_processor"} { |
|
$VMAP update_map_from [$objp get_map_object] |
|
} |
|
|
|
if {[llength $argerrors]} { |
|
set parsestatus "error" |
|
#abort processing at first error - we won't be able to make sense of the remaining args anyway |
|
#even the tail_processor won't be able to classify reliably because flag meanings depend on the configured commands |
|
break |
|
} |
|
} |
|
|
|
#assertion - should be none? |
|
#set remaining_values [lrange $source_values $a_index end] |
|
#do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" |
|
|
|
do_debug 2 $debugc "========>=========>originals : $values" |
|
do_debug 2 $debugc "[$VMAP get_map]" |
|
do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" |
|
|
|
|
|
|
|
|
|
|
|
set all_flagged [$VMAP get_merged_flagged_by_class *] |
|
set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] |
|
|
|
set all_flagged_list [$VMAP get_list_flagged_by_class *] |
|
set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] |
|
|
|
set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] |
|
|
|
set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] |
|
|
|
|
|
set unflagged_list_in_processing_order [dict values $unflagged] |
|
set unflagged_list [$VMAP get_list_unflagged_by_class *] |
|
|
|
set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] |
|
|
|
return [list \ |
|
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" \ |
|
] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#specialisation for collection class to contain commandprocessors |
|
# we expect to use only a single instance of this |
|
oo::class create col_allprocessors { |
|
superclass oolib::collection |
|
variable o_commandspecs |
|
method add_processor {p} { |
|
my add $p [$p name] |
|
if {[$p is_sub]} { |
|
set parentname [$p parentname] |
|
set obj_parent [my item $parentname] |
|
set col_siblings [$obj_parent children] |
|
$col_siblings add $p [$p name] |
|
} |
|
} |
|
method set_commandspecs {cspecs} { |
|
set o_commandspecs $cspecs |
|
} |
|
method get_commandspecs {} { |
|
set o_commandspecs |
|
} |
|
#treating as singleton.. todo tidy |
|
method name_from_record {rec} { |
|
lassign $rec parentname pinfo |
|
if {[dict exists $pinfo sub]} { |
|
set name [join [list $parentname [dict get $pinfo sub]] .] |
|
} else { |
|
set name $parentname |
|
} |
|
return $name |
|
} |
|
method object_from_record {rec} { |
|
set name [my name_from_record $rec] |
|
return [my item $name] |
|
} |
|
#basic check if arg may consume the following one - not based on any specific info from processors |
|
method arg_appears_standalone {f} { |
|
if {(![string match "-*" $f]) && (![string match "/*" $f])} { |
|
#not even flaglike |
|
return 1 |
|
} |
|
if {$f in [list "-" "--"]} { |
|
return 1 |
|
} |
|
} |
|
#does any processor define it as solo |
|
method flag_can_be_solo {f} { |
|
foreach objp [my items] { |
|
if {[$objp arg_is_defined_solo_to_me $f]} { |
|
return 1 |
|
} |
|
} |
|
return 0 |
|
} |
|
} |
|
oo::class create col_parents { |
|
superclass oolib::collection |
|
method add_parent {p} { |
|
if {[$p is_sub]} { |
|
error "cannot add a sub-processor to the main parents collection" |
|
} |
|
my add $p [$p name] |
|
} |
|
} |
|
#each parent processor has a children collection which can only accept processors with sub defined. |
|
oo::class create col_childprocessors { |
|
superclass oolib::collection |
|
variable o_ownername |
|
method set_owner {parentname} { |
|
set o_ownername $parentname |
|
} |
|
#owner of the collection (a parent processor) |
|
method owner {} { |
|
return $o_ownername |
|
} |
|
method add_processor {p} { |
|
if {![$p is_sub]} { |
|
error "processor must have 'sub' element to add to the parent's collection" |
|
} |
|
#check name matches this parent.. |
|
|
|
my add $p [$p name] |
|
} |
|
} |
|
|
|
oo::class create cprocessor { |
|
variable o_runid |
|
variable o_name |
|
variable o_definition |
|
variable o_pinfo |
|
variable o_parentname |
|
variable o_is_sub |
|
variable o_col_children |
|
variable o_mashopts |
|
variable o_singleopts |
|
variable o_pairopts |
|
variable o_longopts |
|
variable o_found_match ;#we directly matched a command trigger or positional argument |
|
variable o_matched_argument |
|
variable o_matched_argnum |
|
variable o_matchspec |
|
variable o_vmap |
|
constructor {definition runid} { |
|
set o_vmap "" |
|
set o_definition $definition |
|
set o_runid $runid |
|
if {([llength $o_definition] < 2) || ([llength [lindex $o_definition 0]] != 1)} { |
|
error "[self class].constructor Unable to interpret definition '$o_definition'" |
|
} |
|
lassign $o_definition o_parentname o_pinfo |
|
if {([llength $o_pinfo] %2) != 0} { |
|
error "[self class].constructor second element of definition '$o_definition' not a dict" |
|
} |
|
set o_is_sub [dict exists $o_pinfo sub] |
|
if {!$o_is_sub} { |
|
set o_name $o_parentname |
|
set o_col_children [::flagfilter::col_childprocessors new] |
|
$o_col_children set_owner $o_name |
|
} else { |
|
set o_name [join [list $o_parentname [dict get $o_pinfo sub]] .] |
|
} |
|
if {[dict exists $o_pinfo match]} { |
|
set o_matchspec [dict get $o_pinfo match] |
|
} else { |
|
set o_matchspec {^[^-^/].*} ;#match anything that isn't flaglike |
|
} |
|
set o_found_match 0 |
|
set o_matched_argument "" ;#need o_found_match to differentiate match of empty string |
|
set o_matched_argnum -1 |
|
#load mashopts etc at construction time as they're static |
|
set o_mashopts [list] |
|
set o_singleopts [list] |
|
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 |
|
} |
|
} |
|
if {[dict exists $o_pinfo singleopts]} { |
|
foreach s [dict get $o_pinfo singleopts] { |
|
lappend o_singleopts $s |
|
} |
|
} |
|
if {[dict exists $o_pinfo pairopts]} { |
|
foreach po [dict get $o_pinfo pairopts] { |
|
lappend o_pairopts $po |
|
} |
|
} |
|
if {[dict exists $o_pinfo longopts]} { |
|
foreach l [dict get $o_pinfo longopts] { |
|
lappend o_longopts $l |
|
} |
|
} |
|
} |
|
|
|
method name {} { |
|
return $o_name |
|
} |
|
#open things up during oo transition.. |
|
method get_def {} { |
|
return $o_definition |
|
} |
|
method is_flag {} { |
|
if {[my is_sub]} { |
|
#sub can be a flag even if parent isn't |
|
set subname [dict get $o_pinfo sub] |
|
return [string match -* $subname] |
|
} else { |
|
return [string match -* $o_name] |
|
} |
|
} |
|
method has_same_parent {other} { |
|
return [expr {[other parentname] eq $o_parentname}] |
|
} |
|
method is_sub {} { |
|
return $o_is_sub |
|
} |
|
|
|
method set_map_object {map} { |
|
set o_vmap $map |
|
} |
|
method get_map_object {} { |
|
return $o_vmap |
|
} |
|
method allocate {argnum type val} { |
|
if {$o_vmap eq ""} { |
|
error "[self class].allocate ($o_name) vmap is not set." |
|
} |
|
$o_vmap allocate [self object] $argnum $type $val |
|
} |
|
|
|
method found_match {} { |
|
return $o_found_match |
|
} |
|
method matched_argument {} { |
|
return $o_matched_argument |
|
} |
|
method matched_argnum {} { |
|
return $o_matched_argnum |
|
} |
|
method set_matched_argument {argnum a} { |
|
#could be empty string |
|
if {$o_found_match} { |
|
error "[self object].set_matched_argument processor:$o_name already found match '$o_matched_argument' - cannot set again" |
|
} |
|
if {![my can_match $a]} { |
|
error "error [self class].set_matched_argument processor:$o_name cannot match '$a' (matchspec: $o_matchspec)" |
|
} |
|
set o_found_match 1 |
|
set o_matched_argument $a |
|
set o_matched_argnum $argnum |
|
} |
|
method has_explicit_matchspec {} { |
|
return [dict exists $o_pinfo match] |
|
} |
|
method matchspec {} { |
|
return $o_matchspec |
|
} |
|
method can_match {a} { |
|
if {!$o_found_match} { |
|
foreach m $o_matchspec { |
|
if {[regexp -- $m $a]} { |
|
return 1 |
|
} |
|
} |
|
return 0 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
#?? |
|
method can_allocate_flags {} { |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#if we are a parent - this is own name |
|
method parentname {} { |
|
return $o_parentname |
|
} |
|
method parent {} { |
|
return [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] |
|
} |
|
method is_parent {} { |
|
return [expr {!$o_is_sub}] |
|
} |
|
method children {} { |
|
if {!$o_is_sub} { |
|
return $o_col_children |
|
} else { |
|
#raise error? |
|
return "" |
|
} |
|
} |
|
method mashopts {} { |
|
return $o_mashopts |
|
} |
|
method singleopts {} { |
|
return $o_singleopts |
|
} |
|
method pairopts {} { |
|
return $o_pairopts |
|
} |
|
method longopts {} { |
|
return $o_longopts |
|
} |
|
|
|
#whether flag categorized as solo by this processor |
|
method arg_is_defined_solo_to_me {a} { |
|
if {(![string match "-*" $a]) && (![string match "/*" $a])} { |
|
#not even flaglike |
|
return 0 |
|
} |
|
if {[my can_match $a]} { |
|
return 0 |
|
} |
|
if {$a in [list "-" "--"]} { |
|
#specials not defined as solos |
|
return 0 |
|
} |
|
if {$o_name eq "global"} { |
|
|
|
} |
|
if {$o_name eq "tail_processor"} { |
|
|
|
} |
|
if {$a in $o_singleopts} { |
|
return 1 |
|
} |
|
if {"any" in $o_singleopts} { |
|
return 1 |
|
} |
|
set equalposn [string first "=" $a] |
|
if {$equalposn >=1} { |
|
if {"any" in $o_longopts} { |
|
return 1 |
|
} else { |
|
set namepart [string range $a 0 $equalposn-1] |
|
foreach lo $o_longopts { |
|
if {[string match "${namepart}=*" $lo]} { |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
#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 {($a in $o_pairopts) && ($a ni $o_mashopts)} { |
|
return 0 |
|
} |
|
set flagletters [split [string range $a 1 end] ""] |
|
set posn 1 |
|
#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 $o_mashopts} { |
|
#presumably an ordinary flag not-known to us |
|
return 0 |
|
} else { |
|
if {"-$l" in $o_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 $o_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 |
|
} |
|
} |
|
} |
|
#This object should not treat the flag as a known solo |
|
#- so if it is allowed to consume it, it may fall back on examining the subsequent argument's flaginess(?) |
|
return 0 |
|
} |
|
|
|
|
|
method get_opts {} { |
|
return [list mashopts $o_mashopts singleopts $o_singleopts pairopts $o_pairopts longopts $o_longopts] |
|
} |
|
#include parent opts |
|
#we use the terminology 'option' for "-" prefixed items belonging to a -commandprocessors spec as opposed to more general -flags |
|
#Note - this may also be called on the default "tail_processor", which will return empty sets, or an overridden tail_processor which may have data |
|
method get_combined_opts {} { |
|
set objparent [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] |
|
set parentopts [$objparent get_opts] |
|
set mashopts [dict get $parentopts mashopts] |
|
set singleopts [dict get $parentopts singleopts] |
|
set pairopts [dict get $parentopts pairopts] |
|
set longopts [dict get $parentopts longopts] |
|
if {[my is_sub]} { |
|
#this spec is a sub |
|
set subopts [my get_opts] |
|
foreach m [dict get $subopts mashopts] { |
|
if {$m ni $mashopts} { |
|
lappend mashopts $m |
|
} |
|
} |
|
foreach s [dict get $subopts singleopts] { |
|
if {$s ni $singleopts} { |
|
lappend singleopts $s |
|
} |
|
} |
|
foreach po [dict get $subopts pairopts] { |
|
if {$po ni $pairopts} { |
|
lappend pairopts $po |
|
} |
|
} |
|
foreach lo [dict get $subopts longopts] { |
|
if {$lo ni $longopts} { |
|
lappend longopts $lo |
|
} |
|
} |
|
|
|
} |
|
return [list mashopts $mashopts singleopts $singleopts pairopts $pairopts longopts $longopts] |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
proc get_command_info {cmdname cspecs} { |
|
foreach item $cspecs { |
|
lassign $item cmd specinfo |
|
if {$cmd eq $cmdname} { |
|
if {[dict exists $specinfo dispatch]} { |
|
return $specinfo |
|
} |
|
} |
|
} |
|
return [list] |
|
} |
|
#### check_flags |
|
# does not support unvalued flags - unless explicitly specified in -soloflags (global) or in -singleopts for a commandprocessor |
|
#e.g not supported: v1 v2 -arg1 arg1val -debug -anotherflag anotherflagval |
|
# - unless -soloflags is something like -soloflags {-debug} or -soloflags {{-debug 1}} where 1 is the default. In this case - we can no longer support accepting a value for -soloflags - the processor will not assign it an argument from the commandline. |
|
#e.g not supported (unless -debug in -soloflags): v1 v2 -arg1 arg1val -anotherflag anotherflagval -debug |
|
#e.g supported: v2 v2 -arg1 arg1val -debug 1 -anotherflag anotherflagval |
|
# supports positional arguments - but only if specified in -commandprocessors |
|
# todo |
|
# - supports -- for treating following arg as value even if it looks like a flag |
|
# - supports - for reading stdin |
|
# expects at least -values |
|
# other options -caller <name> -defaults <dict_keyed_on_dashed_flags> -required <list_of_dashed_flags &| ("all"|"none")> -extras <list_of_dashed_flags|"all"> -commandprocessors |
|
# -soloflags <list of -flag and {-flag default}> (these are flags that *must* be solo - ie they cannot take an argument ) if no default specified they are boolean defaulting to 1, repeated instances in -values will be appended to a list. |
|
# The only flag that can be a mix of solo or not, is the very last flag in the values list. In this case it must not be in the -soloflags list, but it will default to a boolean 1 to indicate presence. |
|
proc check_flags {args} { |
|
set runid [flagfilter::get_new_runid] |
|
#################################################### |
|
#puts "Entered checkflags, args $args" |
|
set distanceToTop [info level] |
|
set callerlist [list] |
|
set was_dispatched_by_another 0 ;#used to |
|
for {set i 1} {$i < $distanceToTop} {incr i} { |
|
set callerlevel [expr {$distanceToTop - $i}] |
|
set callerinfo [info level $callerlevel] |
|
set firstword [lindex $callerinfo 0] |
|
if {[string match "*check_flags*" $firstword]} { |
|
set was_dispatched_by_another 1 |
|
} |
|
lappend callerlist $firstword |
|
} |
|
#puts stdout "callerlist: $callerlist" |
|
|
|
#first handle args for check_flags itself |
|
if {[catch {lindex [info level -1] 0} caller]} { |
|
set caller "<global>" |
|
} |
|
#puts stderr ">>>>check_flags caller $caller" |
|
get_one_paired_flag_value {-x 1} -x ;# |
|
|
|
#manually check for -caller even if unbalanced args |
|
#we only need to use get_one_paired_flag_value because we haven't yet checked args is a properly formed paired list and if -caller is present we want to use it for clearer error messages. |
|
#use normal dict operations to retrieve other flags. |
|
#if failed to retrieve.. fall through to checks below |
|
if {![catch {get_one_paired_flag_value $args -caller} flag_value_result]} { |
|
set caller $flag_value_result |
|
} |
|
#puts stderr ">>>>check_flags caller $caller" |
|
|
|
|
|
|
|
|
|
set cf_defaults [dict create] |
|
dict set cf_defaults -caller $caller |
|
dict set cf_defaults -return [list arglistremaining] |
|
dict set cf_defaults -match [list] |
|
dict set cf_defaults -commandprocessors [list] |
|
dict set cf_defaults -soloflags [list] |
|
dict set cf_defaults -extras [list] |
|
dict set cf_defaults -defaults [list] |
|
dict set cf_defaults -required [list] |
|
dict set cf_defaults -values \uFFFF |
|
dict set cf_defaults -debugargs 0 |
|
dict set cf_defaults -debugargsonerror 1 ;#error level to use when dispatch error occurs.. will not set lower than -debugargs |
|
|
|
|
|
|
|
if {([llength $args] % 2) != 0} { |
|
do_error "check_flags error when called from '$caller' :check_flags must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $cf_defaults]' \n got: $args" |
|
} |
|
set cf_invalid_flags [list] |
|
foreach k [dict keys $args] { |
|
if {$k ni [dict keys $cf_defaults]} { |
|
lappend cf_invalid_flags $k |
|
} |
|
} |
|
if {[llength $cf_invalid_flags]} { |
|
do_error "check_flags error when called from ${caller}: Unknown or incompatible option(s)'$cf_invalid_flags': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values e.g -values [list {*}$cf_invalid_flags]" |
|
} |
|
|
|
|
|
set cf_args [dict merge $cf_defaults $args] |
|
unset args |
|
#################################################### |
|
#now look at -values etc that check_flags is checking |
|
|
|
set caller [dict get $cf_args -caller] |
|
|
|
set debugargs [dict get $cf_args -debugargs] |
|
dict set debugc -debugargs [dict get $cf_args -debugargs] |
|
dict set debugc -source "check_flags $caller" |
|
do_debug 1 $debugc "DEBUG-START $caller" |
|
|
|
set returnkey [dict get $cf_args -return] |
|
set defaults [dict get $cf_args -defaults] |
|
if {([llength $defaults] % 2) != 0} { |
|
do_error "check_flags error when called from '$caller' :-defaults must be a list containing an even number of arguments of form: -flag value'" |
|
} |
|
set required [dict get $cf_args -required] |
|
|
|
|
|
set acceptextra [dict get $cf_args -extras] |
|
|
|
set supplied [string trim [dict get $cf_args -values]] |
|
set soloflags [dict get $cf_args -soloflags] ;#By their nature - solo flags are unlikely to be automatically 'required' - review |
|
set solos_with_defaults [list] |
|
foreach solo_spec $soloflags { |
|
if {[llength $solo_spec] == 1} { |
|
lappend solos_with_defaults $solo_spec 1 |
|
} else { |
|
lappend solos_with_defaults [lindex $solo_spec 0] [lindex $solo_spec 1] |
|
} |
|
|
|
} |
|
|
|
if {$debugargs >= 3} { |
|
set prefix "| $caller>" |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
puts -nonewline stderr "$prefix input\n" |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
#puts stderr "$caller $cf_args" |
|
dict for {k v} $cf_args { |
|
if {$k ne "-commandprocessors"} { |
|
puts -nonewline stderr "$prefix \[$k\]\n" |
|
puts -nonewline stderr "$prefix $v\n" |
|
} |
|
} |
|
if {$debugargs >=4} { |
|
puts -nonewline stderr "$prefix \[-commandprocessors\]\n" |
|
foreach record [dict get $cf_args -commandprocessors] { |
|
puts -nonewline stderr "$prefix $record\n" |
|
} |
|
} |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
#dict for {key val} $cf_args { |
|
# puts stderr " $key" |
|
# puts stderr " $val" |
|
#} |
|
} |
|
|
|
|
|
################################################################################################## |
|
# allocate_arguments does the main work of processing non-flagged items in the main supplied argument list into flagged versions depending on the specs in -commandprocessors |
|
# It sets defaults only for those arguments processed by a '-commandprocessors' spec. |
|
# We must supply it with the -soloflags info because the solo flags affect what is considered an operand. |
|
set command_specs [dict get $cf_args -commandprocessors] ;#may be empty list - that's ok - it will still populate the 'flagged' and 'arglist' return-dict members. |
|
|
|
#some of these are keys returned by allocate_arguments |
|
# - some (e.g supplied) are added by check_flags |
|
# This list is the list of -return values that can be used with check_args |
|
set flaginfo_returns [list \ |
|
parseerrors \ |
|
parsestatus \ |
|
flagged \ |
|
flaggedremaining \ |
|
flaggednew \ |
|
unflagged \ |
|
unflaggedremaining \ |
|
unflaggedlistremaining \ |
|
listremaining \ |
|
arglist \ |
|
arglistremaining \ |
|
impliedunflagged \ |
|
impliedflagged \ |
|
classifications \ |
|
gridstring \ |
|
ranges \ |
|
dispatch \ |
|
dispatchstatuslist \ |
|
dispatchresultlist \ |
|
dispatchstatus \ |
|
supplied \ |
|
defaults \ |
|
status \ |
|
vmapobject \ |
|
] |
|
|
|
set PROCESSORS [col_allprocessors create ::flagfilter::obj::PROCESSORS_$runid] |
|
set PARENTS [col_parents create ::flagfilter::obj::PARENTS_$runid] |
|
|
|
# |
|
#set command_specs [concat [list {global {}}] $command_specs] |
|
lappend command_specs {tail_processor {}} |
|
|
|
foreach cspec $command_specs { |
|
set obj [cprocessor new $cspec $runid] ;#runid gives access to the context-objects PROCESSORS_runid & PARENTS_runid |
|
if {[$obj is_parent]} { |
|
$PARENTS add_parent $obj |
|
} |
|
#do_debug 1 $debugc "CONFIGURING OBJECT for commandprocessor [$obj name]" |
|
$PROCESSORS add_processor $obj |
|
} |
|
do_debug 1 $debugc "ADDED [$PROCESSORS count] processors to main commandprocessor collection" |
|
do_debug 1 $debugc "ADDED [$PARENTS count] processors to the parents collection" |
|
$PROCESSORS set_commandspecs $command_specs |
|
|
|
#allocate_arguments uses the PROCESSORS object |
|
set processed_arguments [allocate_arguments $PROCESSORS $solos_with_defaults $supplied $cf_args $caller] |
|
#set processed_arguments [allocate_arguments {} $supplied] |
|
|
|
set newly_flagged_positionals [dict get $processed_arguments flaggednew] |
|
set unflaggedremaining [dict get $processed_arguments unflaggedremaining] |
|
set unflaggedlistremaining [dict get $processed_arguments unflaggedlistremaining] |
|
set dispatch [dict get $processed_arguments dispatch] |
|
set flaggedremaining [dict get $processed_arguments flaggedremaining] |
|
set RETURNED_VMAP [dict get $processed_arguments vmapobject] |
|
|
|
|
|
|
|
if {$debugargs >= 3} { |
|
set prefix "| $caller>" |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
puts -nonewline stderr "$prefix output\n" |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
#puts stderr "processed_arguments: $processed_arguments" |
|
dict for {key val} $processed_arguments { |
|
puts -nonewline stderr "$prefix $key\n" |
|
puts -nonewline stderr "$prefix $val\n" |
|
} |
|
puts -nonewline stderr "$prefix [string repeat - 30]\n" |
|
} |
|
|
|
################################################################################################## |
|
|
|
|
|
|
|
|
|
|
|
if {![llength $newly_flagged_positionals]} { |
|
if {($supplied eq "\uFFFF") || ![llength $supplied]} { |
|
#do_error "check_flags error when called from ${caller}: missing or empty -values" |
|
} |
|
} |
|
|
|
#probably not something to enforce... we might pass on unbalanced lists to other check_args etc. |
|
#if {([llength $supplied] % 2) != 0} { |
|
# do_error "${caller}: Error. $caller must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $defaults]'\n received values: $supplied" |
|
#} |
|
|
|
|
|
|
|
set new_arg_list [dict get $processed_arguments arglistremaining] |
|
set flagged_list [dict get $processed_arguments flagged] |
|
#set suppliedkeys_with_extrakeys [concat [dict keys $supplied] [dict keys $newly_flagged_positionals]] |
|
#puts stdout "suppliedkeys and new keys: $suppliedkeys_with_extrakeys" |
|
|
|
#todo - add flaggednew to required if all was specified? |
|
#check invalid flags if not indicated in -extras , either explicitly or with 'extra' |
|
set flags_from_required [get_flagged_only $required {}] |
|
set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]] |
|
foreach spec $command_specs { |
|
lassign $spec parentname pinfo |
|
if {[string match -* $parentname]} { |
|
lappend known_flags $parentname |
|
} |
|
if {[dict exists $pinfo sub]} { |
|
if {[string match -* [dict get $pinfo sub]]} { |
|
lappend known_flags [dict get $pinfo sub] |
|
} |
|
} |
|
} |
|
do_debug 2 $debugc "------------------->known_flags: $known_flags soloflags:$soloflags" |
|
set invalid_flags [list] |
|
if {"all" ni [string tolower $acceptextra]} { |
|
if {"none" in [string tolower $acceptextra]} { |
|
set ok_extras [list] |
|
} elseif {[llength $acceptextra]} { |
|
set ok_extras $acceptextra |
|
} |
|
#todo |
|
#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 {[llength $invalid_flags]} { |
|
do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" |
|
} |
|
|
|
set calc_required [list] |
|
set keywords_in_required [lsearch -inline -all -not $required -*] |
|
set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] |
|
if {[llength $bad_keywords_in_required]} { |
|
do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" |
|
} |
|
#keywords_in_required now known to be only comprised of (possibly case variant) values of all|none |
|
if {[llength $keywords_in_required] > 1} { |
|
do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." |
|
} |
|
if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { |
|
set calc_required [list] |
|
} |
|
set flags [lsearch -inline -all $required -*] |
|
|
|
if {[llength $required]} { |
|
if {[lsearch -nocase $keywords_in_required "all"] >= 0} { |
|
#'all' can be present with other flags - and indicates we also require all the flags from -defaults |
|
dict for {k -} $defaults { |
|
if {$k ni $calc_required} { |
|
lappend calc_required $k |
|
} |
|
} |
|
} |
|
} |
|
|
|
set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list |
|
set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] |
|
set ranges [dict get $rangesets -ranges] |
|
set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. |
|
#tailflags are the same for all dispatch items |
|
set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] |
|
|
|
|
|
set dict_supplied [dict create supplied $supplied] |
|
set dict_defaults [dict create defaults $defaults] |
|
set dict_ranges [dict create ranges $ranges] |
|
set dict_rangesbytype [dict create rangesbytype $rangesbytype] |
|
set raise_dispatch_error_instead_of_return "" |
|
set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] |
|
#todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') |
|
if {[llength $dispatch]} { |
|
set dispatchstatuslist [list] |
|
set dispatchresultlist [list] |
|
set dispatchstatus "ok" |
|
#each dispatch entry is a commandname and dict |
|
#set dispatchrecord [lrange $dispatch 0 1] |
|
set re_argnum {%arg([0-9^%]+)%} |
|
set re_argtake {%argtake([0-9^%]+)%} |
|
set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline |
|
#e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} |
|
#dumb-editor rebalancing quote for above comment " |
|
foreach {parentname dispatchrecord} $dispatch { |
|
set commandinfo [get_command_info $parentname $command_specs] |
|
|
|
do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" |
|
|
|
# e.g lscmd lscmd natsortcommandline_ls lscmd.dir x |
|
|
|
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 [list %matched% [dict get $dispatchrecord matched]] $command] |
|
|
|
set argnum_indices [regexp -indices -all -inline $re_argnum $command] |
|
if {[llength $argnum_indices]} { |
|
foreach {argx_indices x_indices} $argnum_indices { |
|
#argx eg %arg12% |
|
set argx [string range $command {*}$argx_indices] |
|
set x [string range $command {*}$x_indices] |
|
set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] |
|
} |
|
} |
|
|
|
set argsreduced [dict get $dispatchrecord arguments] |
|
#set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] |
|
|
|
#review! |
|
#how will this behave differently on unix |
|
package require punk::winrun |
|
set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] |
|
#set argtake_indices [regexp -indices -all -inline $re_argtake $command] |
|
|
|
|
|
set start 0 |
|
while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { |
|
#argx eg %argtake12% |
|
set argx [string range $command {*}$argx_indices] |
|
set x [string range $command {*}$x_indices] |
|
set argval [lindex [dict get $dispatchrecord arguments] $x] |
|
set replacementlen [string length $argval] |
|
set command [string map [list $argx $argval] $command] |
|
set start [expr {[lindex $argx_indices 0] + $replacementlen}] |
|
set argsreduced [lremove $argsreduced $x] |
|
set rawparts [lremove $rawparts $x] |
|
} |
|
dict set dispatchrecord arguments $argsreduced |
|
if {$start > 0} { |
|
set rawreduced [join $rawparts] |
|
dict set dispatchrecord raw $rawreduced |
|
} |
|
|
|
set argvals [dict get $dispatchrecord arguments] |
|
set matched_operands [list] |
|
set matched_opts [list] |
|
set matched_in_order [list] |
|
set prefix "${parentname}." |
|
foreach {k v} $argvals { |
|
#puts "$$$$ $k" |
|
if {[string equal -length [string length $prefix] $prefix $k]} { |
|
#key is prefixed with "commandname." |
|
set k [string replace $k 0 [string length $prefix]-1] |
|
} |
|
#todo - -- ? |
|
if {[string match -* $k]} { |
|
lappend matched_opts $k $v |
|
lappend matched_in_order $k $v |
|
} else { |
|
set kparts [split $k .] |
|
lappend matched_operands $v |
|
lappend matched_in_order $v |
|
} |
|
} |
|
|
|
if {![dict exists $commandinfo dispatchtype]} { |
|
set dispatchtype tcl |
|
} else { |
|
set dispatchtype [dict get $commandinfo dispatchtype] |
|
} |
|
if {![dict exists $commandinfo dispatchglobal]} { |
|
if {$dispatchtype eq "tcl"} { |
|
set dispatchglobal 1 |
|
} else { |
|
set dispatchglobal 0 |
|
} |
|
} else { |
|
set dispatchglobal [dict get $commandinfo dispatchglobal] |
|
} |
|
#generally we only want to dispatch remaining flagged, and only at the tail end.(as opposed to flags occurring between command groups) |
|
# -It doesn't usually make much sense to dispatch remaining unflagged items, and it would be rare to require flags occurring before the command. |
|
#however - there are potential commands such as help, dryrun or maybe an analysis command that may need to see unconsumed operands or even look 'back' at prior items |
|
##update 2023-03 - we definitely want to look back to prior non-matches when we match on a script e.g <callingprocess> tclsh8.6 -someflag etc xxx.tcl scriptarg1 -etc |
|
# if we match and dispatch on *.tcl - then we may need 'tclsh8.6 -someflag etc' as the interpreter (possibly with arguments) to use. |
|
# we may need a 'script' dispatchtype (as well as the option to just pass these prior arguments as additional options for some other dispatchtypes) |
|
# |
|
# todo - add supported dispatchglobal values such as all, pre, post, allpre, allpost, and classifications |
|
# where pre & post are only those occurring directly before and after the command and its args, i.e not extending beyond any prior or subsequent other command. |
|
# classifications would be flagged as -classifications $classifications whereas pre and post would be added directly if specified singly, or flagged with -pre, -post etc if multiple are specified |
|
# Those beginning with 'all' should also be wrapped in flags, because potentially they come from disjointed sections of the argumentlist |
|
# - and we generally shouldn't supply arguments next to each other that weren't contiguous in the original list |
|
# The 1,true,yes,tailflagspaired value is designed for the usecase where a common set of tail flags e.g -debug can apply to any commands matched by the filter. |
|
# tail = all unallocated args after final command, including operands and end-of-options '--' (todo) |
|
# tailflags = all unallocated *contiguous* flags after the final command and final operands. (ie it will deliberately miss flags following last command if there is a later operand) (todo) |
|
# tailflagspaired = same as tailflags, but any solo-flags are defaulted to 1 (flags not merged, so there might be duplicate keys) so that it's a fully paired list |
|
# In other situations - post may make sense to get the very next set of unconsumed arguments. |
|
if {[string tolower $dispatchglobal] in [list 1 true yes tailflagspaired]} { |
|
set command_range_posn [lsearch -index 1 $ranges $parentname] |
|
set extraflags $tailflagspaired |
|
} else { |
|
set extraflags [list] |
|
} |
|
|
|
#jn concat allows $command to itself be a list |
|
##tcl dispatchtype |
|
dict set dispatchrecord dispatchtype $dispatchtype |
|
switch -- $dispatchtype { |
|
tcl { |
|
do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" |
|
#set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] |
|
set commandline [concat $command $matched_operands $matched_opts $extraflags] |
|
} |
|
raw { |
|
do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" |
|
#set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] |
|
set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] |
|
} |
|
shell { |
|
do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" |
|
#assume the shell arguments are in one quoted string? |
|
set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] |
|
} |
|
default { |
|
#non quoted shell? raw + defaults? |
|
do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" |
|
#set commandline [list $command {*}$matched_in_order {*}$extraflags] |
|
set commandline [concat $command $matched_in_order $extraflags] |
|
} |
|
} |
|
|
|
dict set dispatchrecord asdispatched $commandline |
|
set dispatchresult "" |
|
set dispatcherror "" |
|
if {![catch {{*}$commandline} cmdresult]} { |
|
set dispatchresult $cmdresult |
|
lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] |
|
lappend dispatchresultlist $cmdresult |
|
} else { |
|
set dispatchstatus "error" |
|
set dispatcherror $cmdresult |
|
#don't add to dispatchresultlist |
|
lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] |
|
if {!$was_dispatched_by_another} { |
|
#this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning |
|
set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" |
|
dict set dispatchrecord result $dispatchresult |
|
dict set dispatchrecord error $dispatcherror |
|
dict set dispatch $parentname $dispatchrecord |
|
|
|
break |
|
#return -code error "check_flags error during command dispatch:\n$cmdresult" |
|
} |
|
#we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist |
|
} |
|
dict set dispatchrecord result $dispatchresult |
|
dict set dispatchrecord error $dispatcherror |
|
dict set dispatch $parentname $dispatchrecord |
|
} |
|
|
|
set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] |
|
} |
|
#end llength $dispatch |
|
|
|
|
|
set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] |
|
dict set combined dispatch $dispatch ;#update with asdispatched info |
|
if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { |
|
dict set combined status "ok" |
|
} else { |
|
dict set combined status "error" |
|
} |
|
do_debug 1 $debugc "COMBINED:$combined" |
|
|
|
|
|
set returnkey [string tolower $returnkey] |
|
if {"all" in $returnkey} { |
|
set returnval $combined |
|
#set returnval [dict merge $combined $dict_dispatch_results] |
|
} else { |
|
if {[llength $returnkey] == 1} { |
|
set invalid 0 |
|
#todo - support multiple merge? |
|
set right "" |
|
if {[regexp -all {\|} $returnkey] == 1} { |
|
lassign [split $returnkey |] left right |
|
set joinparts [split $left ,] |
|
} else { |
|
set joinparts [split $returnkey ,] |
|
} |
|
foreach j [concat $joinparts $right] { |
|
if {$j ni $flaginfo_returns} { |
|
set invalid 1 |
|
} |
|
} |
|
set returnval [list] |
|
if {!$invalid} { |
|
foreach j $joinparts { |
|
lappend returnval {*}[dict get $combined $j] |
|
} |
|
if {[string length $right]} { |
|
set returnval [dict merge $returnval $defaults $returnval] |
|
} |
|
} else { |
|
set returnval [list callerrors [list "-return '$returnkey' not valid"]] |
|
} |
|
} else { |
|
set callerrors [list] |
|
set returnval [dict create] |
|
foreach rk $returnkey { |
|
if {$returnkey in $flaginfo_returns} { |
|
dict set returnval $rk [dict get $combined $returnkey] |
|
} else { |
|
lappend callerrors [list "-return '$returnkey' not valid"] |
|
} |
|
} |
|
if {[llength $callerrors]} { |
|
dict set returnval callerrors $callerrors |
|
} |
|
} |
|
} |
|
|
|
do_debug 1 $debugc "[string repeat = 40]" |
|
do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" |
|
do_debug 1 $debugc "[string repeat - 40]" |
|
|
|
if {[string length $raise_dispatch_error_instead_of_return]} { |
|
set errdebug [dict get $cf_args -debugargsonerror] |
|
if {$errdebug > [dict get $cf_args -debugargs]} { |
|
dict set debugc -debugargs $errdebug |
|
} |
|
} |
|
|
|
set debuglevel_return 2 |
|
set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return |
|
if {[llength [dict get $combined parseerrors]]} { |
|
dict set debugdict "parseerrors" 0 |
|
} else { |
|
dict set debugdict "parseerrors" 2 |
|
} |
|
dict set debugdict "defaults" 1 |
|
dict set debugdict "supplied" 1 |
|
dict set debugdict "dispatch" 1 |
|
dict set debugdict "ranges" 1 |
|
dict set debugdict "rangesbytype" 1 |
|
dict set debugdict "dispatchstatus" 1 |
|
if {[dict get $combined "status"] eq "ok"} { |
|
dict set debugdict "status" 1 |
|
} else { |
|
dict set debugdict "status" 0 |
|
} |
|
|
|
do_debug 1 $debugc "returning '$returnkey'" |
|
do_debug 1 $debugc "returnval '$returnval'" |
|
if {([llength $returnval] % 2) == 0} { |
|
do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" |
|
} |
|
do_debug 1 $debugc "[string repeat = 40]" |
|
foreach {k v} $combined { |
|
set dlev [dict get $debugdict $k] |
|
switch -- $k { |
|
dispatch { |
|
set col1 [string repeat " " 12] |
|
#process as paired list rather than dict (support repeated commands) |
|
set i 0 |
|
foreach {cmdname cmdinfo} $v { |
|
set field1 [string repeat " " [expr {[string length $cmdname]}]] |
|
set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] |
|
set j 0 |
|
foreach {ckey cval} $cmdinfo { |
|
|
|
if {$i == 0 && $j == 0} { |
|
set c1 [overtype::left $col1 "dispatch"] |
|
} else { |
|
set c1 [overtype::left $col1 { ... }] |
|
} |
|
|
|
if {$j == 0} { |
|
set f1 [overtype::left $field1 $cmdname] |
|
set c2 [overtype::left $col2_dispatch "$f1 $ckey"] |
|
} else { |
|
set f1 [overtype::left $field1 ...] |
|
set c2 [overtype::left $col2_dispatch "$f1 $ckey"] |
|
} |
|
#leave at debug level 1 - because dispatch is generally important |
|
do_debug $dlev $debugc "${c1}${c2} $cval" |
|
|
|
incr j |
|
} |
|
incr i |
|
} |
|
|
|
#do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" |
|
#foreach {nm rem} [lrange $v 2 end] { |
|
# do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" |
|
#} |
|
} |
|
dispatchresultlist { |
|
set col1 [string repeat " " 25] |
|
set i 0 |
|
foreach dresult $v { |
|
if {$i == 0} { |
|
set c1 [overtype::left $col1 $k] |
|
} else { |
|
set c1 [overtype::left $col1 { ... }] |
|
} |
|
do_debug $dlev $debugc "$c1 $dresult" |
|
incr i |
|
} |
|
} |
|
classifications { |
|
set col1 [string repeat " " 25] |
|
set len [dict size $v] |
|
if {$len == 0} { |
|
do_debug $dlev $debugc "[overtype::left $col1 $k]" |
|
continue |
|
} |
|
set max [expr {$len -1}] |
|
set numlines [expr $len / 3 + 1] |
|
if {($len % 3) == 0} { |
|
incr numlines -1 |
|
} |
|
set j 0 |
|
for {set ln 0} {$ln < $numlines} {incr ln} { |
|
if {$ln == 0} { |
|
set c1 "[overtype::left $col1 $k]" |
|
} else { |
|
set c1 "[overtype::left $col1 { ... }]" |
|
} |
|
set line "" |
|
for {set col 0} {$col < 3} {incr col} { |
|
if {$j <= $max} { |
|
append line "$j [list [dict get $v $j]] " |
|
} |
|
incr j |
|
} |
|
do_debug $dlev $debugc "$c1 [string trim $line]" |
|
} |
|
} |
|
gridstring { |
|
set col1 [string repeat " " 25] |
|
set i 0 |
|
foreach ln [split $v \n] { |
|
if {$i == 0} { |
|
set c1 [overtype::left $col1 $k] |
|
} else { |
|
set c1 [overtype::left $col1 { ... }] |
|
} |
|
do_debug $dlev $debugc "$c1 $ln" |
|
incr i |
|
} |
|
} |
|
default { |
|
set col1 [string repeat " " 25] |
|
do_debug $dlev $debugc "[overtype::left $col1 $k] $v" |
|
} |
|
} |
|
} |
|
do_debug 1 $debugc "[string repeat = 40]" |
|
do_debug 1 $debugc "DEBUG-END $caller" |
|
if {[string length $raise_dispatch_error_instead_of_return]} { |
|
return -code error $raise_dispatch_error_instead_of_return |
|
} |
|
|
|
|
|
return $returnval |
|
} |
|
|
|
proc tailflagspaired {defaults supplied classifications rangesbytype} { |
|
lassign [lindex $rangesbytype end] c tp a b |
|
if {($c eq "unallocated") && ($tp eq "flagtype")} { |
|
set tail_unallocated [lrange $supplied $a $b] |
|
} 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 |
|
if {[llength $tail_unallocated]} { |
|
for {set i $a} {$i <=$b} {incr i} { |
|
set arginfo [dict get $classifications $i] |
|
lassign $arginfo class ftype v |
|
switch -- $ftype { |
|
flag - 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} { |
|
lappend extraflags $k $v |
|
} |
|
} |
|
} else { |
|
set extraflags $defaults |
|
} |
|
return $extraflags |
|
} |
|
|
|
proc tailflagspaired1 {defaults supplied classifications rangesbytype} { |
|
lassign [lindex $rangesbytype end] c tp a b |
|
if {($c eq "unallocated") && ($tp eq "flagtype")} { |
|
set tail_unallocated [lrange $supplied $a $b] |
|
} else { |
|
set tail_unallocated [list] |
|
} |
|
#set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] |
|
|
|
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 with no value set |
|
if {[llength $tail_unallocated]} { |
|
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 |
|
} |
|
} |
|
if {$ftype eq "flagvalue"} { |
|
lappend extraflags $v |
|
} |
|
} |
|
foreach {k v} [dict get $defaults] { |
|
if {$k ni $extraflags} { |
|
lappend extraflags $k $v |
|
} |
|
} |
|
} else { |
|
set extraflags $defaults |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
} |
|
|
|
|
|
namespace eval flagfilter { |
|
|
|
#punk::lib::dict_merge_ordered |
|
|
|
|
|
|
|
#retrieve *only* names that are dependant on the provided namekey - not the key itself |
|
# (query is sorted by the trailing numerical index which represents order the arguments were processed) |
|
proc flag_array_get_sorted_subs {arrname sep namekey} { |
|
upvar $arrname arr |
|
set allsubs [array names arr ${namekey}.*${sep}name,*] |
|
set rnames [lmap nm $allsubs {string reverse $nm}] |
|
set sorted_rnames [lsort -dictionary $rnames] |
|
set ordered [lmap nm $sorted_rnames {string reverse $nm}] |
|
return $ordered |
|
} |
|
|
|
proc flag_array_get_sorted_siblings {arrname sep namekey} { |
|
#determine parent by looking at dot - but confirm parent name is in array. |
|
|
|
} |
|
|
|
|
|
|
|
#dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. |
|
#use -dictionary to ensure embedded numbers are sorted as integers |
|
proc array_names_sorted_by_tail {arrname nameglob} { |
|
upvar $arrname arr |
|
set matched_names [array names arr $nameglob] |
|
set rnames [lmap nm $matched_names {string reverse $nm}] |
|
set sorted_rnames [lsort -dictionary $rnames] |
|
return [lmap nm $sorted_rnames {string reverse $nm}] |
|
} |
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|