You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
3820 lines
167 KiB
3820 lines
167 KiB
package provide punk [namespace eval punk { |
|
#FUNCTL |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
#globals... some minimal global var pollution |
|
set punk_testd [dict create \ |
|
a0 a0val \ |
|
b0 [dict create \ |
|
a1 b0a1val \ |
|
b1 b0b1val \ |
|
c1 b0c1val \ |
|
d1 b0d1val \ |
|
]\ |
|
c0 [dict create \ |
|
a1 [dict create \ |
|
a2 c0a1a2val \ |
|
b2 c0a1b2val \ |
|
c2 c0a1c2val \ |
|
] \ |
|
b1 [dict create \ |
|
a2 [dict create \ |
|
a3 c0b1a2a3val \ |
|
b3 c0b1a2b3val \ |
|
] \ |
|
b2 [dict create \ |
|
a3 c0b1b2a3val \ |
|
b3 [dict create \ |
|
a4 c0b1b2b3a4 \ |
|
] \ |
|
c3 [dict create] \ |
|
] \ |
|
] \ |
|
] \ |
|
] |
|
|
|
#cooperative withe punk repl |
|
namespace eval ::repl { |
|
variable running 0 |
|
} |
|
namespace eval punk::config { |
|
variable loaded |
|
variable startup ;#include env overrides |
|
variable running |
|
|
|
set vars [list \ |
|
apps \ |
|
scriptlib \ |
|
color_stdout \ |
|
color_stderr \ |
|
logfile_stdout \ |
|
logfile_stderr \ |
|
syslog_stdout \ |
|
syslog_stderr \ |
|
exec_unknown \ |
|
] |
|
#todo pkg punk::config |
|
|
|
#defaults |
|
|
|
dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run |
|
dict set startup color_stdout [list cyan bold] |
|
dict set startup color_stderr [list red bold] |
|
dict set startup syslog_stdout "127.0.0.1:514" |
|
dict set startup syslog_stderr "127.0.0.1:514" |
|
#default file logs to logs folder at same location as exe if writable, or empty string |
|
dict set startup logfile_stdout "" |
|
dict set startup logfile_stderr "" |
|
set exefolder [file dirname [info nameofexecutable]] |
|
set log_folder $exefolder/logs |
|
dict set startup scriptlib $exefolder/scriptlib |
|
dict set startup apps $exefolder/../punkapps |
|
if {[file exists $log_folder]} { |
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
|
dict set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
|
dict set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
|
} |
|
} |
|
|
|
|
|
#todo - load/write config file |
|
|
|
#env vars override the configuration |
|
|
|
#todo - define which configvars are settable in env |
|
set known_punk_env_vars [list \ |
|
PUNK_APPS \ |
|
PUNK_SCRIPTLIB \ |
|
PUNK_EXECUNKNOWN \ |
|
PUNK_COLOR_STDERR \ |
|
PUNK_COLOR_STDOUT \ |
|
PUNK_LOGFILE_STDOUT \ |
|
PUNK_LOGFILE_STDERR \ |
|
PUNK_SYSLOG_STDOUT \ |
|
PUNK_SYSLOG_STDERR \ |
|
] |
|
|
|
#override with env vars if set |
|
foreach evar $known_punk_env_vars { |
|
if {[info exists ::env($evar)]} { |
|
set f [set ::env($evar)] |
|
if {$f ne "default"} { |
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
|
set varname [string tolower [string range $evar 5 end]] |
|
dict set startup $varname $f |
|
} |
|
} |
|
} |
|
|
|
set running [dict create] |
|
set running [dict merge $running $startup] |
|
} |
|
|
|
namespace eval punk { |
|
package require pattern |
|
package require punkapp |
|
package require funcl |
|
package require control |
|
control::control assert enabled 1 |
|
namespace import ::control::assert |
|
package require struct::list |
|
|
|
#NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) |
|
#(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) |
|
package require debug |
|
|
|
debug define punk.unknown |
|
debug define punk.pipe |
|
debug define punk.pipe.var |
|
debug define punk.pipe.args |
|
debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation |
|
|
|
|
|
#----------------------------------- |
|
# todo - load initial debug state from config |
|
debug off punk.unknown |
|
debug level punk.unknown 1 |
|
debug off punk.pipe |
|
debug level punk.pipe 4 |
|
debug off punk.pipe.var |
|
debug level punk.pipe.var 4 |
|
debug off punk.pipe.args |
|
debug level punk.pipe.args 3 |
|
debug off punk.pipe.rep 2 |
|
|
|
|
|
debug header "dbg> " |
|
|
|
variable last_run_display [list] |
|
variable ansi_disabled 0 |
|
#variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} |
|
|
|
proc ::punk::K {x y} { return $x} |
|
|
|
proc ::punk::var {varname {= {}} args} { |
|
upvar $varname the_var |
|
if {${=} == "="} { |
|
if {[llength $args] > 1} { |
|
set the_var [uplevel 1 $args] |
|
} else { |
|
set the_var [lindex $args 0] |
|
} |
|
} else { |
|
set the_var |
|
} |
|
} |
|
|
|
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
|
# |
|
#we can't provide a float comparison suitable for every situation, |
|
#but we pick something reasonable, keep it stable, and document it. |
|
proc float_almost_equal {a b} { |
|
package require math::constants |
|
set diff [expr {abs($a - $b)}] |
|
if {$diff <= $math::constants::eps} { |
|
return 1 |
|
} |
|
set A [expr {abs($a)}] |
|
set B [expr {abs($b)}] |
|
set largest [expr {($B > $A) ? $B : $A}] |
|
return [expr {$diff <= $largest * $math::constants::eps}] |
|
} |
|
|
|
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
|
proc boolean_equal {a b} { |
|
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
|
expr {($a && 1) == ($b && 1)} |
|
} |
|
#debatable whether boolean_almost_equal is likely to be surprising or helpful. |
|
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
|
#perhaps a fuzzy-boolean is a step too far for a default. use an even more complex classifier? (^&~) ? |
|
proc boolean_almost_equal {a b} { |
|
if {[string is double -strict $a]} { |
|
if {[float_almost_equal $a 0]} { |
|
set a 0 |
|
} |
|
} |
|
if {[string is double -strict $b]} { |
|
if {[float_almost_equal $b 0]} { |
|
set b 0 |
|
} |
|
} |
|
#must handle true,no etc. |
|
expr {($a && 1) == ($b && 1)} |
|
} |
|
|
|
proc know {cond body} { |
|
set existing [info body ::unknown] |
|
#assuming we can't test on cond being present - because it may be fairly simple and prone to false positives (?) |
|
##This means we can't have 2 different conds with same body. Not a big drawback. |
|
#if {$body ni $existing} { |
|
proc ::unknown {args} [string map [list @c@ $cond @b@ $body] { |
|
#--------------------------------------- |
|
debug.punk.unknown {punk unknown_handler $args} 4 |
|
if {![catch {expr {@c@}} res] && $res} { |
|
return [eval {@b@}] |
|
} |
|
#--------------------------------------- |
|
}]$existing |
|
#} |
|
} |
|
proc know? {{len 2000}} { |
|
puts [string range [info body ::unknown] 0 $len] |
|
} |
|
|
|
proc varinfo {vname {flag ""}} { |
|
upvar $vname v |
|
if {[array exists $vname]} { |
|
error "can't read \"$vname\": variable is array" |
|
} |
|
if {[catch {set v} err]} { |
|
error "can't read \"$vname\": no such variable" |
|
} |
|
set inf [shellfilter::list_element_info [list $v]] |
|
set inf [dict get $inf 0] |
|
if {$flag eq "-v"} { |
|
return $inf |
|
} |
|
|
|
set output [dict create] |
|
dict set output wouldbrace [dict get $inf wouldbrace] |
|
dict set output wouldescape [dict get $inf wouldescape] |
|
dict set output head_tail_names [dict get $inf head_tail_names] |
|
dict set output len [dict get $inf len] |
|
return $output |
|
} |
|
|
|
|
|
#split a varname of form var1,var2,var3.. at specified char - but ignoring the char within brackets |
|
#(a common array variable convention is to use comma for levels). |
|
#e.g var(x,y),blah,var(,foo) would be split into var(x,y) blah var(,foo) if comma is specified as the char |
|
#Assumption - char not in "(" ")" |
|
#for punk varspecs we use / as the separator |
|
proc _split_at_unbracketed_comma1 {varname} { |
|
set re_headvar {(.+?)(?![^(]*\))(,.*)*$} |
|
set varname [string trimleft $varname ,] |
|
set varlist [list] |
|
if {[regexp $re_headvar $varname _ v1 vtail]} { |
|
lappend varlist $v1 |
|
set subvars [_split_at_unbracketed_comma $vtail] |
|
set varlist [concat $varlist $subvars] |
|
return $varlist |
|
} else { |
|
return $varname |
|
} |
|
} |
|
|
|
#non recursive without regexp is significantly faster |
|
proc _split_at_unbracketed_comma {varspecs} { |
|
set varlist [list] |
|
set in_brackets 0 |
|
set varspecs [string trimleft $varspecs,] |
|
set token "" |
|
if {[string first "," $varspecs] <0} { |
|
return $varspecs |
|
} |
|
foreach c [split $varspecs ""] { |
|
if {$in_brackets} { |
|
if {$c eq ")"} { |
|
set in_brackets 0 |
|
} |
|
append token $c |
|
} else { |
|
if {$c eq ","} { |
|
lappend varlist $token |
|
set token "" |
|
} else { |
|
append token $c |
|
if {$c eq "("} { |
|
set in_brackets 1 |
|
} |
|
} |
|
} |
|
} |
|
if {[string length $token]} { |
|
lappend varlist $token |
|
} |
|
return $varlist |
|
} |
|
proc splitstrposn {s p} { |
|
if {$p <= 0} { |
|
if {$p == 0} { |
|
list "" $s |
|
} else { |
|
list $s "" |
|
} |
|
} else { |
|
scan $s %${p}s%s |
|
} |
|
} |
|
proc splitstrposn_nonzero {s p} { |
|
scan $s %${p}s%s |
|
} |
|
proc _split_var_key_at_unbracketed_comma {varspecs} { |
|
set varlist [list] |
|
set var_terminals [list "@" "/" "#"] |
|
set protect_terminals [list "^"] ;# e.g sequence ^# |
|
#except when prefixed directly by pin classifier ^ |
|
set in_brackets 0 |
|
#set varspecs [string trimleft $varspecs ,] |
|
set token "" |
|
#if {[string first "," $varspecs] <0} { |
|
# return $varspecs |
|
#} |
|
set first_term -1 |
|
set token_index 0 ;#index of terminal char within each token |
|
set prevc "" |
|
foreach c [split $varspecs ""] { |
|
if {$in_brackets} { |
|
append token $c |
|
if {$c eq ")"} { |
|
set in_brackets 0 |
|
} |
|
} else { |
|
if {$c eq ","} { |
|
#lappend varlist [splitstrposn $token $first_term] |
|
set var $token |
|
set spec "" |
|
if {$first_term > 0} { |
|
lassign [scan $token %${first_term}s%s] var spec |
|
} else { |
|
if {$first_term == 0} { |
|
set var "" |
|
set spec $token |
|
} |
|
} |
|
lappend varlist [list $var $spec] |
|
set token "" |
|
set token_index -1 ;#reduce by 1 because , not included in next token |
|
set first_term -1 |
|
} else { |
|
append token $c |
|
if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
|
set first_term $token_index |
|
} elseif {$c eq "("} { |
|
set in_brackets 1 |
|
} |
|
} |
|
} |
|
set prevc $c |
|
incr token_index |
|
} |
|
if {[string length $token]} { |
|
#lappend varlist [splitstrposn $token $first_term] |
|
set var $token |
|
set spec "" |
|
if {$first_term > 0} { |
|
lassign [scan $token %${first_term}s%s] var spec |
|
} else { |
|
if {$first_term == 0} { |
|
set var "" |
|
set spec $token |
|
} |
|
} |
|
lappend varlist [list $var $spec] |
|
} |
|
return $varlist |
|
} |
|
proc _split_var_key_at_unbracketed_comma1 {varspecs} { |
|
set varlist [list] |
|
set var_terminals [list "@" "/" "#"] |
|
set in_brackets 0 |
|
#set varspecs [string trimleft $varspecs ,] |
|
set token "" |
|
#if {[string first "," $varspecs] <0} { |
|
# return $varspecs |
|
#} |
|
set first_term -1 |
|
set token_index 0 ;#index of terminal char within each token |
|
foreach c [split $varspecs ""] { |
|
if {$in_brackets} { |
|
if {$c eq ")"} { |
|
set in_brackets 0 |
|
} |
|
append token $c |
|
} else { |
|
if {$c eq ","} { |
|
if {$first_term > -1} { |
|
set v [string range $token 0 $first_term-1] |
|
set k [string range $token $first_term end] ;#key section includes the terminal char |
|
lappend varlist [list $v $k] |
|
} else { |
|
lappend varlist [list $token ""] |
|
} |
|
set token "" |
|
set token_index -1 ;#reduce by 1 because , not included in next token |
|
set first_term -1 |
|
} else { |
|
if {$first_term == -1} { |
|
if {$c in $var_terminals} { |
|
set first_term $token_index |
|
} |
|
} |
|
append token $c |
|
if {$c eq "("} { |
|
set in_brackets 1 |
|
} |
|
} |
|
} |
|
incr token_index |
|
} |
|
if {[string length $token]} { |
|
if {$first_term > -1} { |
|
set v [string range $token 0 $first_term-1] |
|
set k [string range $token $first_term end] ;#key section includes the terminal char |
|
lappend varlist [list $v $k] |
|
} else { |
|
lappend varlist [list $token ""] |
|
} |
|
} |
|
return $varlist |
|
} |
|
|
|
proc fp_restructure {selector data} { |
|
if {$selector eq ""} { |
|
fun=.= {val $input} <input| |
|
|
|
} else { |
|
|
|
|
|
} |
|
|
|
return $fun |
|
} |
|
|
|
#todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a tcl script |
|
proc destructure {selector data} { |
|
set selector [string trim $selector /] |
|
upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position |
|
upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position |
|
|
|
set leveldata $data |
|
|
|
set subindices [split $selector /] |
|
|
|
set i_keyindex 0 |
|
set active_key_type "" |
|
set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch-<somereason> and always break |
|
set lhs "" |
|
set rhs "" |
|
#todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? |
|
foreach index $subindices { |
|
set subpath [join [lrange $subindices 0 $i_keyindex] /] |
|
set lhs $subpath |
|
set assigned "" |
|
set get_not 0 |
|
set already_assigned 0 |
|
|
|
if {$index eq "#"} { |
|
set active_key_type "list" |
|
if {![catch {llength $leveldata} assigned]} { |
|
set already_assigned 1 |
|
} else { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
} elseif {$index eq "##"} { |
|
set active_key_type "dict" |
|
if {![catch {dict size $leveldata} assigned]} { |
|
set already_assigned 1 |
|
} else { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
} elseif {$index eq "@"} { |
|
set active_key_type "list" |
|
#e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey |
|
#no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 |
|
#while x@,y@.= is reasonably handy - especially for args e.g <a@,b@,c@| v1 v2 v3 instead of requiring <a@0,b@1,c@2| |
|
# - the utility of x/somesubkey/@ is a bit dubious but included for consistency and completeness. |
|
# - bind specs may be constructed programmatically so it may cause surprise if it only worked at level zero of key lists. |
|
#set subpath [join [lrange $subindices 0 $i_keyindex] /] |
|
set next_this_level [incr v_list_idx($subpath)] ;#incr will return 1 first call as we don't check subpath exists in array |
|
set index [expr {$next_this_level -1}] |
|
|
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$index+1 > $len} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
set assigned [lindex $leveldata $index] |
|
set already_assigned 1 |
|
|
|
} else { |
|
if {$index eq "@@"} { |
|
set active_key_type "dict" |
|
|
|
#NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc |
|
#x@@ = a {x y} |
|
#x@@/@0 = a |
|
#x@@/@1 = x y |
|
#x@@/a = a {x y} |
|
|
|
# |
|
#set subpath [join [lrange $subindices 0 $i_keyindex] /] |
|
if {[catch {dict size $leveldata} dsize]} { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
set next_this_level [incr v_dict_idx($subpath)] |
|
set keyindex [expr {$next_this_level -1}] |
|
if {($keyindex + 1) <= $dsize} { |
|
set k [lindex [dict keys $leveldata] $keyindex] |
|
set assigned [list $k [dict get $leveldata $k]] |
|
set already_assigned 1 |
|
} else { |
|
set action ?mismatch-dict-index-out-of-range |
|
break |
|
} |
|
} elseif {[string match @@* $index]} { |
|
set active_key_type "dict" |
|
set key [string range $index 2 end] |
|
#dict exists test is safe - no need for catch |
|
if {[dict exists $leveldata $key]} { |
|
set assigned [dict get $leveldata $key] |
|
} else { |
|
set action ?mismatch-dict-key-not-found |
|
break |
|
} |
|
set already_assigned 1 |
|
} elseif {[string match @* $index]} { |
|
set active_key_type "list" |
|
set index [string trimleft $index @] |
|
} else { |
|
# |
|
} |
|
|
|
|
|
if {!$already_assigned} { |
|
if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { |
|
#e.g not-0-end-1 not-end-4-end-2 |
|
set get_not 1 |
|
#cherry-pick some easy cases, and either assign, or re-map to corresponding index |
|
if {$index eq "not-tail"} { |
|
set active_key_type "list" |
|
|
|
set assigned [lindex $leveldata 0]; set already_assigned 1 |
|
} elseif {$index in [list "not-head" "not-0"]} { |
|
set active_key_type "list" |
|
#set selector "tail"; set get_not 0 |
|
set assigned [lrange $leveldata 1 end]; set already_assigned 1 |
|
} elseif {$index eq "not-end"} { |
|
set active_key_type "list" |
|
set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 |
|
} else { |
|
#trim off the not- and let the remaining index handle based on get_not being 1 |
|
set index [string range $index 4 end] |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
if {!$already_assigned} { |
|
|
|
#keyword 'pipesyntax' at beginning of error message |
|
set listmsg "pipesyntax Unable to interpret subindex $index\n" |
|
append listmsg "selector: $selector\n" |
|
append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" |
|
append listmsg "Additional accepted keywords include: head tail\n" |
|
append listmsg "Use var@@key to treat value as a dict and retrieve element at key" |
|
|
|
if {$active_key_type in [list "" "list"]} { |
|
set active_key_type "list" |
|
#for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) |
|
if {$index in [list "head" 0]} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$len == 0} { |
|
set action ?mismatch-list-index-out-of-range-empty |
|
break |
|
} |
|
#alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax |
|
set assigned [lindex $leveldata 0] |
|
} elseif {$index eq "tail"} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
#tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list |
|
#arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. |
|
#In this way tail is different to @1-end |
|
if {$len == 0} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. |
|
} elseif {$index eq "anyhead"} { |
|
#allow returning of head or nothing if empty list |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
set assigned [lindex $leveldata 0] |
|
} elseif {$index eq "anytail"} { |
|
#allow returning of tail or nothing if empty list |
|
#anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
set assigned [lrange $leveldata 1 end] |
|
} elseif {$index eq "anylist"} { |
|
#allow returning of entire list even if empty |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
set assigned $leveldata |
|
} elseif {$index eq "any"} { |
|
#no list checking.. |
|
set assigned $leveldata |
|
} elseif {$index eq "keys"} { |
|
#need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements |
|
if {[catch {dict size $leveldata} dsize]} { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
set assigned [dict keys $leveldata] |
|
} elseif {$index eq "values"} { |
|
#need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements |
|
if {[catch {dict size $leveldata} dsize]} { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
set assigned [dict values $leveldata] |
|
} elseif {$index eq "end"} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$len < 1} { |
|
set action ?mismatch-list-index-out-of-range |
|
} |
|
set assigned [lindex $leveldata end] |
|
} elseif {[string is integer -strict $index]} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$index+1 > $len || $index < 0} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
if {$get_not} { |
|
#already handled not-0 |
|
set assigned [lreplace $leveldata $index $index] |
|
} else { |
|
set assigned [lindex $leveldata $index] |
|
} |
|
} elseif {[string first "end" $index] >=0} { |
|
if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
#leave the - from the end- as part of the offset |
|
set offset [expr $endspec] ;#don't brace! |
|
if {$offset > 0 || abs($offset) >= $len} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
if {$get_not} { |
|
set assigned [lreplace $leveldata $index $index] |
|
} else { |
|
set assigned [lindex $leveldata $index] |
|
} |
|
} elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {[string is integer -strict $start]} { |
|
if {$start+1 > $len || $start < 0} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
} elseif {$start eq "end"} { |
|
#ok |
|
} else { |
|
set startoffset [string range $start 3 end] ;#include the - from end- |
|
set startoffset [expr $startoffset] ;#don't brace! |
|
if {$startoffset > 0 || abs($startoffset) >= $len} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
} |
|
if {[string is integer -strict $end]} { |
|
if {$end+1 > $len || $end < 0} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
} elseif {$end eq "end"} { |
|
#ok |
|
} else { |
|
set endoffset [string range $end 3 end] ;#include the - from end- |
|
set endoffset [expr $endoffset] ;#don't brace! |
|
if {$endoffset > 0 || abs($endoffset) >= $len} { |
|
set action ?mismatch-list-index-out-of-range |
|
break |
|
} |
|
} |
|
if {$get_not} { |
|
set assigned [lreplace $leveldata $start $end] |
|
} else { |
|
set assigned [lrange $leveldata $start $end] |
|
} |
|
} else { |
|
error $listmsg |
|
} |
|
} elseif {[string first - $index] > 0} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
#handle pure int-int ranges separately |
|
set testindex [string map [list - "" + ""] $index] |
|
if {[string is digit -strict $testindex]} { |
|
#don't worry about leading - negative value for indices not valid anyway |
|
set parts [split $index -] |
|
if {[llength $parts] != 2} { |
|
error $listmsg |
|
} |
|
lassign $parts start end |
|
if {$start+1 > $len || $end+1 > $len} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$get_not} { |
|
set assigned [lreplace $leveldata $start $end] |
|
} else { |
|
set assigned [lrange $leveldata $start $end] |
|
} |
|
} else { |
|
error $listmsg |
|
} |
|
|
|
} else { |
|
#keyword 'pipesyntax' at beginning of error message |
|
error $listmsg |
|
} |
|
} else { |
|
#treat as dict key |
|
set active_key_type "dict" |
|
if {[dict exists $leveldata $index]} { |
|
set assigned [dict get $leveldata $index] |
|
} else { |
|
set action ?mismatch-dict-key-not-found |
|
break |
|
} |
|
|
|
} |
|
} |
|
set leveldata $assigned |
|
set rhs $leveldata |
|
#don't break on empty data - operations such as # and ## can return 0 |
|
#if {![llength $leveldata]} { |
|
# break |
|
#} |
|
incr i_keyindex |
|
} |
|
|
|
#puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" |
|
|
|
#maintain key order - caller unpacks using lassign |
|
return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] |
|
|
|
} |
|
#called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level |
|
#called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope |
|
#return a dict with keys result, setvars, unsetvars |
|
#TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar |
|
#e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) |
|
#e.g x,x@0 will only match a single element list |
|
proc _multi_bind_result {multivar data args} { |
|
#puts stdout "---- _multi_bind_result $multivar $data $args" |
|
#'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 |
|
if {![string length $multivar]} { |
|
#treat the absence of a pattern as a match to anything |
|
return [dict create ismatch 1 result $data setvars {} unsetvars {}] |
|
} |
|
set returndict [dict create ismatch 0 result "" setvars {} unsetvars {}] |
|
|
|
set defaults [list -unset 0 -levelup 2 ] |
|
set opts [dict merge $defaults $args] |
|
set unset [dict get $opts -unset] |
|
set lvlup [dict get $opts -levelup] |
|
|
|
#comma seems a natural choice to split varspecs, |
|
#but also for list and dict subelement access |
|
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
|
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
|
set varkeylist [_split_var_key_at_unbracketed_comma $multivar] |
|
#puts stdout "\n varkeylist: $varkeylist\n" |
|
|
|
#first classify into var_returntype of either "pipeline" or "segment" |
|
#segment returntype is indicated by leading % |
|
|
|
|
|
#mutually exclusive - atom/pin |
|
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
|
#set var_class [lmap var $varkeylist {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
|
#0 - novar |
|
#1 - atom ' |
|
#2 - pin ^ |
|
#3 - boolean & |
|
#4 - integer |
|
#5 - double |
|
#6 - var |
|
#7 - glob (no classifier and contains * or ?) |
|
#8 - numeric |
|
|
|
set var_class [list] |
|
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers |
|
set var_names [list] |
|
set var_actions [list] |
|
#set var_actions [lmap v $var_names {expr {[list $v "" ""]}}] |
|
|
|
set expected_values [list] |
|
#set expected_values [lmap v $var_names {list $v "-" ""}] |
|
#e.g {a = abc} {b unset ""} |
|
foreach v_key $varkeylist { |
|
lassign $v_key v key |
|
set vname $v ;#default |
|
if {$v eq ""} { |
|
lappend var_class [list $v_key 0] |
|
lappend varspecs_trimmed $v_key |
|
} elseif {[string is integer -strict $v]} { |
|
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
|
#integer test before double.. |
|
#note there is also string is wide (string is wideinteger) for larger ints.. |
|
lappend var_class [list $v_key 4] |
|
lappend varspecs_trimmed $v_key |
|
} elseif {[string is double -strict $v]} { |
|
#sci notation 1e123 etc |
|
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
|
lappend var_class [list $v_key 5] |
|
lappend varspecs_trimmed $v_key |
|
} else { |
|
set firstclassifier [string index $v 0] |
|
if {$firstclassifier eq "'"} { |
|
lappend var_class [list $v_key 1] |
|
set vname [string range $v 1 end] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} elseif {$firstclassifier eq "^"} { |
|
set classes [list 2] |
|
set vname [string range $v 1 end] |
|
set secondclassifier [string index $v 1] |
|
if {$secondclassifier eq "&"} { |
|
#pinned boolean |
|
lappend classes 3 |
|
set vname [string range $v 2 end] |
|
} elseif {$secondclassifier eq "#"} { |
|
#pinned numeric comparison instead of string comparison |
|
lappend classes 8 |
|
set vname [string range $v 2 end] |
|
} elseif {$secondclassifier eq "*"} { |
|
#pinned glob |
|
lappend classes 7 |
|
set vname [string range $v 2 end] |
|
} |
|
#todo - check for second tag - & for pinned boolean? |
|
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
|
#while we're at it.. pinned glob would be nice. ^* |
|
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
|
#These all limit the range of varnames permissible - which is no big deal. |
|
lappend var_class [list $v_key $classes] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} elseif {$firstclassifier eq "&"} { |
|
lappend var_class [list $v_key 3] |
|
set vname [string range $v 1 end] |
|
lappend varspecs_trimmed [list $vname $key] |
|
} else { |
|
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
|
lappend var_class [list $v_key 7] ;#glob |
|
#leave vname as the full glob |
|
lappend varspecs_trimmed [list "" $key] |
|
} else { |
|
lappend var_class [list $v_key 6] ;#var |
|
lappend varspecs_trimmed $v_key |
|
} |
|
} |
|
} |
|
lappend var_names $vname |
|
lappend var_actions [list $vname "" ""] |
|
lappend expected_values [list spec $vname info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default |
|
} |
|
|
|
#puts stdout "\n var_class: $var_class\n" |
|
# e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} |
|
|
|
#set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] |
|
#puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" |
|
|
|
|
|
#var names (possibly empty portion to the left of ) |
|
#debug.punk.pipe.var "varnames: $var_names" 4 |
|
|
|
set v_list_idx(@) 0 ;#for spec with single @ only |
|
set v_dict_idx(@@) 0 ;#for spec with @@ only |
|
|
|
#jn |
|
|
|
#member lists of returndict which will be appended to in the initial value-retrieving loop |
|
set returndict_setvars [dict get $returndict setvars] |
|
set returndict_unsetvars [dict get $returndict unsetvars] |
|
|
|
set assigned_values [list] |
|
|
|
|
|
#varname action value - where value is value to be set if action is set |
|
#actions: |
|
# "" unconfigured - assert none remain unconfigured at end |
|
# noop no-change |
|
# matchvar-set name is a var to be matched |
|
# matchvar-unset |
|
# matchatom-set names is an atom to be matched |
|
# matchatom-unset |
|
# matchglob-set |
|
# set |
|
# unset |
|
# question mark versions are temporary - awaiting a check of action vs var_class |
|
# e.g ?set may be changed to matchvar or matchatom or set |
|
|
|
|
|
debug.punk.pipe.var {initial map expected_values: $expected_values} 5 |
|
|
|
|
|
set returnval "" |
|
set i 0 |
|
#assert i incremented at each continue and at each end of loop - at end i == list length + 1 |
|
#always use 'assigned' var in each loop |
|
# (for consistency and to assist with returnval) |
|
# ^var means a pinned variable - compare value of $var to rhs - don't assign |
|
# |
|
# In this loop we don't set or unset variables - but assign an action entry in var_actions - all with leading question mark. |
|
# as well as adding the data values to the var_actions list |
|
foreach v_and_key $varspecs_trimmed { |
|
set vspec [join $v_and_key ""] |
|
lassign $v_and_key v vkey |
|
|
|
set already_actioned 0 ;#especially for list/dict subkeys so we don't set the default ?set action if we've already set it to something else |
|
set assigned "" |
|
#The binding spec begins at first @ or # or / |
|
|
|
#set firstq [string first "'" $vspec] |
|
#set v [lindex $var_names $i] |
|
#if v contains any * and/or ? - then it is a glob match - not a varname |
|
|
|
if {[string length $vkey]} { |
|
#if {[string is integer -strict $v]} { |
|
# lset var_actions $i 1 matchatom |
|
#} |
|
if {$unset} { |
|
#variable unset traces can't raise an error - so presumably the only error we can get is the built-in no such variable error |
|
#we don't want unset of a nonexistent variable to raise an error here.. |
|
#REVIEW - does it really matter? Would consistency with standard tcl 'unset var' be better? |
|
#if {[string length $v]} { |
|
# catch {uplevel $lvlup [list unset $v]} |
|
#} |
|
lset var_actions $i 1 ?unset |
|
set assigned "" |
|
lappend assigned_values $assigned |
|
incr i |
|
continue |
|
} |
|
|
|
# if @# is found - remove the # and set a flag to indicate we are returning the length/size |
|
# for @#@path - size of dict at the level specified by the path |
|
|
|
|
|
|
|
set vkey [string trimleft $vkey /] |
|
#puts stderr ">>>>>>>>>>>>>>>> $vkey" |
|
|
|
set subindices [split $vkey /] |
|
if {[string is digit -strict [join $subindices ""]]} { |
|
#pure numeric keylist - put straight to lindex |
|
# |
|
#NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ |
|
#We will leave this as a syntax for different (more performant) behaviour |
|
#- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. |
|
#TODO - review and/or document |
|
# |
|
#Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. |
|
set assigned [lindex $data {*}$subindices] |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} elseif {([scan $vkey %d-%d a b] == 2) && $vkey eq "${a}-${b}"} { |
|
#pure digit range a-b |
|
set assigned [lrange $data $a $b] |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} elseif {$vkey in [list 0 head]} { |
|
if {[catch {lindex $data 0} hd]} { |
|
lset var_actions $i 1 ?mismatch-not-a-list |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
if {[llength $data] == 0} { |
|
lset var_actions $i 1 ?mismatch-list-index-out-of-range-empty |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
set assigned $hd |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} elseif {$vkey eq "#"} { |
|
# always present as /# - / required to separate from @@# maining dict key "#" - also leading # would be a comment. |
|
if {[catch {llength $data} len]} { |
|
lset var_actions $i 1 ?mismatch-not-a-list |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
set assigned $len |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} elseif {$vkey eq "##"} { |
|
# /## |
|
if {[catch {dict size $data} dsize]} { |
|
lset var_actions $i 1 ?mismatch-not-a-dict |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
set assigned $dsize |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} elseif {$vkey eq "@"} { |
|
#no dict key following @, this is a positional spec for list |
|
if {[catch {llength $data} len]} { |
|
lset var_actions $i 1 ?mismatch-not-a-list |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
|
|
if {$v_list_idx(@)+1 <= $len} { |
|
set assigned [lindex $data $v_list_idx(@)] |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} else { |
|
lset var_actions $i 1 ?mismatch-list-index-out-of-range |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
|
|
#if {[string length $v]} { |
|
# uplevel $lvlup [list set $v $assigned] |
|
#} |
|
incr v_list_idx(@) ;#only incr each time we have a plain @ at the root level of the index |
|
} elseif {$vkey eq "@@"} { |
|
if {[catch {dict size $data} dlen]} { |
|
lset var_actions $i 1 ?mismatch-not-a-dict |
|
lset var_actions $i 2 $data |
|
set assigned "" |
|
break |
|
} |
|
# @@ positional spec for dict |
|
set k [lindex [dict keys $data] $v_dict_idx(@@)] |
|
if {($v_dict_idx(@@) + 1) <= [dict size $data]} { |
|
set assigned [list $k [dict get $data $k]] ;#return a list of the k,v pair at the current @@ index position |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} else { |
|
lset var_actions $i 1 ?mismatch-dict-index-out-of-range |
|
lset var_actions $i 2 $data |
|
set assigned "" |
|
break |
|
} |
|
incr v_dict_idx(@@) |
|
} elseif {[string match "@@*" $vkey]} { |
|
#part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc |
|
set rawkeylist [split $vkey /] ;#first key retains @@ - may be just '@@' |
|
set keypath [string range $vkey 2 end] |
|
set keylist [split $keypath /] |
|
if {([lindex $rawkeylist 0] ne "@@") && [lsearch $keylist @*] == -1} { |
|
#pure keylist for dict - process in one go |
|
#dict exists will return 0 if not a valid dict. |
|
if {[dict exists $data {*}$keylist]} { |
|
set assigned [dict get $data {*}$keylist] |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
#if {[string length $v]} { |
|
# uplevel $lvlup [list set $v $assigned] |
|
#} |
|
} else { |
|
#deliberate inconsistency with lindex out of range setting var to empty string - we need to cause a pattern mismatch |
|
lset var_actions $i 1 ?mismatch-dict-key-not-found |
|
lset var_actions $i 2 $data |
|
break |
|
} |
|
} else { |
|
#compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) |
|
#process level by level |
|
lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs |
|
if {$matchaction eq "?match"} { |
|
set matchaction "?set" |
|
} |
|
lset var_actions $i 1 $matchaction |
|
#todo - destructure should return more than just assigned..(?) |
|
lset var_actions $i 2 $assigned |
|
set already_actioned 1 |
|
|
|
} |
|
|
|
} else { |
|
# varname@x where x is positive or negative integer or zero - use x as lindex |
|
# or x is a range e.g 0-3 suitable for lrange |
|
|
|
if {[string first "/@@" $vkey] >=0 || [string first "/#" $vkey] >= 0} { |
|
#compound destructuring required - mix of list and dict keys |
|
lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs |
|
if {$matchaction eq "?match"} { |
|
set matchaction "?set" |
|
} |
|
lset var_actions $i 1 $matchaction |
|
|
|
lset var_actions $i 2 $assigned |
|
set already_actioned 1 |
|
|
|
} else { |
|
|
|
lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs |
|
if {$matchaction eq "?match"} { |
|
set matchaction "?set" |
|
} |
|
lset var_actions $i 1 $matchaction |
|
lset var_actions $i 2 $assigned |
|
set already_actioned 1 |
|
|
|
} |
|
if {!$already_actioned} { |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
} |
|
} |
|
} else { |
|
#no vkey - whole of RHS to be applied |
|
|
|
if {$unset} { |
|
#if {[string length $v]} { |
|
# catch {uplevel $lvlup [list unset $v]} |
|
#} |
|
lset var_actions $i 1 ?unset |
|
set assigned "" |
|
lappend assigned_values $assigned |
|
incr i |
|
continue |
|
} |
|
set assigned $data |
|
lset var_actions $i 1 ?set |
|
lset var_actions $i 2 $assigned |
|
#if {[string length $v]} { |
|
# uplevel $lvlup [list set $v $data] |
|
#} |
|
} |
|
|
|
#update the setvars/unsetvars elements |
|
if {[string length $v]} { |
|
if {$unset} { |
|
if {$v ni $returndict_unsetvars} { |
|
lappend returndict_unsetvars $v |
|
} |
|
} else { |
|
dict set returndict_setvars $v $assigned |
|
} |
|
} |
|
lappend assigned_values $assigned |
|
incr i |
|
} |
|
|
|
dict set returndict setvars $returndict_setvars |
|
dict set returndict unsetvars $returndict_unsetvars |
|
|
|
set returnval [lindex $assigned_values 0] |
|
|
|
#assert all var_actions were set with leading question mark |
|
#perform assignments only if matched ok |
|
|
|
debug.punk.pipe.var {VAR_CLASS: $var_class} 5 |
|
debug.punk.pipe.var {VARACTIONS: $var_actions} 5 |
|
|
|
#0 - novar |
|
#1 - atom ' |
|
#2 - pin ^ |
|
#3 - boolean & |
|
#4 - integer |
|
#5 - double |
|
#6 - var |
|
#7 - glob (no classifier and contains * or ?) |
|
if 1 { |
|
debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 |
|
debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 |
|
debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 |
|
debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 |
|
debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 |
|
debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 |
|
debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 |
|
} |
|
|
|
set match_state [lrepeat [llength $var_names] ?] |
|
|
|
set mismatched [list] |
|
set i 0 |
|
#todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) |
|
foreach va $var_actions { |
|
lassign $va nm act val |
|
set class_key [lindex $var_class $i 1] |
|
set isatom [expr {$class_key == 1}] |
|
set ispin [expr {2 in $class_key}] |
|
set isbool [expr {3 in $class_key}] |
|
set isint [expr {$class_key == 4}] |
|
set isdouble [expr {$class_key == 5}] |
|
set isvar [expr {$class_key == 6}] |
|
set isglob [expr {7 in $class_key}] |
|
set isnumeric [expr {8 in $class_key}] ;#force numeric comparison |
|
|
|
#marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? |
|
|
|
# - should set expected_values in each branch where match_state is not set to 1 |
|
# - setting expected_values when match_state is set to 0 is ok except for performance |
|
|
|
if {[string match "?mismatch*" $act]} { |
|
#already determined a mismatch - e.g list or dict key not present |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info mismatch lhs ? rhs $val] |
|
break |
|
} |
|
|
|
#todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or |
|
#ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) |
|
if {$ispin} { |
|
#puts stdout "==>ispin $nm" |
|
if {$act in [list "?set" "?matchvar-set"]} { |
|
lset var_actions $i 1 matchvar-set |
|
#attempt to read |
|
upvar $lvlup $nm the_var |
|
#if {![catch {uplevel $lvlup [list set $nm]} existingval]} {} |
|
if {![catch {set the_var} existingval]} { |
|
|
|
if {$isbool} { |
|
#isbool due to 2nd classifier i.e ^& |
|
lset expected_values $i [list spec $nm info match-lhs-bool lhs $existingval rhs $val] |
|
} elseif {$isglob} { |
|
#isglob due to 2nd classifier ^* |
|
lset expected_values $i [list spec $nm info match-lhs-glob lhs $existingval rhs $val] |
|
} elseif {$isnumeric} { |
|
|
|
if {[string is integer -strict $existingval]} { |
|
set isint 1 |
|
lset expected_values $i [list spec $nm info match-lhs-int lhs $existingval rhs $val] |
|
} elseif {[string is double -strict $existingval]} { |
|
set isdouble 1 |
|
lset expected_values $i [list spec $nm info match-lhs-double lhs $existingval rhs $val] |
|
} |
|
|
|
} else { |
|
#standard pin - single classifier ^var |
|
lset match_state $i [expr {$existingval eq $val}] |
|
if {![lindex $match_state $i]} { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info match lhs $existingval rhs $val] |
|
break |
|
} |
|
} |
|
|
|
} else { |
|
#puts stdout "var ^$nm result:$result vs val:$val" |
|
#failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info failread lhs ? rhs $val] |
|
break |
|
} |
|
} |
|
if {$act in [list "?unset" "?matchvar-unset"]} { |
|
lset var_actions $i 1 matchvar-unset |
|
upvar $lvlup $nm the_var |
|
if {![info exists the_var]} { |
|
lset match_state $i 1 |
|
} else { |
|
#attempt to unset a pinned var that has a value - non-match. ^x= will only match an unset variable x |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info attempt-to-unset-pinned-var-with-value lhs [set the_var] rhs ""] |
|
break |
|
} |
|
} |
|
} |
|
|
|
|
|
if {$isatom} { |
|
#puts stdout "==>isatom $nm" |
|
if {$act in [list "?set"]} { |
|
lset var_actions $i 1 matchatom-set |
|
if {$nm eq $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info match lhs [string range $nm 1 end] rhs $val] |
|
break |
|
} |
|
} elseif {$act eq "?unset"} { |
|
#doesn't make sense for an atom ? - should fail match |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info match lhs [string range $nm 1 end] rhs $val] |
|
break |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info unkown lhs [string range $nm 1 end] rhs $val] |
|
break |
|
} |
|
} elseif {$isint} { |
|
#todo - decide on what diagnosis info to put in expected_values -- or tidy up and shrink duplicate branches. |
|
#expected_values $i [list spec $nm info match-lhs-int lhs $existingval rhs $val] |
|
|
|
if {$act eq "?set"} { |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $nm ;#literal integer in the pattern |
|
} |
|
if {[string is integer -strict $val]} { |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "expr-mismatch-int-int" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {[string is double -strict $val]} { |
|
#dragons. (and shimmering) |
|
if {[string first "e" $val] != -1} { |
|
#scientific notation - let expr compare |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "expr-mismatch-int-sci" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {[string is digit -strict [string trim $val -]] } { |
|
#probably a wideint or bignum with no decimal point |
|
#It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . |
|
#if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. |
|
#2 values further apart can compare equal while int-like ones closer together can compare different. |
|
#The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. |
|
#This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. |
|
#string comparison can presumably always be used as an alternative. |
|
# |
|
#let expr compare |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
#review! if we're using float_almost_equal at all.. should we use it always? |
|
if {[punk::float_almost_equal $lhs $val]} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} else { |
|
#unknown - todo warn? |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "expr-mismatch-unknown" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} |
|
} elseif {$isdouble} { |
|
#dragons (and shimmering) |
|
if {$act eq "?set"} { |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $nm ;#literal integer in the pattern |
|
} |
|
|
|
if {[string first "e" $lhs] >= 0 || [string first "e" $val] >= 0} { |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info expr-mismatch-sci lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { |
|
#both look like big whole numbers.. let expr compare using it's bignum capability |
|
if {$lhs == $val} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info expr-mismatch-pure-digits lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
#float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch |
|
if {[punk::float_almost_equal $lhs $val]} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info float_almost_equal-mismatch lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} |
|
} elseif {$isbool} { |
|
#punk::boolean_equal $a $b |
|
if {$act eq "?set"} { |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $nm ;#literal boolean (&yes,&false,&1,&0 etc) in the pattern |
|
} |
|
|
|
if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { |
|
if {$ismatch} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info boolean-mismatch lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
#we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info boolean-badvalue lhs $lhs rhs $val] |
|
break |
|
} |
|
|
|
|
|
} |
|
} elseif {$isglob} { |
|
if {$act eq "?set"} { |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $nm ;#literal glob in the pattern |
|
} |
|
if {[string match $lhs $val]} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list spec $nm info "glob-mismatch" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
|
|
} elseif {$ispin} { |
|
#handled above.. leave case in place so we don't run else for pins |
|
|
|
} else { |
|
#puts stdout "==> $nm" |
|
#unpinned non-atoms will be set/unset - always considered a match |
|
lset match_state $i 1 |
|
lset var_actions $i 1 [string range $act 1 end] |
|
} |
|
|
|
incr i |
|
} |
|
|
|
#-------------------------------------------------------------------------- |
|
#Variable assignments (set/unset) should only occur down here, and only if we have a match |
|
#-------------------------------------------------------------------------- |
|
set match_count_needed [llength $var_actions] |
|
#set match_count [expr [join $match_state +]] ;#expr must be unbraced here |
|
set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" |
|
set match_count [llength $matches] |
|
|
|
|
|
debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 |
|
debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 |
|
debug.punk.pipe.var {EXPECTED : $expected_values} 4 |
|
|
|
#set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join |
|
#catch {unset v} |
|
if {$match_count == $match_count_needed} { |
|
#do assignments |
|
set i 0 |
|
foreach va $var_actions { |
|
lassign $va nm act val |
|
set isvar [expr {[lindex $var_class $i 1] == 6}] |
|
if {$isvar} { |
|
if {[lindex $var_actions $i 1] eq "set"} { |
|
if {[string length $nm]} { |
|
upvar $lvlup $nm the_var |
|
set the_var $val |
|
#uplevel $lvlup [list set $nm $val] |
|
} |
|
} |
|
if {[lindex $var_actions $i 1] eq "unset"} { |
|
if {[string length $nm]} { |
|
upvar $lvlup $nm the_var |
|
catch {unset the_var} |
|
#catch {uplevel $lvlup [list unset $nm]} |
|
} |
|
} |
|
} |
|
incr i |
|
} |
|
} else { |
|
#todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message |
|
#e.g for within pipeswitch block where mismatches are expected and the reasons are unimportant |
|
set vidx 0 |
|
set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] |
|
set var_display_names [list] |
|
foreach v $var_names { |
|
if {$v eq ""} { |
|
lappend var_display_names {{}} |
|
} else { |
|
lappend var_display_names $v |
|
} |
|
} |
|
set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] |
|
set msg "\n" |
|
append msg "Unmatched\n" |
|
append msg "No match of right hand side for vars in $multivar\n" |
|
append msg "vars/atoms/etc: $var_names\n" |
|
append msg "mismatches: [join $mismatches_display { } ]\n" |
|
set i 0 |
|
#0 - novar |
|
#1 - atom ' |
|
#2 - pin ^ |
|
#3 - boolean & |
|
#4 - integer |
|
#5 - double |
|
#6 - var |
|
#7 - glob (no classifier and contains * or ?) |
|
foreach mismatchinfo $mismatches { |
|
lassign $mismatchinfo status nm |
|
if {$status eq "mismatch"} { |
|
# nm can be empty string |
|
set varclass [lindex $var_class $i 1] |
|
set val [lindex $var_actions $i 2] |
|
set e [dict get [lindex $expected_values $i] lhs] |
|
if {$varclass == 1} { |
|
set type "atom" |
|
} elseif {$varclass == 2} { |
|
set type "pinned var" |
|
} elseif {$varclass == 4} { |
|
set type "int" |
|
} elseif {$varclass == 5} { |
|
set type "double" |
|
} else { |
|
set type "var" |
|
#set e "*" ;# non-atoms and non-pins should always match.. todo - review attempt to set as var instead of array? |
|
} |
|
set lhs_tag "" |
|
set mismatch_reason "" |
|
if {[dict get [lindex $expected_values $i] info] ne "match"} { |
|
set lhs_tag "- [dict get [lindex $expected_values $i] info]" |
|
|
|
set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range |
|
set tag "?mismatch-" |
|
if {[string match $tag* $mmaction]} { |
|
set mismatch_reason [string range $mmaction [string length $tag] end] |
|
} else { |
|
set mismatch_reason $mmaction |
|
} |
|
} |
|
append msg " $type: '$nm' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" |
|
} |
|
incr i |
|
} |
|
#error $msg |
|
dict unset returndict result |
|
#structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" |
|
dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] |
|
return $returndict |
|
} |
|
|
|
if {![llength $varkeylist]} { |
|
dict set returndict result $data |
|
} else { |
|
#punk::assert {$i == [llength $varkeylist]} |
|
|
|
dict set returndict result $returnval |
|
} |
|
return $returndict |
|
} |
|
|
|
|
|
proc _handle_bind_result {d} { |
|
#set match_caller [info level 2] |
|
#debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 |
|
if {![dict exists $d result]} { |
|
#uplevel 1 [list error [dict get $d mismatch]] |
|
error [dict get $d mismatch] |
|
} else { |
|
return [dict get $d result] |
|
} |
|
} |
|
#same as used in unknown func for initial launch |
|
#variable re_assign {^([^\r\n=\{]*)=(.*)} |
|
variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} |
|
variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} |
|
#match_assign is tailcalled from unknown - uplevel 1 gets to caller level |
|
proc match_assign {multivar e1 fulltail} { |
|
debug.punk.pipe {match_assign '$multivar' '$e1' '$fulltail'} 4 |
|
#can match an integer on lhs with a value |
|
# |
|
#if {[string is integer -strict $multivar]} { |
|
# #todo - implement matching |
|
# error "Cannot set a var named '$multivar' using this syntax. use == for comparison, or use set $multivar if you really want a variable named like a number." |
|
#} |
|
|
|
|
|
#attempting to allow x=y to begin a pipeline e.g x=y |> string tolower |
|
#will stop us from easily assigning an entire pipeline string to x using the 'equals-runon' syntax x=.=something etc |> blah |
|
#The tradeoff |
|
if {[llength $fulltail]} { |
|
#avoid use of regexp match on each element - or we will unnecessarily force string reps on lists |
|
#set firstlast [lmap v $fulltail {lreplace [split $v {}] 1 end-1}] |
|
#set firstpipe_posn [lsearch $firstlast {| >}] |
|
set firstpipe_posn [lsearch $fulltail "|*>"] |
|
|
|
if {$firstpipe_posn >=0} { |
|
set firstpipe [lindex $fulltail $firstpipe_posn] |
|
set tail [lrange $fulltail 0 $firstpipe_posn-1] |
|
set nextassignment [lindex $fulltail $firstpipe_posn+1] |
|
set nexttail [lrange $fulltail $firstpipe_posn+1 end] |
|
} else { |
|
set tail $fulltail |
|
set nextassignment [list] |
|
set nexttail [list] |
|
} |
|
#puts stderr "tail len: [llength $fulltail]" |
|
#puts stderr "tail-end: [lindex $fulltail end]" |
|
} else { |
|
set firstpipe_posn -1 |
|
set tail [list] |
|
set nextassignment [list] |
|
set nexttail [list] |
|
} |
|
|
|
|
|
set is_listbuilder 0 |
|
|
|
if {![string length $e1]} { |
|
#space after = |
|
if {[llength $tail] == 1} { |
|
set val [lindex $tail 0] |
|
set d [_multi_bind_result $multivar $val] |
|
set r [_handle_bind_result $d] |
|
set returnval $r |
|
} elseif {[llength $tail] == 0} { |
|
set d [_multi_bind_result $multivar "" -unset 1] ;#final arg 1 to unset variables |
|
set r [_handle_bind_result $d] ;# we can get a mismatch on unsetting a pinned var - so we need _handle_bind_result to give a chance to raise an error etc. |
|
set returnval "" |
|
} else { |
|
#keyword pipesyntax at beginning of error message |
|
set msg "pipesyntax\n" |
|
append msg "Assignment with = accepts only zero or one argument, unless characters immediately follow the = sign.\n" |
|
append msg "Characters immediately after the equals sign form the first element of a list if there is *any* literal whitespace\n" |
|
append msg "e.g x=\"abc\" will assign \"abc\" including the quotes\n" |
|
append msg "but x=\"ab c\" will form a two element list containing \"ab and c\" \n" |
|
append msg "Note the whitespace is interpreted by Tcl as a list separator and collapsed to one space\n" |
|
append msg "To use semantics more equivalent to 'set' leave a space after the = e.g x= \"a b \"\n" |
|
append msg "Note in particular, that for something like: x=\"a b \"\n" |
|
append msg "The second quote is actually the operning quote for the 3rd list element\n" |
|
append msg "so the interpreter or commandline will consume following lines until a closing quote is found\n" |
|
error $msg |
|
} |
|
} elseif {([llength $tail] == 0) && ($firstpipe_posn < 0)} { |
|
#simple value assignment - even if it looks like an expression |
|
#ie x=4+1 assigns "4+1" as a string |
|
#whereas x=4 + 1 assigns 5 |
|
#set commaparts [split $var ,] |
|
set d [_multi_bind_result $multivar $e1] |
|
set r [_handle_bind_result $d] |
|
set returnval $r |
|
} else { |
|
set is_listbuilder 1 |
|
#no space concatenation - good for command aliases |
|
debug.punk.pipe "assigning fulltail [llength $fulltail]" 6 |
|
#e1 is not a list - may even be a single char such as double quote. |
|
#set result [concat $e1 $fulltail] ;#concat produces a string rep - and strips escaped whitespace e.g \t or\n from e1 and trailing args. |
|
|
|
#set result [list] |
|
#lappend result $e1 |
|
#foreach a $fulltail { |
|
# lappend result $a |
|
#} |
|
|
|
#set result [list] |
|
#lappend result $e1 {*}$fulltail |
|
|
|
set result [list $e1 {*}$fulltail] |
|
|
|
set d [_multi_bind_result $multivar $result] |
|
set r [_handle_bind_result $d] |
|
set returnval $r |
|
} |
|
|
|
#return $returnval |
|
|
|
if {![llength $nexttail] || $is_listbuilder} { |
|
return $returnval |
|
} else { |
|
#set exectail [concat [list val $returnval] $firstpipe $nexttail] |
|
set exectail [list val $returnval $firstpipe {*}$nexttail] |
|
#uplevel 1 [list punk::match_exec "" "" {*}$exectail] |
|
tailcall punk::match_exec "" "" {*}$exectail |
|
} |
|
|
|
|
|
} |
|
proc _is_math_func_prefix {e1} { |
|
#also catch starting brackets.. e.g "(min(4,$x) " |
|
if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { |
|
#possible math func |
|
if {$word in [info functions]} { |
|
return true |
|
} |
|
} |
|
return false |
|
} |
|
|
|
#todo - option to disable these traces which provide clarifying errors (performance hit?) |
|
proc pipeline_args_read_trace_error {args} { |
|
error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data instead of \$args." |
|
} |
|
|
|
|
|
#REVIEW! the whole idea of scanning for %x% is a lot of work(performance penalty) |
|
#consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements |
|
#This would simplify code a lot - but also quite possible to collide with user data. |
|
#Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. |
|
# (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope) |
|
# |
|
#detect and retrieve %xxx% elements from item without affecting list/string rep |
|
#commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) |
|
#%% is not a valid tag |
|
#(as opposed to using regexp matching which causes string reps) |
|
proc get_tags {item} { |
|
set chars [split $item {}] |
|
set terminal_chars [list , @ ' ^ " " \t \n \r] |
|
#note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars |
|
set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] |
|
set percents [lmap v $chars {expr {$v eq "%"}}] |
|
#useful for test/debug |
|
#puts "CHARS : $chars" |
|
#puts "NONTERMINAL: $nonterminal" |
|
#puts "PERCENTS : $percents" |
|
set sequences [list] |
|
set in_sequence 0 |
|
set start -1 |
|
set end -1 |
|
set i 0 |
|
#todo - some more functional way of zipping/comparing these lists? |
|
set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 |
|
foreach n $nonterminal p $percents { |
|
if {!$in_sequence} { |
|
if {$n & $p} { |
|
set s_length 1 |
|
set in_sequence 1 |
|
set start $i |
|
set end $i |
|
} else { |
|
set s_length 0 |
|
} |
|
} else { |
|
if {$n ^ $p} { |
|
incr s_length |
|
incr end |
|
} else { |
|
if {$n & $p} { |
|
if {$s_length == 1} { |
|
# % followed dirctly by % - false start |
|
#start again from second % |
|
set s_length 1 |
|
set in_sequence 1 |
|
set start $i |
|
set end $i |
|
} else { |
|
incr end |
|
lappend sequences [list $start $end] |
|
set in_sequence 0 |
|
set s_length 0 |
|
set start -1; set end -1 |
|
} |
|
} else { |
|
#terminated - not a tag |
|
set in_sequence 0 |
|
set s_length 0 |
|
set start -1; set end -1 |
|
} |
|
} |
|
} |
|
incr i |
|
} |
|
|
|
set tags [list] |
|
foreach s $sequences { |
|
lassign $s start end |
|
set parts [lrange $chars $start $end] |
|
lappend tags [join $parts ""] |
|
} |
|
return $tags |
|
} |
|
|
|
#show underlying rep of list and first level |
|
proc rep_listname {lname} { |
|
upvar $lname l |
|
set output "$lname list rep: [rep $l]\n" |
|
foreach item $l { |
|
append output "-rep $item\n" |
|
append output " [rep $item]\n" |
|
} |
|
return $output |
|
} |
|
|
|
# |
|
# |
|
# relatively slow on even small sized scripts |
|
proc arg_is_script_shaped2 {arg} { |
|
set re {^(\s|;|\n)$} |
|
set chars [split $arg ""] |
|
if {[lsearch -regex $chars $re] >=0} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
proc arg_is_script_shaped {arg} { |
|
if {[string first " " $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first \n $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first ";" $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first \t $arg] >= 0} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
proc match_exec {initial_returnvarspec e1 args} { |
|
set fulltail $args |
|
unset args |
|
#debug.punk.pipe {call match_exec: '$initial_returnvarspec' '$e1' '$fulltail'} 9 |
|
#debug.punk.pipe.rep {[rep_listname fulltail]} 6 |
|
|
|
|
|
#temp |
|
set ::_pipescript "" |
|
|
|
|
|
#--------------------------------------------------------------------- |
|
# test if we have an initial x.=y.= or x.= y.= |
|
if {($e1 eq "") } { |
|
set nexttail [lassign $fulltail next1] ;#tail head |
|
} else { |
|
set next1 $e1 |
|
set nexttail $fulltail |
|
} |
|
|
|
if {$next1 eq "pipematch"} { |
|
set results [uplevel 1 [list pipematch {*}$nexttail]] |
|
debug.punk.pipe {>>> pipematch results: $results} 1 |
|
|
|
set d [_multi_bind_result $initial_returnvarspec $results] |
|
set r [_handle_bind_result $d] |
|
|
|
return $r |
|
} elseif {$next1 eq "pipecase"} { |
|
set msg "pipesyntax\n" |
|
append msg "pipecase does not return a value directly in the normal way\n" |
|
append msg "It will return an {error {mismatch <data>}} dict on mismatch\n" |
|
append msg "But on a successful match - it will return {ok result {something}} in the caller's scope -\n" |
|
append msg "which will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" |
|
append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." |
|
error $msg |
|
} |
|
|
|
#maintenance: punk::re_dot_assign |
|
set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} |
|
set re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} |
|
|
|
|
|
if {([string first = $next1] >= 0) && (![arg_is_script_shaped $next1]) } { |
|
|
|
if {[regexp $re_dot_assign $next1 _ nextreturnvarspec nextrhs]} { |
|
#non pipelined call to self - return result |
|
#debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 |
|
set results [uplevel 1 [list ::punk::match_exec $nextreturnvarspec $nextrhs {*}$nexttail]] |
|
#debug.punk.pipe {>>> results: $results} 1 |
|
set d [_multi_bind_result $initial_returnvarspec $results] |
|
return [_handle_bind_result $d] |
|
} |
|
|
|
if {[regexp $re_assign $next1 _ nextreturnvarspec nextrhs]} { |
|
#non pipelined call to plain = assignment - return result |
|
#debug.punk.pipe {nextreturnvarspec: $nextreturnvarspec nextrhs:$nextrhs tail:$nexttail} 4 |
|
set results [uplevel 1 [list ::punk::match_assign $nextreturnvarspec $nextrhs $nexttail]] |
|
#debug.punk.pipe {>>> results: $results} 1 |
|
set d [_multi_bind_result $initial_returnvarspec $results] |
|
return [_handle_bind_result $d] |
|
} |
|
} |
|
|
|
#--------------------------------------------------------------------- |
|
|
|
#todo add 'op' argument and handle both .= and = |
|
# |
|
#|> data piper symbol |
|
#<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) |
|
# |
|
|
|
set more_pipe_segments 1 ;#first loop |
|
|
|
#this contains the main %data% and %datalist% values going forward in the pipeline |
|
#as well as any extra pipeline vars defined in each |> |
|
#It also contains any 'args' with names supplied in <| |
|
set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline |
|
|
|
#determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g <a,b,args|. |
|
#note that there could be script blocks in between containing this symbol |
|
#e.g x.= func a b c |> transform x y z <arg1,arg2| arg1val arg2val |
|
#todo |
|
#set argsposn [lsearch [lreverse $fulltail] <|] |
|
# |
|
# |
|
# |
|
#avoid use of regexp match on each element - or we will unnecessarily force string reps on lists |
|
#set rev_firstlast [lmap v [lreverse $fulltail] {lreplace [split $v {}] 1 end-1}] |
|
#set apipe_posn_reverse [lsearch $rev_firstlast {< |}] ;#search for reverse pipe (allows commandline/curry args) |
|
set apipe_posn_reverse [lsearch [lreverse $fulltail] "<*|"] |
|
if {$apipe_posn_reverse >=0} { |
|
set apipe_posn [expr {[llength $fulltail] - $apipe_posn_reverse -1}] |
|
set datatail [lrange $fulltail 0 $apipe_posn-1] |
|
set argslist [lrange $fulltail $apipe_posn+1 end] |
|
set argpipe [lindex $fulltail $apipe_posn] |
|
set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from "<x,etc|" |
|
} else { |
|
set apipe_posn -1 |
|
set datatail $fulltail |
|
set argslist [list] |
|
set argpipespec "" ;#argumentspec e.g a,b,c from <a,b,c| |
|
} |
|
|
|
debug.punk.pipe.args {argpipespec: $argpipespec argslist: $argslist} 6 |
|
if 0 { |
|
if {[llength $argslist]} { |
|
set d [apply {{mv res} { |
|
punk::_multi_bind_result $mv $res -levelup 1 |
|
}} $argpipespec $argslist] |
|
set r [_handle_bind_result $d] |
|
set setvars [dict get $d setvars] |
|
debug.punk.pipe.args "<| setvars: $setvars" 4 |
|
|
|
#note - can use positional specs: something like <data@0,arg1@,args| |
|
foreach {k v} $setvars { |
|
#add additionally specified vars and allow overriding of %args% and %data% |
|
#dict set dict_tagval %$k% [list $v] |
|
dict set dict_tagval %$k% $v |
|
} |
|
} |
|
} |
|
#rep_listname datatail |
|
|
|
set segment_op ".=" |
|
set assignment $initial_returnvarspec.=$e1 |
|
|
|
# this forces string rep of items within datatail -> set tailremaining [concat $assignment $datatail] |
|
set tailremaining [list $assignment] |
|
lappend tailremaining {*}$datatail |
|
|
|
debug.punk.pipe {initial list (excluding argpipespec <$argpipespec| ): $datatail} 7 |
|
#rep_listname tailremaining |
|
|
|
#pipe symbols contain arg specifications which are referred to as pipespec(i,in) and pipespec(i,out) with reference to the command args between them (segment i) |
|
# - in this case b1 b2 b3 |
|
#a1 a2 a3 |inpipespec> b1 b2 b3 |outpipespec> c1 c2 c3 |
|
# for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec |
|
|
|
|
|
#our initial command list always has *something* before we see any pipespec |> |
|
#Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) |
|
set inpipespec $argpipespec |
|
set outpipespec "" |
|
|
|
#avoiding regexp on each arg to maintain list reps |
|
#set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] |
|
## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] |
|
#e.g for: a b c |> e f g |> h |
|
#set firstpipe_posn [lsearch $tailmap {| >}] |
|
|
|
set firstpipe_posn [lsearch $tailremaining "|*>"] |
|
|
|
if {$firstpipe_posn >=0} { |
|
set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] |
|
set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] |
|
#set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] |
|
set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? |
|
} else { |
|
set segment_members $tailremaining |
|
set tailremaining [list] |
|
} |
|
|
|
|
|
|
|
set script_like_first_word 0 |
|
set rhs $e1 |
|
set segment_members_script_index [list] |
|
if {![string length $e1]} { |
|
set segment_first_word [lindex $segment_members 0] |
|
set segment_second_word [lindex $segment_members 1] |
|
#first word of initial call is alays x.=y even if x and y are empty - so we only need to check second word |
|
if {[arg_is_script_shaped $segment_second_word]} { |
|
set segment_members_script_index 1 |
|
} |
|
|
|
} else { |
|
set segment_first_word $e1 ;#don't look for scriptiness here.. can only be list or expr |
|
set segment_second_word [lindex $segment_members 0] |
|
if {[arg_is_script_shaped $segment_second_word]} { |
|
set segment_members_script_index 0 |
|
} |
|
|
|
} |
|
#tailremaining includes x=y during the loop. |
|
set returnvarspec $initial_returnvarspec |
|
if {![llength $argslist]} { |
|
catch {unset previous_result} ;# we want it unset for first iteration - differentiate from empty string |
|
} else { |
|
set previous_result $argslist |
|
} |
|
|
|
set segment_result_list [list] |
|
set i 0 ;#segment id |
|
set j 1 ;#next segment id |
|
set pipespec(args) $argpipespec ;# from trailing <| |
|
set pipespec(0,in) $inpipespec |
|
set pipespec(0,out) $outpipespec |
|
|
|
set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. |
|
while {$more_pipe_segments == 1} { |
|
#--------------------------------- |
|
debug.punk.pipe {[a+ yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a+]} 4 |
|
debug.punk.pipe {[a+ yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a+]} 4 |
|
debug.punk.pipe {[a+] inpipespec(prev [a+ yellow bold]|$pipespec($i,in)[a+]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a+])} 4 |
|
debug.punk.pipe {[a+ cyan bold] segment_members_script_index:$segment_members_script_index} 4 |
|
if {[llength $segment_members_script_index]} { |
|
debug.punk.pipe {[a+ cyan bold] script segment: [lindex $segment_members $segment_members_script_index][a+]} 4 |
|
} |
|
|
|
if {$i == $max_iterations} { |
|
puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" |
|
set more_pipe_segments 0 |
|
} |
|
|
|
|
|
|
|
|
|
|
|
##set dict_tagval [regexp -all -inline {(%[[:alnum:]]*%)} $segment_members] ;# e.g %args% %args% %data% %data% |
|
#set dict_segment_tags [regexp -all -inline {(%[[:alnum:]]*%)} $segment_members] ;# e.g %args% %args% %data% %data% |
|
# |
|
set dict_segment_tags [dict create] |
|
|
|
|
|
set tagmap [lmap v $segment_members {punk::get_tags $v}] |
|
debug.punk.pipe.var {TAGMAP([llength $tagmap]): $tagmap} 5 |
|
|
|
#we definitely don't want to look for tags in scripts - would interfere with sub/nested pipelines |
|
set si 0 |
|
foreach seg $segment_members { |
|
if {$si ni $segment_members_script_index} { |
|
set tags [punk::get_tags $seg] |
|
foreach t $tags { |
|
dict set dict_segment_tags $t $t |
|
} |
|
} |
|
incr si |
|
} |
|
set segment_has_tags [dict size $dict_segment_tags] |
|
|
|
debug.punk.pipe.var {segment_tags: $dict_segment_tags} 5 |
|
debug.punk.pipe.rep {[rep_listname segment_members]} 4 |
|
|
|
|
|
set segment_result "" |
|
if {[info exists previous_result]} { |
|
set prevr $previous_result |
|
} else { |
|
set prevr "" |
|
} |
|
set pipedvars [dict create] |
|
if {[string length $pipespec($i,in)]} { |
|
#check the varspecs within the input piper |
|
# - data and/or args may have been manipulated |
|
set d [apply {{mv res} { |
|
punk::_multi_bind_result $mv $res -levelup 1 |
|
}} $pipespec($i,in) $prevr] |
|
set inpipespec_result [_handle_bind_result $d] |
|
set pipedvars [dict get $d setvars] |
|
set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' |
|
#puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" |
|
} |
|
debug.punk.pipe {[a+] previous_iteration_result: $prevr[a+]} 6 |
|
|
|
#whether the arguments have %v% tags or not - apply any modification from the piper argspecs (script will use modified args/data) |
|
if {[dict exists $pipedvars "datalist"]} { |
|
dict set dict_tagval %datalist% [dict get $pipedvars "datalist"] |
|
} else { |
|
if {[info exists previous_result]} { |
|
if {![catch {lrange $prevr 0 end} dl]} { |
|
dict set dict_tagval %datalist% $dl ;#deliberately unprotected by 'list' - will be passed through as args *if* a valid tcl list. |
|
} else { |
|
dict set dict_tagval %datalist% [list] |
|
} |
|
} |
|
} |
|
if {[dict exists $pipedvars "data"]} { |
|
#dict set dict_tagval %data% [list [dict get $pipedvars "data"]] |
|
dict set dict_tagval %data% [dict get $pipedvars "data"] |
|
} else { |
|
if {[info exists previous_result]} { |
|
dict set dict_tagval %data% $prevr |
|
} |
|
} |
|
foreach {k v} $pipedvars { |
|
#add additionally specified vars and allow overriding of %args% and %data% by not setting them here |
|
if {$k in [list "datalist" "data"]} { |
|
#already potentially overridden |
|
continue |
|
} |
|
#dict set dict_tagval %$k% [list $v] |
|
dict set dict_tagval %$k% $v |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#check it's still a valid list? |
|
if {!$segment_has_tags} { |
|
#debug.punk.pipe.var {[a+ cyan]SEGMENT has no tags[a+]} 7 |
|
#add previous_result as data only if no tags present (data is just list-wrapped previous_result vs args = forward-result treated as already being a list) |
|
#set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default - not args - because some strings are not valid lists |
|
set segment_members_filled $segment_members |
|
if {[dict exists $dict_tagval %data%]} { |
|
lappend segment_members_filled [dict get $dict_tagval %data%] |
|
} |
|
|
|
} else { |
|
debug.punk.pipe.var {dict_tagval: $dict_tagval} 4 |
|
set segment_members_filled [list] |
|
set idxmem 0 |
|
foreach mem $segment_members { |
|
#todo - skip 'script' segments |
|
set tags [lindex $tagmap $idxmem] |
|
if {[llength $tags]} { |
|
if {"%datalist%" in $tags} { |
|
if {$mem eq "%datalist%"} { |
|
#exact match is the preferred way to use datalist |
|
if {[dict exists $dict_tagval %datalist%]} { |
|
set dl [dict get $dict_tagval %datalist%] |
|
foreach datum $dl { |
|
lappend segment_members_filled $datum |
|
} |
|
} else { |
|
#nothing to put - omit in output |
|
} |
|
} else { |
|
#assume/hope the user knows what they're doing... |
|
#maybe they are trying to quote the list etc. |
|
lappend segment_members_filled [string map $dict_tagval $mem] |
|
} |
|
} else { |
|
lappend segment_members_filled [string map $dict_tagval $mem] |
|
} |
|
} else { |
|
lappend segment_members_filled $mem |
|
} |
|
incr idxmem |
|
} |
|
#note - length of segment_members_filled may now differ from length of original segment_members! |
|
|
|
#set segment_members_filled [string map $dict_tagval $segment_members] |
|
#set segment_members_filled [lrange $segment_members_filled 0 end] ;#back to list rep |
|
} |
|
set rhs [string map $dict_tagval $rhs] |
|
|
|
debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 |
|
|
|
|
|
#we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) |
|
if {(![llength $segment_members_script_index]) && $segment_op eq ".="} { |
|
|
|
|
|
#set subresult [uplevel 1 [list ::punk::match_exec $returnvarspec $rhs $segment_members_filled]] |
|
if {[string index $rhs 0] eq "\{"} { |
|
if {[llength $segment_members_filled] == 1} { |
|
if {[string index $rhs end] eq "\}"} { |
|
set e [string range $rhs 1 end-1] |
|
} else { |
|
#missing close bracket - evaluate anyway? |
|
set e [string range $rhs 1 end] |
|
} |
|
} else { |
|
#must be 2 or more total elements in segment_members (which includes the x.=y) |
|
set seg_remainder [lrange $segment_members_filled 1 end] ;#exclude the x.=y |
|
set last2 [string range $seg_remainder end-1 end] |
|
#puts stderr "last2chars.. $last2" |
|
if {$last2 eq "\\\}"} { |
|
set seg_remainder [string range $seg_remainder 0 end-2] |
|
} |
|
set e [string range $rhs 1 end] |
|
append e $seg_remainder |
|
} |
|
|
|
debug.punk.pipe {>evaluating $e as expression\n due to brace \"\{\" immediately following .=} 4 |
|
|
|
if {![catch {uplevel 1 [list expr $e]} evaluated]} { |
|
#set forward_result $evaluated |
|
set d [_multi_bind_result $returnvarspec [punk::K $evaluated [unset evaluated]]] |
|
set r [_handle_bind_result $d] |
|
#return $r |
|
set segment_result $r |
|
} else { |
|
set msg "pipesyntax" |
|
append msg "Attempted to evaluate as expression '$e'\n" |
|
append msg "due to brace \"\{\" immediately following .= \n" |
|
append msg "(place other commands immediately following .= or place script block after a space)\n" |
|
append msg "expression error: $evaluated" |
|
error $msg |
|
} |
|
} elseif {($rhs ne "") && ([string is double -strict $rhs] || [_is_math_func_prefix $rhs])} { |
|
#check of rhs ne "" is important to not waste time with _is_math_func_prefix |
|
debug.punk.pipe {evaluating $rhs {*}[lrange $segment_members_filled 1 end] as expression\n due to number or math func immediately following .=} 4 |
|
if {![catch {uplevel 1 [list expr $rhs {*}[lrange $segment_members_filled 1 end]]} evaluated]} { |
|
set forward_result $evaluated |
|
set d [_multi_bind_result $returnvarspec $forward_result] |
|
set r [_handle_bind_result $d] |
|
#return $r |
|
set segment_result $r |
|
} else { |
|
set msg "pipesyntax" |
|
append msg "Attempted to evaluate as expression\n" |
|
append msg "due to number or math func immediately following .= \n" |
|
append msg "(place other commands immediately following .= or place script block after a space)\n" |
|
append msg "expression error: $evaluated" |
|
error $msg |
|
} |
|
} else { |
|
#no scriptiness detected |
|
#set cmdlist [list] |
|
if {[llength $rhs]} { |
|
#lappend cmdlist $rhs |
|
set cmdlist [list $rhs] |
|
} else { |
|
set cmdlist [list] |
|
} |
|
lappend cmdlist {*}[lrange $segment_members_filled 1 end] |
|
#set cmdlist [concat $rhs [lrange $segment_members_filled 1 end]] ;#ok if rhs empty |
|
|
|
#debug.punk.pipe {>>firstword: [lindex $cmdlist 0] bindingspec:$returnvarspec >>cmdlist([llength $cmdlist]: $cmdlist)} 4 |
|
#debug.punk.pipe.rep {[a+ yellow bold][rep_listname cmdlist][a+]} 4 |
|
|
|
set cmdlist_result [uplevel 1 $cmdlist] |
|
#debug.punk.pipe {[a+ green bold]forward_result: $forward_result[a+]} 4 |
|
#debug.punk.pipe.rep {[a+ yellow bold]forward_result REP: [rep $forward_result][a+]} 4 |
|
|
|
set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] |
|
set r [_handle_bind_result $d] |
|
set segment_result $r |
|
#puts stderr ">>forward_result: $forward_result segment_result $r" |
|
} |
|
|
|
|
|
|
|
|
|
} elseif {$segment_op eq "="} { |
|
set segment_result [uplevel 1 [list ::punk::match_assign $returnvarspec $rhs [lrange $segment_members_filled 1 end]]] |
|
#review |
|
#set forward_result $segment_result |
|
|
|
|
|
|
|
} elseif {[llength $segment_members_script_index]} { |
|
#script |
|
debug.punk.pipe {[a+ cyan bold].. evaluating as script[a+]} 2 |
|
set script [lindex $segment_members $segment_members_script_index] ;#default. May have pre_script prepended later |
|
#build argument lists for 'apply' |
|
set segmentargnames [list] |
|
set segmentargvals [list] |
|
foreach {k v} $dict_tagval { |
|
set varname [string range $k 1 end-1] ;# strip off first and last % only |
|
if {$varname eq "%argsdata%"} { |
|
#skip args - it is manually added at the end of the apply list if it's a valid tcl list |
|
continue |
|
} |
|
lappend segmentargnames $varname |
|
lappend segmentargvals $v |
|
} |
|
|
|
set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list |
|
set add_argsdata 1 |
|
if {[dict exists $dict_tagval "%argsdata%"]} { |
|
set argsdatalist [dict get $dict_tagval "%argsdata%"] |
|
#see if the raw result can be treated as a list |
|
if {[catch {lindex $argsdatalist 0}]} { |
|
#we cannot supply 'args' |
|
set pre_script "" |
|
#todo - only add trace if verbose warnings enabled? |
|
append pre_script "trace add variable argsdata read punk::pipeline_args_read_trace_error\n" |
|
set script $pre_script |
|
append script $segment_first_word |
|
set add_argsdata 0 |
|
} |
|
} |
|
|
|
if {!$add_argsdata} { |
|
debug.punk.pipe {APPLY1: args:$segmentargnames} 4 |
|
#puts stderr " script: $script" |
|
#puts stderr " vals: $segmentargvals" |
|
#set evaluation [apply [list $segmentargnames $script ::] {*}$segmentargvals] |
|
set evaluation [uplevel 1 [list apply [list $segmentargnames $script ::] {*}$segmentargvals]] |
|
} else { |
|
debug.punk.pipe {APPLY2: args:$segmentargnames} 4 |
|
#puts stderr " script: $script" |
|
#puts stderr " vals: $segmentargvals $argsdatalist" |
|
#set evaluation [apply [list [concat $segmentargnames argsdata] $script ::] {*}$segmentargvals $argsdatalist] |
|
|
|
#pipeline script context should be one below calling context - so upvar v v will work |
|
set evaluation [uplevel 1 [list apply [list [concat $segmentargnames argsdata] $script ::] {*}$segmentargvals $argsdatalist]] |
|
} |
|
#set forward_result $evaluation |
|
set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] |
|
set r [_handle_bind_result $d] |
|
set segment_result $r |
|
|
|
} else { |
|
#tags ? |
|
#debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 |
|
if 0 { |
|
|
|
|
|
|
|
#set s [list uplevel 1 [concat $rhs $segment_members_filled]] |
|
if {![info exists pscript]} { |
|
upvar ::_pipescript pscript |
|
} |
|
if {![info exists pscript]} { |
|
#set pscript $s |
|
set pscript [funcl::o_of_n 1 [list $rhs {*}$segment_members]] |
|
} else { |
|
#set pscript [string map [list <p> $pscript] {uplevel 1 [concat $rhs $segment_members_filled [<p>]]}] |
|
#set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " |
|
#append snew "set pipe_[expr $i -1]" |
|
#append pscript $snew |
|
set pscript [funcl::o_of_n 1 [list $rhs {*}$segment_members] $pscript] |
|
|
|
} |
|
} |
|
set cmdline_result [uplevel 1 [concat $rhs $segment_members_filled]] |
|
set d [_multi_bind_result $returnvarspec [punk::K $cmdline_result [unset cmdline_result]]] |
|
|
|
#multi_bind_result needs to return a funcl for rhs of: |
|
#lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] |
|
#which uses syncvar |
|
# |
|
#The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. |
|
#NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result |
|
|
|
set r [_handle_bind_result $d] |
|
set segment_result $r |
|
} |
|
#the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable |
|
#It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section |
|
#It may however make a good debug point |
|
#puts stderr "segment $i segment_result:$segment_result" |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#examine tailremaining. |
|
# either x x x |?> y y y ... |
|
# or just y y y |
|
#we want the x side for next loop |
|
|
|
#set up the conditions for the next loop |
|
#|> x=y args |
|
# inpipespec - contents of previous piper |xxx> |
|
# outpipespec - empty or content of subsequent piper |xxx> |
|
# previous_result |
|
# assignment (x=y) |
|
|
|
|
|
set pipespec($j,in) $pipespec($i,out) |
|
set outpipespec "" |
|
set tailmap "" |
|
set next_pipe_posn -1 |
|
if {[llength $tailremaining]} { |
|
|
|
#set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] |
|
##e.g for: a b c |> e f g |> h |
|
#set next_pipe_posn [lsearch $tailmap {| >}] |
|
set next_pipe_posn [lsearch $tailremaining "|*>"] |
|
|
|
set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] |
|
} |
|
set pipespec($j,out) $outpipespec |
|
|
|
|
|
set segment_members_script_index [list] |
|
set script_like_first_word 0 |
|
if {[llength $tailremaining] || $next_pipe_posn >= 0} { |
|
|
|
if {$next_pipe_posn >=0} { |
|
set segment_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> |
|
set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] |
|
|
|
} else { |
|
set segment_members $tailremaining |
|
set tailremaining [list] |
|
} |
|
|
|
|
|
#assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) |
|
set segment_first_word "" |
|
set returnvarspec "" ;# the lhs of x=y |
|
set segment_op "" |
|
set rhs "" |
|
if {[llength $segment_members]} { |
|
if {[arg_is_script_shaped [lindex $segment_members 0]]} { |
|
set segment_first_word [lindex $segment_members 0] |
|
set segment_second_word [lindex $segment_members 1] |
|
set segment_members_script_index 0 |
|
set segment_op "" |
|
|
|
} else { |
|
set possible_assignment [lindex $segment_members 0] |
|
if {[regexp $re_dot_assign $possible_assignment _ returnvarspec rhs]} { |
|
set segment_op ".=" |
|
if {![string length $rhs]} { |
|
set segment_first_word [lindex $segment_members 1] |
|
set segment_second_word [lindex $segment_members 2] |
|
set script_like_first_word [arg_is_script_shaped $segment_first_word] |
|
if {$script_like_first_word} { |
|
set segment_members_script_index 1 |
|
} |
|
} else { |
|
set segment_first_word $rhs |
|
set segment_second_word [lindex $segment_members 1] |
|
} |
|
} elseif {[regexp $re_assign $possible_assignment _ returnvarspec rhs]} { |
|
set segment_op "=" |
|
#never scripts |
|
set segment_first_word [lindex $segment_members 1] |
|
set segment_second_word [lindex $segment_members 2] |
|
|
|
} else { |
|
#no assignment operator and not script shaped |
|
set segment_op "" |
|
set returnvarspec "" |
|
set segment_first_word [lindex $segment_members 0] |
|
set segment_first_word [lindex $segment_members 1] |
|
#puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" |
|
} |
|
} |
|
|
|
|
|
} else { |
|
#?? two pipes in a row ? |
|
debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a+]} 0 |
|
set segment_members return |
|
set segment_first_word return |
|
} |
|
|
|
#set forward_result $segment_result |
|
set previous_result $segment_result |
|
} else { |
|
debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a+]} 4 |
|
set more_pipe_segments 0 |
|
} |
|
|
|
#the segment_result is based on the leftmost var on the lhs of the .= |
|
#whereas forward_result is always the entire output of the segment |
|
lappend segment_result_list $segment_result |
|
incr i |
|
incr j |
|
} ;# end while |
|
|
|
return [lindex $segment_result_list end] |
|
#return $forward_result |
|
} |
|
|
|
proc configure_unknown {} { |
|
#----------------------------- |
|
#these are critical e.g core behaviour or important for repl displaying output correctly |
|
|
|
#---------------- |
|
#for var="val {a b c}" |
|
#proc ::punk::val {{v {}}} {tailcall lindex $v} |
|
proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version |
|
#---------------- |
|
|
|
#can't use know - because we don't want to return before original unknown body is called. |
|
proc ::unknown {args} [string map [list] { |
|
set ::punk::last_run_display [list] |
|
set ::repl::last_unknown [lindex $args 0] ;#jn |
|
}][info body ::unknown] |
|
|
|
|
|
#handle process return dict of form {exitcode num etc blah} |
|
#ie when the return result as a whole is treated as a command |
|
#exitcode must be the first key |
|
know {[lindex $args 0 0] eq "exitcode"} { |
|
uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] |
|
} |
|
|
|
|
|
#----------------------------- |
|
# |
|
# potentially can be disabled by config(?) - but then scripts not able to use all repl features.. |
|
|
|
know {[expr $args] || 1} { |
|
#todo - repl output info that it was evaluated as an expression |
|
expr $args |
|
} |
|
|
|
#it is significantly faster to call a proc like this than to inline it in the unknown proc |
|
proc ::punk::range {from to args} { |
|
set count [expr {($to -$from) + 1}] |
|
incr from -1 |
|
return [lmap v [lrepeat $count 0] {incr from}] |
|
} |
|
know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} { |
|
punk::range $from $to |
|
} |
|
#if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} |
|
|
|
|
|
|
|
proc ::punk::_unknown_assign_dispatch {partzerozero varspecs rhs arglist} { |
|
set tail [lassign $args hd] |
|
if {$hd ne $partzerozero} { |
|
regexp $punk::re_assign $hd _ varspecs rhs |
|
} |
|
tailcall ::punk::match_assign $varspecs $rhs $tail |
|
} |
|
|
|
#variable re_assign {^([^\r\n=\{]*)=(.*)} |
|
know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} { |
|
#if {![string length $varspecs]} { |
|
#todo allow = with novar and just return value |
|
#error "usage varspecs=val varspecs cannot be empty string using this syntax. Use ''set {} val' if you want to set a var with an empty-string name" |
|
#} |
|
|
|
#characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) |
|
#unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list |
|
#e.g x=a\nb c |
|
#x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained |
|
set tail [lassign $args hd] |
|
if {$hd ne $partzerozero} { |
|
regexp $punk::re_assign $hd _ varspecs rhs |
|
} |
|
|
|
#must be tailcall so match_assign runs at same level as the unknown proc |
|
tailcall ::punk::match_assign $varspecs $rhs $tail |
|
} |
|
#ensure == is after = in know sequence |
|
#.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions |
|
know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} { |
|
if {![string length [string trim $val2]]} { |
|
if {[llength $args] > 1} { |
|
#error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" |
|
set val2 [string cat {*}[lrange $args 1 end]] |
|
return [expr {$val1 eq $val2}] |
|
} |
|
return $val1 |
|
} elseif {[llength $args] == 1} { |
|
#simple comparison |
|
if {[string is digit -strict $val1$val2]} { |
|
return [expr {$val1 == $val2}] |
|
} else { |
|
return [string equal $val1 $val2] |
|
} |
|
} elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { |
|
if {[string is digit -strict $val1$evaluated]} { |
|
return [expr {$val1 == $evaluated}] |
|
} else { |
|
return [expr {$val1 eq $evaluated}] |
|
} |
|
} else { |
|
set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] |
|
if {[string is digit -strict $val1$evaluated]} { |
|
return [expr {$val1 == $evaluated}] |
|
} else { |
|
return [expr {$val1 eq $evaluated}] |
|
} |
|
} |
|
} |
|
#.= must come after = here to ensure it comes before = in the 'unknown' proc |
|
#set punk::re_dot_assign {([^=]*)\.=(.*)} |
|
#know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { |
|
# set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] |
|
# tailcall ::punk::match_exec $varspecs $rhs {*}$tail |
|
# #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] |
|
#} |
|
know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { |
|
set argstail [lassign $args hd] |
|
#set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! |
|
#avoid using the return from expr and it works: |
|
expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } |
|
|
|
tailcall ::punk::match_exec $varspecs $rhs {*}$tail |
|
#return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] |
|
} |
|
#know {[regexp {^=([^=]*)} [lindex $args 0] _ v1]} { |
|
# set calc [concat $v1 [lrange $args 1 end]] |
|
# puts stderr "= $calc" |
|
# return [expr $calc] |
|
#} |
|
|
|
} |
|
configure_unknown |
|
#if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. |
|
# |
|
|
|
#main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc |
|
#Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. |
|
proc % {args} { |
|
set arglist [lassign $args assign] ;#tail, head |
|
if {$assign eq ".="} { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::match_assign "" "" $arglist] |
|
} elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { |
|
set re_equals {^([^ \t\r\n=\{]*)=$} |
|
set re_dotequals {^([^ \t\r\n=\{]*)\.=$} |
|
if {[regexp $re_dotequals $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::match_exec $returnvarspecs "" {*}$arglist] |
|
} elseif {[regexp $re_equals $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::match_assign $returnvarspecs "" $arglist] |
|
} else { |
|
error "pipesyntax punk::% unable to interpret pipeline '$args'" |
|
} |
|
} else { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$args] |
|
} |
|
tailcall {*}$cmdlist |
|
} |
|
|
|
proc ispipematch {args} { |
|
expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} |
|
} |
|
|
|
#pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} |
|
proc pipematch {args} { |
|
#debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 |
|
variable re_dot_assign |
|
variable re_assign |
|
|
|
set arglist [lassign $args assign] |
|
if {$assign eq ".="} { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::match_assign "" "" $arglist] |
|
} elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::match_exec $returnvarspecs $rhs {*}$arglist] |
|
} elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::match_assign $returnvarspecs $rhs $arglist] |
|
} else { |
|
set cmdlist $args |
|
#return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] |
|
} |
|
|
|
if {[catch {uplevel 1 $cmdlist} result]} { |
|
#debug.punk.pipe {pipematch error $result} 4 |
|
if {[string match "binding*mismatch*" $result]} { |
|
#error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch |
|
#return [dict create error [dict create mismatch $result]] |
|
return [list error [list mismatch $result]] |
|
} |
|
if {[string match "pipesyntax*" $result]} { |
|
error $result |
|
} |
|
#return [dict create error [dict create reason $result]] |
|
return [list error [list reason $result]] |
|
} else { |
|
#debug.punk.pipe {pipematch result $result } 4 |
|
#return [dict create ok [dict create result $result]] |
|
return [list ok [list result $result]] |
|
} |
|
} |
|
|
|
proc pipenomatchvar {varname args} { |
|
if {[string first = $varname] >=0} { |
|
#first word "pipesyntax" is looked for by pipecase |
|
error "pipesyntax pipenomatch expects a simple varname as first argument" |
|
} |
|
#debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 |
|
|
|
set assign [lindex $args 0] |
|
set arglist [lrange $args 1 end] |
|
if {[string first = $assign] >= 0} { |
|
variable re_dot_assign |
|
variable re_assign |
|
#what if we get passed a script block containing = ?? e.g {error x=a} |
|
if {$assign eq ".="} { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::match_assign "" "" $arglist] |
|
} elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::match_exec $returnvarspecs $rhs {*}$arglist] |
|
} elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::match_assign $returnvarspecs $rhs $arglist] |
|
} else { |
|
debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a+]} 0 |
|
set cmdlist $args |
|
#return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] |
|
} |
|
} else { |
|
set cmdlist $args |
|
} |
|
|
|
upvar 1 $varname nomatchvar |
|
if {[catch {uplevel 1 $cmdlist} result]} { |
|
debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a+]} 3 |
|
if {[string match "pipesyntax*" $result]} { |
|
set errordict [dict create error [dict create pipesyntax $result]] |
|
set nomatchvar $errordict |
|
error $result |
|
} |
|
if {[string match "binding*mismatch*" $result]} { |
|
#error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch |
|
set errordict [dict create error [dict create mismatch $result]] |
|
set nomatchvar $errordict |
|
error $result |
|
} |
|
set errordict [dict create error [dict create reason $result]] |
|
set nomatchvar $errordict |
|
#re-raise the error for pipeswitch to deal with |
|
error $result |
|
} else { |
|
debug.punk.pipe {pipematchnomatch result $result } 4 |
|
set nomatchvar "" |
|
#uplevel 1 [list set $varname ""] |
|
#return raw result only - to pass through to pipeswitch |
|
return $result |
|
#return [dict create ok [dict create result $result]] |
|
} |
|
} |
|
|
|
#should only raise an error for pipe syntax errors - all other errors should be wrapped |
|
proc pipecase {args} { |
|
#debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 |
|
set arglist [lassign $args assign] |
|
if {$assign eq ".="} { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::match_assign "" "" $arglist] |
|
} elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { |
|
set re_equals {^([^ \t\r\n=\{]*)=$} |
|
set re_dotequals {^([^ \t\r\n=\{]*)\.=$} |
|
if {[regexp $re_dotequals $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::match_exec $returnvarspecs "" {*}$arglist] |
|
} elseif {[regexp $re_equals $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::match_assign $returnvarspecs "" $arglist] |
|
} else { |
|
error "pipesyntax punk::% unable to interpret pipeline '$args'" |
|
} |
|
} else { |
|
set cmdlist [list ::punk::match_exec "" "" {*}$args] |
|
} |
|
|
|
|
|
if {[catch {uplevel 1 $cmdlist} result]} { |
|
#puts stderr "====>>> $result" |
|
if {[string match "pipesyntax*" $result]} { |
|
error $result |
|
} |
|
if {[string match "binding*mismatch*" $result]} { |
|
#error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch |
|
return [dict create error [dict create mismatch $result]] |
|
#return [dict create error [dict create reason $result]] |
|
} |
|
#we can't always treat $result as a list - may be malformed |
|
if {[catch {lindex $result 0} word1]} { |
|
tailcall error $result |
|
} else { |
|
if {$word1 in [list "switcherror" "funerror"]} { |
|
error $result "pipecase [lsearch -all -inline $args "*="]" |
|
} |
|
if {$word1 in [list "resultswitcherror" "resultfunerror"]} { |
|
#recast the error as a result without @@ok wrapping |
|
#use the tailcall return to stop processing other cases in the switch! |
|
tailcall return [dict create error $result] |
|
} |
|
if {$word1 eq "ignore"} { |
|
#suppress error, but use normal return |
|
return [dict create error [dict create suppressed $result]] |
|
} else { |
|
#normal tcl error |
|
#return [dict create error [dict create reason $result]] |
|
tailcall error $result |
|
} |
|
} |
|
} else { |
|
tailcall return [dict create ok [dict create result $result]] |
|
} |
|
|
|
} |
|
|
|
#note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. |
|
#It also - somewhat unusually accepts args - which we provide as 'switchargs' |
|
#This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. |
|
#Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. |
|
proc pipeswitch {pipescript args} { |
|
#set nextargs $args |
|
#unset args |
|
#upvar args upargs |
|
#set upargs $nextargs |
|
upvar switchargs switchargs |
|
set switchargs $args |
|
uplevel 1 [list if 1 $pipescript] |
|
} |
|
proc ansi+ {args} { |
|
variable ansi_disabled |
|
if {$ansi_disabled == 1} { |
|
return |
|
} |
|
tailcall ::shellfilter::ansi::+ {*}$args |
|
} |
|
proc ansi {{onoff {}}} { |
|
variable ansi_disabled |
|
if {[string length $onoff]} { |
|
set onoff [string tolower $onoff] |
|
if {$onoff in [list 1 on true yes]} { |
|
interp alias "" a+ "" punk::ansi+ |
|
set ansi_disabled 0 |
|
} elseif {$onoff in [list 0 off false no]} { |
|
interp alias "" a+ "" control::no-op |
|
set ansi_disabled 1 |
|
} else { |
|
error "punk::ansi expected 0|1|on|off|true|false|yes|no" |
|
} |
|
} |
|
catch {repl::reset_prompt} |
|
return [expr {!$ansi_disabled}] |
|
} |
|
proc scriptlibpath {{shortname {}} args} { |
|
upvar ::punk::config::running running_config |
|
set scriptlib [dict get $running_config scriptlib] |
|
if {[string match "lib::*" $shortname]} { |
|
set relpath [string map [list "lib::" "" "::" "/"] $shortname] |
|
set relpath [string trimleft $relpath "/"] |
|
set fullpath $scriptlib/$relpath |
|
} else { |
|
set shortname [string trimleft $shortname "/"] |
|
set fullpath $scriptlib/$shortname |
|
} |
|
return $fullpath |
|
} |
|
|
|
#todo - something better - 'previous' rather than reverting to startup |
|
proc channelcolors {{onoff {}}} { |
|
upvar ::punk::config::running running_config |
|
upvar ::punk::config::startup startup_config |
|
|
|
if {![string length $onoff]} { |
|
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] |
|
} else { |
|
set lower_onoff [string tolower $onoff] |
|
if {$lower_onoff in [list true on 1]} { |
|
dict set running_config color_stdout [dict get $startup_config color_stdout] |
|
dict set running_config color_stderr [dict get $startup_config color_stderr] |
|
} elseif {$lower_onoff in [list false off 0]} { |
|
dict set running_config color_stdout "" |
|
dict set running_config color_stderr "" |
|
} else { |
|
error "channelcolors: invalid value $onoff - expected true|false|on|off|1|0" |
|
} |
|
} |
|
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] |
|
} |
|
#useful for aliases e.g treemore -> xmore tree |
|
proc xmore {args} { |
|
if {[llength $args]} { |
|
{*}$args | more |
|
} else { |
|
error "usage: punk::xmore args where args are run as {*}\$args | more" |
|
} |
|
} |
|
proc winpath {path} { |
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
|
# |
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
|
# |
|
#convert /c/etc to C:/etc |
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
|
set volumes [file volumes] |
|
#exclude things like //zipfs:/ |
|
set driveletters [list] |
|
foreach v $volumes { |
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
|
lappend driveletters $letter |
|
} |
|
} |
|
#puts stderr "->$driveletters" |
|
if {[regexp $re_slash_x_slash $path _ letter]} { |
|
#upper case appears to be windows canonical form |
|
set path [string toupper $letter]:/[string range $path 3 end] |
|
} elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { |
|
set path [string toupper $letter]:/[string range $path 7 end] |
|
} elseif {[regexp $re_slash_else $path _ firstpart remainder]} { |
|
#could be for example /c or /something/users |
|
if {[string length $firstpart] == 1} { |
|
set letter $firstpart |
|
set path [string toupper $letter]:/ |
|
} else { |
|
#attempt to use cygpath helper |
|
if {![catch { |
|
set cygpath [runout -n cygpath -w $path] ;#! |
|
set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
|
} errM]} { |
|
set path [string map [list "\\" "/"] $cygpath] |
|
} else { |
|
error "Path '$path' does not appear to be in a standard form. For unix-like paths on windows such as /x, x must correspond to a drive letter. Consider installing cygwin's cygpath tool to see if that helps." |
|
} |
|
} |
|
} |
|
#puts stderr "=> $path" |
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
|
# |
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
|
#We want it to look at cwd for relative paths.. but we don't consider things like /c/Users to be relative even on windows |
|
if {![file exists [file dirname $path]]} { |
|
set path [file normalize $path] |
|
#may still not exist.. that's ok. |
|
} |
|
return $path |
|
} |
|
proc windir {path} { |
|
return [file dirname [punk::winpath $path]] |
|
} |
|
|
|
#------------------------------------------------------------------- |
|
#sh 'test' equivalent - to be used with exitcode of process |
|
# |
|
|
|
#single evaluation to get exitcode |
|
proc sh_test {args} { |
|
tailcall run test {*}$args |
|
} |
|
|
|
|
|
#double-evaluation to get true/fals |
|
#faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented |
|
#The problem with fallthrough is that sh/bash etc have a different view of existant files |
|
#e.g unix files such as /dev/null vs windows devices such as CON,PRN |
|
#e.g COM1 is mapped as /dev/ttyS1 in wsl (?) |
|
proc sh_TEST {args} { |
|
set a1 [lindex $args 0] |
|
set a2 [lindex $args 1] |
|
set a3 [lindex $args 2] |
|
if {[llength $args] == 1} { |
|
#equivalent of -n STRING |
|
return [expr {[string length $a1] != 0}] |
|
} elseif {[llength $args] == 2} { |
|
switch -- $a1 { |
|
-b { |
|
#dubious utility on FreeBSD, windows? |
|
#FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' |
|
#Linux apparently uses them though |
|
if{[file exists $a2]} { |
|
if {[file type $a2] eq "blockSpecial"} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} else { |
|
return false |
|
} |
|
} |
|
-c { |
|
#e.g on windows CON,NUL |
|
if {[file exists $a2]} { |
|
if {[file type $a2] eq "characterSpecial"} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} else { |
|
return false |
|
} |
|
} |
|
-d { |
|
return [file isdirectory $a2] |
|
} |
|
-e { |
|
return [file exists $a2] |
|
} |
|
-f { |
|
#e.g on windows CON,NUL |
|
if {[file exists $a2]} { |
|
if {[file type $a2] eq "file"} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} else { |
|
return false |
|
} |
|
} |
|
-h - |
|
-L { |
|
return [expr {[file type $a2] eq "link"}] |
|
} |
|
-s { |
|
if {[file exists $a2] && ([file size $a2] > 0 )} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} |
|
-S { |
|
if {[file exists $a2]} { |
|
if {[file type $a2] eq "socket"} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} else { |
|
return false |
|
} |
|
} |
|
-x { |
|
if {[file exists $a2] && [file executable $a2]} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} |
|
-w { |
|
if {[file exists $a2] && [file writable $a2]} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} |
|
-z { |
|
return [expr {[string length $a2] == 0}] |
|
} |
|
-n { |
|
return [expr {[string length $a2] != 0}] |
|
} |
|
default { |
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
|
} |
|
} |
|
} elseif {[llength $args] == 3} { |
|
switch -- $a2 { |
|
"=" { |
|
return [string equal $a1 $a3] |
|
} |
|
"!=" { |
|
return [expr {$a1 ne $a3}] |
|
} |
|
"-eq" { |
|
if {![string is integer -strict $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
return false |
|
} |
|
if {![string is integer -strict $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
return false |
|
} |
|
return [expr {$a1 == $a3}] |
|
} |
|
"-ge" { |
|
return [expr {$a1 >= $a3}] |
|
} |
|
"-gt" { |
|
return [expr {$a1 > $a3}] |
|
} |
|
"-le" { |
|
return [expr {$a1 <= $a3}] |
|
} |
|
"-lt" { |
|
return [expr {$a1 < $a3}] |
|
} |
|
"-ne" { |
|
return [expr {$a1 != $a3}] |
|
} |
|
default { |
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
|
} |
|
} |
|
} else { |
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
|
} |
|
} |
|
proc sh_echo {args} { |
|
tailcall run echo {*}$args |
|
} |
|
proc sh_ECHO {args} { |
|
tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args |
|
} |
|
|
|
|
|
#sh style true/false for process exitcode. 0 is true - everything else false |
|
proc exitcode {args} { |
|
set c [lindex $args 0] |
|
if {[string is integer -strict $c]} { |
|
#return [expr {$c == 0}] |
|
#return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true |
|
if {$c == 0} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} else { |
|
return false |
|
} |
|
} |
|
#------------------------------------------------------------------- |
|
|
|
namespace export help aliases alias cdwin cdwindir winpath windir app |
|
namespace ensemble create |
|
|
|
#todo - in thread |
|
#todo - streaming version |
|
proc dirfiles_lists {{glob ""}} { |
|
set dir [pwd] |
|
if {$glob eq ""} { |
|
set glob "*" |
|
} |
|
set dirname [file dirname $glob] ;# for * or something* will return just "." which is ok |
|
set ftail [file tail $glob] |
|
|
|
if {[string first ? $glob] >= 0 || [string first * $glob] >=0} { |
|
#has globchar (we only recognise in tail) |
|
set location $dirname |
|
set glob $ftail |
|
} else { |
|
set location $dirname/$ftail |
|
set glob * |
|
} |
|
|
|
set dirs [glob -nocomplain -directory $location -type d -tail $glob] |
|
set files [glob -nocomplain -directory $location -type f -tail $glob] |
|
return [list dirs $dirs files $files] |
|
} |
|
proc dirfiles {{glob ""}} { |
|
|
|
package require overtype |
|
set contents [dirfiles_lists $glob] |
|
set dirs [dict get $contents dirs] |
|
set files [dict get $contents files] |
|
|
|
set widest 4 |
|
foreach d $dirs { |
|
set w [string length $d] |
|
if {$w > $widest} { |
|
set widest $w |
|
} |
|
} |
|
|
|
set displaylist [list] |
|
set col1 [string repeat " " [expr {$widest + 2}]] |
|
foreach d $dirs f $files { |
|
lappend displaylist [overtype::left $col1 $d]$f |
|
} |
|
|
|
return [list_as_lines $displaylist] |
|
} |
|
|
|
#tailcall is important |
|
#TODO - fix. conflicts with Tk toplevel command "." |
|
proc ./ {args} { |
|
set ::punk::last_run_display [list] |
|
|
|
if {([llength $args]) && ([lindex $args 0] eq "")} { |
|
set args [lrange $args 1 end] |
|
} |
|
|
|
|
|
if {![llength $args]} { |
|
#ls is too slow even over a fairly low-latency network |
|
#set out [runout -n ls -aFC] |
|
set out [punk::dirfiles] |
|
|
|
#puts stdout $out |
|
#puts stderr [a+ white]$out[a+] |
|
set result [pwd] |
|
set chunklist [list] |
|
lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] |
|
lappend chunklist [list result $result] |
|
set ::punk::last_run_display $chunklist |
|
if {$::repl::running} { |
|
repl::term::set_console_title [file normalize $result] |
|
} |
|
return $result |
|
} else { |
|
#set a1 [lindex $args 0] |
|
set atail [lassign $args a1] |
|
if {$a1 in [list . .. "./" "../"]} { |
|
if {$a1 in [list ".." "../"]} { |
|
cd $a1 |
|
} |
|
tailcall punk::./ {*}$atail |
|
} |
|
|
|
set curdir [pwd] |
|
set ptype [file pathtype $a1] |
|
if {$ptype eq "absolute"} { |
|
set path $a1 |
|
} elseif {$ptype eq "volumerelative"} { |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
#unix looking paths like /c/users or /usr/local/etc are reported by tcl as volumerelative.. (as opposed to absolute on unix platforms) |
|
if {[string index $a1 0] eq "/"} { |
|
set path [punk::winpath $a1] |
|
#puts stderr "winpath: $path" |
|
} else { |
|
set path $curdir/$a1 |
|
} |
|
} else { |
|
# unknown what paths are reported as this on other platforms.. treat as absolute for now |
|
set path $a1 |
|
} |
|
} else { |
|
set path $curdir/$a1 |
|
} |
|
|
|
if {[file type $path] eq "file"} { |
|
if {[string tolower [file extension $path]] in [list ".tcl" ".tm"]} { |
|
set newargs $atail |
|
set ::argv0 $path |
|
set ::argc [llength $newargs] |
|
set ::argv $newargs |
|
tailcall source $path |
|
} else { |
|
puts stderr "Cannot run [file extension $path] file directly ([file tail $path])" |
|
return [pwd] |
|
} |
|
} |
|
if {[file type $path] eq "directory"} { |
|
cd $path |
|
tailcall punk::./ {*}$atail |
|
} |
|
error "Cannot access path $path" |
|
} |
|
} |
|
proc ../ {args} { |
|
set ::punk::last_run_display [list] |
|
if {![llength $args]} { |
|
set path .. |
|
} else { |
|
set path ../[file join {*}$args] |
|
} |
|
cd $path |
|
#set out [runout -n ls -aFC] |
|
set out [punk::dirfiles] |
|
set result [pwd] |
|
#return $out\n[pwd] |
|
set chunklist [list] |
|
lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] |
|
lappend chunklist [list result $result] |
|
set ::punk::last_run_display $chunklist |
|
if {$::repl::running} { |
|
repl::term::set_console_title $result |
|
} |
|
return $result |
|
} |
|
proc list_as_lines {list {joinchar \n}} { |
|
join $list $joinchar |
|
} |
|
|
|
proc ls {args} { |
|
if {![llength $args]} { |
|
set args [list [pwd]] |
|
} |
|
if {[llength $args] ==1} { |
|
return [glob -nocomplain -tails -dir [lindex $args 0] *] |
|
} else { |
|
set result [dict create] |
|
foreach a $args { |
|
set k [file normalize $a] |
|
set contents [glob -nocomplain -tails -dir $a *] |
|
dict set result $k $contents |
|
} |
|
return $result |
|
} |
|
} |
|
proc cdwin {path} { |
|
set path [punk::winpath $path] |
|
if {$::repl::running} { |
|
repl::term::set_console_title $path |
|
} |
|
cd $path |
|
} |
|
proc cdwindir {path} { |
|
set path [punk::winpath $path] |
|
if {$::repl::running} { |
|
repl::term::set_console_title $path |
|
} |
|
cd [file dirname $path] |
|
} |
|
#like linelist - but keeps leading and trailing empty lines |
|
#single \n produces {} {} |
|
#the result can be joined to reform the arg if a single arg supplied |
|
# |
|
proc linelistraw {args} { |
|
set linelist [list] |
|
foreach {a} $args { |
|
set nsplit [split $a \n] |
|
lappend linelist {*}$nsplit |
|
} |
|
#return [split $text \n] |
|
return $linelist |
|
} |
|
proc linelist1 {args} { |
|
set linelist [list] |
|
foreach {a} $args { |
|
set nsplit [split $a \n] |
|
set start 0 |
|
set end "end" |
|
|
|
if {[lindex $nsplit 0] eq ""} { |
|
set start 1 |
|
} |
|
if {[lindex $nsplit end] eq ""} { |
|
set end "end-1" |
|
} |
|
set alist [lrange $nsplit $start $end] |
|
lappend linelist {*}$alist |
|
} |
|
return $linelist |
|
} |
|
|
|
# important for match_exec & match_assign |
|
# lineval verbatim|trimmed |
|
proc linelist {text {lineval verbatim}} { |
|
if {$lineval ni [list verbatim trimmed]} {error "linelist 2nd argument valid values are 'verbatim' or 'trimmed'"} |
|
set linelist [list] |
|
if {[string first \n $text] < 0} { |
|
return $text |
|
} |
|
set nsplit [split $text \n] |
|
set start 0 |
|
set end "end" |
|
if {[lindex $nsplit 0] eq ""} { |
|
set start 1 |
|
} |
|
if {[lindex $nsplit end] eq ""} { |
|
set end "end-1" |
|
} |
|
set alist [lrange $nsplit $start $end] |
|
if {$lineval eq "verbatim"} { |
|
set linelist $alist |
|
#lappend linelist {*}$alist |
|
} else { |
|
foreach ln $alist { |
|
lappend linelist [string trim $ln] |
|
} |
|
} |
|
return $linelist |
|
} |
|
|
|
|
|
#!!!todo fix - linedict is unfinished and non-functioning |
|
#linedict based on indents |
|
proc linedict {args} { |
|
set data [lindex $args 0] |
|
set opts [lrange $args 1 end] ;#todo |
|
set nsplit [split $data \n] |
|
set rootindent -1 |
|
set stepindent -1 |
|
|
|
#set wordlike_parts [regexp -inline -all {\S+} $lastitem] |
|
set d [dict create] |
|
set keys [list] |
|
set i 1 |
|
set firstkeyline "N/A" |
|
set firststepline "N/A" |
|
foreach ln $nsplit { |
|
if {![string length [string trim $ln]]} { |
|
incr i |
|
continue |
|
} |
|
set is_rootkey 0 |
|
regexp {(\s*)(.*)} $ln _ space linedata |
|
puts stderr ">>line:'$ln' [string length $space] $linedata" |
|
set this_indent [string length $space] |
|
if {$rootindent < 0} { |
|
set firstkeyline $ln |
|
set rootindent $this_indent |
|
} |
|
if {$this_indent == $rootindent} { |
|
set is_rootkey 1 |
|
} |
|
if {$this_indent < $rootindent} { |
|
error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" |
|
} |
|
if {$is_rootkey} { |
|
dict set d $linedata {} |
|
lappend keys $linedata |
|
} else { |
|
if {$stepindent < 0} { |
|
set stepindent $this_indent |
|
set firststepline $ln |
|
} |
|
if {$this_indent == $stepindent} { |
|
dict set d [lindex $keys end] $ln |
|
} else { |
|
if {($this_indent % $stepindent) != 0} { |
|
error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" |
|
} |
|
|
|
#todo fix! |
|
set parentkey [lindex $keys end] |
|
lappend keys [list $parentkey $ln] |
|
set oldval [dict get $d $parentkey] |
|
if {[string length $oldval]} { |
|
set new [dict create $oldval $ln] |
|
} else { |
|
dict set d $parentkey $ln |
|
} |
|
|
|
} |
|
} |
|
incr i |
|
} |
|
return $d |
|
} |
|
proc dictline {d} { |
|
puts stderr "unimplemented" |
|
set lines [list] |
|
|
|
return $lines |
|
} |
|
#return list of {chan chunk} elements |
|
proc help_chunks {} { |
|
set chunks [list] |
|
set linesep [string repeat - 76] |
|
catch { |
|
package require patternpunk |
|
#puts -nonewline stderr [>punk . rhs] |
|
lappend chunks [list stderr [>punk . rhs]] |
|
} |
|
set text "" |
|
set known $::punk::config::known_punk_env_vars |
|
append text $linesep\n |
|
append text "punk environment vars:\n" |
|
append text $linesep\n |
|
set col1 [string repeat " " 25] |
|
set col2 [string repeat " " 50] |
|
foreach v $known { |
|
set c1 [overtype::left $col1 $v] |
|
if {[info exists ::env($v)]} { |
|
set c2 [overtype::left $col2 [set ::env($v)] |
|
} else { |
|
set c2 [overtype::right $col2 "(NOT SET)"] |
|
} |
|
append text "$c1 $c2\n" |
|
} |
|
append text $linesep\n |
|
lappend chunks [list stdout $text] |
|
|
|
set text "" |
|
append text "Punk commands:\n" |
|
append text "punk help\n" |
|
lappend chunks [list stdout $text] |
|
return $chunks |
|
} |
|
proc help {} { |
|
set chunks [help_chunks] |
|
foreach chunk $chunks { |
|
lassign $chunk chan text |
|
puts -nonewline $chan $text |
|
} |
|
} |
|
proc app {{glob *}} { |
|
upvar ::punk::config::running running_config |
|
set apps_folder [dict get $running_config apps] |
|
if {[file exists $apps_folder]} { |
|
if {[file exists $apps_folder/$glob]} { |
|
tailcall source $apps_folder/$glob/main.tcl |
|
} |
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
|
if {[llength $apps] == 0} { |
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
|
#no glob chars supplied - only launch if exact match for name part |
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
|
if {[llength $namematches] > 0} { |
|
set latest [lindex $namematches end] |
|
lassign $latest nm ver |
|
tailcall source $apps_folder/$latest/main.tcl |
|
} |
|
} |
|
} |
|
|
|
return $apps |
|
} |
|
} |
|
#current interp aliases except those created by pattern package '::p::*' |
|
proc aliases {{glob *}} { |
|
#todo - way to configure and query what aliases are hidden |
|
set interesting [lmap a [interp aliases ""] {expr {![string match ::* $a] ? $a : [continue]}}] |
|
#set interesting [lmap a [interp aliases ""] {expr {![string match ::p::* $a] ? $a : [continue]}}] |
|
set interesting [lmap a $interesting {expr {![string match *twapi::* $a] ? $a : [continue]}}] |
|
set interesting [lmap a $interesting {expr {![string match debug.* $a] ? $a : [continue]}}] |
|
#set interesting [lmap a $interesting {expr {![string match *vfs::* $a] ? $a : [continue]}}] |
|
|
|
set matched [lsearch -all -inline $interesting $glob] |
|
} |
|
proc alias {{aliasorglob ""} args} { |
|
if {[llength $args]} { |
|
if {$aliasorglob in [interp aliases ""]} { |
|
set existing [interp alias "" $aliasorglob] |
|
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" |
|
} |
|
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { |
|
#use empty string/whitespace as intention to delete alias |
|
return [interp alias "" $aliasorglob ""] |
|
} |
|
return [interp alias "" $aliasorglob "" {*}$args] |
|
} else { |
|
if {![string length $aliasorglob]} { |
|
set aliaslist [punk aliases] |
|
puts -nonewline stderr $aliaslist |
|
return |
|
} |
|
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { |
|
set aliaslist [punk aliases $aliasorglob] |
|
puts -nonewline stderr $aliaslist |
|
return |
|
} |
|
return [interp alias "" $aliasorglob] |
|
} |
|
} |
|
|
|
#know is critical to the punk repl for proper display output |
|
interp alias {} know {} punk::know |
|
interp alias {} know? {} punk::know? |
|
|
|
#interp alias {} arg {} punk::val |
|
interp alias {} val {} punk::val |
|
|
|
interp alias {} exitcode {} punk::exitcode |
|
interp alias {} hide {} punkapp::hide_console ;#will only work if controllable toplevels exist |
|
|
|
|
|
interp alias {} ansi {} punk::ansi |
|
interp alias {} a+ {} punk::ansi+ |
|
|
|
#sh style 'test' and 'exitcode' (0 is false) |
|
interp alias {} sh_test {} punk::sh_test |
|
interp alias {} sh_echo {} punk::sh_echo |
|
interp alias {} sh_TEST {} punk::sh_TEST |
|
interp alias {} sh_ECHO {} punk::sh_ECHO |
|
|
|
|
|
|
|
|
|
#friendly sh aliases (which user may wish to disable e.g if conflicts) |
|
interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec |
|
interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode |
|
interp alias {} echo {} punk::sh_echo |
|
interp alias {} ECHO {} punk::sh_ECHO |
|
|
|
#interp alias {} c {} clear ;#external executable 'clear' may not always be available |
|
interp alias {} clear {} repl::term::reset |
|
interp alias {} c {} repl::term::reset |
|
|
|
|
|
interp alias {} help {} punk help |
|
interp alias {} aliases {} punk aliases |
|
interp alias {} alias {} punk alias |
|
interp alias {} treemore {} punk::xmore tree |
|
|
|
#---------------------------------------------- |
|
interp alias {} linelistraw {} punk::linelistraw |
|
interp alias {} linelist {} punk::linelist ;#critical for = assignment features |
|
interp alias {} linedict {} punk::linedict |
|
interp alias {} dictline {} punk::dictline |
|
|
|
interp alias {} % {} punk::% |
|
interp alias {} pipeswitch {} punk::pipeswitch |
|
interp alias {} pipecase {} punk::pipecase |
|
interp alias {} pipematch {} punk::pipematch |
|
interp alias {} ispipematch {} punk::ispipematch |
|
interp alias {} pipenomatchvar {} punk::pipenomatchvar |
|
|
|
interp alias {} nscommands {} ,'ok@0.= { |
|
upvar caseresult caseresult |
|
if {![info exists ns]} { |
|
set ns "" |
|
} |
|
pipeswitch { |
|
#no glob chars present |
|
pipecase \ |
|
caseresult.= val $ns |input> \ |
|
1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { |
|
uplevel #0 [list info commands ${input}::*] |
|
} |
|
|
|
#pipecase1 ns has one or more of glob chars * or ? |
|
pipecase \ |
|
caseresult.= val $ns |input> { |
|
uplevel #0 [list info commands ${input}] |
|
} |
|
} |
|
} |data@@ok/result> {set data} |> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} <ns| |
|
|
|
|
|
proc = {value} { |
|
return $value |
|
} |
|
interp alias {} .= {} ::punk::match_exec "" "" |
|
#proc .= {args} { |
|
# #uplevel 1 [list ::punk::match_exec "" "" {*}$args] |
|
# tailcall ::punk::match_exec "" "" {*}$args |
|
#} |
|
#interp alias {} = {} punk::match_assign "" |
|
#interp alias {} .= {} punk::match_exec "" |
|
|
|
interp alias {} foldl {} struct::list::Lfold |
|
#foldl helpers |
|
proc sum_llength {total listval} { |
|
expr {$total + [llength $listval]} |
|
} |
|
proc sum_length {total stringval} { |
|
expr {$total + [string length $stringval]} |
|
} |
|
>pattern .. Create >f |
|
>f .. Method foldl {total func sequence} { |
|
struct::list::Lfold $sequence $total $func |
|
} |
|
#note: foldr is not equivalent to just doing a foldl on the reversed list |
|
#todo - review/test/fix |
|
>f .. Method foldr {total func sequence} { |
|
set this @this@ |
|
if {![llength $sequence]} { |
|
return $total |
|
} |
|
v,h@head,t@tail.=val $sequence |h@head,t@tail> { |
|
puts "-->$h" |
|
$func [$this . foldr $total $func $t] $h |
|
} <this@,func@,total@| $this $func $total |
|
|
|
return 0 |
|
return $v |
|
} |
|
>f .. Method list_map {commandlist list} { |
|
tailcall lmap item $list $commandlist |
|
} |
|
>f .. Method list_unique {args} { |
|
set list [concat {*}$args] |
|
set d [dict create] |
|
foreach item $list { |
|
dict set d $item "" |
|
} |
|
dict keys $d |
|
} |
|
>f .. Method list_as_lines {args} { |
|
set list [concat {*}$args] |
|
join $list \n |
|
} |
|
>f .. Method list_filter_expr {} {} |
|
|
|
>f .. Method sum_llength {total listval} { |
|
expr {$total + [llength $listval]} |
|
} |
|
>f .. Method sum_length {total stringval} { |
|
expr {$total + [string length $stringval]} |
|
} |
|
>f .. Method debug {total item} { |
|
puts stderr "incr tally: $total item: $item" |
|
expr {$total + 1} |
|
} |
|
>f .. Method dict_walk {d key} { |
|
dict get $d $key |
|
} |
|
>f .. Method sum {total num} { |
|
expr {$total + $num} |
|
} |
|
|
|
interp alias {} >f {} punk::>f |
|
|
|
#Pattern-matching based functional operations |
|
>pattern .. Create >P |
|
>P .. Method map {pattern commandlist sequence} { |
|
#set segment [string map [list <cmd> $commandlist] {<cmd>}] |
|
|
|
set pipeline [list % {val $item} "|,item,$pattern>" $commandlist <item/0|] |
|
tailcall % list $pipeline $sequence |p/0,l/1> {lmap val $l {{*}$p $val }} |
|
} |
|
|
|
|
|
|
|
#example of aliasing a punk pipeline |
|
interp alias {} _commands {} .=info commands punk::%glob% |> .=lmap v %data% {namespace tail $v} <glob| |
|
|
|
#---------------------------------------------- |
|
#leave the winpath related aliases available on all platforms |
|
interp alias {} cdwin {} punk cdwin |
|
interp alias {} cdwindir {} punk cdwindir |
|
interp alias {} winpath {} punk winpath |
|
interp alias {} windir {} punk windir |
|
#---------------------------------------------- |
|
#git |
|
interp alias {} gs {} git status -sb |
|
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
|
interp alias {} glast {} git log -1 HEAD --stat |
|
interp alias {} gconf {} git config --global -l |
|
|
|
#---------------------------------------------- |
|
interp alias {} varinfo {} punk::varinfo |
|
|
|
#temp |
|
interp alias {} rep {} ::tcl::unsupported::representation |
|
interp alias {} dis {} ::tcl::unsupported::disassemble |
|
|
|
# ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion |
|
interp alias {} l {} sh_runout -n ls -A ;#plain text listing |
|
#interp alias {} ls {} sh_runout -n ls -AF --color=always |
|
interp alias {} ls {} unknown ls -AF --color=always ;#use unknown to use terminal and allow | more | less |
|
#note that shell globbing with * won't work on unix systems when using unknown/exec |
|
interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) |
|
interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. |
|
# -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? |
|
#interp alias {} lw {} ls -aFv --color=always |
|
interp alias {} ./ {} punk::./ |
|
interp alias {} ../ {} punk::../ |
|
interp alias {} dirfiles {} punk::dirfiles |
|
interp alias {} df {} punk::dirfiles |
|
|
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set has_powershell 1 |
|
interp alias {} dl {} dir /q |
|
interp alias {} dw {} dir /W/D |
|
} else { |
|
#todo - natsorted equivalent |
|
#interp alias {} dl {} |
|
interp alias {} dl {} puts stderr "not implemented" |
|
interp alias {} dw {} puts stderr "not implemented" |
|
#todo - powershell detection on other platforms |
|
set has_powershell 0 |
|
} |
|
if {$has_powershell} { |
|
interp alias {} ps {} exec >@stdout pwsh -nolo -nop -c |
|
interp alias {} psx {} runx -n pwsh -nop -nolo -c |
|
interp alias {} psr {} run -n pwsh -nop -nolo -c |
|
interp alias {} psout {} runout -n pwsh -nop -nolo -c |
|
interp alias {} pserr {} runerr -n pwsh -nop -nolo -c |
|
interp alias {} psls {} pwsh -nop -nolo -c ls |
|
interp alias {} psps {} pwsh -nop -nolo -c ps |
|
} else { |
|
set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" |
|
interp alias {} ps {} puts stderr $ps_missing |
|
interp alias {} psx {} puts stderr $ps_missing |
|
interp alias {} psr {} puts stderr $ps_missing |
|
interp alias {} psout {} puts stderr $ps_missing |
|
interp alias {} pserr {} puts stderr $ps_missing |
|
interp alias {} psls {} puts stderr $ps_missing |
|
interp alias {} psps {} puts stderr $ps_missing |
|
} |
|
|
|
}
|
|
|