From 9e20b9d43778f786c470dfcd662819ec79334719 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 10 Sep 2025 14:58:48 +1000 Subject: [PATCH] update multishell wrapper and punk::mix::commandset::scriptwrap to support longer nextshellpath + more shell capability --- src/bootsupport/modules/flagfilter-0.3.1.tm | 2718 +++++++++++++++++ src/bootsupport/modules/punk/char-0.1.0.tm | 5 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 16 +- src/bootsupport/modules/punk/repl-0.1.2.tm | 2 + src/bootsupport/modules/punk/zip-0.1.1.tm | 44 +- src/bootsupport/modules/shellrun-0.1.1.tm | 2 +- .../mix/commandset/scriptwrap-999999.0a1.0.tm | 16 +- .../utility/scriptappwrappers/multishell.cmd | 546 +++- .../bootsupport/modules/flagfilter-0.3.1.tm | 2718 +++++++++++++++++ .../bootsupport/modules/punk/char-0.1.0.tm | 5 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 16 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 2 + .../src/bootsupport/modules/punk/zip-0.1.1.tm | 44 +- .../src/bootsupport/modules/shellrun-0.1.1.tm | 2 +- .../bootsupport/modules/flagfilter-0.3.1.tm | 2718 +++++++++++++++++ .../bootsupport/modules/punk/char-0.1.0.tm | 5 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 16 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 2 + .../src/bootsupport/modules/punk/zip-0.1.1.tm | 44 +- .../src/bootsupport/modules/shellrun-0.1.1.tm | 2 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 16 +- .../utility/scriptappwrappers/multishell.cmd | 544 +++- 22 files changed, 9151 insertions(+), 332 deletions(-) create mode 100644 src/bootsupport/modules/flagfilter-0.3.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm diff --git a/src/bootsupport/modules/flagfilter-0.3.1.tm b/src/bootsupport/modules/flagfilter-0.3.1.tm new file mode 100644 index 00000000..474ae8d3 --- /dev/null +++ b/src/bootsupport/modules/flagfilter-0.3.1.tm @@ -0,0 +1,2718 @@ + +#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 {[dict exists $solodict $a]} { + set last_was_flag 0 + if {[dict exists $solo_accumulator $a]} { + set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] + } else { + set soloval [dict get $solodict $a] + } + dict set solo_accumulator $a $soloval + #we need to keep order of first appearance + set idx [lsearch $result $a] + if {$idx < 0} { + lappend result $a $soloval + } else { + lset result $idx+1 $soloval + } + } else { + if {!$last_was_flag} { + if {$a eq "--"} { + + } else { + if {[lindex $arglist $a_idx-1] eq "--"} { + #end of options processing - none of the remaining are considered flags/options no matter what they look like + set last_was_flag 0 + break + } else { + if {[string match -* $a]} { + set last_was_flag 1 + lappend result $a ;#flag + } else { + #last wasnt, this isn't - don't output + set last_was_flag 0 + } + } + } + } else { + #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. + if {$a eq "--"} { + #last was flag + set last_was_flag 0 + } else { + lappend result $a ;#value + set last_was_flag 0 + } + } + } + incr a_idx + } + if {([llength $result] % 2) != 0} { + set last [lindex $result end] + if {[string match -* $last] && ($last ni [dict keys $solodict])} { + lappend result 1 + } + } + #puts ">>>get_flagged_only returning $result" + return $result + } + + + ## get_one_paired_flag_value + #best called with 'catch' unless flag known to be in arglist + #raises an error if no position available after the flag to retrieve value + #raises an error if flag not like -something + #raises an error if flag not found in list + proc get_one_paired_flag_value {arglist flag} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { + #regexp excludes plain - and -- + #if {![string match -* $flag]} {} + error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" + } + set cindex [lsearch $arglist $flag] + if {$cindex >= 0} { + set valueindex [expr {$cindex + 1}] + if {$valueindex < [llength $arglist]} { + #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" + return [lindex $arglist $valueindex] + } else { + error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" + } + } else { + error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" + } + } +} + +namespace eval flagfilter::obj { + +} + + +namespace eval flagfilter { + variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. + #used as a basis for some object-instance names etc + proc get_new_runid {} { + variable run_counter + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" + } + + namespace export check_flags + proc do_debug {lvl debugconfig msg} { + if {$lvl <= [dict get $debugconfig -debugargs]} { + foreach ln [split $msg \n] { + puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" + flush stderr + } + } + } + + #---------------------------------------------------------------------- + # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed + #wiki.tcl-lang.org/page/dict+tips+and+tricks + proc isdict {v} { + if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { + return [expr {!([llength $v] % 2)}] + } else { + return [string match "value is a dict *" [::tcl::unsupported::representation $v]] + } + } + + proc dict_format {dict} { + dictformat_rec $dict "" " " + } + proc dictformat_rec {dict indent indentstring} { + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } + return $result + } + #-------------------------------------------------------------------------- + + #solo 'category' includes longopts with value + #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) + proc is_this_flag_solo {f solos objp} { + if {![string match -* $f]} { + #not even flaglike + return 0 + } + + + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } + + set p_opts [$objp get_combined_opts] + + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] + + if {$f in $singleopts} { + return 1 + } + + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } + + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # + + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + return $is_solo + } + #todo? support global (non-processor specific) mash list? -mashflags ? + proc is_this_flag_mash {f objp} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { + #not even flaglike + return 0 + } + set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc + + #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash + set singleopts pdict get $optinfo singleopts] + if {$f in $singleopts} { + return 0 + } + + set pairopts [dict get $optinfo pairopts] + if {$f in [dict keys $pairopts]} { + #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) + return 0 + } + set mashopts [dict get $optinfo mashopts] + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value + # .. in which case value could be at the tail of the mash.. or be the next arg in the list + # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value + # (ie such a mashopt is a solo that can take a value only as a mashtail) + # presence in pairopts indicates a mashflag must have a value + # presense in singleopts indicates mashflag takes no value ever. + # mashopt cannot be in both singleopts and pairopts. (NAND) + foreach l $flagletters { + if {-$l in $pairopts} { + if {"-$l" in $mashopts} { + #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. + # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt + break + } else { + #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash + set is_mash 0 + } + } elseif {"-$l" in $singleopts} { + #singleopt & mashopt - cannot take a value, mashed or otherwise + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } else { + if {"-$l" ni $mashopts} { + set is_mash 0 + } else { + #present only in mashopts - can take a value, but only immediately following in the mash + break + } + } + } + return $is_mash + } + proc is_this_flag_for_me {f objp cf_args} { + set processorname [$objp name] + set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc + + if {$processorname in [list "tail_processor"]} { + return 1 + } + if {$processorname in [list "global"]} { + #todo - mashflags for global? + set defaults [dict get $cf_args -defaults] + set extras [dict get $cf_args -extras] + set soloflags [dict get $cf_args -soloflags] + if {$f in [concat $extras $soloflags [dict keys $defaults]]} { + return 1 + } + } + + set singleopts [dict get $optinfo singleopts] + if {"any" in [string tolower $singleopts]} { + #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? + return 1 + } + set pairopts [dict get $optinfo pairopts] + set allopts [concat $singleopts [dict keys $pairopts]] + if {$f in $allopts} { + return 1 + } + + #process mashopts last + set mashopts [dict get $optinfo mashopts] + if {"any" in [string tolower $mashopts]} { + #if 'all' in mashopts - it can eat anything - review - is this even useful? + return 1 + } else { + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash + foreach l $flagletters { + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } + return $is_mash + } + + return 0 + } + + + + proc add_dispatch_raw {recordvar parentname v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo + } + } + proc add_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo + } + } + proc lsearch-all-stride-2 {l search} { + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] + } + proc update_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo + } + } + + #Note the difference between this and is_command_match. + #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters + #Note that this isn't a general test to be applied to the entire argument list. + # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor + # so this test only applies during the ordered examination of args + proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { + set cmdinfo [lindex $cspec 1] + if {$cmdinfo eq "tail_processor"} { + return 1 + } + if {$cmdinfo eq "global"} { + set defaults [dict get $cf_args -defaults] + set soloflags [dict get $cf_args -soloflags] + set extras [dict get $cf_args -extras] + if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { + return 1 + } + } + if {![dict exists $cmdinfo match]} { + return 1 + } + set matchspeclist [dict get $cmdinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + #only block it if there was a match pattern specified but it didn't match + return 0 + } + #Note - returns false for a cspec that has no match specified. + #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this + # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. + proc is_command_match {flag cspec} { + set pinfo [lindex $cspec 1] + if {[dict exists $pinfo match]} { + set matchspeclist [dict get $pinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + proc is_command_match_any {f commandprocessors} { + foreach comspec $commandprocessors { + lassign $comspec cmdname cmdinfo + if {[dict exists $cmdinfo match]} { + set matchlist [dict get $cmdinfo match] + foreach matchspec $matchlist { + if {[regexp -- $matchspec $f]} { + #actually a command + return true + } + } + } + } + return false + } + + #determine if f is potentially a flag that takes a parameter from the next argument. + #e.g --x=y (longopt) does not consume following arg but --something *might* + proc is_candidate_toplevel_param_flag {f solos commandprocessors} { + if {[is_command_match_any $f $commandprocessors]} { + return false + } + if {$f in $solos} { + return 0 + } + if {$f in {- --}} { + return 0 + } + #longopts (--x=blah) and alternative --x blah + #possibly also -x=blah + if {[string match -* $f]} { + if {[string first "=" $f]>1} { + return 0 + } + } + return [expr {[string match -* $f]}] + } + + + + + + + + + + + + + + + + + + + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? + #todo - show caller info + proc assert_equal {a b} { + if {![expr {$a eq $b}]} { + error "assert_equal $a $b" + } + } + + + + + + #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map + #1 2 3 4 5 6 ;#original list posns example + # 2 6 ;#map_remaining example (scanlist) + #1 3 4 5 ;#map_allocated example + #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example + oo::class create class_vmap { + variable o_map + variable o_remaining + variable o_allocated + variable o_values + variable o_codemap + variable o_flagcategory + constructor {values} { + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ + ] + set o_flagcategory [list "flag" "flagvalue" "soloflag"] + set o_values $values + #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 + #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ + if {[llength $values]} { + if {[llength $values] < 30} { + #common case is short lists - but we don't want to penalize large lists + set o_remaining [lsearch -all $values *] + } else { + #punk::lib::range wraps lseq if available + set o_remaining [punk::lib::range 0 [llength $values]-1] + } + } else { + set o_remaining [list] + } + set o_allocated [list] + set o_map [list] + foreach posn $o_remaining { + 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]} { + switch -- $type { + flag - flagvalue - soloflag {} + default { + 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]} { + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } + } + } + } + return $list_flagged + } + + method get_merged_flagged_by_class {classmatch} { + variable flagcategory + set all_flagged [list] + set seenflag [dict create] ;#key = -flagname val=earliest vindex + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + set a [llength $all_flagged] ;#index into all_flagged list we are building + switch -- $type { + soloflag { + if {[dict exists $seenflag $val]} { + set seenindex [dict get $seenflag $val] + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? + lset all_flagged $seenindexplus $existingvals + } else { + dict set seenflag $val $a + lappend all_flagged $val 1 + } + } + flag { + if {![dict exists $seenflag $val]} { + dict set seenflag $val $a + lappend all_flagged $val + } + #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. + } + flagvalue { + set idxflagfor [expr {$k -1}] + set flagforinfo [dict get $o_map $idxflagfor] + lassign $flagforinfo ffclass fftype ffval + #jn "--" following a flag could result in us getting here accidentaly.. review + set seenindex [dict get $seenflag $ffval] + if {$seenindex == [expr {$a-1}]} { + #usual case - this is a flagvalue following the first instance of the flag + lappend all_flagged $val + } else { + #write the value back to the seenindex+1 + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals $val ;#we keep multiples as a list + lset all_flagged $seenindexplus $existingvals + } + } + } + } + } + return $all_flagged + } + method typedrange_class_type_from_arg {argclass argtype} { + #set o_flagcategory [list "flag" "flagvalue" "soloflag"] + if {$argclass eq "unallocated"} { + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + default { + if {![string length $argtype]} { + #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . + set argtype UNKNOWN + } + return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions + } + } + } 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append remline [overtype::left $col $tp] + } + } + set cmdlist [list] + dict for {vidx info} $o_map { + if {[lindex $info 0] ne "unallocated"} { + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } + } + } + set 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] + if {[dict exists $o_codemap $type]} { + set tp [dict get $o_codemap $type] + } + append cline [overtype::left $col $tp] + } else { + append cline [overtype::left $col "."] + } + } + 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $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 + } + } + + #assertion - should be none? + #set remaining_values [lrange $source_values $a_index end] + #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" + + do_debug 2 $debugc "========>=========>originals : $values" + do_debug 2 $debugc "[$VMAP get_map]" + do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" + + + + + + set all_flagged [$VMAP get_merged_flagged_by_class *] + set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] + + set all_flagged_list [$VMAP get_list_flagged_by_class *] + set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] + + set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] + + set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] + + + set unflagged_list_in_processing_order [dict values $unflagged] + set unflagged_list [$VMAP get_list_unflagged_by_class *] + + set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] + + return [dict create \ + listremaining $unconsumed_flags_and_values \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ + ] + } + + + + + + + + + + + + #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 {- --}} { + 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] + } + } + + #todo - rename 'cprocessor' is misleading + 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 { + #review - unix paths? conflict with windows style flag such as /w + #must accept empty string + 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]} { + lappend o_mashopts {*}[dict get $o_pinfo mashopts] + } + if {[dict exists $o_pinfo singleopts]} { + lappend o_singleopts {*}[dict get $o_pinfo singleopts] + } + if {[dict exists $o_pinfo pairopts]} { + lappend o_pairopts {*}[dict get $o_pinfo pairopts] + } + if {[dict exists $o_pinfo longopts]} { + lappend o_longopts {*}[dict get $o_pinfo longopts] + } + } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } + + 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 {- --}} { + #specials not defined as solos + return 0 + } + + if {$o_name eq "global"} { + + } elseif {$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] + #does order matter? could use struct::set union ? + 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 && [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\ + -caller $caller\ + -return [list arglistremaining]\ + -match [list]\ + -commandprocessors [list]\ + -soloflags [list]\ + -extras [list]\ + -defaults [list]\ + -required [list]\ + -values \uFFFF\ + -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_args $cf_defaults + foreach {k v} $args { + switch -- $k { + -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { + dict set cf_args $k $v + } + default { + do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" + } + } + } + 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]] ;#why -nocase? why should -l and -L collapse to the uppercase version? + set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] + foreach spec $command_specs { + lassign $spec parentname pinfo + if {[string match -* $parentname] && $parentname ni $known_flags} { + 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 && $f ni $known_flags} { + lappend invalid_flags $f + } + } + } + if {[llength $invalid_flags]} { + do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" + } + + set calc_required [list] + set keywords_in_required [lsearch -inline -all -not $required -*] + set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] + if {[llength $bad_keywords_in_required]} { + do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" + } + #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none + if {[llength $keywords_in_required] > 1} { + do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." + } + if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { + set calc_required [list] + } + set flags [lsearch -inline -all $required -*] + + if {[llength $required]} { + if {[lsearch -nocase $keywords_in_required "all"] >= 0} { + #'all' can be present with other flags - and indicates we also require all the flags from -defaults + dict for {k -} $defaults { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list + set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] + set ranges [dict get $rangesets -ranges] + set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. + #tailflags are the same for all dispatch items + set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] + + + set dict_supplied [dict create supplied $supplied] + set dict_defaults [dict create defaults $defaults] + set dict_ranges [dict create ranges $ranges] + set dict_rangesbytype [dict create rangesbytype $rangesbytype] + set raise_dispatch_error_instead_of_return "" + set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] + #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + + if {[llength $dispatch]} { + set dispatchstatuslist [list] + set dispatchresultlist [list] + set dispatchstatus "ok" + #each dispatch entry is a commandname and dict + #set dispatchrecord [lrange $dispatch 0 1] + set re_argnum {%arg([0-9^%]+)%} + set re_argtake {%argtake([0-9^%]+)%} + set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline + #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} + #dumb-editor rebalancing quote for above comment " + foreach {parentname dispatchrecord} $dispatch { + set commandinfo [get_command_info $parentname $command_specs] + + do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" + + # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x + + do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" + set command [dict get $dispatchrecord command] + #support for %x% placeholders in dispatchrecord command + set command [string map {%match% %matched%} $command] ;#alias + set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] + + set argnum_indices [regexp -indices -all -inline $re_argnum $command] + if {[llength $argnum_indices]} { + foreach {argx_indices x_indices} $argnum_indices { + #argx eg %arg12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] + } + } + + set argsreduced [dict get $dispatchrecord arguments] + #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] + + #review! + #how will this behave differently on unix + package require punk::winrun + set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] + #set argtake_indices [regexp -indices -all -inline $re_argtake $command] + + + set start 0 + while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { + #argx eg %argtake12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set argval [lindex [dict get $dispatchrecord arguments] $x] + set replacementlen [string length $argval] + set command [string map [list $argx $argval] $command] + set start [expr {[lindex $argx_indices 0] + $replacementlen}] + set argsreduced [lremove $argsreduced $x] + set rawparts [lremove $rawparts $x] + } + dict set dispatchrecord arguments $argsreduced + if {$start > 0} { + set rawreduced [join $rawparts] + dict set dispatchrecord raw $rawreduced + } + + set argvals [dict get $dispatchrecord arguments] + set matched_operands [list] + set matched_opts [list] + set matched_in_order [list] + set prefix "${parentname}." + set prefixlen [string length $prefix] + foreach {k v} $argvals { + #puts "$$$$ $k" + if {[string equal -length $prefixlen $prefix $k]} { + #key is prefixed with "commandname." + set k [string replace $k 0 $prefixlen-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 + switch -- $dispatchtype { + tcl { + do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" + #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] + set commandline [concat $command $matched_operands $matched_opts $extraflags] + } + raw { + do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" + #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] + set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] + } + shell { + do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" + #assume the shell arguments are in one quoted string? + set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] + } + default { + #non quoted shell? raw + defaults? + do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" + #set commandline [list $command {*}$matched_in_order {*}$extraflags] + set commandline [concat $command $matched_in_order $extraflags] + } + } + + + + + dict set dispatchrecord asdispatched $commandline + set dispatchresult "" + set dispatcherror "" + if {![catch {{*}$commandline} cmdresult]} { + set dispatchresult $cmdresult + lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] + lappend dispatchresultlist $cmdresult + } else { + set dispatchstatus "error" + set dispatcherror $cmdresult + #don't add to dispatchresultlist + lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] + if {!$was_dispatched_by_another} { + #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning + set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + + break + #return -code error "check_flags error during command dispatch:\n$cmdresult" + } + #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist + } + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + } + + set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] + } + #end llength $dispatch + + + set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] + dict set combined dispatch $dispatch ;#update with asdispatched info + if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { + dict set combined status "ok" + } else { + dict set combined status "error" + } + do_debug 1 $debugc "COMBINED:$combined" + + + set returnkey [string tolower $returnkey] + if {"all" in $returnkey} { + set returnval $combined + #set returnval [dict merge $combined $dict_dispatch_results] + } else { + if {[llength $returnkey] == 1} { + set invalid 0 + #todo - support multiple merge? + set right "" + if {[regexp -all {\|} $returnkey] == 1} { + lassign [split $returnkey |] left right + set joinparts [split $left ,] + } else { + set joinparts [split $returnkey ,] + } + foreach j [concat $joinparts $right] { + if {$j ni $flaginfo_returns} { + set invalid 1 + } + } + set returnval [list] + if {!$invalid} { + foreach j $joinparts { + lappend returnval {*}[dict get $combined $j] + } + if {[string length $right]} { + set returnval [dict merge $returnval $defaults $returnval] + } + } else { + set returnval [list callerrors [list "-return '$returnkey' not valid"]] + } + } else { + set callerrors [list] + set returnval [dict create] + foreach rk $returnkey { + if {$returnkey in $flaginfo_returns} { + dict set returnval $rk [dict get $combined $returnkey] + } else { + lappend callerrors [list "-return '$returnkey' not valid"] + } + } + if {[llength $callerrors]} { + dict set returnval callerrors $callerrors + } + } + } + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" + do_debug 1 $debugc "[string repeat - 40]" + + if {[string length $raise_dispatch_error_instead_of_return]} { + set errdebug [dict get $cf_args -debugargsonerror] + if {$errdebug > [dict get $cf_args -debugargs]} { + dict set debugc -debugargs $errdebug + } + } + + set debuglevel_return 2 + set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return + if {[llength [dict get $combined parseerrors]]} { + dict set debugdict "parseerrors" 0 + } else { + dict set debugdict "parseerrors" 2 + } + dict set debugdict "defaults" 1 + dict set debugdict "supplied" 1 + dict set debugdict "dispatch" 1 + dict set debugdict "ranges" 1 + dict set debugdict "rangesbytype" 1 + dict set debugdict "dispatchstatus" 1 + if {[dict get $combined "status"] eq "ok"} { + dict set debugdict "status" 1 + } else { + dict set debugdict "status" 0 + } + + do_debug 1 $debugc "returning '$returnkey'" + do_debug 1 $debugc "returnval '$returnval'" + if {([llength $returnval] % 2) == 0} { + do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" + } + do_debug 1 $debugc "[string repeat = 40]" + dict for {k v} $combined { + set dlev [dict get $debugdict $k] + switch -- $k { + dispatch { + set col1 [string repeat " " 12] + #process as paired list rather than dict (support repeated commands) + set i 0 + foreach {cmdname cmdinfo} $v { + set field1 [string repeat " " [expr {[string length $cmdname]}]] + set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] + set j 0 + foreach {ckey cval} $cmdinfo { + + if {$i == 0 && $j == 0} { + set c1 [overtype::left $col1 "dispatch"] + } else { + set c1 [overtype::left $col1 { ... }] + } + + if {$j == 0} { + set f1 [overtype::left $field1 $cmdname] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } else { + set f1 [overtype::left $field1 ...] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } + #leave at debug level 1 - because dispatch is generally important + do_debug $dlev $debugc "${c1}${c2} $cval" + + incr j + } + incr i + } + + #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" + #foreach {nm rem} [lrange $v 2 end] { + # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" + #} + } + dispatchresultlist { + set col1 [string repeat " " 25] + set i 0 + foreach dresult $v { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $dresult" + incr i + } + } + classifications { + set col1 [string repeat " " 25] + set len [dict size $v] + if {$len == 0} { + do_debug $dlev $debugc "[overtype::left $col1 $k]" + continue + } + set max [expr {$len -1}] + set numlines [expr $len / 3 + 1] + if {($len % 3) == 0} { + incr numlines -1 + } + set j 0 + for {set ln 0} {$ln < $numlines} {incr ln} { + if {$ln == 0} { + set c1 "[overtype::left $col1 $k]" + } else { + set c1 "[overtype::left $col1 { ... }]" + } + set line "" + for {set col 0} {$col < 3} {incr col} { + if {$j <= $max} { + append line "$j [list [dict get $v $j]] " + } + incr j + } + do_debug $dlev $debugc "$c1 [string trim $line]" + } + } + gridstring { + set col1 [string repeat " " 25] + set i 0 + foreach ln [split $v \n] { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $ln" + incr i + } + } + default { + set col1 [string repeat " " 25] + do_debug $dlev $debugc "[overtype::left $col1 $k] $v" + } + } + } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "DEBUG-END $caller" + if {[string length $raise_dispatch_error_instead_of_return]} { + return -code error $raise_dispatch_error_instead_of_return + } + + + return $returnval + } + + proc tailflagspaired {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set extraflags [list] + set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags? + #review + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + return $extraflags + } + + proc tailflagspaired1 {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] + + set extraflags [list] + + #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags with no value set + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + + } + + + +} + + +namespace eval flagfilter { + + #punk::lib::dict_merge_ordered + + + + #retrieve *only* names that are dependant on the provided namekey - not the key itself + # (query is sorted by the trailing numerical index which represents order the arguments were processed) + proc flag_array_get_sorted_subs {arrname sep namekey} { + upvar $arrname arr + set allsubs [array names arr ${namekey}.*${sep}name,*] + set rnames [lmap nm $allsubs {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + set ordered [lmap nm $sorted_rnames {string reverse $nm}] + return $ordered + } + + proc flag_array_get_sorted_siblings {arrname sep namekey} { + #determine parent by looking at dot - but confirm parent name is in array. + + } + + + + #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. + #use -dictionary to ensure embedded numbers are sorted as integers + proc array_names_sorted_by_tail {arrname nameglob} { + upvar $arrname arr + set matched_names [array names arr $nameglob] + set rnames [lmap nm $matched_names {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + return [lmap nm $sorted_rnames {string reverse $nm}] + } + + +} + +package provide [lassign {flagfilter 0.3.1} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + + + + + diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index c8195b6e..e6bf4b9d 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -186,8 +186,9 @@ tcl::namespace::eval punk::char { set r [list "" {*}[split $lowbits ""] $ridx {*}$charlist] $t add_row $r } - puts stderr $t - $t print + set result [$t print] + $t destroy + return $result } #just the 7-bit ascii. use [page ascii] for the 8-bit layout diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 85ef0692..84dca1df 100644 --- a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -916,19 +916,19 @@ namespace eval punk::mix::commandset::scriptwrap { return $configd } proc _get_nextshell_script {configd} { - #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" + #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" #@SET "nextshelltype[win32___________]=tcl_____________" - #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[dragonflybsd____]=tcl_____________" - #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[freebsd_________]=tcl_____________" - #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[netbsd__________]=tcl_____________" - #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[linux___________]=tcl_____________" - #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[macosx__________]=tcl_____________" - #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[other___________]=tcl_____________" #delimeters @@ -941,7 +941,7 @@ namespace eval punk::mix::commandset::scriptwrap { set n [expr {16 - [string length $os]}] set _os [string repeat _ $n] set path [dict get $v nextshellpath] - set n [expr {64 - [string length $path]}] + set n [expr {128 - [string length $path]}] set _path [string repeat _ $n] set type [dict get $v nextshelltype] set n [expr {16 - [string length $type]}] diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index 731e263e..9d199997 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -2418,6 +2418,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #if {[lindex $command 0] eq "runx"} {} + #temporary hack. + #todo - use happy path return options for non-primary result (like www package) ? if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ [string equal "d/\n" $commandstr] || \ diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm index 2ed4f1e4..02415ccd 100644 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -283,9 +283,47 @@ tcl::namespace::eval punk::zip { #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) #Otherwise extract an internal preamble. - #if neither - + #if neither -? #review - reconsider auto-determination of internal vs external preamble - proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + set inzip [open $infile r] fconfigure $inzip -encoding iso8859-1 -translation binary if {[file exists $outfile_preamble]} { @@ -346,7 +384,7 @@ tcl::namespace::eval punk::zip { #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) #we can't assume they're ordered in any particular way - so we in theory have to look at them all. set baseoffset "unknown" diff --git a/src/bootsupport/modules/shellrun-0.1.1.tm b/src/bootsupport/modules/shellrun-0.1.1.tm index b2ce1feb..8f03892d 100644 --- a/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/bootsupport/modules/shellrun-0.1.1.tm @@ -427,7 +427,7 @@ namespace eval shellrun { cmdarg -type any -multiple 1 -optional 1 }] proc runerr {args} { - set argd [punk::args::parse $args withid ::shellrun::runout] + set argd [punk::args::parse $args withid ::shellrun::runerr] lassign [dict values $argd] leaders opts values received if {[dict exists $received "-nonewline"]} { diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index a40ae2cb..8bc84cc4 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -916,19 +916,19 @@ namespace eval punk::mix::commandset::scriptwrap { return $configd } proc _get_nextshell_script {configd} { - #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" + #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" #@SET "nextshelltype[win32___________]=tcl_____________" - #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[dragonflybsd____]=tcl_____________" - #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[freebsd_________]=tcl_____________" - #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[netbsd__________]=tcl_____________" - #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[linux___________]=tcl_____________" - #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[macosx__________]=tcl_____________" - #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[other___________]=tcl_____________" #delimeters @@ -941,7 +941,7 @@ namespace eval punk::mix::commandset::scriptwrap { set n [expr {16 - [string length $os]}] set _os [string repeat _ $n] set path [dict get $v nextshellpath] - set n [expr {64 - [string length $path]}] + set n [expr {128 - [string length $path]}] set _path [string repeat _ $n] set type [dict get $v nextshelltype] set n [expr {16 - [string length $type]}] diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 6642a26f..23e2b8db 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -95,19 +95,19 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @REM If more than 64 chars needed for a target, it can still be done but overall script padding may need checking/adjusting @REM Supporting more explicit oses than those listed may also require script padding adjustment : <> -@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" +@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" @SET "nextshelltype[win32___________]=tcl_____________" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[dragonflybsd____]=tcl_____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[freebsd_________]=tcl_____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[netbsd__________]=tcl_____________" -@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[linux___________]=tcl_____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[macosx__________]=tcl_____________" -@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[other___________]=tcl_____________" : <> @rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). @@ -119,7 +119,7 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed @REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @SET "selected_shellpath=%nextshellpath[win32___________]%" -@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed +@CALL :stringTrimTrailingUnderscores "%selected_shellpath%" selected_shellpath_trimmed @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @REM @ECHO keyremoved %keyRemoved% @REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available @@ -151,6 +151,7 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @SET "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" @SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% +@SET "fullscriptname=%~dp0%~n0%~x0" @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -162,6 +163,62 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @CALL :stringToUpper %~nx0 capscripttail @REM @ECHO capscriptname: %capscripttail% +@goto skip_parameter_wrangling +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args and shift, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) +:skip_parameter_wrangling + @IF "%nftail%"=="%capscripttail%" ( @ECHO forcing asadmin=1 due to file name on filesystem being uppercase @SET "asadmin=1" @@ -189,31 +246,112 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% :getPrivileges @IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) @ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" -@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@ECHO pre = "/c %fullscriptname% PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@REM @echo pre = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@echo args = pre >> "%vbsGetPrivileges%" @ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" -@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" +@ECHO args = args ^& Chr(34) ^& strArg ^& Chr(34) ^& " " >> "%vbsGetPrivileges%" @ECHO Next >> "%vbsGetPrivileges%" -@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%" -@ECHO Launching script in new window due to administrator elevation +@GOTO skiptest + +%= Option Explicit =% +%= We need a child process to locate the current script. =% +@ECHO Const FLAG_PROCESS = "winver.exe" >> "%vbsGetPrivileges%" + +%= ' WMI constants %= +@ECHO Const wbemFlagForwardOnly = 32 >> "%vbsGetPrivileges%" + +%=' Generate a unique value to be used as a flag =% +@ECHO Dim guid >> "%vbsGetPrivileges% +@ECHO guid = Left(CreateObject("Scriptlet.TypeLib").GUID,38) >> "%vbsGetPrivileges%" + +%= ' Start a process using the indicated flag inside its command line =% +@ECHO WScript.CreateObject("WScript.Shell").Run """" ^& FLAG_PROCESS ^& """ " ^& guid, 0, False >> "%vbsGetPrivileges%" + +%= ' To retrieve process information a WMI reference is needed =% +@ECHO Dim wmi >> "%vbsGetPrivileges%" +@ECHO Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}^!\\.\root\cimv2") >> "%vbsGetPrivileges%" + +%= ' Query the list of processes with the flag in its command line, retrieve the =% +%= ' process ID of its parent process ( our script! ) and terminate the process =% +@ECHO Dim colProcess, process, myProcessID >> "%vbsGetPrivileges%" +@ECHO Set colProcess = wmi.ExecQuery( _>> "%vbsGetPrivileges%" +@ECHO "SELECT ParentProcessID From Win32_Process " ^& _>> "%vbsGetPrivileges%" +@ECHO "WHERE Name='" ^& FLAG_PROCESS ^& "' " ^& _>> "%vbsGetPrivileges%" +@ECHO "AND CommandLine LIKE '%%" ^& guid ^& "%%'" _>> "%vbsGetPrivileges%" +@ECHO ,"WQL" , wbemFlagForwardOnly _>> "%vbsGetPrivileges%" +@ECHO ) >> "%vbsGetPrivileges%" +@ECHO For Each process In colProcess >> "%vbsGetPrivileges%" +@ECHO myProcessID = process.ParentProcessID >> "%vbsGetPrivileges%" +@ECHO process.Terminate >> "%vbsGetPrivileges%" +@ECHO Next >> "%vbsGetPrivileges%" + +%= ' Knowing the process id of our script we can query the process list =% +%= ' and retrieve its command line =% +@ECHO Dim commandLine >> "%vbsGetPrivileges%" +@ECHO set colProcess = wmi.ExecQuery( _>> "%vbsGetPrivileges%" +@ECHO "SELECT CommandLine From Win32_Process " ^& _>> "%vbsGetPrivileges%" +@ECHO "WHERE ProcessID=" ^& myProcessID _>> "%vbsGetPrivileges%" +@ECHO ,"WQL" , wbemFlagForwardOnly _>> "%vbsGetPrivileges%" +@ECHO ) >> "%vbsGetPrivileges%" +@ECHO For Each process In colProcess >> "%vbsGetPrivileges%" +@ECHO commandLine = process.CommandLine >> "%vbsGetPrivileges%" +@ECHO Next >> "%vbsGetPrivileges%" +@ECHO WScript.Echo "raw commandline: " ^& commandLine >>"%vbsGetPrivileges%" + +%= ' Done =% +@ECHO intpos = 0 >> "%vbsGetPrivileges%" +@ECHO intCount = 0 >> "%vbsGetPrivileges%" +@ECHO intstartsearch = 1 >> "%vbsGetPrivileges%" +@ECHO intmax = 100 >> "%vbsGetPrivileges%" +@ECHO do While intCount ^< 4 and intmax ^> 0 >> "%vbsGetPrivileges%" +@ECHO intpos = InStr(intstartsearch, commandline, """") >> "%vbsGetPrivileges%" +@ECHO if intpos ^<^> 0 then >> "%vbsGetPrivileges%" +@ECHO intCount = intCount + 1 >> "%vbsGetPrivileges%" +@ECHO if intcount = 4 then >> "%vbsGetPrivileges%" +@ECHO ' wscript.echo "position: " ^& intpos >> "%vbsGetPrivileges%" +@ECHO commandline = Mid(commandline,intpos+1) >> "%vbsGetPrivileges%" +@ECHO exit do >> "%vbsGetPrivileges%" +@ECHO else >> "%vbsGetPrivileges%" +@ECHO intstartsearch = intpos + 1 >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO intmax = intmax -1 >> "%vbsGetPrivileges%" +@ECHO Loop >> "%vbsGetPrivileges%" +@ECHO if intcount ^< 4 then >> "%vbsGetPrivileges%" +@ECHO err.raise vbObjectError + 1001, "vbsGetPrivileges", "failed to parse commandline" >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO commandline = pre ^& commandline >> "%vbsGetPrivileges%" +@ECHO WScript.Echo "commandline: " ^& commandLine >>"%vbsGetPrivileges%" +@ECHO WScript.Echo "args: " ^& args >>"%vbsGetPrivileges%" +:skiptest + +@ECHO UAC.ShellExecute "cmd.exe", args, "", "runas", 1 >> "%vbsGetPrivileges%" +@REM @ECHO UAC.ShellExecute "%fullscriptname%", commandline, "", "runas", 1 >> "%vbsGetPrivileges%" +@ECHO Launching script "%fullscriptname%" in new window due to administrator elevation with args: "%*" @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* +@REM @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" !newcommandline! @EXIT /B +@REM buffer +@REM buffer :gotPrivileges @REM setlocal & pushd . @PUSHD . -@cd /d %~dp0 +@cd /d %winpath% @IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% + @SHIFT ) :skip_privileges @SET need_ps1=0 @REM we want the ps1 to exist even if the nextshell isn't powershell -@if not exist "%~dp0%~n0.ps1" ( +@if not exist "%scriptrootname%.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different + fc "%fullscriptname%" "%scriptrootname%.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -223,74 +361,13 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL + COPY "%fullscriptname%" "%scriptrootname%.ps1" >NUL ) @REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) - - - -@set argCount=30 -@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe -@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon -@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. - -@set tmpfile_base=%TEMP%\punkbatch_params -@call :getUniqueFile %tmpfile_base% ".txt" paramfile -@echo %paramfile% - -%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= -@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 -@rem outer loop required to redirect all rem lines at once to file -@for %%x in (1) do @( - @for /L %%f in (1,1,%argCount%) do @( - @set "argnum=%%~nf" - @set "a1=%%1" - @rem @set "argname=%%!argnum!" - @rem @echo argname: !argname! - @call :rem_output !argnum! !a1! - @shift - ) -) > %paramfile% -@echo off - -@set "newcommandline= " - -@(set target=cmd_pwsh) -@if "%target%"=="cmd_pwsh" ( - @for /F "delims=" %%L in (%paramfile%) do @( - SETLOCAL DisableDelayedExpansion - set "param=%%L" - @REM @echo ######### %%L - @rem call :buildcmdline newcommandline param "{" "}" - @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= - call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= - @rem @echo . - ) -) ELSE ( - @for /F "delims=" %%L in (%paramfile%) do @( - SETLOCAL DisableDelayedExpansion - set "param=%%L" - call :buildcmdline newcommandline param - ) -) -@REM padding -SETLOCAL EnableDelayedExpansion - -@echo off -@IF EXIST %paramfile% ( - @DEL /F /Q %paramfile% -) -@IF EXIST %paramfile% ( - echo failed to delete %paramfile% - cat %paramfile% -) - - - @REM @SET "squoted_args=" @REM @for %%a in (%*) do @( @REM set "v=%%a" @@ -311,19 +388,24 @@ SETLOCAL EnableDelayedExpansion REM fallback to powershell if pwsh failed IF !pwshtest_exitcode!==0 ( @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% - @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted - cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! + @rem pwsh -nop -nologo -ExecutionPolicy bypass -f "%scriptrootname%.ps1" %arglist% %= ok =% + @rem cmd /c pwsh -nop -nologo -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! + !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% SET task_exitcode=!errorlevel! ) ELSE ( REM TODO prompt user with option to call script to install pwsh using winget - @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% - cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! + %= powershell with -file flag treats it's arguments differently to pwsh - we need cmd /c to preserve args with spaces =% + cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% - cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! + %= powershell with -file flag treats it's arguments differently to pwsh - we need cmd /c to preserve args with spaces =% + @rem @echo powershell - !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" %arglist% %= ok - this works =% + !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -337,24 +419,23 @@ SETLOCAL EnableDelayedExpansion REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode - @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" - %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; + @REM @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" + !selected_shellpath_trimmed! "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @REM boundary padding - GOTO :exit_multishell ) ) ) ) @REM batch file library functions - @GOTO :endlib @REM padding @REM padding @REM padding +@REM padding %= ---------------------------------------------------------------------- =% @rem courtesy of dbenham @@ -458,6 +539,7 @@ do if not defined param1 set %%~"param1=%2%%~" rem %1 #%2# @exit /b +@rem padding @REM courtesy of: https://stackoverflow.com/users/463115/jeb :strlen stringVar returnVar @( @@ -506,6 +588,8 @@ do if not defined param1 set %%~"param1=%2%%~" ) @EXIT /B +@REM padding +@REM padding :getFileTail @REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd @REM we can't use things such as %~nx1 as it can change capitalisation @@ -545,6 +629,7 @@ do if not defined param1 set %%~"param1=%2%%~" @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -654,14 +739,14 @@ do if not defined param1 set %%~"param1=%2%%~" @REM boundary padding @REM boundary padding @REM boundary padding -@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @SET "trimstring=%~1" - @REM trim up to 63 underscores from the end of a string using string substitution + @REM trim up to 127 underscores from the end of a string using string substitution @SET "trimstring=%trimstring%###" + @SET "trimstring=%trimstring:________________________________________________________________###=###%" @SET "trimstring=%trimstring:________________________________###=###%" @SET "trimstring=%trimstring:________________###=###%" @SET "trimstring=%trimstring:________###=###%" @@ -707,10 +792,11 @@ do if not defined param1 set %%~"param1=%2%%~" # ## ### ### ### ### ### ### ### ### ### ### ### ### ### # -- tcl script section # -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- It is tuned to run (and possibly divert to different payload shell) when called from cmd.exe as a batch file, tclsh,sh,zsh,bash,perl or pwsh/powershell script # -- i.e it is a polyglot file. +# -- The payload target (by os) is defined in the nextshell block at the top which is constructed when generating the polyglot +# -- using the tcl 'dev scriptwrap.multishell' command in a tcl punk shell +# -- The payload can be tcl,perl,powershell/pwsh or zsh/bash. # -- The specific layout including some lines that appear just as comments is quite sensitive to change. # -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. # -- e.g ./scriptname.cmd in sh or zsh or bash @@ -720,7 +806,13 @@ do if not defined param1 set %%~"param1=%2%%~" rename set ""; rename S set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore Hide :exit_multishell;Hide {<#};Hide '@ #--------------------------------------------------------------------- +puts "info script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- #divert to configured nextshell +set script_as_called [info script] package require platform set plat_full [platform::generic] set plat [lindex [split $plat_full -] 0] @@ -733,6 +825,14 @@ set in_data 0 set nextshellpath "" set nextshelltype "" puts stderr "PLAT: $plat" +switch -glob -- $plat { + "msys" - "mingw*" { + set os "win32" + } + default { + set os $plat + } +} foreach ln [split $scriptdata \n] { if {[string trim $ln] eq ""} {continue} if {!$in_data} { @@ -740,14 +840,14 @@ foreach ln [split $scriptdata \n] { set in_data 1 } } else { - if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + if {[string match "*@SET*nextshellpath?${os}_*" $ln]} { set lineparts [split $ln =] set tail [lindex $lineparts 1] set nextshellpath [string trimright $tail {_"}] if {$nextshellpath ne "" && $nextshelltype ne ""} { break } - } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + } elseif {[string match "*@SET*nextshelltype?${os}_*" $ln]} { set lineparts [split $ln =] set tail [lindex $lineparts 1] set nextshelltype [string trimright $tail {_"}] @@ -760,31 +860,112 @@ foreach ln [split $scriptdata \n] { } } if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + set script_rootname [file rootname $script_as_called] if {$nextshelltype in "pwsh powershell"} { - set scrname [file rootname [info script]].ps1 - set arglist [list] - foreach a $::argv { - set a "'$a'" - lappend arglist $a + # experimental + set script_ps1 $script_rootname.ps1 + set arglist $::argv + + if {[file extension $script_as_called] ne ".ps1"} { + #we need to ensure .ps1 is up to date + set needs_updating 0 + if {![file exists $script_ps1]} { + set needs_updating 1 + } else { + #both exist + if {[file size $script_as_called] != [file size $script_ps1]} { + set needs_updating 1 + } else { + #both exist with same size - do full check that they're identical + catch {package require sha256} + if {[package provide sha256] ne ""} { + set h1 [sha2::sha256 -hex -file $script_as_called] + set h2 [sha2::sha256 -hex -file $script_ps1] + if {[string length $h1] != 64 || [string length $h2] != 64} { + set needs_updating 1 + } elseif {$h1 ne $h2} { + set needs_updating 1 + } + } else { + #manually compare - scripts aren't too big, so slurp and string compare is fine + set fd [open $script_as_called] + chan configure $fd -translation binary + set data1 [read $fd] + close $fd + set fd [open $script_ps1] + chan configure $fd -translation binary + set data2 [read $fd] + close $fd + if {![string equal $data1 $data2]} { + set needs_updating 1 + } + } + } + } + + if {$needs_updating} { + file copy -force $script_as_called $script_ps1 + } + } else { + #when called on the .ps1 - we assume it's up to date - review } + set scrname $script_ps1 + + #set arglist [list] + #foreach a $::argv { + # set a "'$a'" + # lappend arglist $a + #} } else { - set scrname [info script] + set scrname $script_as_called set arglist $::argv } - puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" #todo - handle /usr/bin/env #todo - exitcode - if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { - set nextshell_words [list $nextshellpath] - } else { - set nextshell_words $nextshellpath + #review - test spaced quoted words in nextshellpath? + # + #if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + # set nextshell_words [list $nextshellpath] + #} else { + # set nextshell_words $nextshellpath + #} + + #perform any msys argument munging on a cmd/cmd.exe based nextshellpath before we convert the first word to an auto_exec path + switch -glob -- $plat { + "msys" - "mingw*" { + set cmdword [lindex $nextshellpath 0] + #we only act on cmd or cmd.exe - not a full path such as c:/WINDOWS/system32/cmd.exe + #the nextshellpath should generally be configured as cmd /c ... or cmd.exe ... but specifying it as a path could allow bypassing this un-munging. + #The un-munging only applies to msys/mingw, so such bypassing should be unnecessary - review + #maint: keep this munging in sync with zsh/bash and perl blocks which must also do msys mangling + if {[regexp {^cmd$|^cmd[.]exe$} $cmdword]} { + #need to deal with msys argument munging + puts stderr "cmd call via msys detected. performing translation of /c to //C" + #for now we only deal with /C or /c - todo - other cmd.exe flags? + #In this context we would usually only be using cmd.exe /c to launch older 'desktop' powershell to avoid spaced-argument problems - so we aren't expecting other flags + set new_nextshellpath [list $cmdword] + #for now - just do what zsh munging does - bash regex/string/array processing is tedious and footgunny for the unfamiliar (me), + #so determine the minimum viable case for code there, then port behaviour to perl/tcl msys munging sections. + foreach w [lrange $nextshellpath 1 end] { + if {[regexp {^/[Cc]$} $w]} { + lappend new_nextshellpath {//C} + } else { + lappend new_nextshellpath $w + } + } + set nextshellpath $new_nextshellpath + } + } } + set ns_firstword [lindex $nextshellpath 0] - if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { - set ns_firstword [string range $ns_firstword 1 end-1] - } + #review - is this test for extra layer of double quoting on first word really necessary? + #if we are treaing $nextshellpath as a tcl list - the first layer of double quotes will already have disappeared + ##if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + ## set ns_firstword [string range $ns_firstword 1 end-1] + ##} - if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + if {$::tcl_platform(platform) ne "windows" && [string match {/*/env} $ns_firstword]} { set exec_part $nextshellpath } else { set epath [auto_execok $ns_firstword] @@ -794,6 +975,10 @@ if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] } } + + + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + puts stdout "exec: $exec_part $scrname $arglist" catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts if {[dict exists $eopts -errorcode]} { @@ -837,11 +1022,6 @@ namespace eval ::punk::multishell { } } # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- # puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" @@ -867,8 +1047,11 @@ if {[::punk::multishell::is_main]} { HEREDOC1B_HIDE_FROM_BASH_AND_SH # Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ echo "var0: $0 @: $@" -# use oldschool backticks and sed - lowest common denominator \ -ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# use oldschool backticks and sed (posix - lowest common denominator) \ +# ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` \ +# some ps impls will return arguments - so last field not always appropriate \ +# some ps impls don't have -o (e.g cygwin) so ps_shellname may remain empty and emit an error \ +ps_shellname=`ps -o pid,comm -p $$ | awk '$1 != "PID" {print $2}'` # \ echo "shell from ps: $ps_shellname" # \ @@ -900,8 +1083,11 @@ pop() { } # ------------------------------------------------------------------------------ -# non-bash-like posix diversion \ -if [ "$ps_shellname" != "bash" ] && [ "$ps_shellname" != "zsh" ]; then +# non-bash-like posix diversion +# we don't use $BASH_VERSION/$ZSH_VERSION as these can still be set when for example +# sh is a symlink to bash (posix-mode bash - reduced bashism capabilities?) +# if our ps_shellname didn't contain a result, don't divert and risk looping +if [ -n "$ps_shellname" ] && [ "$ps_shellname" != "bash" ] && [ "$ps_shellname" != "zsh" ] ; then shift pop $# eval "$POP_EXPR" @@ -919,17 +1105,14 @@ if false==false # else { then : # - # zsh/bash \ shift && set -- "${@:1:$((${#@}-1))}" # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust the %nextshell% value above -# -- if sh/bash scripting needs to run on windows too. +# -- zsh/bash script section # -- +# -- review - for zsh do we want to use: setopt KSH_ARRAYS ? +# -- arrays in bash 0-based vs 1-based in zsh +# -- stick to the @:i:len syntax which is same for both # ## ### ### ### ### ### ### ### ### ### ### ### ### ### plat=$(uname -s) #platform/system @@ -952,18 +1135,31 @@ elif [[ "$plat" == "MINGW64"* ]]; then elif [[ "$plat" == "CYGWIN_NT"* ]]; then os="win32" elif [[ "$plat" == "MSYS_NT"* ]]; then - #review.. - echo MSYS - #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #review.. + + #Need to consider the difference between when msys2 was launched (which strips some paths and sets up the environment) + # vs if the msys2 sh was called - (actually bash) in which case paths will be different + + #wsl and cygwin or msys2 can commonly be problematic combinations - primarily due to path issues + #e.g "c:/windows/system32/" is quite likely in the path ahead of msys,git etc. + #e.g It means a /usr/bin/env bash call may launch the (linux elf) bash for wsl rather than the msys bash + # + + #msys provides win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' #bash reports $OSTYPE msys + + #there are statements around the web that cmd /c .. will work under msys2 + # - but from experience, it can be required to use cmd //c ... + # or MSYS2_ARG_CONV_ECL='*' cmd /c .. + # This seems to be because process arguments that look like unix paths are converted to windows paths :/ + #review! + os="win32" #review - need ps/sed/awk to determine shell? - interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` + interp=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` #use 'command -v' (shell builtin preferred over external which) shellpath=`command -v $interp` shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname - #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. - #This breaks calls to various unix utils such as sed etc (wsl related?) export PATH="$shellfolder${PATH:+:${PATH}}" elif [[ "$OSTYPE" == "win32" ]]; then os="win32" @@ -985,6 +1181,8 @@ elif [[ "$ps_shellname" == "zsh" ]]; then else #fallback - doesn't seem to work in zsh - untested in early bash IFS=$'\n' arr_oslines=($shellconfiglines) + IFS=$' \t\n' + # review fi nextshellpath="" nextshelltype="" @@ -1008,8 +1206,56 @@ exitcode=0 #-- sh/bash launches nextscript here instead of shebang line at top if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then echo zsh/bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" - #e.g /usr/bin/env tclsh "$0" "$@" - ${nextshellpath} "$0" "$@" + + script="$0" + if [[ "$nextshelltype" == "pwsh" || "$nextshelltype" == "powershell" ]]; then + #powershell requires the file extension to be .ps1 (always - on windows) + #on other platforms it's not required if a shebang line is used - but this script must be shebangless for portability and to maintain polyglot capabilities. + cmdpattern="[.]cmd$" + if [[ "$script" =~ $cmdpattern ]]; then + ps1script="${script%????}.ps1" + if ! cmp -s "$script" "$ps1script" ; then + #ps1script either different or missing + #on windows - batch script copies .cmd -> .ps1 if not identical + cp -f "$script" "$ps1script" + fi + script=$ps1script + fi + fi + if [[ "$plat" == "MSYS_NT"* ]]; then + + #we need to deal with MSYS argument munging + cmdpattern="^cmd.exe |^cmd " + #do not double quote cmdpattern - or it will be treated as literal string + if [[ "$nextshellpath" =~ $cmdpattern ]]; then + #for now - tell the user what's going on + echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path" >&2 + #flags to cmd.exe such as /c are interpreted by msys as looking like a unix path + #review - for nextshellpath targets specified in the block for win32 - we don't expect unix paths (?) + #what about other flags? - can we just double up all forward slashes? + #maint: keep this munging in sync with the tcl block and perl block which must also do msys munging + nextshellpath="${nextshellpath// \/[cC] / \/\/c }" + # echo "new nextshellpath: ${nextshellpath}" + #review - + #don't double quote this + script=${script//\\/\\\\} + fi + echo "calling ${nextshellpath} $script $@" + + #load into array + cmd_array=($nextshellpath) + cmd_array+=("$script") #add script, which may contain spaces as a single entry ? + cmd_array+=( "$@" ) #add each element of args to array as a separate entry (equiv ? "${arr[@]}") + # printf "%s\n" "${cmd_array[@]}" + "${cmd_array[@]}" + + # this works to make nextshellpath run - but joins $@ members incorrectly + #eval ${nextshellpath} "$script" "$@" + else + #e.g /usr/bin/env tclsh "$0" "$@" + ${nextshellpath} "$script" "$@" + fi + exitcode=$? #echo "zsh/bash reporting exitcode: ${exitcode}" @@ -1189,18 +1435,44 @@ if ($match.Success) { $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { + if ($args[0] -eq "PUNK-ELEVATED") { + # May be present if launch and elevation was done via cmd.exe script + # shift away first arg + $newargs = $args | Select-Object -Skip 1 + } else { + $newargs = $args + } + # -Wait e.g for starting a service or other operations which remainder of script may depend on + $arguments = @("-NoProfile","-NoLogo", "-NoExit", "-ExecutionPolicy", "Bypass") + $arguments += @("-File", $($MyInvocation.MyCommand.Path)) + foreach ($a in $newargs) { + if ($a -match '\s') { + $arguments += "`"$a`"" + } else { + $arguments += $a + } + } if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { # If not elevated, relaunch with elevated privileges - # -Wait e.g for starting a service or other operations which remainder of script may depend on - $arguments = @("-NoProfile", "-NoExit", "-ExecutionPolicy", "Bypass") - $arguments += @("-File", $($MyInvocation.MyCommand.Path)) - $arguments += $args + Write-Host "Powershell elevating using start-process with -Verb RunAs" if ($PSVersionTable.PSEdition -eq 'Core') { Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -Wait -Verb RunAs } else { Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -Wait -Verb RunAs } Exit # Exit the current non-elevated process + } else { + if ($args[0] -eq "PUNK-ELEVATED") { + #Already elevated (by cmd.exe) + #.. but it is impossible to modify or reassign the automatic $args variable + # so let's start yet another whole new process just to remove one leading argument so the custom script can operate on parameters cleanly - thanks powershell :/ + if ($PSVersionTable.PSEdition -eq 'Core') { + Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -NoNewWindow -Wait + } else { + Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -NoNewWindow -Wait + } + Exit + } } } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm new file mode 100644 index 00000000..474ae8d3 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm @@ -0,0 +1,2718 @@ + +#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 {[dict exists $solodict $a]} { + set last_was_flag 0 + if {[dict exists $solo_accumulator $a]} { + set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] + } else { + set soloval [dict get $solodict $a] + } + dict set solo_accumulator $a $soloval + #we need to keep order of first appearance + set idx [lsearch $result $a] + if {$idx < 0} { + lappend result $a $soloval + } else { + lset result $idx+1 $soloval + } + } else { + if {!$last_was_flag} { + if {$a eq "--"} { + + } else { + if {[lindex $arglist $a_idx-1] eq "--"} { + #end of options processing - none of the remaining are considered flags/options no matter what they look like + set last_was_flag 0 + break + } else { + if {[string match -* $a]} { + set last_was_flag 1 + lappend result $a ;#flag + } else { + #last wasnt, this isn't - don't output + set last_was_flag 0 + } + } + } + } else { + #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. + if {$a eq "--"} { + #last was flag + set last_was_flag 0 + } else { + lappend result $a ;#value + set last_was_flag 0 + } + } + } + incr a_idx + } + if {([llength $result] % 2) != 0} { + set last [lindex $result end] + if {[string match -* $last] && ($last ni [dict keys $solodict])} { + lappend result 1 + } + } + #puts ">>>get_flagged_only returning $result" + return $result + } + + + ## get_one_paired_flag_value + #best called with 'catch' unless flag known to be in arglist + #raises an error if no position available after the flag to retrieve value + #raises an error if flag not like -something + #raises an error if flag not found in list + proc get_one_paired_flag_value {arglist flag} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { + #regexp excludes plain - and -- + #if {![string match -* $flag]} {} + error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" + } + set cindex [lsearch $arglist $flag] + if {$cindex >= 0} { + set valueindex [expr {$cindex + 1}] + if {$valueindex < [llength $arglist]} { + #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" + return [lindex $arglist $valueindex] + } else { + error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" + } + } else { + error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" + } + } +} + +namespace eval flagfilter::obj { + +} + + +namespace eval flagfilter { + variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. + #used as a basis for some object-instance names etc + proc get_new_runid {} { + variable run_counter + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" + } + + namespace export check_flags + proc do_debug {lvl debugconfig msg} { + if {$lvl <= [dict get $debugconfig -debugargs]} { + foreach ln [split $msg \n] { + puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" + flush stderr + } + } + } + + #---------------------------------------------------------------------- + # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed + #wiki.tcl-lang.org/page/dict+tips+and+tricks + proc isdict {v} { + if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { + return [expr {!([llength $v] % 2)}] + } else { + return [string match "value is a dict *" [::tcl::unsupported::representation $v]] + } + } + + proc dict_format {dict} { + dictformat_rec $dict "" " " + } + proc dictformat_rec {dict indent indentstring} { + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } + return $result + } + #-------------------------------------------------------------------------- + + #solo 'category' includes longopts with value + #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) + proc is_this_flag_solo {f solos objp} { + if {![string match -* $f]} { + #not even flaglike + return 0 + } + + + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } + + set p_opts [$objp get_combined_opts] + + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] + + if {$f in $singleopts} { + return 1 + } + + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } + + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # + + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + return $is_solo + } + #todo? support global (non-processor specific) mash list? -mashflags ? + proc is_this_flag_mash {f objp} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { + #not even flaglike + return 0 + } + set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc + + #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash + set singleopts pdict get $optinfo singleopts] + if {$f in $singleopts} { + return 0 + } + + set pairopts [dict get $optinfo pairopts] + if {$f in [dict keys $pairopts]} { + #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) + return 0 + } + set mashopts [dict get $optinfo mashopts] + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value + # .. in which case value could be at the tail of the mash.. or be the next arg in the list + # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value + # (ie such a mashopt is a solo that can take a value only as a mashtail) + # presence in pairopts indicates a mashflag must have a value + # presense in singleopts indicates mashflag takes no value ever. + # mashopt cannot be in both singleopts and pairopts. (NAND) + foreach l $flagletters { + if {-$l in $pairopts} { + if {"-$l" in $mashopts} { + #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. + # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt + break + } else { + #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash + set is_mash 0 + } + } elseif {"-$l" in $singleopts} { + #singleopt & mashopt - cannot take a value, mashed or otherwise + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } else { + if {"-$l" ni $mashopts} { + set is_mash 0 + } else { + #present only in mashopts - can take a value, but only immediately following in the mash + break + } + } + } + return $is_mash + } + proc is_this_flag_for_me {f objp cf_args} { + set processorname [$objp name] + set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc + + if {$processorname in [list "tail_processor"]} { + return 1 + } + if {$processorname in [list "global"]} { + #todo - mashflags for global? + set defaults [dict get $cf_args -defaults] + set extras [dict get $cf_args -extras] + set soloflags [dict get $cf_args -soloflags] + if {$f in [concat $extras $soloflags [dict keys $defaults]]} { + return 1 + } + } + + set singleopts [dict get $optinfo singleopts] + if {"any" in [string tolower $singleopts]} { + #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? + return 1 + } + set pairopts [dict get $optinfo pairopts] + set allopts [concat $singleopts [dict keys $pairopts]] + if {$f in $allopts} { + return 1 + } + + #process mashopts last + set mashopts [dict get $optinfo mashopts] + if {"any" in [string tolower $mashopts]} { + #if 'all' in mashopts - it can eat anything - review - is this even useful? + return 1 + } else { + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash + foreach l $flagletters { + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } + return $is_mash + } + + return 0 + } + + + + proc add_dispatch_raw {recordvar parentname v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo + } + } + proc add_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo + } + } + proc lsearch-all-stride-2 {l search} { + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] + } + proc update_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo + } + } + + #Note the difference between this and is_command_match. + #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters + #Note that this isn't a general test to be applied to the entire argument list. + # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor + # so this test only applies during the ordered examination of args + proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { + set cmdinfo [lindex $cspec 1] + if {$cmdinfo eq "tail_processor"} { + return 1 + } + if {$cmdinfo eq "global"} { + set defaults [dict get $cf_args -defaults] + set soloflags [dict get $cf_args -soloflags] + set extras [dict get $cf_args -extras] + if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { + return 1 + } + } + if {![dict exists $cmdinfo match]} { + return 1 + } + set matchspeclist [dict get $cmdinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + #only block it if there was a match pattern specified but it didn't match + return 0 + } + #Note - returns false for a cspec that has no match specified. + #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this + # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. + proc is_command_match {flag cspec} { + set pinfo [lindex $cspec 1] + if {[dict exists $pinfo match]} { + set matchspeclist [dict get $pinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + proc is_command_match_any {f commandprocessors} { + foreach comspec $commandprocessors { + lassign $comspec cmdname cmdinfo + if {[dict exists $cmdinfo match]} { + set matchlist [dict get $cmdinfo match] + foreach matchspec $matchlist { + if {[regexp -- $matchspec $f]} { + #actually a command + return true + } + } + } + } + return false + } + + #determine if f is potentially a flag that takes a parameter from the next argument. + #e.g --x=y (longopt) does not consume following arg but --something *might* + proc is_candidate_toplevel_param_flag {f solos commandprocessors} { + if {[is_command_match_any $f $commandprocessors]} { + return false + } + if {$f in $solos} { + return 0 + } + if {$f in {- --}} { + return 0 + } + #longopts (--x=blah) and alternative --x blah + #possibly also -x=blah + if {[string match -* $f]} { + if {[string first "=" $f]>1} { + return 0 + } + } + return [expr {[string match -* $f]}] + } + + + + + + + + + + + + + + + + + + + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? + #todo - show caller info + proc assert_equal {a b} { + if {![expr {$a eq $b}]} { + error "assert_equal $a $b" + } + } + + + + + + #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map + #1 2 3 4 5 6 ;#original list posns example + # 2 6 ;#map_remaining example (scanlist) + #1 3 4 5 ;#map_allocated example + #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example + oo::class create class_vmap { + variable o_map + variable o_remaining + variable o_allocated + variable o_values + variable o_codemap + variable o_flagcategory + constructor {values} { + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ + ] + set o_flagcategory [list "flag" "flagvalue" "soloflag"] + set o_values $values + #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 + #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ + if {[llength $values]} { + if {[llength $values] < 30} { + #common case is short lists - but we don't want to penalize large lists + set o_remaining [lsearch -all $values *] + } else { + #punk::lib::range wraps lseq if available + set o_remaining [punk::lib::range 0 [llength $values]-1] + } + } else { + set o_remaining [list] + } + set o_allocated [list] + set o_map [list] + foreach posn $o_remaining { + 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]} { + switch -- $type { + flag - flagvalue - soloflag {} + default { + 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]} { + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } + } + } + } + return $list_flagged + } + + method get_merged_flagged_by_class {classmatch} { + variable flagcategory + set all_flagged [list] + set seenflag [dict create] ;#key = -flagname val=earliest vindex + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + set a [llength $all_flagged] ;#index into all_flagged list we are building + switch -- $type { + soloflag { + if {[dict exists $seenflag $val]} { + set seenindex [dict get $seenflag $val] + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? + lset all_flagged $seenindexplus $existingvals + } else { + dict set seenflag $val $a + lappend all_flagged $val 1 + } + } + flag { + if {![dict exists $seenflag $val]} { + dict set seenflag $val $a + lappend all_flagged $val + } + #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. + } + flagvalue { + set idxflagfor [expr {$k -1}] + set flagforinfo [dict get $o_map $idxflagfor] + lassign $flagforinfo ffclass fftype ffval + #jn "--" following a flag could result in us getting here accidentaly.. review + set seenindex [dict get $seenflag $ffval] + if {$seenindex == [expr {$a-1}]} { + #usual case - this is a flagvalue following the first instance of the flag + lappend all_flagged $val + } else { + #write the value back to the seenindex+1 + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals $val ;#we keep multiples as a list + lset all_flagged $seenindexplus $existingvals + } + } + } + } + } + return $all_flagged + } + method typedrange_class_type_from_arg {argclass argtype} { + #set o_flagcategory [list "flag" "flagvalue" "soloflag"] + if {$argclass eq "unallocated"} { + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + default { + if {![string length $argtype]} { + #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . + set argtype UNKNOWN + } + return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions + } + } + } 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append remline [overtype::left $col $tp] + } + } + set cmdlist [list] + dict for {vidx info} $o_map { + if {[lindex $info 0] ne "unallocated"} { + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } + } + } + set 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] + if {[dict exists $o_codemap $type]} { + set tp [dict get $o_codemap $type] + } + append cline [overtype::left $col $tp] + } else { + append cline [overtype::left $col "."] + } + } + 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $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 + } + } + + #assertion - should be none? + #set remaining_values [lrange $source_values $a_index end] + #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" + + do_debug 2 $debugc "========>=========>originals : $values" + do_debug 2 $debugc "[$VMAP get_map]" + do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" + + + + + + set all_flagged [$VMAP get_merged_flagged_by_class *] + set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] + + set all_flagged_list [$VMAP get_list_flagged_by_class *] + set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] + + set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] + + set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] + + + set unflagged_list_in_processing_order [dict values $unflagged] + set unflagged_list [$VMAP get_list_unflagged_by_class *] + + set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] + + return [dict create \ + listremaining $unconsumed_flags_and_values \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ + ] + } + + + + + + + + + + + + #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 {- --}} { + 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] + } + } + + #todo - rename 'cprocessor' is misleading + 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 { + #review - unix paths? conflict with windows style flag such as /w + #must accept empty string + 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]} { + lappend o_mashopts {*}[dict get $o_pinfo mashopts] + } + if {[dict exists $o_pinfo singleopts]} { + lappend o_singleopts {*}[dict get $o_pinfo singleopts] + } + if {[dict exists $o_pinfo pairopts]} { + lappend o_pairopts {*}[dict get $o_pinfo pairopts] + } + if {[dict exists $o_pinfo longopts]} { + lappend o_longopts {*}[dict get $o_pinfo longopts] + } + } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } + + 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 {- --}} { + #specials not defined as solos + return 0 + } + + if {$o_name eq "global"} { + + } elseif {$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] + #does order matter? could use struct::set union ? + 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 && [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\ + -caller $caller\ + -return [list arglistremaining]\ + -match [list]\ + -commandprocessors [list]\ + -soloflags [list]\ + -extras [list]\ + -defaults [list]\ + -required [list]\ + -values \uFFFF\ + -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_args $cf_defaults + foreach {k v} $args { + switch -- $k { + -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { + dict set cf_args $k $v + } + default { + do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" + } + } + } + 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]] ;#why -nocase? why should -l and -L collapse to the uppercase version? + set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] + foreach spec $command_specs { + lassign $spec parentname pinfo + if {[string match -* $parentname] && $parentname ni $known_flags} { + 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 && $f ni $known_flags} { + lappend invalid_flags $f + } + } + } + if {[llength $invalid_flags]} { + do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" + } + + set calc_required [list] + set keywords_in_required [lsearch -inline -all -not $required -*] + set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] + if {[llength $bad_keywords_in_required]} { + do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" + } + #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none + if {[llength $keywords_in_required] > 1} { + do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." + } + if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { + set calc_required [list] + } + set flags [lsearch -inline -all $required -*] + + if {[llength $required]} { + if {[lsearch -nocase $keywords_in_required "all"] >= 0} { + #'all' can be present with other flags - and indicates we also require all the flags from -defaults + dict for {k -} $defaults { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list + set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] + set ranges [dict get $rangesets -ranges] + set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. + #tailflags are the same for all dispatch items + set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] + + + set dict_supplied [dict create supplied $supplied] + set dict_defaults [dict create defaults $defaults] + set dict_ranges [dict create ranges $ranges] + set dict_rangesbytype [dict create rangesbytype $rangesbytype] + set raise_dispatch_error_instead_of_return "" + set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] + #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + + if {[llength $dispatch]} { + set dispatchstatuslist [list] + set dispatchresultlist [list] + set dispatchstatus "ok" + #each dispatch entry is a commandname and dict + #set dispatchrecord [lrange $dispatch 0 1] + set re_argnum {%arg([0-9^%]+)%} + set re_argtake {%argtake([0-9^%]+)%} + set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline + #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} + #dumb-editor rebalancing quote for above comment " + foreach {parentname dispatchrecord} $dispatch { + set commandinfo [get_command_info $parentname $command_specs] + + do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" + + # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x + + do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" + set command [dict get $dispatchrecord command] + #support for %x% placeholders in dispatchrecord command + set command [string map {%match% %matched%} $command] ;#alias + set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] + + set argnum_indices [regexp -indices -all -inline $re_argnum $command] + if {[llength $argnum_indices]} { + foreach {argx_indices x_indices} $argnum_indices { + #argx eg %arg12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] + } + } + + set argsreduced [dict get $dispatchrecord arguments] + #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] + + #review! + #how will this behave differently on unix + package require punk::winrun + set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] + #set argtake_indices [regexp -indices -all -inline $re_argtake $command] + + + set start 0 + while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { + #argx eg %argtake12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set argval [lindex [dict get $dispatchrecord arguments] $x] + set replacementlen [string length $argval] + set command [string map [list $argx $argval] $command] + set start [expr {[lindex $argx_indices 0] + $replacementlen}] + set argsreduced [lremove $argsreduced $x] + set rawparts [lremove $rawparts $x] + } + dict set dispatchrecord arguments $argsreduced + if {$start > 0} { + set rawreduced [join $rawparts] + dict set dispatchrecord raw $rawreduced + } + + set argvals [dict get $dispatchrecord arguments] + set matched_operands [list] + set matched_opts [list] + set matched_in_order [list] + set prefix "${parentname}." + set prefixlen [string length $prefix] + foreach {k v} $argvals { + #puts "$$$$ $k" + if {[string equal -length $prefixlen $prefix $k]} { + #key is prefixed with "commandname." + set k [string replace $k 0 $prefixlen-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 + switch -- $dispatchtype { + tcl { + do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" + #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] + set commandline [concat $command $matched_operands $matched_opts $extraflags] + } + raw { + do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" + #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] + set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] + } + shell { + do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" + #assume the shell arguments are in one quoted string? + set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] + } + default { + #non quoted shell? raw + defaults? + do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" + #set commandline [list $command {*}$matched_in_order {*}$extraflags] + set commandline [concat $command $matched_in_order $extraflags] + } + } + + + + + dict set dispatchrecord asdispatched $commandline + set dispatchresult "" + set dispatcherror "" + if {![catch {{*}$commandline} cmdresult]} { + set dispatchresult $cmdresult + lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] + lappend dispatchresultlist $cmdresult + } else { + set dispatchstatus "error" + set dispatcherror $cmdresult + #don't add to dispatchresultlist + lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] + if {!$was_dispatched_by_another} { + #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning + set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + + break + #return -code error "check_flags error during command dispatch:\n$cmdresult" + } + #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist + } + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + } + + set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] + } + #end llength $dispatch + + + set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] + dict set combined dispatch $dispatch ;#update with asdispatched info + if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { + dict set combined status "ok" + } else { + dict set combined status "error" + } + do_debug 1 $debugc "COMBINED:$combined" + + + set returnkey [string tolower $returnkey] + if {"all" in $returnkey} { + set returnval $combined + #set returnval [dict merge $combined $dict_dispatch_results] + } else { + if {[llength $returnkey] == 1} { + set invalid 0 + #todo - support multiple merge? + set right "" + if {[regexp -all {\|} $returnkey] == 1} { + lassign [split $returnkey |] left right + set joinparts [split $left ,] + } else { + set joinparts [split $returnkey ,] + } + foreach j [concat $joinparts $right] { + if {$j ni $flaginfo_returns} { + set invalid 1 + } + } + set returnval [list] + if {!$invalid} { + foreach j $joinparts { + lappend returnval {*}[dict get $combined $j] + } + if {[string length $right]} { + set returnval [dict merge $returnval $defaults $returnval] + } + } else { + set returnval [list callerrors [list "-return '$returnkey' not valid"]] + } + } else { + set callerrors [list] + set returnval [dict create] + foreach rk $returnkey { + if {$returnkey in $flaginfo_returns} { + dict set returnval $rk [dict get $combined $returnkey] + } else { + lappend callerrors [list "-return '$returnkey' not valid"] + } + } + if {[llength $callerrors]} { + dict set returnval callerrors $callerrors + } + } + } + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" + do_debug 1 $debugc "[string repeat - 40]" + + if {[string length $raise_dispatch_error_instead_of_return]} { + set errdebug [dict get $cf_args -debugargsonerror] + if {$errdebug > [dict get $cf_args -debugargs]} { + dict set debugc -debugargs $errdebug + } + } + + set debuglevel_return 2 + set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return + if {[llength [dict get $combined parseerrors]]} { + dict set debugdict "parseerrors" 0 + } else { + dict set debugdict "parseerrors" 2 + } + dict set debugdict "defaults" 1 + dict set debugdict "supplied" 1 + dict set debugdict "dispatch" 1 + dict set debugdict "ranges" 1 + dict set debugdict "rangesbytype" 1 + dict set debugdict "dispatchstatus" 1 + if {[dict get $combined "status"] eq "ok"} { + dict set debugdict "status" 1 + } else { + dict set debugdict "status" 0 + } + + do_debug 1 $debugc "returning '$returnkey'" + do_debug 1 $debugc "returnval '$returnval'" + if {([llength $returnval] % 2) == 0} { + do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" + } + do_debug 1 $debugc "[string repeat = 40]" + dict for {k v} $combined { + set dlev [dict get $debugdict $k] + switch -- $k { + dispatch { + set col1 [string repeat " " 12] + #process as paired list rather than dict (support repeated commands) + set i 0 + foreach {cmdname cmdinfo} $v { + set field1 [string repeat " " [expr {[string length $cmdname]}]] + set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] + set j 0 + foreach {ckey cval} $cmdinfo { + + if {$i == 0 && $j == 0} { + set c1 [overtype::left $col1 "dispatch"] + } else { + set c1 [overtype::left $col1 { ... }] + } + + if {$j == 0} { + set f1 [overtype::left $field1 $cmdname] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } else { + set f1 [overtype::left $field1 ...] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } + #leave at debug level 1 - because dispatch is generally important + do_debug $dlev $debugc "${c1}${c2} $cval" + + incr j + } + incr i + } + + #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" + #foreach {nm rem} [lrange $v 2 end] { + # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" + #} + } + dispatchresultlist { + set col1 [string repeat " " 25] + set i 0 + foreach dresult $v { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $dresult" + incr i + } + } + classifications { + set col1 [string repeat " " 25] + set len [dict size $v] + if {$len == 0} { + do_debug $dlev $debugc "[overtype::left $col1 $k]" + continue + } + set max [expr {$len -1}] + set numlines [expr $len / 3 + 1] + if {($len % 3) == 0} { + incr numlines -1 + } + set j 0 + for {set ln 0} {$ln < $numlines} {incr ln} { + if {$ln == 0} { + set c1 "[overtype::left $col1 $k]" + } else { + set c1 "[overtype::left $col1 { ... }]" + } + set line "" + for {set col 0} {$col < 3} {incr col} { + if {$j <= $max} { + append line "$j [list [dict get $v $j]] " + } + incr j + } + do_debug $dlev $debugc "$c1 [string trim $line]" + } + } + gridstring { + set col1 [string repeat " " 25] + set i 0 + foreach ln [split $v \n] { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $ln" + incr i + } + } + default { + set col1 [string repeat " " 25] + do_debug $dlev $debugc "[overtype::left $col1 $k] $v" + } + } + } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "DEBUG-END $caller" + if {[string length $raise_dispatch_error_instead_of_return]} { + return -code error $raise_dispatch_error_instead_of_return + } + + + return $returnval + } + + proc tailflagspaired {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set extraflags [list] + set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags? + #review + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + return $extraflags + } + + proc tailflagspaired1 {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] + + set extraflags [list] + + #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags with no value set + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + + } + + + +} + + +namespace eval flagfilter { + + #punk::lib::dict_merge_ordered + + + + #retrieve *only* names that are dependant on the provided namekey - not the key itself + # (query is sorted by the trailing numerical index which represents order the arguments were processed) + proc flag_array_get_sorted_subs {arrname sep namekey} { + upvar $arrname arr + set allsubs [array names arr ${namekey}.*${sep}name,*] + set rnames [lmap nm $allsubs {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + set ordered [lmap nm $sorted_rnames {string reverse $nm}] + return $ordered + } + + proc flag_array_get_sorted_siblings {arrname sep namekey} { + #determine parent by looking at dot - but confirm parent name is in array. + + } + + + + #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. + #use -dictionary to ensure embedded numbers are sorted as integers + proc array_names_sorted_by_tail {arrname nameglob} { + upvar $arrname arr + set matched_names [array names arr $nameglob] + set rnames [lmap nm $matched_names {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + return [lmap nm $sorted_rnames {string reverse $nm}] + } + + +} + +package provide [lassign {flagfilter 0.3.1} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + + + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index c8195b6e..e6bf4b9d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -186,8 +186,9 @@ tcl::namespace::eval punk::char { set r [list "" {*}[split $lowbits ""] $ridx {*}$charlist] $t add_row $r } - puts stderr $t - $t print + set result [$t print] + $t destroy + return $result } #just the 7-bit ascii. use [page ascii] for the 8-bit layout diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 85ef0692..84dca1df 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -916,19 +916,19 @@ namespace eval punk::mix::commandset::scriptwrap { return $configd } proc _get_nextshell_script {configd} { - #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" + #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" #@SET "nextshelltype[win32___________]=tcl_____________" - #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[dragonflybsd____]=tcl_____________" - #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[freebsd_________]=tcl_____________" - #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[netbsd__________]=tcl_____________" - #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[linux___________]=tcl_____________" - #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[macosx__________]=tcl_____________" - #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[other___________]=tcl_____________" #delimeters @@ -941,7 +941,7 @@ namespace eval punk::mix::commandset::scriptwrap { set n [expr {16 - [string length $os]}] set _os [string repeat _ $n] set path [dict get $v nextshellpath] - set n [expr {64 - [string length $path]}] + set n [expr {128 - [string length $path]}] set _path [string repeat _ $n] set type [dict get $v nextshelltype] set n [expr {16 - [string length $type]}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 731e263e..9d199997 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -2418,6 +2418,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #if {[lindex $command 0] eq "runx"} {} + #temporary hack. + #todo - use happy path return options for non-primary result (like www package) ? if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ [string equal "d/\n" $commandstr] || \ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm index 2ed4f1e4..02415ccd 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -283,9 +283,47 @@ tcl::namespace::eval punk::zip { #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) #Otherwise extract an internal preamble. - #if neither - + #if neither -? #review - reconsider auto-determination of internal vs external preamble - proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + set inzip [open $infile r] fconfigure $inzip -encoding iso8859-1 -translation binary if {[file exists $outfile_preamble]} { @@ -346,7 +384,7 @@ tcl::namespace::eval punk::zip { #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) #we can't assume they're ordered in any particular way - so we in theory have to look at them all. set baseoffset "unknown" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index b2ce1feb..8f03892d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -427,7 +427,7 @@ namespace eval shellrun { cmdarg -type any -multiple 1 -optional 1 }] proc runerr {args} { - set argd [punk::args::parse $args withid ::shellrun::runout] + set argd [punk::args::parse $args withid ::shellrun::runerr] lassign [dict values $argd] leaders opts values received if {[dict exists $received "-nonewline"]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm new file mode 100644 index 00000000..474ae8d3 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/flagfilter-0.3.1.tm @@ -0,0 +1,2718 @@ + +#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 {[dict exists $solodict $a]} { + set last_was_flag 0 + if {[dict exists $solo_accumulator $a]} { + set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] + } else { + set soloval [dict get $solodict $a] + } + dict set solo_accumulator $a $soloval + #we need to keep order of first appearance + set idx [lsearch $result $a] + if {$idx < 0} { + lappend result $a $soloval + } else { + lset result $idx+1 $soloval + } + } else { + if {!$last_was_flag} { + if {$a eq "--"} { + + } else { + if {[lindex $arglist $a_idx-1] eq "--"} { + #end of options processing - none of the remaining are considered flags/options no matter what they look like + set last_was_flag 0 + break + } else { + if {[string match -* $a]} { + set last_was_flag 1 + lappend result $a ;#flag + } else { + #last wasnt, this isn't - don't output + set last_was_flag 0 + } + } + } + } else { + #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. + if {$a eq "--"} { + #last was flag + set last_was_flag 0 + } else { + lappend result $a ;#value + set last_was_flag 0 + } + } + } + incr a_idx + } + if {([llength $result] % 2) != 0} { + set last [lindex $result end] + if {[string match -* $last] && ($last ni [dict keys $solodict])} { + lappend result 1 + } + } + #puts ">>>get_flagged_only returning $result" + return $result + } + + + ## get_one_paired_flag_value + #best called with 'catch' unless flag known to be in arglist + #raises an error if no position available after the flag to retrieve value + #raises an error if flag not like -something + #raises an error if flag not found in list + proc get_one_paired_flag_value {arglist flag} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { + #regexp excludes plain - and -- + #if {![string match -* $flag]} {} + error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" + } + set cindex [lsearch $arglist $flag] + if {$cindex >= 0} { + set valueindex [expr {$cindex + 1}] + if {$valueindex < [llength $arglist]} { + #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" + return [lindex $arglist $valueindex] + } else { + error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" + } + } else { + error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" + } + } +} + +namespace eval flagfilter::obj { + +} + + +namespace eval flagfilter { + variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. + #used as a basis for some object-instance names etc + proc get_new_runid {} { + variable run_counter + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" + } + + namespace export check_flags + proc do_debug {lvl debugconfig msg} { + if {$lvl <= [dict get $debugconfig -debugargs]} { + foreach ln [split $msg \n] { + puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" + flush stderr + } + } + } + + #---------------------------------------------------------------------- + # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed + #wiki.tcl-lang.org/page/dict+tips+and+tricks + proc isdict {v} { + if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { + return [expr {!([llength $v] % 2)}] + } else { + return [string match "value is a dict *" [::tcl::unsupported::representation $v]] + } + } + + proc dict_format {dict} { + dictformat_rec $dict "" " " + } + proc dictformat_rec {dict indent indentstring} { + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } + return $result + } + #-------------------------------------------------------------------------- + + #solo 'category' includes longopts with value + #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) + proc is_this_flag_solo {f solos objp} { + if {![string match -* $f]} { + #not even flaglike + return 0 + } + + + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } + + set p_opts [$objp get_combined_opts] + + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] + + if {$f in $singleopts} { + return 1 + } + + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } + + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # + + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + return $is_solo + } + #todo? support global (non-processor specific) mash list? -mashflags ? + proc is_this_flag_mash {f objp} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { + #not even flaglike + return 0 + } + set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc + + #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash + set singleopts pdict get $optinfo singleopts] + if {$f in $singleopts} { + return 0 + } + + set pairopts [dict get $optinfo pairopts] + if {$f in [dict keys $pairopts]} { + #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) + return 0 + } + set mashopts [dict get $optinfo mashopts] + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value + # .. in which case value could be at the tail of the mash.. or be the next arg in the list + # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value + # (ie such a mashopt is a solo that can take a value only as a mashtail) + # presence in pairopts indicates a mashflag must have a value + # presense in singleopts indicates mashflag takes no value ever. + # mashopt cannot be in both singleopts and pairopts. (NAND) + foreach l $flagletters { + if {-$l in $pairopts} { + if {"-$l" in $mashopts} { + #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. + # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt + break + } else { + #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash + set is_mash 0 + } + } elseif {"-$l" in $singleopts} { + #singleopt & mashopt - cannot take a value, mashed or otherwise + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } else { + if {"-$l" ni $mashopts} { + set is_mash 0 + } else { + #present only in mashopts - can take a value, but only immediately following in the mash + break + } + } + } + return $is_mash + } + proc is_this_flag_for_me {f objp cf_args} { + set processorname [$objp name] + set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc + + if {$processorname in [list "tail_processor"]} { + return 1 + } + if {$processorname in [list "global"]} { + #todo - mashflags for global? + set defaults [dict get $cf_args -defaults] + set extras [dict get $cf_args -extras] + set soloflags [dict get $cf_args -soloflags] + if {$f in [concat $extras $soloflags [dict keys $defaults]]} { + return 1 + } + } + + set singleopts [dict get $optinfo singleopts] + if {"any" in [string tolower $singleopts]} { + #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? + return 1 + } + set pairopts [dict get $optinfo pairopts] + set allopts [concat $singleopts [dict keys $pairopts]] + if {$f in $allopts} { + return 1 + } + + #process mashopts last + set mashopts [dict get $optinfo mashopts] + if {"any" in [string tolower $mashopts]} { + #if 'all' in mashopts - it can eat anything - review - is this even useful? + return 1 + } else { + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash + foreach l $flagletters { + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } + return $is_mash + } + + return 0 + } + + + + proc add_dispatch_raw {recordvar parentname v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo + } + } + proc add_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo + } + } + proc lsearch-all-stride-2 {l search} { + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] + } + proc update_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo + } + } + + #Note the difference between this and is_command_match. + #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters + #Note that this isn't a general test to be applied to the entire argument list. + # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor + # so this test only applies during the ordered examination of args + proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { + set cmdinfo [lindex $cspec 1] + if {$cmdinfo eq "tail_processor"} { + return 1 + } + if {$cmdinfo eq "global"} { + set defaults [dict get $cf_args -defaults] + set soloflags [dict get $cf_args -soloflags] + set extras [dict get $cf_args -extras] + if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { + return 1 + } + } + if {![dict exists $cmdinfo match]} { + return 1 + } + set matchspeclist [dict get $cmdinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + #only block it if there was a match pattern specified but it didn't match + return 0 + } + #Note - returns false for a cspec that has no match specified. + #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this + # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. + proc is_command_match {flag cspec} { + set pinfo [lindex $cspec 1] + if {[dict exists $pinfo match]} { + set matchspeclist [dict get $pinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + proc is_command_match_any {f commandprocessors} { + foreach comspec $commandprocessors { + lassign $comspec cmdname cmdinfo + if {[dict exists $cmdinfo match]} { + set matchlist [dict get $cmdinfo match] + foreach matchspec $matchlist { + if {[regexp -- $matchspec $f]} { + #actually a command + return true + } + } + } + } + return false + } + + #determine if f is potentially a flag that takes a parameter from the next argument. + #e.g --x=y (longopt) does not consume following arg but --something *might* + proc is_candidate_toplevel_param_flag {f solos commandprocessors} { + if {[is_command_match_any $f $commandprocessors]} { + return false + } + if {$f in $solos} { + return 0 + } + if {$f in {- --}} { + return 0 + } + #longopts (--x=blah) and alternative --x blah + #possibly also -x=blah + if {[string match -* $f]} { + if {[string first "=" $f]>1} { + return 0 + } + } + return [expr {[string match -* $f]}] + } + + + + + + + + + + + + + + + + + + + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? + #todo - show caller info + proc assert_equal {a b} { + if {![expr {$a eq $b}]} { + error "assert_equal $a $b" + } + } + + + + + + #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map + #1 2 3 4 5 6 ;#original list posns example + # 2 6 ;#map_remaining example (scanlist) + #1 3 4 5 ;#map_allocated example + #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example + oo::class create class_vmap { + variable o_map + variable o_remaining + variable o_allocated + variable o_values + variable o_codemap + variable o_flagcategory + constructor {values} { + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ + ] + set o_flagcategory [list "flag" "flagvalue" "soloflag"] + set o_values $values + #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 + #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ + if {[llength $values]} { + if {[llength $values] < 30} { + #common case is short lists - but we don't want to penalize large lists + set o_remaining [lsearch -all $values *] + } else { + #punk::lib::range wraps lseq if available + set o_remaining [punk::lib::range 0 [llength $values]-1] + } + } else { + set o_remaining [list] + } + set o_allocated [list] + set o_map [list] + foreach posn $o_remaining { + 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]} { + switch -- $type { + flag - flagvalue - soloflag {} + default { + 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]} { + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } + } + } + } + return $list_flagged + } + + method get_merged_flagged_by_class {classmatch} { + variable flagcategory + set all_flagged [list] + set seenflag [dict create] ;#key = -flagname val=earliest vindex + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + set a [llength $all_flagged] ;#index into all_flagged list we are building + switch -- $type { + soloflag { + if {[dict exists $seenflag $val]} { + set seenindex [dict get $seenflag $val] + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? + lset all_flagged $seenindexplus $existingvals + } else { + dict set seenflag $val $a + lappend all_flagged $val 1 + } + } + flag { + if {![dict exists $seenflag $val]} { + dict set seenflag $val $a + lappend all_flagged $val + } + #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. + } + flagvalue { + set idxflagfor [expr {$k -1}] + set flagforinfo [dict get $o_map $idxflagfor] + lassign $flagforinfo ffclass fftype ffval + #jn "--" following a flag could result in us getting here accidentaly.. review + set seenindex [dict get $seenflag $ffval] + if {$seenindex == [expr {$a-1}]} { + #usual case - this is a flagvalue following the first instance of the flag + lappend all_flagged $val + } else { + #write the value back to the seenindex+1 + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals $val ;#we keep multiples as a list + lset all_flagged $seenindexplus $existingvals + } + } + } + } + } + return $all_flagged + } + method typedrange_class_type_from_arg {argclass argtype} { + #set o_flagcategory [list "flag" "flagvalue" "soloflag"] + if {$argclass eq "unallocated"} { + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + default { + if {![string length $argtype]} { + #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . + set argtype UNKNOWN + } + return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions + } + } + } 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append remline [overtype::left $col $tp] + } + } + set cmdlist [list] + dict for {vidx info} $o_map { + if {[lindex $info 0] ne "unallocated"} { + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } + } + } + set 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] + if {[dict exists $o_codemap $type]} { + set tp [dict get $o_codemap $type] + } + append cline [overtype::left $col $tp] + } else { + append cline [overtype::left $col "."] + } + } + 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] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $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 + } + } + + #assertion - should be none? + #set remaining_values [lrange $source_values $a_index end] + #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" + + do_debug 2 $debugc "========>=========>originals : $values" + do_debug 2 $debugc "[$VMAP get_map]" + do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" + + + + + + set all_flagged [$VMAP get_merged_flagged_by_class *] + set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] + + set all_flagged_list [$VMAP get_list_flagged_by_class *] + set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] + + set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] + + set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] + + + set unflagged_list_in_processing_order [dict values $unflagged] + set unflagged_list [$VMAP get_list_unflagged_by_class *] + + set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] + + return [dict create \ + listremaining $unconsumed_flags_and_values \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ + ] + } + + + + + + + + + + + + #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 {- --}} { + 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] + } + } + + #todo - rename 'cprocessor' is misleading + 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 { + #review - unix paths? conflict with windows style flag such as /w + #must accept empty string + 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]} { + lappend o_mashopts {*}[dict get $o_pinfo mashopts] + } + if {[dict exists $o_pinfo singleopts]} { + lappend o_singleopts {*}[dict get $o_pinfo singleopts] + } + if {[dict exists $o_pinfo pairopts]} { + lappend o_pairopts {*}[dict get $o_pinfo pairopts] + } + if {[dict exists $o_pinfo longopts]} { + lappend o_longopts {*}[dict get $o_pinfo longopts] + } + } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } + + 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 {- --}} { + #specials not defined as solos + return 0 + } + + if {$o_name eq "global"} { + + } elseif {$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] + #does order matter? could use struct::set union ? + 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 && [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\ + -caller $caller\ + -return [list arglistremaining]\ + -match [list]\ + -commandprocessors [list]\ + -soloflags [list]\ + -extras [list]\ + -defaults [list]\ + -required [list]\ + -values \uFFFF\ + -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_args $cf_defaults + foreach {k v} $args { + switch -- $k { + -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { + dict set cf_args $k $v + } + default { + do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" + } + } + } + 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]] ;#why -nocase? why should -l and -L collapse to the uppercase version? + set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] + foreach spec $command_specs { + lassign $spec parentname pinfo + if {[string match -* $parentname] && $parentname ni $known_flags} { + 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 && $f ni $known_flags} { + lappend invalid_flags $f + } + } + } + if {[llength $invalid_flags]} { + do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" + } + + set calc_required [list] + set keywords_in_required [lsearch -inline -all -not $required -*] + set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] + if {[llength $bad_keywords_in_required]} { + do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" + } + #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none + if {[llength $keywords_in_required] > 1} { + do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." + } + if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { + set calc_required [list] + } + set flags [lsearch -inline -all $required -*] + + if {[llength $required]} { + if {[lsearch -nocase $keywords_in_required "all"] >= 0} { + #'all' can be present with other flags - and indicates we also require all the flags from -defaults + dict for {k -} $defaults { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list + set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] + set ranges [dict get $rangesets -ranges] + set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. + #tailflags are the same for all dispatch items + set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] + + + set dict_supplied [dict create supplied $supplied] + set dict_defaults [dict create defaults $defaults] + set dict_ranges [dict create ranges $ranges] + set dict_rangesbytype [dict create rangesbytype $rangesbytype] + set raise_dispatch_error_instead_of_return "" + set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] + #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + + if {[llength $dispatch]} { + set dispatchstatuslist [list] + set dispatchresultlist [list] + set dispatchstatus "ok" + #each dispatch entry is a commandname and dict + #set dispatchrecord [lrange $dispatch 0 1] + set re_argnum {%arg([0-9^%]+)%} + set re_argtake {%argtake([0-9^%]+)%} + set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline + #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} + #dumb-editor rebalancing quote for above comment " + foreach {parentname dispatchrecord} $dispatch { + set commandinfo [get_command_info $parentname $command_specs] + + do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" + + # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x + + do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" + set command [dict get $dispatchrecord command] + #support for %x% placeholders in dispatchrecord command + set command [string map {%match% %matched%} $command] ;#alias + set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] + + set argnum_indices [regexp -indices -all -inline $re_argnum $command] + if {[llength $argnum_indices]} { + foreach {argx_indices x_indices} $argnum_indices { + #argx eg %arg12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] + } + } + + set argsreduced [dict get $dispatchrecord arguments] + #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] + + #review! + #how will this behave differently on unix + package require punk::winrun + set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] + #set argtake_indices [regexp -indices -all -inline $re_argtake $command] + + + set start 0 + while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { + #argx eg %argtake12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set argval [lindex [dict get $dispatchrecord arguments] $x] + set replacementlen [string length $argval] + set command [string map [list $argx $argval] $command] + set start [expr {[lindex $argx_indices 0] + $replacementlen}] + set argsreduced [lremove $argsreduced $x] + set rawparts [lremove $rawparts $x] + } + dict set dispatchrecord arguments $argsreduced + if {$start > 0} { + set rawreduced [join $rawparts] + dict set dispatchrecord raw $rawreduced + } + + set argvals [dict get $dispatchrecord arguments] + set matched_operands [list] + set matched_opts [list] + set matched_in_order [list] + set prefix "${parentname}." + set prefixlen [string length $prefix] + foreach {k v} $argvals { + #puts "$$$$ $k" + if {[string equal -length $prefixlen $prefix $k]} { + #key is prefixed with "commandname." + set k [string replace $k 0 $prefixlen-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 + switch -- $dispatchtype { + tcl { + do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" + #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] + set commandline [concat $command $matched_operands $matched_opts $extraflags] + } + raw { + do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" + #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] + set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] + } + shell { + do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" + #assume the shell arguments are in one quoted string? + set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] + } + default { + #non quoted shell? raw + defaults? + do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" + #set commandline [list $command {*}$matched_in_order {*}$extraflags] + set commandline [concat $command $matched_in_order $extraflags] + } + } + + + + + dict set dispatchrecord asdispatched $commandline + set dispatchresult "" + set dispatcherror "" + if {![catch {{*}$commandline} cmdresult]} { + set dispatchresult $cmdresult + lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] + lappend dispatchresultlist $cmdresult + } else { + set dispatchstatus "error" + set dispatcherror $cmdresult + #don't add to dispatchresultlist + lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] + if {!$was_dispatched_by_another} { + #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning + set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + + break + #return -code error "check_flags error during command dispatch:\n$cmdresult" + } + #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist + } + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + } + + set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] + } + #end llength $dispatch + + + set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] + dict set combined dispatch $dispatch ;#update with asdispatched info + if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { + dict set combined status "ok" + } else { + dict set combined status "error" + } + do_debug 1 $debugc "COMBINED:$combined" + + + set returnkey [string tolower $returnkey] + if {"all" in $returnkey} { + set returnval $combined + #set returnval [dict merge $combined $dict_dispatch_results] + } else { + if {[llength $returnkey] == 1} { + set invalid 0 + #todo - support multiple merge? + set right "" + if {[regexp -all {\|} $returnkey] == 1} { + lassign [split $returnkey |] left right + set joinparts [split $left ,] + } else { + set joinparts [split $returnkey ,] + } + foreach j [concat $joinparts $right] { + if {$j ni $flaginfo_returns} { + set invalid 1 + } + } + set returnval [list] + if {!$invalid} { + foreach j $joinparts { + lappend returnval {*}[dict get $combined $j] + } + if {[string length $right]} { + set returnval [dict merge $returnval $defaults $returnval] + } + } else { + set returnval [list callerrors [list "-return '$returnkey' not valid"]] + } + } else { + set callerrors [list] + set returnval [dict create] + foreach rk $returnkey { + if {$returnkey in $flaginfo_returns} { + dict set returnval $rk [dict get $combined $returnkey] + } else { + lappend callerrors [list "-return '$returnkey' not valid"] + } + } + if {[llength $callerrors]} { + dict set returnval callerrors $callerrors + } + } + } + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" + do_debug 1 $debugc "[string repeat - 40]" + + if {[string length $raise_dispatch_error_instead_of_return]} { + set errdebug [dict get $cf_args -debugargsonerror] + if {$errdebug > [dict get $cf_args -debugargs]} { + dict set debugc -debugargs $errdebug + } + } + + set debuglevel_return 2 + set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return + if {[llength [dict get $combined parseerrors]]} { + dict set debugdict "parseerrors" 0 + } else { + dict set debugdict "parseerrors" 2 + } + dict set debugdict "defaults" 1 + dict set debugdict "supplied" 1 + dict set debugdict "dispatch" 1 + dict set debugdict "ranges" 1 + dict set debugdict "rangesbytype" 1 + dict set debugdict "dispatchstatus" 1 + if {[dict get $combined "status"] eq "ok"} { + dict set debugdict "status" 1 + } else { + dict set debugdict "status" 0 + } + + do_debug 1 $debugc "returning '$returnkey'" + do_debug 1 $debugc "returnval '$returnval'" + if {([llength $returnval] % 2) == 0} { + do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" + } + do_debug 1 $debugc "[string repeat = 40]" + dict for {k v} $combined { + set dlev [dict get $debugdict $k] + switch -- $k { + dispatch { + set col1 [string repeat " " 12] + #process as paired list rather than dict (support repeated commands) + set i 0 + foreach {cmdname cmdinfo} $v { + set field1 [string repeat " " [expr {[string length $cmdname]}]] + set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] + set j 0 + foreach {ckey cval} $cmdinfo { + + if {$i == 0 && $j == 0} { + set c1 [overtype::left $col1 "dispatch"] + } else { + set c1 [overtype::left $col1 { ... }] + } + + if {$j == 0} { + set f1 [overtype::left $field1 $cmdname] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } else { + set f1 [overtype::left $field1 ...] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } + #leave at debug level 1 - because dispatch is generally important + do_debug $dlev $debugc "${c1}${c2} $cval" + + incr j + } + incr i + } + + #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" + #foreach {nm rem} [lrange $v 2 end] { + # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" + #} + } + dispatchresultlist { + set col1 [string repeat " " 25] + set i 0 + foreach dresult $v { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $dresult" + incr i + } + } + classifications { + set col1 [string repeat " " 25] + set len [dict size $v] + if {$len == 0} { + do_debug $dlev $debugc "[overtype::left $col1 $k]" + continue + } + set max [expr {$len -1}] + set numlines [expr $len / 3 + 1] + if {($len % 3) == 0} { + incr numlines -1 + } + set j 0 + for {set ln 0} {$ln < $numlines} {incr ln} { + if {$ln == 0} { + set c1 "[overtype::left $col1 $k]" + } else { + set c1 "[overtype::left $col1 { ... }]" + } + set line "" + for {set col 0} {$col < 3} {incr col} { + if {$j <= $max} { + append line "$j [list [dict get $v $j]] " + } + incr j + } + do_debug $dlev $debugc "$c1 [string trim $line]" + } + } + gridstring { + set col1 [string repeat " " 25] + set i 0 + foreach ln [split $v \n] { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $ln" + incr i + } + } + default { + set col1 [string repeat " " 25] + do_debug $dlev $debugc "[overtype::left $col1 $k] $v" + } + } + } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "DEBUG-END $caller" + if {[string length $raise_dispatch_error_instead_of_return]} { + return -code error $raise_dispatch_error_instead_of_return + } + + + return $returnval + } + + proc tailflagspaired {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set extraflags [list] + set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags? + #review + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + return $extraflags + } + + proc tailflagspaired1 {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] + + set extraflags [list] + + #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags with no value set + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + + } + + + +} + + +namespace eval flagfilter { + + #punk::lib::dict_merge_ordered + + + + #retrieve *only* names that are dependant on the provided namekey - not the key itself + # (query is sorted by the trailing numerical index which represents order the arguments were processed) + proc flag_array_get_sorted_subs {arrname sep namekey} { + upvar $arrname arr + set allsubs [array names arr ${namekey}.*${sep}name,*] + set rnames [lmap nm $allsubs {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + set ordered [lmap nm $sorted_rnames {string reverse $nm}] + return $ordered + } + + proc flag_array_get_sorted_siblings {arrname sep namekey} { + #determine parent by looking at dot - but confirm parent name is in array. + + } + + + + #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. + #use -dictionary to ensure embedded numbers are sorted as integers + proc array_names_sorted_by_tail {arrname nameglob} { + upvar $arrname arr + set matched_names [array names arr $nameglob] + set rnames [lmap nm $matched_names {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + return [lmap nm $sorted_rnames {string reverse $nm}] + } + + +} + +package provide [lassign {flagfilter 0.3.1} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + + + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index c8195b6e..e6bf4b9d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -186,8 +186,9 @@ tcl::namespace::eval punk::char { set r [list "" {*}[split $lowbits ""] $ridx {*}$charlist] $t add_row $r } - puts stderr $t - $t print + set result [$t print] + $t destroy + return $result } #just the 7-bit ascii. use [page ascii] for the 8-bit layout diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 85ef0692..84dca1df 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -916,19 +916,19 @@ namespace eval punk::mix::commandset::scriptwrap { return $configd } proc _get_nextshell_script {configd} { - #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" + #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" #@SET "nextshelltype[win32___________]=tcl_____________" - #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[dragonflybsd____]=tcl_____________" - #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[freebsd_________]=tcl_____________" - #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[netbsd__________]=tcl_____________" - #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[linux___________]=tcl_____________" - #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[macosx__________]=tcl_____________" - #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[other___________]=tcl_____________" #delimeters @@ -941,7 +941,7 @@ namespace eval punk::mix::commandset::scriptwrap { set n [expr {16 - [string length $os]}] set _os [string repeat _ $n] set path [dict get $v nextshellpath] - set n [expr {64 - [string length $path]}] + set n [expr {128 - [string length $path]}] set _path [string repeat _ $n] set type [dict get $v nextshelltype] set n [expr {16 - [string length $type]}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 731e263e..9d199997 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -2418,6 +2418,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #if {[lindex $command 0] eq "runx"} {} + #temporary hack. + #todo - use happy path return options for non-primary result (like www package) ? if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ [string equal "d/\n" $commandstr] || \ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm index 2ed4f1e4..02415ccd 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -283,9 +283,47 @@ tcl::namespace::eval punk::zip { #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) #Otherwise extract an internal preamble. - #if neither - + #if neither -? #review - reconsider auto-determination of internal vs external preamble - proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + set inzip [open $infile r] fconfigure $inzip -encoding iso8859-1 -translation binary if {[file exists $outfile_preamble]} { @@ -346,7 +384,7 @@ tcl::namespace::eval punk::zip { #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) #we can't assume they're ordered in any particular way - so we in theory have to look at them all. set baseoffset "unknown" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index b2ce1feb..8f03892d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -427,7 +427,7 @@ namespace eval shellrun { cmdarg -type any -multiple 1 -optional 1 }] proc runerr {args} { - set argd [punk::args::parse $args withid ::shellrun::runout] + set argd [punk::args::parse $args withid ::shellrun::runerr] lassign [dict values $argd] leaders opts values received if {[dict exists $received "-nonewline"]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 85ef0692..84dca1df 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -916,19 +916,19 @@ namespace eval punk::mix::commandset::scriptwrap { return $configd } proc _get_nextshell_script {configd} { - #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" + #@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" #@SET "nextshelltype[win32___________]=tcl_____________" - #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[dragonflybsd____]=tcl_____________" - #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[freebsd_________]=tcl_____________" - #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[netbsd__________]=tcl_____________" - #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[linux___________]=tcl_____________" - #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[macosx__________]=tcl_____________" - #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" + #@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" #@SET "nextshelltype[other___________]=tcl_____________" #delimeters @@ -941,7 +941,7 @@ namespace eval punk::mix::commandset::scriptwrap { set n [expr {16 - [string length $os]}] set _os [string repeat _ $n] set path [dict get $v nextshellpath] - set n [expr {64 - [string length $path]}] + set n [expr {128 - [string length $path]}] set _path [string repeat _ $n] set type [dict get $v nextshelltype] set n [expr {16 - [string length $type]}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 6642a26f..fa5f30e4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -95,19 +95,19 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @REM If more than 64 chars needed for a target, it can still be done but overall script padding may need checking/adjusting @REM Supporting more explicit oses than those listed may also require script padding adjustment : <> -@SET "nextshellpath[win32___________]=tclsh___________________________________________________________" +@SET "nextshellpath[win32___________]=tclsh___________________________________________________________________________________________________________________________" @SET "nextshelltype[win32___________]=tcl_____________" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[dragonflybsd____]=tcl_____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[freebsd_________]=tcl_____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[netbsd__________]=tcl_____________" -@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[linux___________]=tcl_____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[macosx__________]=tcl_____________" -@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________" +@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________________________________________________________________________________________________________" @SET "nextshelltype[other___________]=tcl_____________" : <> @rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). @@ -119,7 +119,7 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed @REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @SET "selected_shellpath=%nextshellpath[win32___________]%" -@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed +@CALL :stringTrimTrailingUnderscores "%selected_shellpath%" selected_shellpath_trimmed @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @REM @ECHO keyremoved %keyRemoved% @REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available @@ -151,6 +151,7 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @SET "winpath=%~dp0" %= e.g c:\punkshell\bin\ %= @SET "fname=%~nx0" @SET "scriptrootname=%~dp0%~n0" %= e.g c:\punkshell\bin\runtime (full path without extension) unavailable after shift, so store it =% +@SET "fullscriptname=%~dp0%~n0%~x0" @REM @ECHO fname %fname% @REM @ECHO winpath %winpath% @REM @ECHO commandlineascalled %0 @@ -162,6 +163,62 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @CALL :stringToUpper %~nx0 capscripttail @REM @ECHO capscriptname: %capscripttail% +@goto skip_parameter_wrangling +@set argCount=30 +@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe +@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon +@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. +@set tmpfile_base=%TEMP%\punkbatch_params +@call :getUniqueFile %tmpfile_base% ".txt" paramfile +@echo %paramfile% + +%= NOTE when we loop like this using the percent-n args and shift, we lose unquoted separators such as comma and semicolon %= +@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 +@rem outer loop required to redirect all rem lines at once to file +@for %%x in (1) do @( + @for /L %%f in (1,1,%argCount%) do @( + @set "argnum=%%~nf" + @set "a1=%%1" + @rem @set "argname=%%!argnum!" + @rem @echo argname: !argname! + @call :rem_output !argnum! !a1! + @shift + ) +) > %paramfile% +@echo off + +@set "newcommandline= " + +@(set target=cmd_pwsh) +@if "%target%"=="cmd_pwsh" ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + @REM @echo ######### %%L + @rem call :buildcmdline newcommandline param "{" "}" + @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= + call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= + @rem @echo . + ) +) ELSE ( + @for /F "delims=" %%L in (%paramfile%) do @( + SETLOCAL DisableDelayedExpansion + set "param=%%L" + call :buildcmdline newcommandline param + ) +) +@REM padding +SETLOCAL EnableDelayedExpansion +@echo off +@IF EXIST %paramfile% ( + @DEL /F /Q %paramfile% +) +@IF EXIST %paramfile% ( + echo failed to delete %paramfile% + cat %paramfile% +) +:skip_parameter_wrangling + @IF "%nftail%"=="%capscripttail%" ( @ECHO forcing asadmin=1 due to file name on filesystem being uppercase @SET "asadmin=1" @@ -189,31 +246,112 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% :getPrivileges @IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) @ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" -@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@ECHO pre = "/c %fullscriptname% PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@REM @echo pre = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" +@echo args = pre >> "%vbsGetPrivileges%" @ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" -@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" +@ECHO args = args ^& Chr(34) ^& strArg ^& Chr(34) ^& " " >> "%vbsGetPrivileges%" @ECHO Next >> "%vbsGetPrivileges%" -@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%" -@ECHO Launching script in new window due to administrator elevation +@GOTO skiptest + +%= Option Explicit =% +%= We need a child process to locate the current script. =% +@ECHO Const FLAG_PROCESS = "winver.exe" >> "%vbsGetPrivileges%" + +%= ' WMI constants %= +@ECHO Const wbemFlagForwardOnly = 32 >> "%vbsGetPrivileges%" + +%=' Generate a unique value to be used as a flag =% +@ECHO Dim guid >> "%vbsGetPrivileges% +@ECHO guid = Left(CreateObject("Scriptlet.TypeLib").GUID,38) >> "%vbsGetPrivileges%" + +%= ' Start a process using the indicated flag inside its command line =% +@ECHO WScript.CreateObject("WScript.Shell").Run """" ^& FLAG_PROCESS ^& """ " ^& guid, 0, False >> "%vbsGetPrivileges%" + +%= ' To retrieve process information a WMI reference is needed =% +@ECHO Dim wmi >> "%vbsGetPrivileges%" +@ECHO Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}^!\\.\root\cimv2") >> "%vbsGetPrivileges%" + +%= ' Query the list of processes with the flag in its command line, retrieve the =% +%= ' process ID of its parent process ( our script! ) and terminate the process =% +@ECHO Dim colProcess, process, myProcessID >> "%vbsGetPrivileges%" +@ECHO Set colProcess = wmi.ExecQuery( _>> "%vbsGetPrivileges%" +@ECHO "SELECT ParentProcessID From Win32_Process " ^& _>> "%vbsGetPrivileges%" +@ECHO "WHERE Name='" ^& FLAG_PROCESS ^& "' " ^& _>> "%vbsGetPrivileges%" +@ECHO "AND CommandLine LIKE '%%" ^& guid ^& "%%'" _>> "%vbsGetPrivileges%" +@ECHO ,"WQL" , wbemFlagForwardOnly _>> "%vbsGetPrivileges%" +@ECHO ) >> "%vbsGetPrivileges%" +@ECHO For Each process In colProcess >> "%vbsGetPrivileges%" +@ECHO myProcessID = process.ParentProcessID >> "%vbsGetPrivileges%" +@ECHO process.Terminate >> "%vbsGetPrivileges%" +@ECHO Next >> "%vbsGetPrivileges%" + +%= ' Knowing the process id of our script we can query the process list =% +%= ' and retrieve its command line =% +@ECHO Dim commandLine >> "%vbsGetPrivileges%" +@ECHO set colProcess = wmi.ExecQuery( _>> "%vbsGetPrivileges%" +@ECHO "SELECT CommandLine From Win32_Process " ^& _>> "%vbsGetPrivileges%" +@ECHO "WHERE ProcessID=" ^& myProcessID _>> "%vbsGetPrivileges%" +@ECHO ,"WQL" , wbemFlagForwardOnly _>> "%vbsGetPrivileges%" +@ECHO ) >> "%vbsGetPrivileges%" +@ECHO For Each process In colProcess >> "%vbsGetPrivileges%" +@ECHO commandLine = process.CommandLine >> "%vbsGetPrivileges%" +@ECHO Next >> "%vbsGetPrivileges%" +@ECHO WScript.Echo "raw commandline: " ^& commandLine >>"%vbsGetPrivileges%" + +%= ' Done =% +@ECHO intpos = 0 >> "%vbsGetPrivileges%" +@ECHO intCount = 0 >> "%vbsGetPrivileges%" +@ECHO intstartsearch = 1 >> "%vbsGetPrivileges%" +@ECHO intmax = 100 >> "%vbsGetPrivileges%" +@ECHO do While intCount ^< 4 and intmax ^> 0 >> "%vbsGetPrivileges%" +@ECHO intpos = InStr(intstartsearch, commandline, """") >> "%vbsGetPrivileges%" +@ECHO if intpos ^<^> 0 then >> "%vbsGetPrivileges%" +@ECHO intCount = intCount + 1 >> "%vbsGetPrivileges%" +@ECHO if intcount = 4 then >> "%vbsGetPrivileges%" +@ECHO ' wscript.echo "position: " ^& intpos >> "%vbsGetPrivileges%" +@ECHO commandline = Mid(commandline,intpos+1) >> "%vbsGetPrivileges%" +@ECHO exit do >> "%vbsGetPrivileges%" +@ECHO else >> "%vbsGetPrivileges%" +@ECHO intstartsearch = intpos + 1 >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO intmax = intmax -1 >> "%vbsGetPrivileges%" +@ECHO Loop >> "%vbsGetPrivileges%" +@ECHO if intcount ^< 4 then >> "%vbsGetPrivileges%" +@ECHO err.raise vbObjectError + 1001, "vbsGetPrivileges", "failed to parse commandline" >> "%vbsGetPrivileges%" +@ECHO end if >> "%vbsGetPrivileges%" +@ECHO commandline = pre ^& commandline >> "%vbsGetPrivileges%" +@ECHO WScript.Echo "commandline: " ^& commandLine >>"%vbsGetPrivileges%" +@ECHO WScript.Echo "args: " ^& args >>"%vbsGetPrivileges%" +:skiptest + +@ECHO UAC.ShellExecute "cmd.exe", args, "", "runas", 1 >> "%vbsGetPrivileges%" +@REM @ECHO UAC.ShellExecute "%fullscriptname%", commandline, "", "runas", 1 >> "%vbsGetPrivileges%" +@ECHO Launching script "%fullscriptname%" in new window due to administrator elevation with args: "%*" @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* +@REM @"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" !newcommandline! @EXIT /B +@REM buffer +@REM buffer :gotPrivileges @REM setlocal & pushd . @PUSHD . -@cd /d %~dp0 +@cd /d %winpath% @IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( @DEL "%vbsGetPrivileges%" 1>nul 2>nul @SET arglist=%arglist:~14% + @SHIFT ) :skip_privileges @SET need_ps1=0 @REM we want the ps1 to exist even if the nextshell isn't powershell -@if not exist "%~dp0%~n0.ps1" ( +@if not exist "%scriptrootname%.ps1" ( @SET need_ps1=1 ) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different + fc "%fullscriptname%" "%scriptrootname%.ps1" >nul || goto different @REM @ECHO "files same" @SET need_ps1=0 ) @@ -223,74 +361,13 @@ set ^"endlocal=for %%# in (1 2) do if %%#==2 (%\n% @SET need_ps1=1 :pscontinue @IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL + COPY "%fullscriptname%" "%scriptrootname%.ps1" >NUL ) @REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? @IF "!selected_shelltype_trimmed!"=="none" ( SET selected_shelltype_trimmed=pwsh ) - - - -@set argCount=30 -@rem This is the max number of args we are willing to handle. also bounded by approx 8k char limit of cmd.exe -@rem We do not loop over %* to count args as it is brittle for some inputs e.g will always skip cmd.exe separators e.g comma and semicolon -@rem Set argCount higher if desired, but there is a small amount of additional looping overhead. - -@set tmpfile_base=%TEMP%\punkbatch_params -@call :getUniqueFile %tmpfile_base% ".txt" paramfile -@echo %paramfile% - -%= NOTE when we loop like this using the percent-n args, we lose unquoted separators such as comma and semicolon %= -@rem https://stackoverflow.com/questions/26551/how-can-i-pass-arguments-to-a-batch-file/5493124#5493124 -@rem outer loop required to redirect all rem lines at once to file -@for %%x in (1) do @( - @for /L %%f in (1,1,%argCount%) do @( - @set "argnum=%%~nf" - @set "a1=%%1" - @rem @set "argname=%%!argnum!" - @rem @echo argname: !argname! - @call :rem_output !argnum! !a1! - @shift - ) -) > %paramfile% -@echo off - -@set "newcommandline= " - -@(set target=cmd_pwsh) -@if "%target%"=="cmd_pwsh" ( - @for /F "delims=" %%L in (%paramfile%) do @( - SETLOCAL DisableDelayedExpansion - set "param=%%L" - @REM @echo ######### %%L - @rem call :buildcmdline newcommandline param "{" "}" - @rem call :buildcmdline newcommandline param ' ' %= cmd.exe /c powershell ... -c %= - call :buildcmdline newcommandline param %= cmd.exe /c powershell ... -f %= - @rem @echo . - ) -) ELSE ( - @for /F "delims=" %%L in (%paramfile%) do @( - SETLOCAL DisableDelayedExpansion - set "param=%%L" - call :buildcmdline newcommandline param - ) -) -@REM padding -SETLOCAL EnableDelayedExpansion - -@echo off -@IF EXIST %paramfile% ( - @DEL /F /Q %paramfile% -) -@IF EXIST %paramfile% ( - echo failed to delete %paramfile% - cat %paramfile% -) - - - @REM @SET "squoted_args=" @REM @for %%a in (%*) do @( @REM set "v=%%a" @@ -311,19 +388,24 @@ SETLOCAL EnableDelayedExpansion REM fallback to powershell if pwsh failed IF !pwshtest_exitcode!==0 ( @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%scriptrootname%.ps1" %arglist% - @rem pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted - cmd /c pwsh -nop -nol -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! + @rem pwsh -nop -nologo -ExecutionPolicy bypass -f "%scriptrootname%.ps1" %arglist% %= ok =% + @rem cmd /c pwsh -nop -nologo -ExecutionPolicy bypass -f "%scriptrootname%.ps1" !newcommandline! + !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% SET task_exitcode=!errorlevel! ) ELSE ( REM TODO prompt user with option to call script to install pwsh using winget - @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% - cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! + %= powershell with -file flag treats it's arguments differently to pwsh - we need cmd /c to preserve args with spaces =% + cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ) ELSE ( IF "!selected_shelltype_trimmed!"=="powershell" ( - @rem powershell -nop -nol -ExecutionPolicy Bypass -c "%scriptrootname%.ps1" %arglist% - cmd /c powershell -nop -nol -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! + %= powershell with -file flag treats it's arguments differently to pwsh - we need cmd /c to preserve args with spaces =% + @rem @echo powershell - !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" %arglist% %= ok - this works =% + !selected_shellpath_trimmed! "%scriptrootname%.ps1" %arglist% + @rem cmd /c powershell -nop -nologo -ExecutionPolicy Bypass -f "%scriptrootname%.ps1" !newcommandline! SET task_exitcode=!errorlevel! ) ELSE ( IF "!selected_shelltype_trimmed!"=="wslbash" ( @@ -337,24 +419,23 @@ SETLOCAL EnableDelayedExpansion REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode - @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" - %selected_shellpath_trimmed% "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; + @REM @ECHO HERE "!selected_shelltype_trimmed!" "!selected_shellpath_trimmed!" + !selected_shellpath_trimmed! "%winpath%%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 @REM boundary padding - GOTO :exit_multishell ) ) ) ) @REM batch file library functions - @GOTO :endlib @REM padding @REM padding @REM padding +@REM padding %= ---------------------------------------------------------------------- =% @rem courtesy of dbenham @@ -458,6 +539,7 @@ do if not defined param1 set %%~"param1=%2%%~" rem %1 #%2# @exit /b +@rem padding @REM courtesy of: https://stackoverflow.com/users/463115/jeb :strlen stringVar returnVar @( @@ -506,6 +588,8 @@ do if not defined param1 set %%~"param1=%2%%~" ) @EXIT /B +@REM padding +@REM padding :getFileTail @REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd @REM we can't use things such as %~nx1 as it can change capitalisation @@ -545,6 +629,7 @@ do if not defined param1 set %%~"param1=%2%%~" @EXIT /B @REM boundary padding @REM boundary padding +@REM boundary padding :getNormalizedScriptTail @SETLOCAL @SET "result=%~nx0" @@ -654,14 +739,14 @@ do if not defined param1 set %%~"param1=%2%%~" @REM boundary padding @REM boundary padding @REM boundary padding -@REM boundary padding :stringTrimTrailingUnderscores @SETLOCAL @SET "rtrn=%~2" @SET "string=%~1" @SET "trimstring=%~1" - @REM trim up to 63 underscores from the end of a string using string substitution + @REM trim up to 127 underscores from the end of a string using string substitution @SET "trimstring=%trimstring%###" + @SET "trimstring=%trimstring:________________________________________________________________###=###%" @SET "trimstring=%trimstring:________________________________###=###%" @SET "trimstring=%trimstring:________________###=###%" @SET "trimstring=%trimstring:________###=###%" @@ -707,10 +792,11 @@ do if not defined param1 set %%~"param1=%2%%~" # ## ### ### ### ### ### ### ### ### ### ### ### ### ### # -- tcl script section # -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- It is tuned to run (and possibly divert to different payload shell) when called from cmd.exe as a batch file, tclsh,sh,zsh,bash,perl or pwsh/powershell script # -- i.e it is a polyglot file. +# -- The payload target (by os) is defined in the nextshell block at the top which is constructed when generating the polyglot +# -- using the tcl 'dev scriptwrap.multishell' command in a tcl punk shell +# -- The payload can be tcl,perl,powershell/pwsh or zsh/bash. # -- The specific layout including some lines that appear just as comments is quite sensitive to change. # -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. # -- e.g ./scriptname.cmd in sh or zsh or bash @@ -720,7 +806,13 @@ do if not defined param1 set %%~"param1=%2%%~" rename set ""; rename S set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore Hide :exit_multishell;Hide {<#};Hide '@ #--------------------------------------------------------------------- +puts "info script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- #divert to configured nextshell +set script_as_called [info script] package require platform set plat_full [platform::generic] set plat [lindex [split $plat_full -] 0] @@ -733,6 +825,14 @@ set in_data 0 set nextshellpath "" set nextshelltype "" puts stderr "PLAT: $plat" +switch -glob -- $plat { + "msys" - "mingw*" { + set os "win32" + } + default { + set os $plat + } +} foreach ln [split $scriptdata \n] { if {[string trim $ln] eq ""} {continue} if {!$in_data} { @@ -740,14 +840,14 @@ foreach ln [split $scriptdata \n] { set in_data 1 } } else { - if {[string match "*@SET*nextshellpath?${plat}_*" $ln]} { + if {[string match "*@SET*nextshellpath?${os}_*" $ln]} { set lineparts [split $ln =] set tail [lindex $lineparts 1] set nextshellpath [string trimright $tail {_"}] if {$nextshellpath ne "" && $nextshelltype ne ""} { break } - } elseif {[string match "*@SET*nextshelltype?${plat}_*" $ln]} { + } elseif {[string match "*@SET*nextshelltype?${os}_*" $ln]} { set lineparts [split $ln =] set tail [lindex $lineparts 1] set nextshelltype [string trimright $tail {_"}] @@ -760,31 +860,111 @@ foreach ln [split $scriptdata \n] { } } if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { + set script_rootname [file rootname $script_as_called] if {$nextshelltype in "pwsh powershell"} { - set scrname [file rootname [info script]].ps1 - set arglist [list] - foreach a $::argv { - set a "'$a'" - lappend arglist $a + # experimental + set script_ps1 $script_rootname.ps1 + set arglist $::argv + + if {[file extension $script_as_called] ne ".ps1"} { + #we need to ensure .ps1 is up to date + set needs_updating 0 + if {![file exists $script_ps1]} { + set needs_updating 1 + } else { + #both exist + if {[file size $script_as_called] != [file size $script_ps1]} { + set needs_updating 1 + } else { + #both exist with same size - do full check that they're identical + catch {package require sha256} + if {[package provide sha256] ne ""} { + set h1 [sha2::sha256 -hex -file $script_as_called] + set h2 [sha2::sha256 -hex -file $script_ps1] + if {[string length $h1] != 64 || [string length $h2] != 64} { + set needs_updating 1 + } elseif {$h1 ne $h2} { + set needs_updating 1 + } + } else { + #manually compare - scripts aren't too big, so slurp and string compare is fine + set fd [open $script_as_called] + chan configure $fd -translation binary + set data1 [read $fd] + close $fd + set fd [open $script_ps1] + chan configure $fd -translation binary + set data2 [read $fd] + close $fd + if {![string equal $data1 $data2]} { + set needs_updating 1 + } + } + } + } + + if {$needs_updating} { + file copy -force $script_as_called $script_ps1 + } + } else { + #when called on the .ps1 - we assume it's up to date - review } + set scrname $script_ps1 + + #set arglist [list] + #foreach a $::argv { + # set a "'$a'" + # lappend arglist $a + #} } else { - set scrname [info script] + set scrname $script_as_called set arglist $::argv } - puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" #todo - handle /usr/bin/env #todo - exitcode - if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { - set nextshell_words [list $nextshellpath] - } else { - set nextshell_words $nextshellpath + #review - test spaced quoted words in nextshellpath? + # + #if {[llength $nextshellpath] == 1 && [string index $nextshellpath 0] eq {"} && [string index $nextshellpath end] eq {"}} { + # set nextshell_words [list $nextshellpath] + #} else { + # set nextshell_words $nextshellpath + #} + + #perform any msys argument munging on a cmd/cmd.exe based nextshellpath before we convert the first word to an auto_exec path + switch -glob -- $plat { + "msys" - "mingw*" { + set cmdword [lindex $nextshellpath 0] + #we only act on cmd or cmd.exe - not a full path such as c:/WINDOWS/system32/cmd.exe + #the nextshellpath should generally be configured as cmd /c ... or cmd.exe ... but specifying it as a path could allow bypassing this un-munging. + #The un-munging only applies to msys/mingw, so such bypassing should be unnecessary - review + #maint: keep this munging in sync with zsh/bash and perl blocks which must also do msys mangling + if {[regexp {^cmd$|^cmd[.]exe$} $cmdword]} { + #need to deal with msys argument munging + #for now we only deal with /C or /c - todo - other cmd.exe flags? + #In this context we would usually only be using cmd.exe /c to launch older 'desktop' powershell to avoid spaced-argument problems - so we aren't expecting other flags + set new_nextshellpath [list $cmdword] + #for now - just do what zsh munging does - bash regex/string/array processing is tedious and footgunny for the unfamiliar (me), + #so determine the minimum viable case for code there, then port behaviour to perl/tcl msys munging sections. + foreach w [lrange $nextshellpath 1 end] { + if {[regexp {^/[Cc]$} $w]} { + lappend new_nextshellpath {//C} + } else { + lappend new_nextshellpath $w + } + } + set nextshellpath $new_nextshellpath + } + } } + set ns_firstword [lindex $nextshellpath 0] - if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { - set ns_firstword [string range $ns_firstword 1 end-1] - } + #review - is this test for extra layer of double quoting on first word really necessary? + #if we are treaing $nextshellpath as a tcl list - the first layer of double quotes will already have disappeared + ##if {[string index $ns_firstword 0] eq {"} && [string index $ns_firstword end] eq {"}} { + ## set ns_firstword [string range $ns_firstword 1 end-1] + ##} - if {[string match {/*/env} $ns_firstword] && $::tcl_platform(platform) ne "windows"} { + if {$::tcl_platform(platform) ne "windows" && [string match {/*/env} $ns_firstword]} { set exec_part $nextshellpath } else { set epath [auto_execok $ns_firstword] @@ -794,6 +974,10 @@ if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} { set exec_part [list {*}$epath {*}[lrange $nextshellpath 1 end]] } } + + + puts stdout "tclsh launching subshell of type: $nextshelltype shellpath: $nextshellpath on script $scrname with args: $arglist" + puts stdout "exec: $exec_part $scrname $arglist" catch {exec {*}$exec_part $scrname {*}$arglist <@stdin >@stdout 2>@stderr} emsg eopts if {[dict exists $eopts -errorcode]} { @@ -837,11 +1021,6 @@ namespace eval ::punk::multishell { } } # -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- # puts stderr "No tcl code for this script. Try another program such as zsh or bash or perl" @@ -867,8 +1046,11 @@ if {[::punk::multishell::is_main]} { HEREDOC1B_HIDE_FROM_BASH_AND_SH # Be wary of any non-trivial sed/awk etc - can be brittle to maintain across linux,freebsd,macosx due to differing implementations \ echo "var0: $0 @: $@" -# use oldschool backticks and sed - lowest common denominator \ -ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` +# use oldschool backticks and sed (posix - lowest common denominator) \ +# ps_shellname=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` \ +# some ps impls will return arguments - so last field not always appropriate \ +# some ps impls don't have -o (e.g cygwin) so ps_shellname may remain empty and emit an error \ +ps_shellname=`ps -o pid,comm -p $$ | awk '$1 != "PID" {print $2}'` # \ echo "shell from ps: $ps_shellname" # \ @@ -900,8 +1082,11 @@ pop() { } # ------------------------------------------------------------------------------ -# non-bash-like posix diversion \ -if [ "$ps_shellname" != "bash" ] && [ "$ps_shellname" != "zsh" ]; then +# non-bash-like posix diversion +# we don't use $BASH_VERSION/$ZSH_VERSION as these can still be set when for example +# sh is a symlink to bash (posix-mode bash - reduced bashism capabilities?) +# if our ps_shellname didn't contain a result, don't divert and risk looping +if [ -n "$ps_shellname" ] && [ "$ps_shellname" != "bash" ] && [ "$ps_shellname" != "zsh" ] ; then shift pop $# eval "$POP_EXPR" @@ -919,17 +1104,14 @@ if false==false # else { then : # - # zsh/bash \ shift && set -- "${@:1:$((${#@}-1))}" # ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust the %nextshell% value above -# -- if sh/bash scripting needs to run on windows too. +# -- zsh/bash script section # -- +# -- review - for zsh do we want to use: setopt KSH_ARRAYS ? +# -- arrays in bash 0-based vs 1-based in zsh +# -- stick to the @:i:len syntax which is same for both # ## ### ### ### ### ### ### ### ### ### ### ### ### ### plat=$(uname -s) #platform/system @@ -952,18 +1134,31 @@ elif [[ "$plat" == "MINGW64"* ]]; then elif [[ "$plat" == "CYGWIN_NT"* ]]; then os="win32" elif [[ "$plat" == "MSYS_NT"* ]]; then - #review.. - echo MSYS - #win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' + #review.. + + #Need to consider the difference between when msys2 was launched (which strips some paths and sets up the environment) + # vs if the msys2 sh was called - (actually bash) in which case paths will be different + + #wsl and cygwin or msys2 can commonly be problematic combinations - primarily due to path issues + #e.g "c:/windows/system32/" is quite likely in the path ahead of msys,git etc. + #e.g It means a /usr/bin/env bash call may launch the (linux elf) bash for wsl rather than the msys bash + # + + #msys provides win32 binaries - but e.g tclsh installed in msys reports ::tcl_platform(platform) as 'unix' #bash reports $OSTYPE msys + + #there are statements around the web that cmd /c .. will work under msys2 + # - but from experience, it can be required to use cmd //c ... + # or MSYS2_ARG_CONV_ECL='*' cmd /c .. + # This seems to be because process arguments that look like unix paths are converted to windows paths :/ + #review! + os="win32" #review - need ps/sed/awk to determine shell? - interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` + interp=`ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` #use 'command -v' (shell builtin preferred over external which) shellpath=`command -v $interp` shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname - #"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. - #This breaks calls to various unix utils such as sed etc (wsl related?) export PATH="$shellfolder${PATH:+:${PATH}}" elif [[ "$OSTYPE" == "win32" ]]; then os="win32" @@ -985,6 +1180,8 @@ elif [[ "$ps_shellname" == "zsh" ]]; then else #fallback - doesn't seem to work in zsh - untested in early bash IFS=$'\n' arr_oslines=($shellconfiglines) + IFS=$' \t\n' + # review fi nextshellpath="" nextshelltype="" @@ -1008,8 +1205,55 @@ exitcode=0 #-- sh/bash launches nextscript here instead of shebang line at top if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then echo zsh/bash launching subshell of type: $nextshelltype shellpath: $nextshellpath on "$0" with args "$@" - #e.g /usr/bin/env tclsh "$0" "$@" - ${nextshellpath} "$0" "$@" + + script="$0" + if [[ "$nextshelltype" == "pwsh" || "$nextshelltype" == "powershell" ]]; then + #powershell requires the file extension to be .ps1 (always - on windows) + #on other platforms it's not required if a shebang line is used - but this script must be shebangless for portability and to maintain polyglot capabilities. + cmdpattern="[.]cmd$" + if [[ "$script" =~ $cmdpattern ]]; then + ps1script="${script%????}.ps1" + if ! cmp -s "$script" "$ps1script" ; then + #ps1script either different or missing + #on windows - batch script copies .cmd -> .ps1 if not identical + cp -f "$script" "$ps1script" + fi + script=$ps1script + fi + fi + if [[ "$plat" == "MSYS_NT"* ]]; then + + #we need to deal with MSYS argument munging + cmdpattern="^cmd.exe |^cmd " + #do not double quote cmdpattern - or it will be treated as literal string + if [[ "$nextshellpath" =~ $cmdpattern ]]; then + #for now - tell the user what's going on + echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path" + #flags to cmd.exe such as /c are interpreted by msys as looking like a unix path + #review - for nextshellpath targets specified in the block for win32 - we don't expect unix paths (?) + #what about other flags? - can we just double up all forward slashes? + #maint: keep this munging in sync with the tcl block and perl block which must also do msys munging + nextshellpath="${nextshellpath// \/[cC] / \/\/c }" + # echo "new nextshellpath: ${nextshellpath}" + #don't double quote this + script=${script//\\/\\\\} + fi + echo "calling ${nextshellpath} $script $@" + + #load into array + cmd_array=($nextshellpath) + cmd_array+=("$script") #add script, which may contain spaces as a single entry ? + cmd_array+=( "$@" ) #add each element of args to array as a separate entry (equiv ? "${arr[@]}") + # printf "%s\n" "${cmd_array[@]}" + "${cmd_array[@]}" + + # this works to make nextshellpath run - but joins $@ members incorrectly + #eval ${nextshellpath} "$script" "$@" + else + #e.g /usr/bin/env tclsh "$0" "$@" + ${nextshellpath} "$script" "$@" + fi + exitcode=$? #echo "zsh/bash reporting exitcode: ${exitcode}" @@ -1189,18 +1433,44 @@ if ($match.Success) { $admininfo = $match.Groups[1].Value $asadmin = $admininfo.Contains("asadmin=1") if ($asadmin) { + if ($args[0] -eq "PUNK-ELEVATED") { + # May be present if launch and elevation was done via cmd.exe script + # shift away first arg + $newargs = $args | Select-Object -Skip 1 + } else { + $newargs = $args + } + # -Wait e.g for starting a service or other operations which remainder of script may depend on + $arguments = @("-NoProfile","-NoLogo", "-NoExit", "-ExecutionPolicy", "Bypass") + $arguments += @("-File", $($MyInvocation.MyCommand.Path)) + foreach ($a in $newargs) { + if ($a -match '\s') { + $arguments += "`"$a`"" + } else { + $arguments += $a + } + } if (-not ([Security.Principal.WindowsPrincipal][Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { # If not elevated, relaunch with elevated privileges - # -Wait e.g for starting a service or other operations which remainder of script may depend on - $arguments = @("-NoProfile", "-NoExit", "-ExecutionPolicy", "Bypass") - $arguments += @("-File", $($MyInvocation.MyCommand.Path)) - $arguments += $args + Write-Host "Powershell elevating using start-process with -Verb RunAs" if ($PSVersionTable.PSEdition -eq 'Core') { Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -Wait -Verb RunAs } else { Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -Wait -Verb RunAs } Exit # Exit the current non-elevated process + } else { + if ($args[0] -eq "PUNK-ELEVATED") { + #Already elevated (by cmd.exe) + #.. but it is impossible to modify or reassign the automatic $args variable + # so let's start yet another whole new process just to remove one leading argument so the custom script can operate on parameters cleanly - thanks powershell :/ + if ($PSVersionTable.PSEdition -eq 'Core') { + Start-Process -FilePath "pwsh.exe" -ArgumentList $arguments -NoNewWindow -Wait + } else { + Start-Process -FilePath "powershell.exe" -ArgumentList $arguments -NoNewWindow -Wait + } + Exit + } } } }