@ -4,6 +4,37 @@ package provide punk [namespace eval punk {
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
@ -14,6 +45,7 @@ namespace eval punk::config {
variable running
set vars [list \
apps \
scriptlib \
color_stdout \
color_stderr \
@ -26,6 +58,7 @@ namespace eval punk::config {
#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]
@ -37,6 +70,7 @@ namespace eval punk::config {
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
@ -51,6 +85,7 @@ namespace eval punk::config {
#todo - define which configvars are settable in env
set known_punk_env_vars [list \
PUNK_APPS \
PUNK_SCRIPTLIB \
PUNK_EXECUNKNOWN \
PUNK_COLOR_STDERR \
@ -79,6 +114,7 @@ namespace eval punk::config {
namespace eval punk {
package require pattern
package require punkapp
package require funcl
package require control
control::control assert enabled 1
@ -259,8 +295,226 @@ namespace eval punk {
}
return $varlist
}
proc _split_var_key_at_unbracketed_comma {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 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 ""
foreach index $subindices {
set assigned ""
set get_not 0
set already_assigned 0
if {$index eq "#"} {
set active_key_type "list"
set assigned [llength $leveldata]
set already_assigned 1
} elseif {$index eq "##"} {
set active_key_type "dict"
set assigned [dict size $leveldata]
set already_assigned 1
} 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}]
set assigned [lindex $leveldata $index]
set already_assigned 1
} else {
if {$index eq "@@"} {
set active_key_type "list"
#NOTE: This may seem inconsistent with @@key, which sets the active_key_type to dict, however it's important to set this to list.
#The reason is that x@@.= val $somedict will return {key val} .. but if we leave the active_key_type as dict
#the only possible subindex would be x@@/key - which defeats the purpose of @@ allowing us to retrieve k,v pairs where we don't know k
#By setting to 'list' we can use x@@/0 to get the name x@@/1 to get the value.
#To keep navigating into sub-dicts we can use x@@/1/@@key/etc
#An alternative could be to set active_key_type as dict and automatically access subelements.
#ie x@@/subkey - but this is too surprising (too much magic).
#e.g for dict {a {x y}} x@@ returning a {x y} but x@@/x = y is likely to cause confusion and errors
#better is:
#x@@ = a {x y}
#x@@/0 = a
#x@@/1 = x y
#
set subpath [join [lrange $subindices 0 $i_keyindex] /]
set next_this_level [incr v_dict_idx($subpath)]
set keyindex [expr {$next_this_level -1}]
if {($keyindex + 1) <= [dict size $leveldata]} {
set k [lindex [dict keys $leveldata] $keyindex]
set assigned [list $k [dict get $leveldata $k]]
} else {
set assigned ""
}
set already_assigned 1
} elseif {[string match @@* $index]} {
set active_key_type "dict"
set key [string range $index 2 end]
if {[dict exists $leveldata $key]} {
set assigned [dict get $leveldata $key]
} else {
#for consistency with lindex out of range setting var to empty string - we will do same for non existent dict key rather than unset
#This stops us *directly* using @@key for pattern-match testing that key exists - but we can acheive matching using the count mechanism.
#e.g 0+@#@key ? (where 0 is empty list/string and -1 means key not found)
set assigned ""
}
set already_assigned 1
} elseif {[string match @* $index]} {
set active_key_type "list"
set index [string trimleft $index @]
} elseif {[string match "not-*" $index] && $active_key_type in [list "" "list"]} {
#not- only valid at beginning if selector is a range.
#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]
}
} else {
#
}
}
if {!$already_assigned} {
if {$active_key_type in [list "" "list"]} {
set active_key_type "list"
if {$index in [list "head" 0]} {
#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"} {
set assigned [lrange $leveldata 1 end]
} elseif {[string is integer -strict $index]} {
if {$get_not} {
#already handled not-0
set assigned [lreplace $leveldata $index $index]
} else {
set assigned [lindex $leveldata $index]
}
} elseif {[regexp {^(end)$|^end[-+]{1,2}([0-9]+)$} $index]} {
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 {$get_not} {
set assigned [lreplace $leveldata $start $end]
} else {
set assigned [lrange $leveldata $start $end]
}
} else {
#puts stderr "selector:$selector"
#keyword 'pipesyntax' at beginning of error message
set msg "pipesyntax Unable to interpret subindex $index\n"
append msg "selector: $selector\n"
append msg "@ 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 msg "Additional accepted keywords include: head tail\n"
append msg "Use var@@key to treat value as a dict and retrieve element at key"
error $msg
}
} else {
#treat as dict key
set active_key_type "dict"
if {[dict exists $leveldata $index]} {
set assigned [dict get $leveldata $index]
} else {
set assigned ""
}
}
}
set leveldata $assigned
if {![llength $leveldata]} {
break
}
incr i_keyindex
}
return $leveldata
}
#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
@ -291,6 +545,8 @@ namespace eval punk {
} else {
set varspeclist [list $multivar]
}
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 %
@ -299,20 +555,33 @@ namespace eval punk {
#mutually exclusive - atom/pin
set map [list "" ' ^] ;#0 = don't-care/other 1 = atom 2 = pin
set var_class [lmap var $varspeclist {expr {([set m [lsearch $map [string index $var 0]]] >= 0) ? [list $var $m] : [list $var 0]}}]
# e.g {a 0} {'b 1'} {c 0} {^x(a,b) 2}
#set var_class [lmap var $varspeclist {expr {([set m [lsearch $map [string index $var 0]]] >= 0) ? [list $var $m] : [list $var 0]}}]
#puts stdout "\n var_class: $var_class\n"
# e.g {a 0} {'b 1} {c 0} {^x(a,b) 2}
set var_class [lmap var $varkeylist {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}]
#puts stdout "\n var_class: $var_class\n"
#raw varspecs without pin/atom modifiers
set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [string range [lindex $varinfo 0] 1 end] : [lindex $varinfo 0]}}]
#set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [string range [lindex $varinfo 0] 1 end] : [lindex $varinfo 0]}}]
#puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n"
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 )
set var_names [lmap v $varspecs_trimmed {expr {([set p [string first @ $v]] >= 0) ? [string range $v 0 $p-1] : $v}}]
#set var_names [lmap v $varspecs_trimmed {expr {([set p [string first @ $v]] >= 0) ? [string range $v 0 $p-1] : $v}}]
set var_names [lmap v $varspecs_trimmed {lindex $v 0}]
#puts stdout "\nvar_names: $var_names\n"
set v_list_idx 0 ;#for vars with single @ only
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 appp ended to in the initial value-retrieving loop
#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]
@ -349,14 +618,19 @@ namespace eval punk {
#
# 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 vspec $varspecs_trimmed {
foreach v_and_key $varspecs_trimmed {
set vspec [join $v_and_key ""]
lassign $v_and_key v vkey
set assigned ""
set firstat [string first "@" $vspec]
#The binding spec begins at first @ or # or /
set firstat [string first "@" $vkey]
#set firstq [string first "'" $vspec]
set v [lindex $var_names $i]
# set v [lindex $var_names $i]
#if v contains any * and/or ? - then it is a glob match - not a varname
if {$firstat >= 0 } {
if {[string length $vkey] } {
#if {[string is integer -strict $v]} {
# lset var_actions $i 1 matchatom
#}
@ -379,24 +653,38 @@ namespace eval punk {
set after_first_at [string range $vspec $firstat+1 end]
if {$after_first_at eq ""} {
#no dict key following @, this is a positional spec
set assigned [lindex $data $v_list_idx]
set after_first_at [string range $vkey $firstat+1 end]
set vkey [string trimleft $vkey /]
if {$vkey eq "@"} {
#no dict key following @, this is a positional spec for list
set assigned [lindex $data $v_list_idx(@)]
lset var_actions $i 1 ?set
lset var_actions $i 2 $assigned
#if {[string length $v]} {
# uplevel $lvlup [list set $v $assigned]
#}
incr v_list_idx ;#only incr each time we have a trailing @
} elseif {[string match "@*" $after_first_at]} {
incr v_list_idx(@) ;#only incr each time we have a plain @ at the root level of the index
} elseif {$vkey eq "@@"} {
# @@ 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
} else {
set assigned ""
}
lset var_actions $i 1 ?set
lset var_actions $i 2 $assigned
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 keypath [string range $after_first_at 1 end]
set key [split $keypath /]
if {[dict exists $data {*}$key]} {
set assigned [dict get $data {*}$key]
set keypath [string range $vkey 1 end]
set keylist [split $keypath /]
if {([lindex $keylist 0] ne "@@") && [lsearch $keylist @*] == -1} {
#pure keylist for dict - process in one go
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]} {
@ -405,22 +693,57 @@ namespace eval punk {
} else {
#for consistency with lindex out of range setting var to empty string - we will do same for non existent dict key rather than unset
#This stops us *directly* using @@key for pattern-match testing that key exists - but we can acheive matching using the count mechanism.
#e.g 0+@#@key ? (where 0 is empty list/string and -1 means key not found)
#e.g 0+@@key/ # or 0+@ @key/## ? (where 0 is empty list/string and -1 means key not found)
set assigned ""
lset var_actions $i 1 ?set
lset var_actions $i 2 ""
}
} else {
#compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access)
#process level by level
set assigned [destructure $vkey $data]
lset var_actions $i 1 ?set
#todo - destructure should return more than just assigned..(?)
lset var_actions $i 2 $assigned
}
} 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
set selector $after_first_at
#set selector $after_first_at
set selector $vkey
#puts stderr "selector:$selector leveldata: $data"
set leveldata $data
set subindices [split $selector /]
set chars [join $subindices ""]
if {[string is digit -strict $chars]} {
#pure numeric keylist - put straight to lindex
puts stderr "lindex $leveldata $subindices"
set assigned [lindex $leveldata {*}$subindices]
} elseif {[string first "/@@" $selector] >=0 || [string first "/#" $selector] >= 0} {
#compound destructuring required - mix of list and dict keys
set assigned [destructure $vkey $data]
lset var_actions $i 1 ?set
lset var_actions $i 2 $assigned
} else {
set i_keyindex 0
foreach index $subindices {
if {$index eq "@"} {
#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}]
} else {
set index [string trimleft $index @]
}
set assigned ""
set get_not 0
set already_assigned 0
@ -481,8 +804,9 @@ namespace eval punk {
if {![llength $leveldata]} {
break
}
incr i_keyindex
}
}
#if {[string length $v]} {
@ -703,7 +1027,8 @@ namespace eval punk {
}
#error $msg
dict unset returndict result
dict set returndict mismatch [dict create varnames $var_names matchinfo $mismatches display $msg]
#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
}
@ -1238,7 +1563,8 @@ namespace eval punk {
}
}
if {[dict exists $pipedvars "data"]} {
dict set dict_tagval %data% [list [dict get $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
@ -1437,13 +1763,13 @@ namespace eval punk {
}
if {!$add_argsdata} {
puts stderr "APPLY1: args:$segmentargnames"
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 {
puts stderr "APPLY2: args:$segmentargnames"
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]
@ -1827,10 +2153,14 @@ namespace eval punk {
if {[catch {uplevel 1 $cmdlist} result]} {
#puts stderr "====>>> $result"
if {[string match "pipesyntax*" $result]} {
error $result
}
if {[string match "binding*mismatch*" $result]} {
return [dict create error [dict create reason $result]]
}
error $result
} else {
tailcall return [dict create ok [dict create result $result]]
}
@ -1838,8 +2168,12 @@ namespace eval punk {
}
proc pipeswitch {pipescript args} {
set prefix "set args \[list $args\]\n"
set pipescript $prefix$pipescript
set nextargs $args
unset args
upvar args upargs
set upargs $nextargs
#set prefix "set args \[list $args\]\n"
#set pipescript $prefix$pipescript
uplevel 1 [list if 1 $pipescript]
}
proc ansi+ {args} {
@ -2124,7 +2458,7 @@ namespace eval punk {
}
#-------------------------------------------------------------------
namespace export help aliases alias cdwin cdwindir winpath windir
namespace export help aliases alias cdwin cdwindir winpath windir app
namespace ensemble create
#tailcall is important
@ -2403,6 +2737,30 @@ namespace eval punk {
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
@ -2448,6 +2806,7 @@ namespace eval punk {
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
