diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-0.3.tm index 575f43d5..df61a724 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/src/modules/flagfilter-0.3.tm @@ -1,2693 +1,2693 @@ -#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 '\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 '\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 '\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 - package require Thread - return "ff-[pid]-[thread::id]-[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]}] - } - - - - - - - - - - - - - - - - - - - - #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] - 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 - if {$type eq "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 - } - } elseif {$type eq "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. - } elseif {$type eq "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 (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 "" - 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 - } - } - - #assert - 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 -defaults -required -extras -commandprocessors - # -soloflags (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 "" - } - #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 - foreach k [dict keys $defaults] { - if {$k ni $calc_required} { - lappend calc_required $k - } - } - } - } - - set classifications [dict get $processed_arguments classifications] ;#assert - 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] - 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 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 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 - if {$dispatchtype eq "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] - } elseif {$dispatchtype eq "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] - } elseif {$dispatchtype eq "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] - } else { - #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]" - 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 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] - if {$k eq "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]" - #} - } elseif {$k eq "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 - } - } elseif {$k eq "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]" - } - } elseif {$k eq "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 - } - - } else { - 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 [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 - 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 - } - 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 [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 { - - #The standard dict merge accepts multiple dicts with values from dicts to the right taking precedence. - #When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #This function merges maintaining the key order of main followed by defaults. - proc dict_merge_ordered {defaults main} { - set keys [dict keys $main] - dict for {k v} $defaults { - if {$k ni $keys} { - lappend keys $k - } - } - #use normal merge mechanism - but then pick out values using our ordered key list - set combined_values [dict merge $defaults $main] - set merged [list] - foreach k $keys { - lappend merged $k [dict get $combined_values $k] - } - return $merged - } - - - - #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}] - } - - -} - - - - - +#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 '\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 '\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 '\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 + package require Thread + return "ff-[pid]-[thread::id]-[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]}] + } + + + + + + + + + + + + + + + + + + + + #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] + 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 + if {$type eq "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 + } + } elseif {$type eq "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. + } elseif {$type eq "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 (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 "" + 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 + } + } + + #assert - 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 -defaults -required -extras -commandprocessors + # -soloflags (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 "" + } + #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 + foreach k [dict keys $defaults] { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assert - 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] + 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 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 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 + if {$dispatchtype eq "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] + } elseif {$dispatchtype eq "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] + } elseif {$dispatchtype eq "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] + } else { + #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]" + 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 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] + if {$k eq "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]" + #} + } elseif {$k eq "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 + } + } elseif {$k eq "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]" + } + } elseif {$k eq "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 + } + + } else { + 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 [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 + 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 + } + 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 [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 { + + #The standard dict merge accepts multiple dicts with values from dicts to the right taking precedence. + #When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #This function merges maintaining the key order of main followed by defaults. + proc dict_merge_ordered {defaults main} { + set keys [dict keys $main] + dict for {k v} $defaults { + if {$k ni $keys} { + lappend keys $k + } + } + #use normal merge mechanism - but then pick out values using our ordered key list + set combined_values [dict merge $defaults $main] + set merged [list] + foreach k $keys { + lappend merged $k [dict get $combined_values $k] + } + return $merged + } + + + + #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}] + } + + +} + + + + + diff --git a/src/modules/overtype-1.3.tm b/src/modules/overtype-1.3.tm index ca3748b5..472bbb98 100644 --- a/src/modules/overtype-1.3.tm +++ b/src/modules/overtype-1.3.tm @@ -1,157 +1,157 @@ - -package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - - -namespace eval overtype { - namespace export * -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - - -proc overtype::left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - - return "$overtext[string range $undertext $overlen end]" - } -} - -# test - use more tcl8.5 features. -proc overtype::left2 {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 $len-1 ] - } - } - } else { - #return "$overtext[string range $undertext $overlen end]" - return [string replace $undertext 0 $overlen-1 $overtext] - } -} -proc overtype::centre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-bias) left - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - set diff [expr {$ulen - $olen}] - if {$diff > 0} { - set half [expr {round(int($diff / 2))}] - if {[string match right $opt(-bias)]} { - if {[expr {2 * $half}] < $diff} { - incr half - } - } - - set rhs [expr {$diff - $half - 1}] - set lhs [expr {$half - 1}] - - set a [string range $undertext 0 $lhs] - set b $overtext - set c [string range $undertext end-$rhs end] - return $a$b$c - } else { - if {$diff < 0} { - if {$opt(-overflow)} { - return $overtext - } else { - return [string range $overtext 0 [expr {$ulen - 1}]] - } - } else { - return $overtext - } - } -} - -proc overtype::right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } -} - -namespace eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} + +package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + + +namespace eval overtype { + namespace export * +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + + +proc overtype::left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-ellipsis) 0 + set opt(-ellipsistext) {...} + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set len [string length $undertext] + set overlen [string length $overtext] + set diff [expr {$overlen - $len}] + if {$diff > 0} { + if {$opt(-overflow)} { + return $overtext + } else { + if {$opt(-ellipsis)} { + return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] + } else { + return [string range $overtext 0 [expr {$len -1}]] + } + } + } else { + + return "$overtext[string range $undertext $overlen end]" + } +} + +# test - use more tcl8.5 features. +proc overtype::left2 {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-ellipsis) 0 + set opt(-ellipsistext) {...} + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set len [string length $undertext] + set overlen [string length $overtext] + set diff [expr {$overlen - $len}] + if {$diff > 0} { + if {$opt(-overflow)} { + return $overtext + } else { + if {$opt(-ellipsis)} { + return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)] + } else { + return [string range $overtext 0 $len-1 ] + } + } + } else { + #return "$overtext[string range $undertext $overlen end]" + return [string replace $undertext 0 $overlen-1 $overtext] + } +} +proc overtype::centre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-bias) left + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set olen [string length $overtext] + set ulen [string length $undertext] + set diff [expr {$ulen - $olen}] + if {$diff > 0} { + set half [expr {round(int($diff / 2))}] + if {[string match right $opt(-bias)]} { + if {[expr {2 * $half}] < $diff} { + incr half + } + } + + set rhs [expr {$diff - $half - 1}] + set lhs [expr {$half - 1}] + + set a [string range $undertext 0 $lhs] + set b $overtext + set c [string range $undertext end-$rhs end] + return $a$b$c + } else { + if {$diff < 0} { + if {$opt(-overflow)} { + return $overtext + } else { + return [string range $overtext 0 [expr {$ulen - 1}]] + } + } else { + return $overtext + } + } +} + +proc overtype::right {args} { + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set olen [string length $overtext] + set ulen [string length $undertext] + + if {$opt(-overflow)} { + return [string range $undertext 0 end-$olen]$overtext + } else { + if {$olen > $ulen} { + set diff [expr {$olen - $ulen}] + return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] + } else { + return [string range $undertext 0 end-$olen]$overtext + } + } +} + +namespace eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index fc2349f4..1b46aacd 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -1,265 +1,265 @@ -# -# -# -# -# -# 2004 - Public Domain -# -# PatternPunk - DIALECT -#Dynamic Instance Accumulation Language Extending Classic Tcl -#The goofy acronym is a fancy way of not referring to PatternPunk as yet another OO system. - - -package require pattern -package require overtype -pattern::init - -package provide patternpunk [namespace eval punk { - variable version - - set version 1.1 -}] - - -::>pattern .. Create ::>punk -::>punk .. Property license {Public Domain} -::>punk .. Property logo2 { -+-----------------------+ -| Pattern PUNK | -| . \\\_ . | -| .*. \@ > .=. | -| .*.*. | ~ .=.=. | -|.*.*.*.\_- -_/.=.=.=.| -| .*.*. \\ .=.=. | -| .*. / \ .=. | -| . _+ +_ . | -+-----------------------+ -} -set ::punk::bannerTemplate { -+-----------------------+ -| .000000000000000. | -| .*. \\\_ .=. | -| .*.*. \@ > .=.=. | -|.*.*.*. | ~ .=.=.=.| -| .*.*. \_- -_/ .=.=. | -| .*. \\ .=. | -| . / \ . | -|111111111_+ +_2222222| -+-----------------------+ -} - ->punk .. Method banner {args} { - set defaults [list -title "Pattern PUNK" -left "" -right ""] - if {[catch {set opts [dict merge $defaults $args]} ]} { - error "usage: banner \[-title \$title -left \$left -right \$right\]" - } - - set word1 [overtype::left [string repeat " " 9] [dict get $opts -left]] - set word2 [overtype::right [string repeat " " 7] [dict get $opts -right]] - set title [overtype::centre [string repeat " " 15] [dict get $opts -title]] - - return [string map [list 111111111 $word1 2222222 $word2 000000000000000 $title] $punk::bannerTemplate] -} - - - ->punk .. Property logo [>punk . banner] ->punk .. Property versionLogo [>punk . banner -left " Ver" -right "$::punk::version "] ->punk .. Property version $::punk::version - ->punk .. Property front { - _|_ - @ v @ - ~ - - - - |_\ /_| - / \ - _+ +_ -} ->punk .. Property back { - | - ( | ) - | - - - - |_\ /_| - / \ - _- -_ -} ->punk .. Property rhs { - \\\_ - \@ > - | ~ - \_- -_ - \\ / - / \ - _+ +_ -} ->punk .. Property right ->punk .. PropertyRead right {} { - return $o_rhs -} - - ->punk .. Property lhs { - _/// - < @/ - ~ | - _- -_/ - \ // - / \ - _+ +_ -} ->punk .. Property left ->punk .. PropertyRead left {} { - return $o_lhs -} - ->punk .. Property rhs_air { - \\\_ - \@ > - | ~ - \_- -_/ - \\ - / \ - _+ +_ -} ->punk .. Property lhs_air { - _/// - < @/ - ~ | - \_- -_/ - // - / \ - _+ +_ -} - ->punk .. Property lhs_hips { - _/// - < @/ - ~ | - _- -_ - \ | | / - / \ - _+ +_ -} ->punk .. Property rhs_hips { - \\\_ - \@ > - | ~ - _- -_ - \ | | / - / \ - _+ +_ -} - - ->punk .. Property piss { - \\\_ - \@ > - | ~ - \_- -_/ - \\_ .. - / \ .. - _+ +_ . -} - ->punk .. Property poop { - _/// - < @/ - ^ | - _- -_ - \ \\ / - //. ~ - _+_+ @ -} - ->punk .. Method dumpProperties {{object ::>punk}} { - foreach {p v} [$object .. Properties . pairs] { - puts $p - puts [set $v] - puts \n - } -} ->punk .. Method listProperties {{object ::>punk}} { - set result {} - foreach {p v} [$object .. Properties . pairs] { - lappend result $p [set $v] - } - return $result -} - - -########################################################## -#CANDY-CODE -# -#!todo - unset etc. -if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} - -proc ::punk::var {varname {= {}} args} { - if {${=} == "="} { - if {[llength $args] > 1} { - uplevel 1 [list set $varname [uplevel 1 $args]] - } else { - uplevel 1 [list set $varname [lindex $args 0]] - } - } else { - uplevel 1 [list set $varname] - } -} -proc unknown {args} { - if {[lindex $args 1] eq "="} { - set n [lindex $args 0] - set v [lindex $args 2] - #uplevel 1 [string map [list @n@ $n @v@ $v] {proc @n@ {= val} {uplevel 1 set @n@ $val}}] - uplevel 1 [list interp alias {} $n {} ::punk::var $n] - - #uplevel 1 [list trace add variable $n unset [string map [list @n@ $n] {uplevel 1 [list interp alias {} @n@ {}]}]] - uplevel 1 [list trace add variable $n unset [list interp alias {} $n {}]] - - if {[llength $args] > 3} { - #RHS consists of multiple args; evaluate - return [uplevel 1 [list set $n [uplevel 1 [lrange $args 2 end]]]] - } else { - #RHS is single arg; treat as value - return [uplevel 1 [list set $n $v]] - } - } else { - #delegate to original 'unknown' command - uplevel 1 ::punk::_unknown $args - } -} - - -#Cute names for file I/O -proc <- filename { - set fp [open $filename] - ::pattern::K [read $fp] [close $fp] -} -proc -> {filename string} { - set fp [open $filename w] - puts $fp $string - close $fp -} -proc ->> {filename string} { - set fp [open $filename a] - puts $fp $string - close $fp -} - -#presumably this is to allow calling of standard objects using dotted notation? -::>pattern .. Create ::> -::> .. Method item {args} { - #uplevel #0 $args - #uplevel #0 [join $args] - - uplevel #0 $args -} - -#]]> -# -# -# -# -# - +# +# +# +# +# +# 2004 - Public Domain +# +# PatternPunk - DIALECT +#Dynamic Instance Accumulation Language Extending Classic Tcl +#The goofy acronym is a fancy way of not referring to PatternPunk as yet another OO system. + + +package require pattern +package require overtype +pattern::init + +package provide patternpunk [namespace eval punk { + variable version + + set version 1.1 +}] + + +::>pattern .. Create ::>punk +::>punk .. Property license {Public Domain} +::>punk .. Property logo2 { ++-----------------------+ +| Pattern PUNK | +| . \\\_ . | +| .*. \@ > .=. | +| .*.*. | ~ .=.=. | +|.*.*.*.\_- -_/.=.=.=.| +| .*.*. \\ .=.=. | +| .*. / \ .=. | +| . _+ +_ . | ++-----------------------+ +} +set ::punk::bannerTemplate { ++-----------------------+ +| .000000000000000. | +| .*. \\\_ .=. | +| .*.*. \@ > .=.=. | +|.*.*.*. | ~ .=.=.=.| +| .*.*. \_- -_/ .=.=. | +| .*. \\ .=. | +| . / \ . | +|111111111_+ +_2222222| ++-----------------------+ +} + +>punk .. Method banner {args} { + set defaults [list -title "Pattern PUNK" -left "" -right ""] + if {[catch {set opts [dict merge $defaults $args]} ]} { + error "usage: banner \[-title \$title -left \$left -right \$right\]" + } + + set word1 [overtype::left [string repeat " " 9] [dict get $opts -left]] + set word2 [overtype::right [string repeat " " 7] [dict get $opts -right]] + set title [overtype::centre [string repeat " " 15] [dict get $opts -title]] + + return [string map [list 111111111 $word1 2222222 $word2 000000000000000 $title] $punk::bannerTemplate] +} + + + +>punk .. Property logo [>punk . banner] +>punk .. Property versionLogo [>punk . banner -left " Ver" -right "$::punk::version "] +>punk .. Property version $::punk::version + +>punk .. Property front { + _|_ + @ v @ + ~ + - - + |_\ /_| + / \ + _+ +_ +} +>punk .. Property back { + | + ( | ) + | + - - + |_\ /_| + / \ + _- -_ +} +>punk .. Property rhs { + \\\_ + \@ > + | ~ + \_- -_ + \\ / + / \ + _+ +_ +} +>punk .. Property right +>punk .. PropertyRead right {} { + return $o_rhs +} + + +>punk .. Property lhs { + _/// + < @/ + ~ | + _- -_/ + \ // + / \ + _+ +_ +} +>punk .. Property left +>punk .. PropertyRead left {} { + return $o_lhs +} + +>punk .. Property rhs_air { + \\\_ + \@ > + | ~ + \_- -_/ + \\ + / \ + _+ +_ +} +>punk .. Property lhs_air { + _/// + < @/ + ~ | + \_- -_/ + // + / \ + _+ +_ +} + +>punk .. Property lhs_hips { + _/// + < @/ + ~ | + _- -_ + \ | | / + / \ + _+ +_ +} +>punk .. Property rhs_hips { + \\\_ + \@ > + | ~ + _- -_ + \ | | / + / \ + _+ +_ +} + + +>punk .. Property piss { + \\\_ + \@ > + | ~ + \_- -_/ + \\_ .. + / \ .. + _+ +_ . +} + +>punk .. Property poop { + _/// + < @/ + ^ | + _- -_ + \ \\ / + //. ~ + _+_+ @ +} + +>punk .. Method dumpProperties {{object ::>punk}} { + foreach {p v} [$object .. Properties . pairs] { + puts $p + puts [set $v] + puts \n + } +} +>punk .. Method listProperties {{object ::>punk}} { + set result {} + foreach {p v} [$object .. Properties . pairs] { + lappend result $p [set $v] + } + return $result +} + + +########################################################## +#CANDY-CODE +# +#!todo - unset etc. +if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} + +proc ::punk::var {varname {= {}} args} { + if {${=} == "="} { + if {[llength $args] > 1} { + uplevel 1 [list set $varname [uplevel 1 $args]] + } else { + uplevel 1 [list set $varname [lindex $args 0]] + } + } else { + uplevel 1 [list set $varname] + } +} +proc unknown {args} { + if {[lindex $args 1] eq "="} { + set n [lindex $args 0] + set v [lindex $args 2] + #uplevel 1 [string map [list @n@ $n @v@ $v] {proc @n@ {= val} {uplevel 1 set @n@ $val}}] + uplevel 1 [list interp alias {} $n {} ::punk::var $n] + + #uplevel 1 [list trace add variable $n unset [string map [list @n@ $n] {uplevel 1 [list interp alias {} @n@ {}]}]] + uplevel 1 [list trace add variable $n unset [list interp alias {} $n {}]] + + if {[llength $args] > 3} { + #RHS consists of multiple args; evaluate + return [uplevel 1 [list set $n [uplevel 1 [lrange $args 2 end]]]] + } else { + #RHS is single arg; treat as value + return [uplevel 1 [list set $n $v]] + } + } else { + #delegate to original 'unknown' command + uplevel 1 ::punk::_unknown $args + } +} + + +#Cute names for file I/O +proc <- filename { + set fp [open $filename] + ::pattern::K [read $fp] [close $fp] +} +proc -> {filename string} { + set fp [open $filename w] + puts $fp $string + close $fp +} +proc ->> {filename string} { + set fp [open $filename a] + puts $fp $string + close $fp +} + +#presumably this is to allow calling of standard objects using dotted notation? +::>pattern .. Create ::> +::> .. Method item {args} { + #uplevel #0 $args + #uplevel #0 [join $args] + + uplevel #0 $args +} + +#]]> +# +# +# +# +# + diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 34819dd3..81d38cfb 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -1,542 +1,542 @@ -package provide punk [namespace eval punk { - variable version - set version 0.1 -}] - -namespace eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running - - set vars [list \ - scriptlib \ - color_stdout \ - color_stderr \ - logfile_stdout \ - logfile_stderr \ - syslog_stdout \ - syslog_stderr \ - exec_unknown \ - ] - #todo pkg punk::config - - #defaults - dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run - dict set startup color_stdout [list cyan bold] - dict set startup color_stderr [list red bold] - dict set startup syslog_stdout "127.0.0.1:514" - dict set startup syslog_stderr "127.0.0.1:514" - #default file logs to logs folder at same location as exe if writable, or empty string - dict set startup logfile_stdout "" - dict set startup logfile_stderr "" - set exefolder [file dirname [info nameofexecutable]] - set log_folder $exefolder/logs - dict set startup scriptlib $exefolder/scriptlib - if {[file exists $log_folder]} { - if {[file isdirectory $log_folder] && [file writable $log_folder]} { - dict set startup logfile_stdout $log_folder/repl-exec-stdout.txt - dict set startup logfile_stderr $log_folder/repl-exec-stderr.txt - } - } - - - #todo - load/write config file - - #env vars override the configuration - - #todo - define which configvars are settable in env - set known_punk_env_vars [list \ - PUNK_SCRIPTLIB \ - PUNK_EXECUNKNOWN \ - PUNK_COLOR_STDERR \ - PUNK_COLOR_STDOUT \ - PUNK_LOGFILE_STDOUT \ - PUNK_LOGFILE_STDERR \ - PUNK_SYSLOG_STDOUT \ - PUNK_SYSLOG_STDERR \ - ] - - #override with env vars if set - foreach evar $known_punk_env_vars { - if {[info exists ::env($evar)]} { - set f [set ::env($evar)] - if {$f ne "default"} { - #e.g PUNK_SCRIPTLIB -> scriptlib - set varname [string tolower [string range $evar 5 end]] - dict set startup $varname $f - } - } - } - - set running [dict create] - set running [dict merge $running $startup] -} - -namespace eval punk { - proc scriptlibpath {{shortname {}} args} { - upvar ::punk::config::running running_config - set scriptlib [dict get $running_config scriptlib] - if {[string match "lib::*" $shortname]} { - set relpath [string map [list "lib::" "" "::" "/"] $shortname] - set relpath [string trimleft $relpath "/"] - set fullpath $scriptlib/$relpath - } else { - set shortname [string trimleft $shortname "/"] - set fullpath $scriptlib/$shortname - } - return $fullpath - } - - #todo - something better - 'previous' rather than reverting to startup - proc channelcolors {{onoff {}}} { - upvar ::punk::config::running running_config - upvar ::punk::config::startup startup_config - - if {![string length $onoff]} { - return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] - } else { - set lower_onoff [string tolower $onoff] - if {$lower_onoff in [list true on 1]} { - dict set running_config color_stdout [dict get $startup_config color_stdout] - dict set running_config color_stderr [dict get $startup_config color_stderr] - } elseif {$lower_onoff in [list false off 0]} { - dict set running_config color_stdout "" - dict set running_config color_stderr "" - } else { - error "channelcolors: invalid value $onoff - expected true|false|on|off|1|0" - } - } - return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] - } - #useful for aliases e.g treemore -> xmore tree - proc xmore {args} { - {*}$args | more - } - proc winpath {path} { - #convert /c/etc to C:/etc - set re {^/([[:alpha:]]){1}/.*} - - set volumes [file volumes] - #exclude things like //zipfs:/ - set driveletters [list] - foreach v $volumes { - if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { - lappend driveletters $letter - } - } - #puts stderr "->$driveletters" - if {[regexp $re $path _ letter]} { - #upper case appears to be windows canonical form - if {[string toupper $letter] in $driveletters} { - set path [string toupper $letter]:/[string range $path 3 end] - } - } elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { - if {[string toupper $letter] in $driveletters} { - set path [string toupper $letter]:/[string range $path 7 end] - } - } - #puts stderr "=> $path" - #things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder - if {![file exists [file dirname $path]]} { - set path [file normalize $path] - } - return $path - } - proc windir {path} { - return [file dirname [punk::winpath $path]] - } - - #------------------------------------------------------------------- - #sh 'test' equivalent - to be used with exitcode of process - # - - #single evaluation to get exitcode - proc sh_test {args} { - tailcall run test {*}$args - } - - - #double-evaluation to get true/fals - #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented - #The problem with fallthrough is that sh/bash etc have a different view of existant files - #e.g unix files such as /dev/null vs windows devices such as CON,PRN - #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) - proc sh_TEST {args} { - set a1 [lindex $args 0] - set a2 [lindex $args 1] - set a3 [lindex $args 2] - if {[llength $args] == 1} { - #equivalent of -n STRING - return [expr {[string length $a1] != 0}] - } elseif {[llength $args] == 2} { - switch -- $a1 { - -b { - #dubious utility on FreeBSD, windows? - #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' - #Linux apparently uses them though - if{[file exists $a2]} { - if {[file type $a2] eq "blockSpecial"} { - return true - } else { - return false - } - } else { - return false - } - } - -c { - #e.g on windows CON,NUL - if {[file exists $a2]} { - if {[file type $a2] eq "characterSpecial"} { - return true - } else { - return false - } - } else { - return false - } - } - -d { - return [file isdirectory $a2] - } - -e { - return [file exists $a2] - } - -f { - #e.g on windows CON,NUL - if {[file exists $a2]} { - if {[file type $a2] eq "file"} { - return true - } else { - return false - } - } else { - return false - } - } - -h - - -L { - return [expr {[file type $a2] eq "link"}] - } - -s { - if {[file exists $a2] && ([file size $a2] > 0 )} { - return true - } else { - return false - } - } - -S { - if {[file exists $a2]} { - if {[file type $a2] eq "socket"} { - return true - } else { - return false - } - } else { - return false - } - } - -x { - if {[file exists $a2] && [file executable $a2]} { - return true - } else { - return false - } - } - -w { - if {[file exists $a2] && [file writable $a2]} { - return true - } else { - return false - } - } - -z { - return [expr {[string length $a2] == 0}] - } - -n { - return [expr {[string length $a2] != 0}] - } - default { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args - } - } - } elseif {[llength $args] == 3} { - switch -- $a2 { - "=" { - return [string equal $a1 $a3] - } - "!=" { - return [expr {$a1 ne $a3}] - } - "-eq" { - if {![string is integer -strict $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - return false - } - if {![string is integer -strict $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - return false - } - return [expr {$a1 == $a3}] - } - "-ge" { - return [expr {$a1 >= $a3}] - } - "-gt" { - return [expr {$a1 > $a3}] - } - "-le" { - return [expr {$a1 <= $a3}] - } - "-lt" { - return [expr {$a1 < $a3}] - } - "-ne" { - return [expr {$a1 != $a3}] - } - default { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args - } - } - } else { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args - } - } - proc sh_echo {args} { - tailcall run echo {*}$args - } - proc sh_ECHO {args} { - tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args - } - - - #sh style true/false for process exitcode. 0 is true - everything else false - proc exitcode {args} { - set c [lindex $args 0] - if {[string is integer -strict $c]} { - #return [expr {$c == 0}] - #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true - if {$c == 0} { - return true - } else { - return false - } - } else { - return false - } - } - #------------------------------------------------------------------- - - namespace export help aliases alias cdwin cdwindir winpath windir - namespace ensemble create - - #tailcall is important - #TODO - fix. conflicts with Tk toplevel command "." - proc ./ {args} { - set ::punk::last_run_display [list] - - if {([llength $args]) && ([lindex $args 0] eq "")} { - set args [lrange $args 1 end] - } - - - if {![llength $args]} { - set out [runout -n ls -aFC] - #puts stdout $out - #puts stderr [a+ white]$out[a+] - set result [pwd] - set chunklist [list] - lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] - lappend chunklist [list stdout $result\n] - set ::punk::last_run_display $chunklist - return $result - } else { - set a1 [lindex $args 0] - if {$a1 in [list . .. "./" "../"]} { - if {$a1 in [list ".." "../"]} { - cd $a1 - } - tailcall punk::./ {*}[lrange $args 1 end] - } - set curdir [pwd] - set path $curdir/$a1 - if {[file type $path] eq "file"} { - if {[string tolower [file extension $path]] in [list ".tcl" ".tm"]} { - set newargs [lrange $args 1 end] - set ::argv0 $path - set ::argc [llength $newargs] - set ::argv $newargs - tailcall source $path - } else { - puts stderr "Cannot run [file extension $path] file directly ([file tail $path])" - return [pwd] - } - } - if {[file type $path] eq "directory"} { - cd $path - tailcall punk::./ {*}[lrange $args 1 end] - } - error "Cannot access path $path" - } - } - proc ../ {args} { - set ::punk::last_run_display [list] - if {![llength $args]} { - cd .. - } else { - cd ../[file join {*}$args] - } - set out [runout -n ls -aFC] - set result [pwd] - #return $out\n[pwd] - set chunklist [list] - lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] - lappend chunklist [list stdout $result\n] - set ::punk::last_run_display $chunklist - return $result - } - proc ls {args} { - if {![llength $args]} { - set args [list [pwd]] - } - if {[llength $args] ==1} { - return [glob -nocomplain -tails -dir [lindex $args 0] *] - } else { - set result [dict create] - foreach a $args { - set k [file normalize $a] - set contents [glob -nocomplain -tails -dir $a *] - dict set result $k $contents - } - return $result - } - } - proc cdwin {path} { - set path [punk::winpath $path] - cd $path - } - proc cdwindir {path} { - set path [punk::winpath $path] - cd [file dirname $path] - } - - #return list of {chan chunk} elements - proc help_chunks {} { - set chunks [list] - set linesep [string repeat - 76] - catch { - package require patternpunk - #puts -nonewline stderr [>punk . rhs] - lappend chunks [list stderr [>punk . rhs]] - } - set text "" - set known $::punk::config::known_punk_env_vars - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n - lappend chunks [list stdout $text] - - set text "" - append text "Punk commands:\n" - append text "punk help\n" - lappend chunks [list stdout $text] - return $chunks - } - proc help {} { - set chunks [help_chunks] - foreach chunk $chunks { - lassign $chunk chan text - puts -nonewline $chan $text - } - } - #current interp aliases except those created by pattern package '::p::*' - proc aliases {{glob *}} { - set interesting [lmap a [interp aliases ""] {expr {![string match ::p::* $a] ? $a : [continue]}}] - set matched [lsearch -all -inline $interesting $glob] - } - proc alias {a args} { - if {[llength $args]} { - if {$a in [interp aliases ""]} { - set existing [interp alias "" $a] - puts stderr "Overwriting existing alias $a -> $existing with $a -> $args (in current session only)" - } - interp alias "" $a "" {*}$args - } else { - return [interp alias "" $a] - } - } - - #sh style 'test' and 'exitcode' (0 is false) - interp alias {} sh_test {} punk::sh_test - interp alias {} sh_echo {} punk::sh_echo - interp alias {} sh_TEST {} punk::sh_TEST - interp alias {} sh_ECHO {} punk::sh_ECHO - - - interp alias {} exitcode {} punk::exitcode - - - #friendly sh aliases (which user may wish to disable e.g if conflicts) - interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec - interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode - interp alias {} echo {} punk::sh_echo - interp alias {} ECHO {} punk::sh_ECHO - - interp alias {} c {} clear - interp alias {} a+ {} shellfilter::ansi::+ - interp alias {} run {} shellrun::run - interp alias {} runout {} shellrun::runout - interp alias {} runerr {} shellrun::runerr - interp alias {} runx {} shellrun::runx - - interp alias {} help {} punk help - interp alias {} aliases {} punk aliases - interp alias {} alias {} punk alias - interp alias {} treemore {} punk::xmore tree - #---------------------------------------------- - #leave the winpath related aliases available on all platforms - interp alias {} cdwin {} punk cdwin - interp alias {} cdwindir {} punk cdwindir - interp alias {} winpath {} punk winpath - interp alias {} windir {} punk windir - #---------------------------------------------- - #git - interp alias {} gs {} git status -sb - interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console - interp alias {} glast {} git log -1 HEAD --stat - interp alias {} gconf {} git config --global -l - - #---------------------------------------------- - interp alias {} l {} ls -aFC ;#wide listing () - interp alias {} ll {} ls -laFo --color=always - interp alias {} lw {} ls -aFv --color=always - interp alias {} ./ {} punk::./ - interp alias {} ../ {} punk::../ - if {$::tcl_platform(platform) eq "windows"} { - set has_powershell 1 - interp alias {} dl {} dir /q - interp alias {} dw {} dir /W/D - } else { - #todo - natsorted equivalent - #interp alias {} dl {} - #todo - powershell detection on other platforms - set has_powershell 0 - } - if {$has_powershell} { - interp alias {} psls {} pwsh -nop -nolo -c ls - interp alias {} psps {} pwsh -nop -nolo -c ps - } - -} +package provide punk [namespace eval punk { + variable version + set version 0.1 +}] + +namespace eval punk::config { + variable loaded + variable startup ;#include env overrides + variable running + + set vars [list \ + scriptlib \ + color_stdout \ + color_stderr \ + logfile_stdout \ + logfile_stderr \ + syslog_stdout \ + syslog_stderr \ + exec_unknown \ + ] + #todo pkg punk::config + + #defaults + dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run + dict set startup color_stdout [list cyan bold] + dict set startup color_stderr [list red bold] + dict set startup syslog_stdout "127.0.0.1:514" + dict set startup syslog_stderr "127.0.0.1:514" + #default file logs to logs folder at same location as exe if writable, or empty string + dict set startup logfile_stdout "" + dict set startup logfile_stderr "" + set exefolder [file dirname [info nameofexecutable]] + set log_folder $exefolder/logs + dict set startup scriptlib $exefolder/scriptlib + if {[file exists $log_folder]} { + if {[file isdirectory $log_folder] && [file writable $log_folder]} { + dict set startup logfile_stdout $log_folder/repl-exec-stdout.txt + dict set startup logfile_stderr $log_folder/repl-exec-stderr.txt + } + } + + + #todo - load/write config file + + #env vars override the configuration + + #todo - define which configvars are settable in env + set known_punk_env_vars [list \ + PUNK_SCRIPTLIB \ + PUNK_EXECUNKNOWN \ + PUNK_COLOR_STDERR \ + PUNK_COLOR_STDOUT \ + PUNK_LOGFILE_STDOUT \ + PUNK_LOGFILE_STDERR \ + PUNK_SYSLOG_STDOUT \ + PUNK_SYSLOG_STDERR \ + ] + + #override with env vars if set + foreach evar $known_punk_env_vars { + if {[info exists ::env($evar)]} { + set f [set ::env($evar)] + if {$f ne "default"} { + #e.g PUNK_SCRIPTLIB -> scriptlib + set varname [string tolower [string range $evar 5 end]] + dict set startup $varname $f + } + } + } + + set running [dict create] + set running [dict merge $running $startup] +} + +namespace eval punk { + proc scriptlibpath {{shortname {}} args} { + upvar ::punk::config::running running_config + set scriptlib [dict get $running_config scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + #todo - something better - 'previous' rather than reverting to startup + proc channelcolors {{onoff {}}} { + upvar ::punk::config::running running_config + upvar ::punk::config::startup startup_config + + if {![string length $onoff]} { + return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] + } else { + set lower_onoff [string tolower $onoff] + if {$lower_onoff in [list true on 1]} { + dict set running_config color_stdout [dict get $startup_config color_stdout] + dict set running_config color_stderr [dict get $startup_config color_stderr] + } elseif {$lower_onoff in [list false off 0]} { + dict set running_config color_stdout "" + dict set running_config color_stderr "" + } else { + error "channelcolors: invalid value $onoff - expected true|false|on|off|1|0" + } + } + return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] + } + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + {*}$args | more + } + proc winpath {path} { + #convert /c/etc to C:/etc + set re {^/([[:alpha:]]){1}/.*} + + set volumes [file volumes] + #exclude things like //zipfs:/ + set driveletters [list] + foreach v $volumes { + if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { + lappend driveletters $letter + } + } + #puts stderr "->$driveletters" + if {[regexp $re $path _ letter]} { + #upper case appears to be windows canonical form + if {[string toupper $letter] in $driveletters} { + set path [string toupper $letter]:/[string range $path 3 end] + } + } elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { + if {[string toupper $letter] in $driveletters} { + set path [string toupper $letter]:/[string range $path 7 end] + } + } + #puts stderr "=> $path" + #things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder + if {![file exists [file dirname $path]]} { + set path [file normalize $path] + } + return $path + } + proc windir {path} { + return [file dirname [punk::winpath $path]] + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + tailcall run test {*}$args + } + + + #double-evaluation to get true/fals + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + proc sh_TEST {args} { + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + if {[llength $args] == 1} { + #equivalent of -n STRING + return [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + if {[file type $a2] eq "blockSpecial"} { + return true + } else { + return false + } + } else { + return false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + if {[file type $a2] eq "characterSpecial"} { + return true + } else { + return false + } + } else { + return false + } + } + -d { + return [file isdirectory $a2] + } + -e { + return [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + if {[file type $a2] eq "file"} { + return true + } else { + return false + } + } else { + return false + } + } + -h - + -L { + return [expr {[file type $a2] eq "link"}] + } + -s { + if {[file exists $a2] && ([file size $a2] > 0 )} { + return true + } else { + return false + } + } + -S { + if {[file exists $a2]} { + if {[file type $a2] eq "socket"} { + return true + } else { + return false + } + } else { + return false + } + } + -x { + if {[file exists $a2] && [file executable $a2]} { + return true + } else { + return false + } + } + -w { + if {[file exists $a2] && [file writable $a2]} { + return true + } else { + return false + } + } + -z { + return [expr {[string length $a2] == 0}] + } + -n { + return [expr {[string length $a2] != 0}] + } + default { + tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + return [string equal $a1 $a3] + } + "!=" { + return [expr {$a1 ne $a3}] + } + "-eq" { + if {![string is integer -strict $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + return false + } + if {![string is integer -strict $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + return false + } + return [expr {$a1 == $a3}] + } + "-ge" { + return [expr {$a1 >= $a3}] + } + "-gt" { + return [expr {$a1 > $a3}] + } + "-le" { + return [expr {$a1 <= $a3}] + } + "-lt" { + return [expr {$a1 < $a3}] + } + "-ne" { + return [expr {$a1 != $a3}] + } + default { + tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + } + } + } else { + tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + } + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias cdwin cdwindir winpath windir + namespace ensemble create + + #tailcall is important + #TODO - fix. conflicts with Tk toplevel command "." + proc ./ {args} { + set ::punk::last_run_display [list] + + if {([llength $args]) && ([lindex $args 0] eq "")} { + set args [lrange $args 1 end] + } + + + if {![llength $args]} { + set out [runout -n ls -aFC] + #puts stdout $out + #puts stderr [a+ white]$out[a+] + set result [pwd] + set chunklist [list] + lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] + lappend chunklist [list stdout $result\n] + set ::punk::last_run_display $chunklist + return $result + } else { + set a1 [lindex $args 0] + if {$a1 in [list . .. "./" "../"]} { + if {$a1 in [list ".." "../"]} { + cd $a1 + } + tailcall punk::./ {*}[lrange $args 1 end] + } + set curdir [pwd] + set path $curdir/$a1 + if {[file type $path] eq "file"} { + if {[string tolower [file extension $path]] in [list ".tcl" ".tm"]} { + set newargs [lrange $args 1 end] + set ::argv0 $path + set ::argc [llength $newargs] + set ::argv $newargs + tailcall source $path + } else { + puts stderr "Cannot run [file extension $path] file directly ([file tail $path])" + return [pwd] + } + } + if {[file type $path] eq "directory"} { + cd $path + tailcall punk::./ {*}[lrange $args 1 end] + } + error "Cannot access path $path" + } + } + proc ../ {args} { + set ::punk::last_run_display [list] + if {![llength $args]} { + cd .. + } else { + cd ../[file join {*}$args] + } + set out [runout -n ls -aFC] + set result [pwd] + #return $out\n[pwd] + set chunklist [list] + lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] + lappend chunklist [list stdout $result\n] + set ::punk::last_run_display $chunklist + return $result + } + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] ==1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + proc cdwin {path} { + set path [punk::winpath $path] + cd $path + } + proc cdwindir {path} { + set path [punk::winpath $path] + cd [file dirname $path] + } + + #return list of {chan chunk} elements + proc help_chunks {} { + set chunks [list] + set linesep [string repeat - 76] + catch { + package require patternpunk + #puts -nonewline stderr [>punk . rhs] + lappend chunks [list stderr [>punk . rhs]] + } + set text "" + set known $::punk::config::known_punk_env_vars + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + lappend chunks [list stdout $text] + + set text "" + append text "Punk commands:\n" + append text "punk help\n" + lappend chunks [list stdout $text] + return $chunks + } + proc help {} { + set chunks [help_chunks] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + } + #current interp aliases except those created by pattern package '::p::*' + proc aliases {{glob *}} { + set interesting [lmap a [interp aliases ""] {expr {![string match ::p::* $a] ? $a : [continue]}}] + set matched [lsearch -all -inline $interesting $glob] + } + proc alias {a args} { + if {[llength $args]} { + if {$a in [interp aliases ""]} { + set existing [interp alias "" $a] + puts stderr "Overwriting existing alias $a -> $existing with $a -> $args (in current session only)" + } + interp alias "" $a "" {*}$args + } else { + return [interp alias "" $a] + } + } + + #sh style 'test' and 'exitcode' (0 is false) + interp alias {} sh_test {} punk::sh_test + interp alias {} sh_echo {} punk::sh_echo + interp alias {} sh_TEST {} punk::sh_TEST + interp alias {} sh_ECHO {} punk::sh_ECHO + + + interp alias {} exitcode {} punk::exitcode + + + #friendly sh aliases (which user may wish to disable e.g if conflicts) + interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec + interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode + interp alias {} echo {} punk::sh_echo + interp alias {} ECHO {} punk::sh_ECHO + + interp alias {} c {} clear + interp alias {} a+ {} shellfilter::ansi::+ + interp alias {} run {} shellrun::run + interp alias {} runout {} shellrun::runout + interp alias {} runerr {} shellrun::runerr + interp alias {} runx {} shellrun::runx + + interp alias {} help {} punk help + interp alias {} aliases {} punk aliases + interp alias {} alias {} punk alias + interp alias {} treemore {} punk::xmore tree + #---------------------------------------------- + #leave the winpath related aliases available on all platforms + interp alias {} cdwin {} punk cdwin + interp alias {} cdwindir {} punk cdwindir + interp alias {} winpath {} punk winpath + interp alias {} windir {} punk windir + #---------------------------------------------- + #git + interp alias {} gs {} git status -sb + interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console + interp alias {} glast {} git log -1 HEAD --stat + interp alias {} gconf {} git config --global -l + + #---------------------------------------------- + interp alias {} l {} ls -aFC ;#wide listing () + interp alias {} ll {} ls -laFo --color=always + interp alias {} lw {} ls -aFv --color=always + interp alias {} ./ {} punk::./ + interp alias {} ../ {} punk::../ + if {$::tcl_platform(platform) eq "windows"} { + set has_powershell 1 + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + #todo - powershell detection on other platforms + set has_powershell 0 + } + if {$has_powershell} { + interp alias {} psls {} pwsh -nop -nolo -c ls + interp alias {} psps {} pwsh -nop -nolo -c ps + } + +} diff --git a/src/modules/shellrun-0.1.tm b/src/modules/shellrun-0.1.tm index 3745d324..b505cbef 100644 --- a/src/modules/shellrun-0.1.tm +++ b/src/modules/shellrun-0.1.tm @@ -1,388 +1,388 @@ -# vim: set ft=tcl -# -package provide shellrun [namespace eval shellrun { - variable version - set version 0.1 -}] -#purpose: handle the run commands that call shellfilter::run -#e.g run,runout,runerr,runx - - - -#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. -# - If it did run, but there was a non-zero exitcode it is up to the application to check that. -#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. -#The user can always use exec for different process error semantics (they don't get exitcode with exec) - -namespace eval shellrun { - variable runout - variable runerr - - - proc run {args} { - set ::punk::last_run_display [list] - #we provide -nonewline for 'run' even though run doesn't deliver stderr or stdout to the tcl return value - #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. - set known_runopts [list "-echo" "-e" "-nonewline" "-n"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self - set runopts [list] - set cmdargs [list] - set idx_first_cmdarg [lsearch -not $args "-*"] - set runopts [lrange $args 0 $idx_first_cmdarg-1] - set cmdargs [lrange $args $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "run: Unknown runoption $o" - } - } - set runopts [lmap o $runopts {dict get $aliases $o}] - if {"-nonewline" in $runopts} { - set nonewline 1 - } else { - set nonewline 0 - } - - set id_err [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] - shellfilter::stack::remove stderr $id_err - - flush stderr - flush stdout - - set c [shellfilter::ansi::+ green] - set n [shellfilter::ansi::+] - if {[dict exists $exitinfo error]} { - error [dict get $exitinfo error] - } - - return $exitinfo - } - - proc runout {args} { - set ::punk::last_run_display [list] - variable runout - variable runerr - set runout "" - set runerr "" - - set known_runopts [list "-echo" "-e" "-nonewline" "-n"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self - set runopts [list] - set cmdargs [list] - set idx_first_cmdarg [lsearch -not $args "-*"] - set runopts [lrange $args 0 $idx_first_cmdarg-1] - set cmdargs [lrange $args $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "runout: Unknown runoption $o" - } - } - set runopts [lmap o $runopts {dict get $aliases $o}] - if {"-nonewline" in $runopts} { - set nonewline 1 - } else { - set nonewline 0 - } - - #puts stdout "RUNOUT cmdargs: $cmdargs" - - #todo add -data boolean and -data lastwrite to -settings with default being -data all - # because sometimes we're only interested in last char (e.g to detect something was output) - - #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] - # - #when not echoing - use float-locked so that the repl's stack is bypassed - if {"-echo" in $runopts} { - set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] - set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] - #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] - } else { - set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] - set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] - } - - #shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler - set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] - - flush stderr - flush stdout - - shellfilter::stack::remove stdout $stdout_stackid - shellfilter::stack::remove stderr $stderr_stackid - - #shellfilter::stack::remove commandout $outvar_stackid - if {[dict exists $exitinfo error]} { - #we must raise an error. - #todo - check errorInfo makes sense.. return -code? tailcall? - error [dict get $exitinfo error] - } - - set chunklist [list] - - set n [a+] - set c "" - if [dict exists $exitinfo exitcode] { - set code [dict get $exitinfo exitcode] - if {$code == 0} { - set c [a+ green] - } else { - set c [a+ white bold] - } - } else { - set c [a+ Yellow red bold] - } - #exitcode not part of return value for runout - colourcode appropriately - lappend chunklist [list stderr "$c$exitinfo$n\n"] - - - set chunk "[a+ red bold]stderr[a+]\n" - if {[string length $::shellrun::runerr]} { - if {$nonewline} { - set e [string trimright $::shellrun::runerr \r\n] - } else { - set e $::shellrun::runerr - } - append chunk "[a+ red light]$e[a+]\n" - } - lappend chunklist [list stderr $chunk] - - - - - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] - set chunk "" - if {[string length $::shellrun::runout]} { - if {$nonewline} { - set o [string trimright $::shellrun::runout \r\n] - } else { - set o $::shellrun::runout - } - append chunk "$o\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. - } - lappend chunklist [list stdout $chunk] - - - set ::punk::last_run_display $chunklist - - if {$nonewline} { - return [string trimright $::shellrun::runout \r\n] - } else { - return $::shellrun::runout - } - } - - proc runerr {args} { - set ::punk::last_run_display [list] - variable runout - variable runerr - set runout "" - set runerr "" - set known_runopts [list "-echo" "-e" "-nonewline" "-n"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self - set runopts [list] - set cmdargs [list] - set idx_first_cmdarg [lsearch -not $args "-*"] - set runopts [lrange $args 0 $idx_first_cmdarg-1] - set cmdargs [lrange $args $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "runerr: Unknown runoption $o" - } - } - set runopts [lmap o $runopts {dict get $aliases $o}] - if {"-nonewline" in $runopts} { - set nonewline 1 - } else { - set nonewline 0 - } - - if {"-echo" in $runopts} { - set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] - set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] - } else { - set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] - set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] - } - - - set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] - shellfilter::stack::remove stderr $stderr_stackid - shellfilter::stack::remove stdout $stdout_stackid - - - flush stderr - flush stdout - - #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch - # to determine something other than just a nonzero exit code or output on stderr. - if {[dict exists $exitinfo error]} { - #todo - check errorInfo makes sense.. return -code? tailcall? - error [dict get $exitinfo error] - } - - set chunklist [list] - - set n [a+] - set c "" - if [dict exists $exitinfo exitcode] { - set code [dict get $exitinfo exitcode] - if {$code == 0} { - set c [a+ green] - } else { - set c [a+ white bold] - } - } else { - set c [a+ Yellow red bold] - } - #exitcode not part of return value for runout - colourcode appropriately - lappend chunklist [list stderr "$c$exitinfo$n\n"] - - - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] - set chunk "" - if {[string length $::shellrun::runout]} { - if {$nonewline} { - set o [string trimright $::shellrun::runout \r\n] - } else { - set o $::shellrun::runout - } - append chunk "[a+ white light]$o[a+]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. - } - lappend chunklist [list stdout $chunk] - - - - set chunk "[a+ red bold]stderr[a+]\n" - if {[string length $::shellrun::runerr]} { - if {$nonewline} { - set e [string trimright $::shellrun::runerr \r\n] - } else { - set e $::shellrun::runerr - } - append chunk "$e\n" - } - lappend chunklist [list stderr $chunk] - - - set ::punk::last_run_display $chunklist - - if {$nonewline} { - return [string trimright $::shellrun::runerr \r\n] - } - return $::shellrun::runerr - } - - proc runx {args} { - set ::punk::last_run_display [list] - variable last_run_display - variable runout - variable runerr - set runout "" - set runerr "" - - set known_runopts [list "-echo" "-e" "-nonewline" "-n"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self - set runopts [list] - set cmdargs [list] - set idx_first_cmdarg [lsearch -not $args "-*"] - set runopts [lrange $args 0 $idx_first_cmdarg-1] - set cmdargs [lrange $args $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "runx: Unknown runoption $o - known options $known_runopts" - } - } - set runopts [lmap o $runopts {dict get $aliases $o}] - if {"-nonewline" in $runopts} { - set nonewline 1 - } else { - set nonewline 0 - } - - - - #shellfilter::stack::remove stdout $::repl::id_outstack - - if {"-echo" in $runopts} { - set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] - set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::shellrun::runout}] - } else { - #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] - #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] - - #float above the repl's tee_to_var to deliberately block it. - #a var transform is naturally a junction point because there is no flow-through.. - # - but mark it with -junction 1 just to be explicit - set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] - set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] - } - - #set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] - set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none] - - shellfilter::stack::remove stdout $stdout_stackid - shellfilter::stack::remove stderr $stderr_stackid - - - flush stderr - flush stdout - - if {[dict exists $exitinfo error]} { - #todo - check errorInfo makes sense.. return -code? tailcall? - error [dict get $exitinfo error] - } - - #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] - set chunklist [list] - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] - - set chunk "" - if {[string length $::shellrun::runout]} { - if {$nonewline} { - set o [string trimright $::shellrun::runout \r\n] - } else { - set o $::shellrun::runout - } - append chunk $o\n - } - lappend chunklist [list stdout $chunk] - - - set chunk "[a+ red bold]stderr[a+]\n" - if {[string length $::shellrun::runerr]} { - if {$nonewline} { - set e [string trimright $::shellrun::runerr \r\n] - } else { - set e $::shellrun::runerr - } - append chunk $e\n - } - lappend chunklist [list stderr $chunk] - - - - set n [a+] - set c "" - if [dict exists $exitinfo exitcode] { - set code [dict get $exitinfo exitcode] - if {$code == 0} { - set c [a+ green] - } else { - set c [a+ white bold] - } - } - lappend chunklist [list stderr "$c$exitinfo$n\n"] - - set ::punk::last_run_display $chunklist - - #set ::repl::result_print 0 - #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] - - - if {$nonewline} { - return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] - } - #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) - return [list {*}$exitinfo stdout $::shellrun::runout stderr $::shellrun::runerr] - } -} +# vim: set ft=tcl +# +package provide shellrun [namespace eval shellrun { + variable version + set version 0.1 +}] +#purpose: handle the run commands that call shellfilter::run +#e.g run,runout,runerr,runx + + + +#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. +# - If it did run, but there was a non-zero exitcode it is up to the application to check that. +#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. +#The user can always use exec for different process error semantics (they don't get exitcode with exec) + +namespace eval shellrun { + variable runout + variable runerr + + + proc run {args} { + set ::punk::last_run_display [list] + #we provide -nonewline for 'run' even though run doesn't deliver stderr or stdout to the tcl return value + #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. + set known_runopts [list "-echo" "-e" "-nonewline" "-n"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self + set runopts [list] + set cmdargs [list] + set idx_first_cmdarg [lsearch -not $args "-*"] + set runopts [lrange $args 0 $idx_first_cmdarg-1] + set cmdargs [lrange $args $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "run: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + set id_err [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] + shellfilter::stack::remove stderr $id_err + + flush stderr + flush stdout + + set c [shellfilter::ansi::+ green] + set n [shellfilter::ansi::+] + if {[dict exists $exitinfo error]} { + error [dict get $exitinfo error] + } + + return $exitinfo + } + + proc runout {args} { + set ::punk::last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set known_runopts [list "-echo" "-e" "-nonewline" "-n"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self + set runopts [list] + set cmdargs [list] + set idx_first_cmdarg [lsearch -not $args "-*"] + set runopts [lrange $args 0 $idx_first_cmdarg-1] + set cmdargs [lrange $args $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "runout: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #puts stdout "RUNOUT cmdargs: $cmdargs" + + #todo add -data boolean and -data lastwrite to -settings with default being -data all + # because sometimes we're only interested in last char (e.g to detect something was output) + + #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] + # + #when not echoing - use float-locked so that the repl's stack is bypassed + if {"-echo" in $runopts} { + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + } else { + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + } + + #shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler + set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] + + flush stderr + flush stdout + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + #shellfilter::stack::remove commandout $outvar_stackid + if {[dict exists $exitinfo error]} { + #we must raise an error. + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + + set chunklist [list] + + set n [a+] + set c "" + if [dict exists $exitinfo exitcode] { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + } else { + set c [a+ Yellow red bold] + } + #exitcode not part of return value for runout - colourcode appropriately + lappend chunklist [list stderr "$c$exitinfo$n\n"] + + + set chunk "[a+ red bold]stderr[a+]\n" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "[a+ red light]$e[a+]\n" + } + lappend chunklist [list stderr $chunk] + + + + + lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "$o\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + set ::punk::last_run_display $chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runout \r\n] + } else { + return $::shellrun::runout + } + } + + proc runerr {args} { + set ::punk::last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + set known_runopts [list "-echo" "-e" "-nonewline" "-n"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self + set runopts [list] + set cmdargs [list] + set idx_first_cmdarg [lsearch -not $args "-*"] + set runopts [lrange $args 0 $idx_first_cmdarg-1] + set cmdargs [lrange $args $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "runerr: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + if {"-echo" in $runopts} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + } else { + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + } + + + set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + shellfilter::stack::remove stderr $stderr_stackid + shellfilter::stack::remove stdout $stdout_stackid + + + flush stderr + flush stdout + + #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch + # to determine something other than just a nonzero exit code or output on stderr. + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + + set chunklist [list] + + set n [a+] + set c "" + if [dict exists $exitinfo exitcode] { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + } else { + set c [a+ Yellow red bold] + } + #exitcode not part of return value for runout - colourcode appropriately + lappend chunklist [list stderr "$c$exitinfo$n\n"] + + + lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "[a+ white light]$o[a+]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + + set chunk "[a+ red bold]stderr[a+]\n" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "$e\n" + } + lappend chunklist [list stderr $chunk] + + + set ::punk::last_run_display $chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runerr \r\n] + } + return $::shellrun::runerr + } + + proc runx {args} { + set ::punk::last_run_display [list] + variable last_run_display + variable runout + variable runerr + set runout "" + set runerr "" + + set known_runopts [list "-echo" "-e" "-nonewline" "-n"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#include map to self + set runopts [list] + set cmdargs [list] + set idx_first_cmdarg [lsearch -not $args "-*"] + set runopts [lrange $args 0 $idx_first_cmdarg-1] + set cmdargs [lrange $args $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "runx: Unknown runoption $o - known options $known_runopts" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + + + #shellfilter::stack::remove stdout $::repl::id_outstack + + if {"-echo" in $runopts} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::shellrun::runout}] + } else { + #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] + #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] + + #float above the repl's tee_to_var to deliberately block it. + #a var transform is naturally a junction point because there is no flow-through.. + # - but mark it with -junction 1 just to be explicit + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] + } + + #set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none] + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] + set chunklist [list] + lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk $o\n + } + lappend chunklist [list stdout $chunk] + + + set chunk "[a+ red bold]stderr[a+]\n" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk $e\n + } + lappend chunklist [list stderr $chunk] + + + + set n [a+] + set c "" + if [dict exists $exitinfo exitcode] { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + } + lappend chunklist [list stderr "$c$exitinfo$n\n"] + + set ::punk::last_run_display $chunklist + + #set ::repl::result_print 0 + #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] + + + if {$nonewline} { + return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] + } + #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) + return [list {*}$exitinfo stdout $::shellrun::runout stderr $::shellrun::runerr] + } +} diff --git a/src/modules/shellthread-1.6.tm b/src/modules/shellthread-1.6.tm index 6c44242f..142742a8 100644 --- a/src/modules/shellthread-1.6.tm +++ b/src/modules/shellthread-1.6.tm @@ -1,595 +1,595 @@ -#package require logger - -package provide shellthread [namespace eval shellthread { - variable version - set version 1.6 -}] - - -package require Thread - -namespace eval shellthread { - - proc iso8601 {{tsmicros ""}} { - if {$tsmicros eq ""} { - set tsmicros [clock micros] - } else { - set microsnow [clock micros] - if {[string length $tsmicros] != [string length $microsnow]} { - error "iso8601 requires 'clock micros' or empty string to create timestamp" - } - } - set seconds [expr {$tsmicros / 1000000}] - return [clock format $seconds -format "%Y-%m-%d_%H-%M-%S"] - } -} - -namespace eval shellthread::worker { - variable settings - variable sysloghost_port - variable sock - variable logfile "" - variable fd - variable client_ids [list] - variable ts_start_micros - variable errorlist [list] - variable inpipe "" - - proc bgerror {args} { - variable errorlist - lappend errorlist $args - } - proc send_errors_now {tidcli} { - variable errorlist - thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] - } - proc add_client_tid {tidcli} { - variable client_ids - if {$tidcli ni $client_ids} { - lappend client_ids $tidcli - } - } - proc init {tidclient start_m settingsdict} { - variable sysloghost_port - variable logfile - variable settings - interp bgerror {} shellthread::worker::bgerror - package require overtype - variable client_ids - variable ts_start_micros - lappend client_ids $tidclient - set ts_start_micros $start_m - - set defaults [list -raw 0 -file "" -syslog "" -direction out] - set settings [dict merge $defaults $settingsdict] - - set syslog [dict get $settings -syslog] - if {[string length $syslog]} { - lassign [split $syslog :] s_host s_port - set sysloghost_port [list $s_host $s_port] - } else { - set sysloghost_port "" - } - if {[catch {package require udp} errm]} { - #disable rather than bomb and interfere with any -file being written - set sysloghost_port "" - } - - set logfile [dict get $settings -file] - } - - proc start_pipe_read {source readchan args} { - #assume 1 inpipe for now - variable inpipe - variable sysloghost_port - variable logfile - set defaults [dict create -buffering \uFFFF ] - set opts [dict merge $defaults $args] - if {[dict exists $opts -readbuffering]} { - set readbuffering [dict get $opts -readbuffering] - } else { - if {[dict get $opts -buffering] eq "\uFFFF"} { - #get buffering setting from the channel as it was set prior to thread::transfer - set readbuffering [chan configure $readchan -buffering] - } else { - set readbuffering [dict get $opts -buffering] - chan configure $readchan -buffering $readbuffering - } - } - if {[dict exists $opts -writebuffering]} { - set writebuffering [dict get $opts -writebuffering] - } else { - if {[dict get $opts -buffering] eq "\uFFFF"} { - set writebuffering line - #set writebuffering [chan configure $writechan -buffering] - } else { - set writebuffering [dict get $opts -buffering] - #can configure $writechan -buffering $writebuffering - } - } - - chan configure $readchan -translation lf - - if {$readchan ni [chan names]} { - error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" - } - set inpipe $readchan - #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO\n" line - chan configure $readchan -blocking 0 - #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO2 readbuffering: $readbuffering syslog $sysloghost_port filename $logfile" line - - set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) - chan event $readchan readable [list apply {{chan source waitfor readbuffering writebuffering} { - if {$readbuffering eq "line"} { - set chunksize [chan gets $chan chunk] - if {$chunksize >= 0} { - if {![chan eof $chan]} { - ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering - } else { - ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering - } - } - } else { - set chunk [chan read $chan] - ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering - } - if {[chan eof $chan]} { - chan event $chan readable {} - set $waitfor "pipe" - chan close $chan - } - }} $readchan $source $waitvar $readbuffering $writebuffering] - #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO3 vwaiting on $waitvar\n" line - vwait $waitvar - } - - proc start_pipe_write {source writechan args} { - variable outpipe - set defaults [dict create -buffering \uFFFF ] - set opts [dict merge $defaults $args] - - #todo! - set readchan stdin - - if {[dict exists $opts -readbuffering]} { - set readbuffering [dict get $opts -readbuffering] - } else { - if {[dict get $opts -buffering] eq "\uFFFF"} { - set readbuffering [chan configure $readchan -buffering] - } else { - set readbuffering [dict get $opts -buffering] - chan configure $readchan -buffering $readbuffering - } - } - if {[dict exists $opts -writebuffering]} { - set writebuffering [dict get $opts -writebuffering] - } else { - if {[dict get $opts -buffering] eq "\uFFFF"} { - #nothing explicitly set - take from transferred channel - set writebuffering [chan configure $writechan -buffering] - } else { - set writebuffering [dict get $opts -buffering] - can configure $writechan -buffering $writebuffering - } - } - - if {$writechan ni [chan names]} { - error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" - } - set outpipe $writechan - chan configure $readchan -blocking 0 - chan configure $writechan -blocking 0 - set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) - - chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { - if {$readbuffering eq "line"} { - set chunksize [chan gets $chan chunk] - if {$chunksize >= 0} { - if {![chan eof $chan]} { - puts $writechan $chunk - } else { - puts -nonewline $writechan $chunk - } - } - } else { - set chunk [chan read $chan] - puts -nonewline $writechan $chunk - } - if {[chan eof $chan]} { - chan event $chan readable {} - set $waitfor "pipe" - chan close $writechan - if {$chan ne "stdin"} { - chan close $chan - } - } - }} $readchan $writechan $source $waitvar $readbuffering] - - vwait $waitvar - } - - - proc _initsock {} { - variable sysloghost_port - variable sock - if {[string length $sysloghost_port]} { - if {[catch {fconfigure $sock} state]} { - set sock [udp_open] - fconfigure $sock -buffering none -translation binary - fconfigure $sock -remote $sysloghost_port - } - } - } - proc _reconnect {} { - variable sock - catch {close $sock} - _initsock - return [fconfigure $sock] - } - - proc send_info {client_tid ts_sent source msg} { - set ts_received [clock micros] - set lag_micros [expr {$ts_received - $ts_sent}] - set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds - - log $client_tid $ts_sent $lag $source - info $msg line 1 - } - proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { - variable sock - variable fd - variable sysloghost_port - variable logfile - variable settings - - set logchunk $msg - - if {![dict get $settings -raw]} { - set tail_crlf 0 - set tail_lf 0 - set tail_cr 0 - #for cooked - always remove the trailing newline before splitting.. - # - #note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. - # - #Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split - #but add it back exactly as it was afterwards - #we can always split on \n - and any adjacent \r will be preserved in the rejoin - set lastchar [string range $logchunk end end] - if {[string range $logchunk end-1 end] eq "\r\n"} { - set tail_crlf 1 - set logchunk [string range $logchunk 0 end-2] - } else { - if {$lastchar eq "\n"} { - set tail_lf 1 - set logchunk [string range $logchunk 0 end-1] - } elseif {$lastchar eq "\r"} { - #\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. - set tail_cr 1 - set logchunk [string range $logchunk 0 end-1] - } else { - #possibly a single line with no linefeed.. or has linefeeds only in the middle - } - } - - if {$ts_sent != 0} { - set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] - set time_info [::shellthread::iso8601 $ts_sent].$micros - #set time_info "${time_info}+$lag" - set lagfp "+[format %f $lag]" - } else { - #from pipe - no ts_sent/lag info available - set time_info "" - set lagfp "" - } - - set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway - set col0 [string repeat " " 9] - set col1 [string repeat " " 27] - set col2 [string repeat " " 11] - set col3 [string repeat " " 20] - #do not columnize the final data column or append to tail - or we could muck up the crlf integrity - - lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 - - #split on \n no matter the actual line-ending in use - #shouldn't matter as long as we don't add anything at the end of the line other than the raw data - #ie - don't quote or add spaces - set lines [split $logchunk \n] - - set i 1 - set outlines [list] - foreach ln $lines { - if {$i == 1} { - lappend outlines "$c0 $c1 $c2 $c3 $ln" - } else { - lappend outlines "$c0 $c1 $col2 $c3 $ln" - } - incr i - } - if {$tail_lf} { - set logchunk "[join $outlines \n]\n" - } elseif {$tail_crlf} { - set logchunk "[join $outlines \r\n]\r\n" - } elseif {$tail_cr} { - set logchunk "[join $outlines \r]\r" - } else { - #no trailing linefeed - set logchunk [join $outlines \n] - - } - - #set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" - } - - if {[string length $sysloghost_port]} { - _initsock - catch {puts -nonewline $sock $logchunk} - } - #todo - sockets etc? - if {[string length $logfile]} { - #todo - setting to maintain open filehandle and reduce io. - # possible settings for buffersize - and maybe logrotation, although this could be left to client - #for now - default to safe option of open/close each write despite the overhead. - set fd [open $logfile a] - chan configure $fd -translation auto -buffering $writebuffering - #whether line buffered or not - by now our logchunk includes newlines - puts -nonewline $fd $logchunk - close $fd - } - } - - # - withdraw just this client - proc finish {tidclient} { - variable client_ids - if {($tidclient in $clientids) && ([llength $clientids] == 1)} { - terminate $tidclient - } else { - set posn [lsearch $client_ids $tidclient] - set client_ids [lreplace $clientids $posn $posn] - } - } - - #allow any client to terminate - proc terminate {tidclient} { - variable sock - variable client_ids - if {$tidclient in $client_ids} { - catch {close $sock} - set client_ids [list] - return 1 - } else { - return 0 - } - } - - -} - - -namespace eval shellthread::manager { - variable workers [dict create] - variable worker_errors [list] - - variable log_threads - - #new datastructure regarding workers and sourcetags required. - #one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. - #generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. - # - #As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins - #If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. - #If another thread want's to maintain joinability beyond the span provided by the starting client, - #it can join with both the primary tag and a tag it will actually use for logging. - #A thread can join the logger with any existingtag - not just the 'primary' - #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) - proc join_worker {client_tid existingtag sourcetaglist} { - #todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker - } - proc leave_worker {client_tid sourcetaglist} { - #todo - #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, - #if no more sourcetags - close worker - } - #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) - # This allows multiple threads to more easily write to the same named sourcetag if necessary - # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file - # - # todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. - # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target - # On the other hand socket targets such as UDP can happily be written to by multiple threads. - # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. - # but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. - # Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker - # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' - # probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. - proc new_worker {sourcetaglist {settingsdict {}}} { - variable workers - set ts_start [clock micros] - set tidclient [thread::id] - set sourcetag [lindex $sourcetaglist 0] ;#todo - use all - - if {[dict exists $workers $sourcetag]} { - set winfo [dict get $workers $sourcetag] - if {[thread::exists [dict get $winfo tid]]} { - #add our client-info to existing worker thread - dict lappend winfo list_client_tids $tidclient - dict set workers $sourcetag $winfo ;#writeback - return [dict get $winfo tid] - } - } - #set ts_start [::shellthread::iso8601] - set tidworker [thread::create -preserved] - set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { - #set tclbase [file dirname [file dirname [info nameofexecutable]]] - #set tcllib $tclbase/lib - #if {$tcllib ni $::auto_path} { - # lappend ::auto_path $tcllib - #} - - set ::settingsinfo [dict create %sd%] - #if the executable running things is something like a tclkit, - # then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things - #The caller can tune the thread's package search by providing a settingsdict - if {![dict exists $::settingsinfo tcl_tm_list]} { - tcl::tm::add %mp% - } else { - tcl::tm::remove {*}[tcl::tm::list] - tcl::tm::add {*}[dict get $::settingsinfo tcl_tm_list] - } - if {![dict exists $::settingsinfo auto_path]} { - set ::auto_path [list %ap%] - } else { - set ::auto_path [dict get $::settingsinfo auto_path] - } - - package require Thread - package require shellthread - if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { - unset ::settingsinfo - set ::shellthread_init "ok" - } else { - unset ::settingsinfo - set ::shellthread_init "err $errmsg" - } - }] - - thread::send -async $tidworker $init_script - #thread::send $tidworker $init_script - set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] - dict set workers $sourcetag $winfo - return $tidworker - } - - proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { - variable workers - if {![dict exists $workers $tag_pipename]} { - error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" - } - set match_worker_tid [dict get $workers $tag_pipename tid] - if {$worker_tid ne $match_worker_tid} { - error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" - } - #buffering set during channel creation will be preserved on thread::transfer - thread::transfer $worker_tid $rchan - #start_pipe_read will vwait - so we have to send async - thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] - #client may start writing immediately - but presumably it will buffer in fifo2 - } - - proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { - variable workers - if {![dict exists $workers $tag_pipename]} { - error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" - } - set match_worker_tid [dict get $workers $tag_pipename tid] - if {$worker_tid ne $match_worker_tid} { - error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" - } - #buffering set during channel creation will be preserved on thread::transfer - thread::transfer $worker_tid $wchan - thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] - } - - proc write_log {source msg args} { - variable workers - set ts_micros_sent [clock micros] - set defaults [list -async 1 -level info] - set opts [dict merge $defaults $args] - - if {[dict exists $workers $source]} { - set tidworker [dict get $workers $source tid] - if {![thread::exists $tidworker]} { - set tidworker [new_worker $source] - } - } else { - #auto create with no requirement to call new_worker.. warn? - set tidworker [new_worker $source] - } - set client_tid [thread::id] - if {[dict get $opts -async]} { - thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] - } else { - thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] - } - } - proc report_worker_errors {errdict} { - variable workers - set reporting_tid [dict get $errdict worker_tid] - dict for {src srcinfo} $workers { - if {[dict get $srcinfo tid] eq $reporting_tid} { - dict set srcinfo errors [dict get $errdict errors] - dict set workers $src $srcinfo ;#writeback updated - break - } - } - } - proc close_worker {source {timeout 2500}} { - variable workers - variable worker_errors - set ts_now [clock micros] - #puts stderr "close_worker $source" - if {[dict exists $workers $source]} { - set tidworker [dict get $workers $source tid] - set ts_end_list [dict get $workers $source ts_end_list] - if {[llength $ts_end_list]} { - set last_end_ts [lindex $ts_end_list end] - if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { - lappend ts_end_list $ts_now - dict set workers $source ts_end_list $ts_end_list - } else { - #existing close in progress.. assume it will work - return - } - } - - if {[thread::exists $tidworker]} { - #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" - set timeoutarr($source) 0 - after $timeout [list set timeoutarr($source) 2] - - thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] - thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) - - #thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { - # shellthread::worker::terminate %tidclient% - #}] timeoutarr($source) - - vwait timeoutarr($source) - #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" - - thread::release $tidworker - #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" - if {[dict exists $workers $source errors]} { - set errlist [dict get $workers $source errors] - if {[llength $errlist]} { - lappend worker_errors [list $source [dict get $workers $source]] - } - } - dict unset workers $source - } - } - #puts stdout "close_worker $source - end" - } - - #worker errors only available for a source after close_worker called on that source - #It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, - # e.g if a thread - proc get_and_clear_errors {source} { - variable worker_errors - set source_errors [lsearch -all -inline -index 0 $worker_errors $source] - set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] - return $source_errors - } - - -} - - - - - - - - - - +#package require logger + +package provide shellthread [namespace eval shellthread { + variable version + set version 1.6 +}] + + +package require Thread + +namespace eval shellthread { + + proc iso8601 {{tsmicros ""}} { + if {$tsmicros eq ""} { + set tsmicros [clock micros] + } else { + set microsnow [clock micros] + if {[string length $tsmicros] != [string length $microsnow]} { + error "iso8601 requires 'clock micros' or empty string to create timestamp" + } + } + set seconds [expr {$tsmicros / 1000000}] + return [clock format $seconds -format "%Y-%m-%d_%H-%M-%S"] + } +} + +namespace eval shellthread::worker { + variable settings + variable sysloghost_port + variable sock + variable logfile "" + variable fd + variable client_ids [list] + variable ts_start_micros + variable errorlist [list] + variable inpipe "" + + proc bgerror {args} { + variable errorlist + lappend errorlist $args + } + proc send_errors_now {tidcli} { + variable errorlist + thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] + } + proc add_client_tid {tidcli} { + variable client_ids + if {$tidcli ni $client_ids} { + lappend client_ids $tidcli + } + } + proc init {tidclient start_m settingsdict} { + variable sysloghost_port + variable logfile + variable settings + interp bgerror {} shellthread::worker::bgerror + package require overtype + variable client_ids + variable ts_start_micros + lappend client_ids $tidclient + set ts_start_micros $start_m + + set defaults [list -raw 0 -file "" -syslog "" -direction out] + set settings [dict merge $defaults $settingsdict] + + set syslog [dict get $settings -syslog] + if {[string length $syslog]} { + lassign [split $syslog :] s_host s_port + set sysloghost_port [list $s_host $s_port] + } else { + set sysloghost_port "" + } + if {[catch {package require udp} errm]} { + #disable rather than bomb and interfere with any -file being written + set sysloghost_port "" + } + + set logfile [dict get $settings -file] + } + + proc start_pipe_read {source readchan args} { + #assume 1 inpipe for now + variable inpipe + variable sysloghost_port + variable logfile + set defaults [dict create -buffering \uFFFF ] + set opts [dict merge $defaults $args] + if {[dict exists $opts -readbuffering]} { + set readbuffering [dict get $opts -readbuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + #get buffering setting from the channel as it was set prior to thread::transfer + set readbuffering [chan configure $readchan -buffering] + } else { + set readbuffering [dict get $opts -buffering] + chan configure $readchan -buffering $readbuffering + } + } + if {[dict exists $opts -writebuffering]} { + set writebuffering [dict get $opts -writebuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + set writebuffering line + #set writebuffering [chan configure $writechan -buffering] + } else { + set writebuffering [dict get $opts -buffering] + #can configure $writechan -buffering $writebuffering + } + } + + chan configure $readchan -translation lf + + if {$readchan ni [chan names]} { + error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" + } + set inpipe $readchan + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO\n" line + chan configure $readchan -blocking 0 + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO2 readbuffering: $readbuffering syslog $sysloghost_port filename $logfile" line + + set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) + chan event $readchan readable [list apply {{chan source waitfor readbuffering writebuffering} { + if {$readbuffering eq "line"} { + set chunksize [chan gets $chan chunk] + if {$chunksize >= 0} { + if {![chan eof $chan]} { + ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering + } else { + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + } + } + } else { + set chunk [chan read $chan] + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + } + if {[chan eof $chan]} { + chan event $chan readable {} + set $waitfor "pipe" + chan close $chan + } + }} $readchan $source $waitvar $readbuffering $writebuffering] + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO3 vwaiting on $waitvar\n" line + vwait $waitvar + } + + proc start_pipe_write {source writechan args} { + variable outpipe + set defaults [dict create -buffering \uFFFF ] + set opts [dict merge $defaults $args] + + #todo! + set readchan stdin + + if {[dict exists $opts -readbuffering]} { + set readbuffering [dict get $opts -readbuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + set readbuffering [chan configure $readchan -buffering] + } else { + set readbuffering [dict get $opts -buffering] + chan configure $readchan -buffering $readbuffering + } + } + if {[dict exists $opts -writebuffering]} { + set writebuffering [dict get $opts -writebuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + #nothing explicitly set - take from transferred channel + set writebuffering [chan configure $writechan -buffering] + } else { + set writebuffering [dict get $opts -buffering] + can configure $writechan -buffering $writebuffering + } + } + + if {$writechan ni [chan names]} { + error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" + } + set outpipe $writechan + chan configure $readchan -blocking 0 + chan configure $writechan -blocking 0 + set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) + + chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { + if {$readbuffering eq "line"} { + set chunksize [chan gets $chan chunk] + if {$chunksize >= 0} { + if {![chan eof $chan]} { + puts $writechan $chunk + } else { + puts -nonewline $writechan $chunk + } + } + } else { + set chunk [chan read $chan] + puts -nonewline $writechan $chunk + } + if {[chan eof $chan]} { + chan event $chan readable {} + set $waitfor "pipe" + chan close $writechan + if {$chan ne "stdin"} { + chan close $chan + } + } + }} $readchan $writechan $source $waitvar $readbuffering] + + vwait $waitvar + } + + + proc _initsock {} { + variable sysloghost_port + variable sock + if {[string length $sysloghost_port]} { + if {[catch {fconfigure $sock} state]} { + set sock [udp_open] + fconfigure $sock -buffering none -translation binary + fconfigure $sock -remote $sysloghost_port + } + } + } + proc _reconnect {} { + variable sock + catch {close $sock} + _initsock + return [fconfigure $sock] + } + + proc send_info {client_tid ts_sent source msg} { + set ts_received [clock micros] + set lag_micros [expr {$ts_received - $ts_sent}] + set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds + + log $client_tid $ts_sent $lag $source - info $msg line 1 + } + proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { + variable sock + variable fd + variable sysloghost_port + variable logfile + variable settings + + set logchunk $msg + + if {![dict get $settings -raw]} { + set tail_crlf 0 + set tail_lf 0 + set tail_cr 0 + #for cooked - always remove the trailing newline before splitting.. + # + #note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. + # + #Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split + #but add it back exactly as it was afterwards + #we can always split on \n - and any adjacent \r will be preserved in the rejoin + set lastchar [string range $logchunk end end] + if {[string range $logchunk end-1 end] eq "\r\n"} { + set tail_crlf 1 + set logchunk [string range $logchunk 0 end-2] + } else { + if {$lastchar eq "\n"} { + set tail_lf 1 + set logchunk [string range $logchunk 0 end-1] + } elseif {$lastchar eq "\r"} { + #\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. + set tail_cr 1 + set logchunk [string range $logchunk 0 end-1] + } else { + #possibly a single line with no linefeed.. or has linefeeds only in the middle + } + } + + if {$ts_sent != 0} { + set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] + set time_info [::shellthread::iso8601 $ts_sent].$micros + #set time_info "${time_info}+$lag" + set lagfp "+[format %f $lag]" + } else { + #from pipe - no ts_sent/lag info available + set time_info "" + set lagfp "" + } + + set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway + set col0 [string repeat " " 9] + set col1 [string repeat " " 27] + set col2 [string repeat " " 11] + set col3 [string repeat " " 20] + #do not columnize the final data column or append to tail - or we could muck up the crlf integrity + + lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 + + #split on \n no matter the actual line-ending in use + #shouldn't matter as long as we don't add anything at the end of the line other than the raw data + #ie - don't quote or add spaces + set lines [split $logchunk \n] + + set i 1 + set outlines [list] + foreach ln $lines { + if {$i == 1} { + lappend outlines "$c0 $c1 $c2 $c3 $ln" + } else { + lappend outlines "$c0 $c1 $col2 $c3 $ln" + } + incr i + } + if {$tail_lf} { + set logchunk "[join $outlines \n]\n" + } elseif {$tail_crlf} { + set logchunk "[join $outlines \r\n]\r\n" + } elseif {$tail_cr} { + set logchunk "[join $outlines \r]\r" + } else { + #no trailing linefeed + set logchunk [join $outlines \n] + + } + + #set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" + } + + if {[string length $sysloghost_port]} { + _initsock + catch {puts -nonewline $sock $logchunk} + } + #todo - sockets etc? + if {[string length $logfile]} { + #todo - setting to maintain open filehandle and reduce io. + # possible settings for buffersize - and maybe logrotation, although this could be left to client + #for now - default to safe option of open/close each write despite the overhead. + set fd [open $logfile a] + chan configure $fd -translation auto -buffering $writebuffering + #whether line buffered or not - by now our logchunk includes newlines + puts -nonewline $fd $logchunk + close $fd + } + } + + # - withdraw just this client + proc finish {tidclient} { + variable client_ids + if {($tidclient in $clientids) && ([llength $clientids] == 1)} { + terminate $tidclient + } else { + set posn [lsearch $client_ids $tidclient] + set client_ids [lreplace $clientids $posn $posn] + } + } + + #allow any client to terminate + proc terminate {tidclient} { + variable sock + variable client_ids + if {$tidclient in $client_ids} { + catch {close $sock} + set client_ids [list] + return 1 + } else { + return 0 + } + } + + +} + + +namespace eval shellthread::manager { + variable workers [dict create] + variable worker_errors [list] + + variable log_threads + + #new datastructure regarding workers and sourcetags required. + #one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. + #generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. + # + #As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins + #If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. + #If another thread want's to maintain joinability beyond the span provided by the starting client, + #it can join with both the primary tag and a tag it will actually use for logging. + #A thread can join the logger with any existingtag - not just the 'primary' + #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) + proc join_worker {client_tid existingtag sourcetaglist} { + #todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker + } + proc leave_worker {client_tid sourcetaglist} { + #todo + #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, + #if no more sourcetags - close worker + } + #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) + # This allows multiple threads to more easily write to the same named sourcetag if necessary + # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file + # + # todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. + # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target + # On the other hand socket targets such as UDP can happily be written to by multiple threads. + # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. + # but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. + # Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker + # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' + # probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. + proc new_worker {sourcetaglist {settingsdict {}}} { + variable workers + set ts_start [clock micros] + set tidclient [thread::id] + set sourcetag [lindex $sourcetaglist 0] ;#todo - use all + + if {[dict exists $workers $sourcetag]} { + set winfo [dict get $workers $sourcetag] + if {[thread::exists [dict get $winfo tid]]} { + #add our client-info to existing worker thread + dict lappend winfo list_client_tids $tidclient + dict set workers $sourcetag $winfo ;#writeback + return [dict get $winfo tid] + } + } + #set ts_start [::shellthread::iso8601] + set tidworker [thread::create -preserved] + set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { + #set tclbase [file dirname [file dirname [info nameofexecutable]]] + #set tcllib $tclbase/lib + #if {$tcllib ni $::auto_path} { + # lappend ::auto_path $tcllib + #} + + set ::settingsinfo [dict create %sd%] + #if the executable running things is something like a tclkit, + # then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things + #The caller can tune the thread's package search by providing a settingsdict + if {![dict exists $::settingsinfo tcl_tm_list]} { + tcl::tm::add %mp% + } else { + tcl::tm::remove {*}[tcl::tm::list] + tcl::tm::add {*}[dict get $::settingsinfo tcl_tm_list] + } + if {![dict exists $::settingsinfo auto_path]} { + set ::auto_path [list %ap%] + } else { + set ::auto_path [dict get $::settingsinfo auto_path] + } + + package require Thread + package require shellthread + if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { + unset ::settingsinfo + set ::shellthread_init "ok" + } else { + unset ::settingsinfo + set ::shellthread_init "err $errmsg" + } + }] + + thread::send -async $tidworker $init_script + #thread::send $tidworker $init_script + set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] + dict set workers $sourcetag $winfo + return $tidworker + } + + proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { + variable workers + if {![dict exists $workers $tag_pipename]} { + error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" + } + set match_worker_tid [dict get $workers $tag_pipename tid] + if {$worker_tid ne $match_worker_tid} { + error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" + } + #buffering set during channel creation will be preserved on thread::transfer + thread::transfer $worker_tid $rchan + #start_pipe_read will vwait - so we have to send async + thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] + #client may start writing immediately - but presumably it will buffer in fifo2 + } + + proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { + variable workers + if {![dict exists $workers $tag_pipename]} { + error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" + } + set match_worker_tid [dict get $workers $tag_pipename tid] + if {$worker_tid ne $match_worker_tid} { + error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" + } + #buffering set during channel creation will be preserved on thread::transfer + thread::transfer $worker_tid $wchan + thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] + } + + proc write_log {source msg args} { + variable workers + set ts_micros_sent [clock micros] + set defaults [list -async 1 -level info] + set opts [dict merge $defaults $args] + + if {[dict exists $workers $source]} { + set tidworker [dict get $workers $source tid] + if {![thread::exists $tidworker]} { + set tidworker [new_worker $source] + } + } else { + #auto create with no requirement to call new_worker.. warn? + set tidworker [new_worker $source] + } + set client_tid [thread::id] + if {[dict get $opts -async]} { + thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] + } else { + thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] + } + } + proc report_worker_errors {errdict} { + variable workers + set reporting_tid [dict get $errdict worker_tid] + dict for {src srcinfo} $workers { + if {[dict get $srcinfo tid] eq $reporting_tid} { + dict set srcinfo errors [dict get $errdict errors] + dict set workers $src $srcinfo ;#writeback updated + break + } + } + } + proc close_worker {source {timeout 2500}} { + variable workers + variable worker_errors + set ts_now [clock micros] + #puts stderr "close_worker $source" + if {[dict exists $workers $source]} { + set tidworker [dict get $workers $source tid] + set ts_end_list [dict get $workers $source ts_end_list] + if {[llength $ts_end_list]} { + set last_end_ts [lindex $ts_end_list end] + if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { + lappend ts_end_list $ts_now + dict set workers $source ts_end_list $ts_end_list + } else { + #existing close in progress.. assume it will work + return + } + } + + if {[thread::exists $tidworker]} { + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" + set timeoutarr($source) 0 + after $timeout [list set timeoutarr($source) 2] + + thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] + thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) + + #thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { + # shellthread::worker::terminate %tidclient% + #}] timeoutarr($source) + + vwait timeoutarr($source) + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" + + thread::release $tidworker + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" + if {[dict exists $workers $source errors]} { + set errlist [dict get $workers $source errors] + if {[llength $errlist]} { + lappend worker_errors [list $source [dict get $workers $source]] + } + } + dict unset workers $source + } + } + #puts stdout "close_worker $source - end" + } + + #worker errors only available for a source after close_worker called on that source + #It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, + # e.g if a thread + proc get_and_clear_errors {source} { + variable worker_errors + set source_errors [lsearch -all -inline -index 0 $worker_errors $source] + set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] + return $source_errors + } + + +} + + + + + + + + + +