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.
7864 lines
387 KiB
7864 lines
387 KiB
#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. |
|
#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. |
|
|
|
|
|
namespace eval punk { |
|
proc lazyload {pkg} { |
|
package require zzzload |
|
if {[package provide $pkg] eq ""} { |
|
zzzload::pkg_require $pkg |
|
} |
|
} |
|
#lazyload twapi ? |
|
|
|
catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later |
|
|
|
variable can_exec_windowsapp |
|
set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed |
|
variable windowsappdir |
|
set windowsappdir "" |
|
variable cmdexedir |
|
set cmdexedir "" |
|
|
|
proc sync_package_paths_script {} { |
|
#the tcl::tm namespace doesn't exist until one of the tcl::tm commands |
|
#is run. (they are loaded via ::auto_index triggering load of tm.tcl) |
|
#we call tcl::tm::list to trigger the initial set of tm paths before |
|
#we can override it, otherwise our changes will be lost |
|
#REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc |
|
return "\ |
|
apply {{ap tmlist} { |
|
set ::auto_path \$ap |
|
tcl::tm::list |
|
set ::tcl::tm::paths \$tmlist |
|
}} {$::auto_path} {[tcl::tm::list]} |
|
" |
|
} |
|
|
|
proc rehash {{refresh 0}} { |
|
global auto_execs |
|
if {!$refresh} { |
|
unset -nocomplain auto_execs |
|
} else { |
|
set names [array names auto_execs] |
|
unset -nocomplain auto_execs |
|
foreach nm $names { |
|
auto_execok_windows $nm |
|
} |
|
} |
|
return |
|
} |
|
|
|
|
|
proc ::punk::auto_execok_original name [info body ::auto_execok] |
|
variable better_autoexec |
|
|
|
#set better_autoexec 0 ;#use this var via better_autoexec only |
|
#proc ::punk::auto_execok_windows name { |
|
# ::punk::auto_execok_original $name |
|
#} |
|
|
|
set better_autoexec 1 |
|
proc ::punk::auto_execok_windows name { |
|
::punk::auto_execok_better $name |
|
} |
|
|
|
set has_commandstack [expr {![catch {package require commandstack}]}] |
|
if {$has_commandstack} { |
|
if {[catch { |
|
package require punk::packagepreference |
|
} errM]} { |
|
catch {puts stderr "Failed to load punk::packagepreference"} |
|
} |
|
catch punk::packagepreference::install |
|
} else { |
|
# |
|
} |
|
|
|
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { |
|
|
|
#still a caching version of auto_execok - but with proper(fixed) search order |
|
|
|
#set b [info body ::auto_execok] |
|
#proc ::auto_execok_original name $b |
|
|
|
proc better_autoexec {{onoff ""}} { |
|
variable better_autoexec |
|
if {$onoff eq ""} { |
|
return $better_autoexec |
|
} |
|
if {![string is boolean -strict $onoff]} { |
|
error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" |
|
} |
|
if {$onoff && ($onoff != $better_autoexec)} { |
|
puts "Turning on better_autoexec - search PATH first then extension" |
|
set better_autoexec 1 |
|
proc ::punk::auto_execok_windows name { |
|
::punk::auto_execok_better $name |
|
} |
|
punk::rehash |
|
} elseif {!$onoff && ($onoff != $better_autoexec)} { |
|
puts "Turning off better_autoexec - search extension then PATH" |
|
set better_autoexec 0 |
|
proc ::punk::auto_execok_windows name { |
|
::punk::auto_execok_original $name |
|
} |
|
punk::rehash |
|
} else { |
|
puts "no change" |
|
} |
|
} |
|
#better_autoexec $better_autoexec ;#init to default |
|
|
|
|
|
proc auto_execok_better name { |
|
global auto_execs env tcl_platform |
|
|
|
if {[info exists auto_execs($name)]} { |
|
return $auto_execs($name) |
|
} |
|
#puts stdout "[a+ red]...[a]" |
|
set auto_execs($name) "" |
|
|
|
set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ |
|
md mkdir mklink move rd ren rename rmdir start time type ver vol] |
|
if {[info exists env(PATHEXT)]} { |
|
# Add an initial ; to have the {} extension check first. |
|
set execExtensions [split ";$env(PATHEXT)" ";"] |
|
} else { |
|
set execExtensions [list {} .com .exe .bat .cmd] |
|
} |
|
|
|
if {[string tolower $name] in $shellBuiltins} { |
|
# When this is command.com for some reason on Win2K, Tcl won't |
|
# exec it unless the case is right, which this corrects. COMSPEC |
|
# may not point to a real file, so do the check. |
|
set cmd $env(COMSPEC) |
|
if {[file exists $cmd]} { |
|
set cmd [file attributes $cmd -shortname] |
|
} |
|
return [set auto_execs($name) [list $cmd /c $name]] |
|
} |
|
|
|
if {[llength [file split $name]] != 1} { |
|
#has a path |
|
foreach ext $execExtensions { |
|
set file ${name}${ext} |
|
if {[file exists $file] && ![file isdirectory $file]} { |
|
return [set auto_execs($name) [list $file]] |
|
} |
|
} |
|
return "" |
|
} |
|
|
|
#change1 |
|
#set path "[file dirname [info nameofexecutable]];.;" |
|
set path "[file dirname [info nameofexecutable]];" |
|
|
|
if {[info exists env(SystemRoot)]} { |
|
set windir $env(SystemRoot) |
|
} elseif {[info exists env(WINDIR)]} { |
|
set windir $env(WINDIR) |
|
} |
|
if {[info exists windir]} { |
|
append path "$windir/system32;$windir/system;$windir;" |
|
} |
|
|
|
foreach var {PATH Path path} { |
|
if {[info exists env($var)]} { |
|
append path ";$env($var)" |
|
} |
|
} |
|
|
|
#change2 |
|
if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { |
|
set lookfor [list $name] |
|
} else { |
|
set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] |
|
} |
|
#puts "-->$lookfor" |
|
foreach dir [split $path {;}] { |
|
set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" |
|
#set dir [file normalize $dir] |
|
# Skip already checked directories |
|
if {[info exists checked($dir)] || ($dir eq "")} { |
|
continue |
|
} |
|
set checked($dir) {} |
|
|
|
#surprisingly fast |
|
#set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] |
|
##puts "--dir $dir matches:$matches" |
|
#if {[llength $matches]} { |
|
# set file [file join $dir [lindex $matches 0]] |
|
# #puts "--match0:[lindex $matches 0] file:$file" |
|
# return [set auto_execs($name) [list $file]] |
|
#} |
|
|
|
#what if it's a link? |
|
#foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { |
|
# set file [file join $dir $match] |
|
# if {[file exists $file]} { |
|
# return [set auto_execs($name) [list $file]] |
|
# } |
|
#} |
|
|
|
#safest? could be a link? |
|
foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { |
|
set file [file join $dir $match] |
|
if {[file exists $file] && ![file isdirectory $file]} { |
|
return [set auto_execs($name) [list $file]] |
|
} |
|
} |
|
} |
|
|
|
#foreach ext $execExtensions { |
|
#unset -nocomplain checked |
|
#foreach dir [split $path {;}] { |
|
# # Skip already checked directories |
|
# if {[info exists checked($dir)] || ($dir eq "")} { |
|
# continue |
|
# } |
|
# set checked($dir) {} |
|
# set file [file join $dir ${name}${ext}] |
|
# if {[file exists $file] && ![file isdirectory $file]} { |
|
# return [set auto_execs($name) [list $file]] |
|
# } |
|
#} |
|
#} |
|
return "" |
|
} |
|
|
|
|
|
|
|
#review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? |
|
#what if we create another interp and use the same ::auto_execs? The appdir won't be detected. |
|
#TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed |
|
|
|
|
|
|
|
#winget is installed on all modern windows and is an example of the problem this addresses |
|
#we target apps with same location |
|
|
|
#the main purpose of this override is to support windows app executables (installed as 'reparse points') |
|
#for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac |
|
#versions prior to this will use cmd.exe to resolve the links |
|
set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { |
|
#set windowsappdir "%appdir%" |
|
upvar ::punk::can_exec_windowsapp can_exec_windowsapp |
|
upvar ::punk::windowsappdir windowsappdir |
|
upvar ::punk::cmdexedir cmdexedir |
|
|
|
if {$windowsappdir eq ""} { |
|
#we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' |
|
#Tcl (2025) can't exec when given a path to these 0KB files |
|
#This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps |
|
if {!([info exists ::env(LOCALAPPDATA)] && |
|
[file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { |
|
#should be unlikely to get here - unless LOCALAPPDATA missing |
|
set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] |
|
catch {puts stderr "(resolved winget by search)"} |
|
} else { |
|
set windowsappdir [file dirname $testapp] |
|
} |
|
} |
|
|
|
#set default_auto [$COMMANDSTACKNEXT $name] |
|
set default_auto [::punk::auto_execok_windows $name] |
|
#if {$name ni {cmd cmd.exe}} { |
|
# unset -nocomplain ::auto_execs |
|
#} |
|
|
|
if {$default_auto eq ""} { |
|
return |
|
} |
|
set namedir [file dirname [lindex $default_auto 0]] |
|
|
|
if {$namedir eq $windowsappdir} { |
|
if {$can_exec_windowsapp eq "unknown"} { |
|
if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { |
|
set can_exec_windowsapp 0 |
|
} else { |
|
set can_exec_windowsapp 1 |
|
} |
|
} |
|
if {$can_exec_windowsapp} { |
|
return [file join $windowsappdir $name] |
|
} |
|
if {$cmdexedir eq ""} { |
|
#cmd.exe very unlikely to move |
|
set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] |
|
#auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index |
|
#anyway.. it has other side effects (affects auto_load) |
|
} |
|
return "[file join $cmdexedir cmd.exe] /c $name" |
|
} |
|
return $default_auto |
|
}] |
|
|
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
#repltelemetry cooperation with other packages such as shellrun |
|
#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists |
|
namespace eval punk { |
|
variable repltelemetry_emmitters |
|
#don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early |
|
if {![info exists repltelemetry_emitters]} { |
|
set repltelemetry_emmitters [list] |
|
} |
|
} |
|
|
|
namespace eval punk::pipecmds { |
|
#where to install proc/compilation artifacts for pieplines |
|
namespace export * |
|
} |
|
namespace eval punk::pipecmds::split_patterns {} |
|
namespace eval punk::pipecmds::split_rhs {} |
|
namespace eval punk::pipecmds::var_classify {} |
|
namespace eval punk::pipecmds::destructure {} |
|
namespace eval punk::pipecmds::insertion {} |
|
|
|
|
|
#globals... some minimal global var pollution |
|
#punk's official silly test dictionary |
|
set punk_testd [dict create \ |
|
a0 a0val \ |
|
b0 [dict create \ |
|
a1 b0a1val \ |
|
b1 b0b1val \ |
|
c1 b0c1val \ |
|
d1 b0d1val \ |
|
] \ |
|
c0 [dict create] \ |
|
d0 [dict create \ |
|
a1 [dict create \ |
|
a2 d0a1a2val \ |
|
b2 d0a1b2val \ |
|
c2 d0a1c2val \ |
|
] \ |
|
b1 [dict create \ |
|
a2 [dict create \ |
|
a3 d0b1a2a3val \ |
|
b3 d0b1a2b3val \ |
|
] \ |
|
b2 [dict create \ |
|
a3 d0b1b2a3val \ |
|
bananas "in pyjamas" \ |
|
c3 [dict create \ |
|
po "in { }" \ |
|
b4 ""\ |
|
c4 "can go boom" \ |
|
] \ |
|
d3 [dict create \ |
|
a4 "-paper -cuts" \ |
|
] \ |
|
e3 [dict create] \ |
|
] \ |
|
] \ |
|
] \ |
|
e0 "multi\nline"\ |
|
] |
|
#test dict 2 - uniform structure and some keys with common prefixes for glob matching |
|
set punk_testd2 [dict create \ |
|
a0 [dict create \ |
|
b1 {a b c}\ |
|
b2 {a b c d}\ |
|
x1 {x y z 1 2}\ |
|
y2 {X Y Z 1 2}\ |
|
z1 {k1 v1 k2 v2 k3 v3}\ |
|
] \ |
|
a1 [dict create \ |
|
b1 {a b c}\ |
|
b2 {a b c d}\ |
|
x1 {x y z 1 2}\ |
|
y2 {X Y Z 1 2}\ |
|
z1 {k1 v1 k2 v2 k3 v3}\ |
|
] \ |
|
b1 [dict create \ |
|
b1 {a b c}\ |
|
b2 {a b c d}\ |
|
x1 {x y z 1 2}\ |
|
y2 {X Y Z 1 2}\ |
|
z1 {k1 v1 k2 v2 k3 v3}\ |
|
] \ |
|
] |
|
|
|
#impolitely cooperative with punk repl - todo - tone it down. |
|
#namespace eval ::punk::repl::codethread { |
|
# variable running 0 |
|
#} |
|
package require punk::lib ;# subdependency punk::args |
|
package require punk::ansi |
|
if {![llength [info commands ::ansistring]]} { |
|
namespace import punk::ansi::ansistring |
|
} |
|
#require aliascore after punk::lib & punk::ansi are loaded |
|
package require punk::aliascore ;#mostly punk::lib aliases |
|
punk::aliascore::init -force 1 |
|
|
|
package require punk::repl::codethread |
|
package require punk::config |
|
#package require textblock |
|
package require punk::console ;#requires Thread |
|
package require punk::ns |
|
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems |
|
package require punk::repo |
|
package require punk::du |
|
package require punk::mix::base |
|
package require base64 |
|
|
|
package require punk::pipe |
|
|
|
namespace eval punk { |
|
# -- --- --- |
|
#namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace |
|
# using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. |
|
#e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. |
|
#package require control |
|
#control::control assert enabled 1 |
|
|
|
#We will use punk::assertion instead |
|
|
|
package require punk::assertion |
|
if {[catch {namespace import ::punk::assertion::assert} errM]} { |
|
catch { |
|
puts stderr "punk error importing punk::assertion::assert\n$errM" |
|
puts stderr "punk::a* commands:[info commands ::punk::a*]" |
|
} |
|
} |
|
punk::assertion::active on |
|
# -- --- --- |
|
|
|
interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system |
|
if {[catch { |
|
package require pattern |
|
} errpkg]} { |
|
catch {puts stderr "Failed to load package pattern error: $errpkg"} |
|
} |
|
package require shellfilter |
|
package require punkapp |
|
package require funcl |
|
|
|
package require struct::list |
|
package require fileutil |
|
#package require punk::lib |
|
|
|
#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 |
|
debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc |
|
|
|
|
|
#----------------------------------- |
|
# 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 off punk.pipe.compile |
|
debug level punk.pipe.compile 2 |
|
|
|
|
|
debug header "dbg> " |
|
|
|
|
|
variable last_run_display [list] |
|
|
|
|
|
#variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} |
|
|
|
|
|
|
|
#----------------------------------------------------------------------------------- |
|
#strlen is important for testing issues with string representationa and shimmering. |
|
#This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed |
|
#It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour |
|
proc strlen {str} { |
|
append str2 $str {} |
|
string length $str2 |
|
} |
|
#----------------------------------------------------------------------------------- |
|
|
|
#get a copy of the item without affecting internal rep |
|
proc objclone {obj} { |
|
append obj2 $obj {} |
|
} |
|
proc set_clone {varname obj} { |
|
#maintenance: also punk::lib::set_clone |
|
#e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] |
|
append obj2 $obj {} |
|
uplevel 1 [list set $varname $obj2] |
|
} |
|
|
|
interp alias "" strlen "" ::punk::strlen |
|
interp alias "" str_len "" ::punk::strlen |
|
interp alias "" objclone "" ::punk::objclone |
|
#proc ::strlen {str} { |
|
# string length [append str2 $str {}] |
|
#} |
|
#proc ::objclone {obj} { |
|
# append obj2 $obj {} |
|
#} |
|
#----------------------------------------------------------------------------------- |
|
#order of arguments designed for pipelining |
|
#review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining |
|
#piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. |
|
proc piper_append {new base} { |
|
append base $new |
|
} |
|
interp alias "" piper_append "" ::punk::piper_append |
|
proc piper_prepend {new base} { |
|
append new $base |
|
} |
|
interp alias "" piper_prepend "" ::punk::piper_prepend |
|
|
|
proc ::punk::K {x y} { return $x} |
|
|
|
proc stacktrace {} { |
|
set stack "Stack trace:\n" |
|
for {set i 1} {$i < [info level]} {incr i} { |
|
set lvl [info level -$i] |
|
set pname [lindex $lvl 0] |
|
append stack [string repeat " " $i]$pname |
|
|
|
if {![catch {info args $pname} pargs]} { |
|
foreach value [lrange $lvl 1 end] arg $pargs { |
|
|
|
if {$value eq ""} { |
|
if {$arg != 0} { |
|
info default $pname $arg value |
|
} |
|
} |
|
append stack " $arg='$value'" |
|
} |
|
} else { |
|
append stack " !unknown vars for $pname" |
|
} |
|
|
|
append stack \n |
|
} |
|
return $stack |
|
} |
|
|
|
#review - there are various type of uuid - we should use something consistent across platforms |
|
#twapi is used on windows because it's about 5 times faster - but is this more important than consistency? |
|
#twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway |
|
#(counterpoint: in the case of punk - we currently need twapi anyway on windows) |
|
#does tcllib's uuid use the same mechanisms on different platforms anyway? |
|
proc ::punk::uuid {} { |
|
set has_twapi 0 |
|
if 0 { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {![catch { |
|
set loader [zzzload::pkg_wait twapi] |
|
} errM]} { |
|
if {$loader in [list failed loading]} { |
|
catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"} |
|
} |
|
} else { |
|
package require twapi |
|
} |
|
if {[package provide twapi] ne ""} { |
|
set has_twapi 1 |
|
} |
|
} |
|
} |
|
if {!$has_twapi} { |
|
if {[catch {package require uuid} errM]} { |
|
error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows" |
|
} |
|
return [uuid::uuid generate] |
|
} else { |
|
return [twapi::new_uuid] |
|
} |
|
} |
|
|
|
#get last command result that was run through the repl |
|
proc ::punk::get_runchunk {args} { |
|
set argd [punk::args::parse $args withdef { |
|
@id -id ::punk::get_runchunk |
|
@cmd -name "punk::get_runchunk" -help\ |
|
"experimental" |
|
@opts |
|
-1 -optional 1 -type none |
|
-2 -optional 1 -type none |
|
@values -min 0 -max 0 |
|
}] |
|
#todo - make this command run without truncating previous runchunks |
|
set runchunks [tsv::array names repl runchunks-*] |
|
|
|
set sortlist [list] |
|
foreach cname $runchunks { |
|
set num [lindex [split $cname -] 1] |
|
lappend sortlist [list $num $cname] |
|
} |
|
set sorted [lsort -index 0 -integer $sortlist] |
|
set chunkname [lindex $sorted end-1 1] |
|
set runlist [tsv::get repl $chunkname] |
|
#puts stderr "--$runlist" |
|
if {![llength $runlist]} { |
|
return "" |
|
} else { |
|
return [lindex [lsearch -inline -index 0 $runlist result] 1] |
|
} |
|
} |
|
interp alias {} _ {} ::punk::get_runchunk |
|
|
|
|
|
proc ::punk::var {varname {= _=.=_} args} { |
|
upvar $varname the_var |
|
switch -exact -- ${=} { |
|
= { |
|
if {[llength $args] > 1} { |
|
set the_var $args |
|
} else { |
|
set the_var [lindex $args 0] |
|
} |
|
} |
|
.= { |
|
if {[llength $args] > 1} { |
|
set the_var [uplevel 1 $args] |
|
} else { |
|
set the_var [uplevel 1 [lindex $args 0]] |
|
} |
|
} |
|
_=.=_ { |
|
set the_var |
|
} |
|
default { |
|
set the_var [list ${=} {*}$args] |
|
} |
|
} |
|
} |
|
proc src {args} { |
|
#based on wiki.. https://wiki.tcl-lang.org/page/source+with+args |
|
#added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename |
|
# review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. |
|
set cmdargs [list] |
|
set scriptargs [list] |
|
set inopts 0 |
|
set i 0 |
|
foreach a $args { |
|
if {$i eq [llength $args]-1} { |
|
#reached end without finding end of opts |
|
#must be file - even if it does match -* ? |
|
break |
|
} |
|
if {!$inopts} { |
|
if {[string match -* $a]} { |
|
set inopts 1 |
|
} else { |
|
#leave loop at first nonoption - i should be index of file |
|
break |
|
} |
|
} else { |
|
#leave for next iteration to check |
|
set inopts 0 |
|
} |
|
incr i |
|
} |
|
set cmdargs [lrange $args 0 $i] |
|
set scriptargs [lrange $args $i+1 end] |
|
set argv $::argv |
|
set argc $::argc |
|
set ::argv $scriptargs |
|
set ::argc [llength $scriptargs] |
|
set code [catch {uplevel [list source {*}$cmdargs]} return] |
|
set ::argv $argv |
|
set ::argc $argc |
|
return -code $code $return |
|
} |
|
|
|
|
|
|
|
|
|
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 |
|
} |
|
|
|
#review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. |
|
#e.g contrived pipeline example to only allow setting existing keys |
|
## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} <new,nkeys@keys| a AAA c CCC |
|
#conversely - only allow setting new keys: |
|
## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} <new,nkeys@keys| x XXX y YYY z ZZZ |
|
namespace eval dictextension { |
|
proc modify {var args} { |
|
upvar 1 $var dvar |
|
if {![info exists dvar]} { |
|
error "dict modify requires existing variable $var" |
|
} |
|
foreach {name val} $args { |
|
dict set dvar $name $val |
|
} |
|
set dvar |
|
} |
|
} |
|
|
|
|
|
#punk::lib::ensemble::extend dict ::punk::dictextension |
|
|
|
|
|
|
|
#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 "@" "/" "#" "!"] |
|
#except when prefixed directly by pin classifier ^ |
|
set protect_terminals [list "^"] ;# e.g sequence ^# |
|
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
|
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
|
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 |
|
} |
|
|
|
proc destructure {selector data} { |
|
# replaced by proc generating destructure_func - |
|
catch {puts stderr "punk::destructure .d. selector:'$selector'"} |
|
set selector [string trim $selector /] |
|
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 |
|
set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. |
|
#thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. |
|
#todo - see if 'string is list' improved in tcl9 vs catch {llength $list} |
|
switch -exact -- $index { |
|
# { |
|
set active_key_type "list" |
|
if {![catch {llength $leveldata} assigned]} { |
|
set already_assigned 1 |
|
} else { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
} |
|
## { |
|
set active_key_type "dict" |
|
if {![catch {dict size $leveldata} assigned]} { |
|
set already_assigned 1 |
|
} else { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
} |
|
#? { |
|
#review - compare to %# ????? |
|
#seems to be unimplemented ? |
|
set assigned [string length $leveldata] |
|
set already_assigned 1 |
|
} |
|
@ { |
|
upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position |
|
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 |
|
} |
|
@@ - @?@ - @??@ { |
|
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} |
|
# but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. |
|
# (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) |
|
# It is analogous to v1@,v2@ for lists. |
|
# @pairs is more useful for repeated operations |
|
|
|
# |
|
#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] |
|
if {$index eq "@?@"} { |
|
set assigned [dict get $leveldata $k] |
|
} else { |
|
set assigned [list $k [dict get $leveldata $k]] |
|
} |
|
} else { |
|
if {$index eq "@@"} { |
|
set action ?mismatch-dict-index-out-of-range |
|
break |
|
} else { |
|
set assigned [list] |
|
} |
|
} |
|
set already_assigned 1 |
|
} |
|
default { |
|
switch -glob -- $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 |
|
} |
|
{@\?@*} { |
|
set active_key_type "dict" |
|
set key [string range $index 3 end] |
|
#dict exists test is safe - no need for catch |
|
if {[dict exists $leveldata $key]} { |
|
set assigned [dict get $leveldata $key] |
|
} else { |
|
set assigned [list] |
|
} |
|
set already_assigned 1 |
|
} |
|
{@\?\?@*} { |
|
set active_key_type "dict" |
|
set key [string range $index 4 end] |
|
#dict exists test is safe - no need for catch |
|
if {[dict exists $leveldata $key]} { |
|
set assigned [list $key [dict get $leveldata $key]] |
|
} else { |
|
set assigned [list] |
|
} |
|
set already_assigned 1 |
|
} |
|
@* { |
|
set active_key_type "list" |
|
set do_bounds_check 1 |
|
set index [string trimleft $index @] |
|
} |
|
default { |
|
# |
|
} |
|
} |
|
|
|
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 |
|
switch -- $index { |
|
not-tail { |
|
set active_key_type "list" |
|
set assigned [lindex $leveldata 0]; set already_assigned 1 |
|
} |
|
not-head { |
|
set active_key_type "list" |
|
#set selector "tail"; set get_not 0 |
|
set assigned [lrange $leveldata 1 end]; set already_assigned 1 |
|
} |
|
not-end { |
|
set active_key_type "list" |
|
set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 |
|
} |
|
default { |
|
#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" |
|
|
|
|
|
#we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against |
|
#need to set a corresponding action |
|
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 eq "0"} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
set assigned [lindex $leveldata 0] |
|
} elseif {$index eq "head"} { |
|
#NOTE: /@head and /head both do bounds check. This is intentional |
|
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 "end"} { |
|
# @end /end |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
if {$do_bounds_check && $len < 1} { |
|
set action ?mismatch-list-index-out-of-range |
|
} |
|
set assigned [lindex $leveldata end] |
|
} elseif {$index eq "tail"} { |
|
#NOTE: /@tail and /tail both do bounds check. This is intentional. |
|
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"} { |
|
# @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"} { |
|
# @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 "init"} { |
|
# @init |
|
#all but last element - same as haskell 'init' |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
set assigned [lrange $leveldata 0 end-1] |
|
} elseif {$index eq "list"} { |
|
# @list |
|
#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 "raw"} { |
|
#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 "pairs"} { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
set action ?mismatch-not-a-dict |
|
break |
|
} |
|
#set assigned [dict values $leveldata] |
|
set pairs [list] |
|
tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} |
|
set assigned [lindex [list $pairs [unset pairs]] 0] |
|
} elseif {[string is integer -strict $index]} { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
break |
|
} |
|
# only check if @ was directly in original index section |
|
if {$do_bounds_check && ($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! (consider: set x --34;puts expr $j;puts expr {$j} ) |
|
if {$do_bounds_check && ($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 {$do_bounds_check && [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 |
|
} elseif {$do_bounds_check} { |
|
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 {$do_bounds_check && [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 |
|
} elseif {$do_bounds_check} { |
|
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 "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
} elseif {[string first - $index] > 0} { |
|
puts "====> index:$index leveldata:$leveldata" |
|
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 "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
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 "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
|
|
} else { |
|
#keyword 'pipesyntax' at beginning of error message |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
} 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 rep leveldata: [rep $leveldata]" |
|
#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] |
|
|
|
} |
|
#todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script |
|
proc destructure_func {selector data} { |
|
#puts stderr ".d." |
|
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 |
|
|
|
#map some problematic things out of the way in a manner that maintains some transparency |
|
#e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} |
|
#The selector forms part of the proc name |
|
#review - compare with pipecmd_namemapping |
|
set selector_safe [string map [list\ |
|
? <q>\ |
|
* <star>\ |
|
\\ <bsl>\ |
|
{"} <dq>\ |
|
{$} <d>\ |
|
"\x1b\[" <csi>\ |
|
"\x1b\]" <osc>\ |
|
{[} <lb>\ |
|
{]} <rb>\ |
|
:: <nssep>\ |
|
{;} <sc>\ |
|
" " <sp>\ |
|
\t <tab>\ |
|
\n <nl>\ |
|
\r <cr>\ |
|
] $selector] |
|
|
|
set cmdname ::punk::pipecmds::destructure::_$selector_safe |
|
if {[info commands $cmdname] ne ""} { |
|
return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context |
|
} |
|
|
|
set leveldata $data |
|
set body [destructure_func_build_procbody $cmdname $selector $data] |
|
|
|
puts stdout ---- |
|
puts stderr "proc $cmdname {leveldata} {" |
|
puts stderr $body |
|
puts stderr "}" |
|
puts stdout --- |
|
proc $cmdname {leveldata} $body |
|
#eval $script ;#create the proc |
|
debug.punk.pipe.compile {proc $cmdname} 4 |
|
#return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] |
|
#use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context |
|
return [$cmdname $data] |
|
} |
|
|
|
#Builds a *basic* function to do the destructuring. |
|
#This is simply a set of steps to destructure each level of the data based on the hierarchical selector. |
|
#It just uses intermediate variables and adds some comments to the code to show the indices used at each point. |
|
#This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. |
|
proc destructure_func_build_procbody {cmdname selector data} { |
|
set script "" |
|
#place selector in comment in script only - if there is an error in selector we pick it up when building the script. |
|
#The script itself should only be returning errors in its action key of the result dictionary |
|
append script \n [string map [list <selector> $selector] {# set selector {<selector>}}] |
|
set subindices [split $selector /] |
|
append script \n [string map [list <subindices> [list $subindices]] {# set subindices <subindices>}] |
|
set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch-<somereason> and always break |
|
append script \n {set action ?match} |
|
#append script \n {set assigned ""} ;#review |
|
set active_key_type "" |
|
append script \n {# set active_key_type ""} |
|
set lhs "" |
|
#append script \n [tstr {set lhs ${{$lhs}}}] |
|
append script \n {set lhs ""} |
|
set rhs "" |
|
append script \n {set rhs ""} |
|
|
|
set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope |
|
|
|
#maintain key order - caller unpacks using lassign |
|
set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} |
|
set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
#set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
#dict 'index' when using stateful @@ etc to iterate over dict instead of by key |
|
set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} |
|
|
|
|
|
if {![string length $selector]} { |
|
#just return $leveldata |
|
set script { |
|
dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata |
|
} |
|
return $script |
|
} |
|
|
|
if {[string is digit -strict [join $subindices ""]]} { |
|
#review tip 551 (tcl9+?) |
|
#puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $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. |
|
#(or more generally - loop until we hit another type of subindex) |
|
|
|
#set assigned [lindex $leveldata {*}$subindices] |
|
if {[llength $subindices] == 1} { |
|
append script \n "# index_operation listindex" \n |
|
lappend INDEX_OPERATIONS listindex |
|
} else { |
|
append script \n "# index_operation listindex-nested" \n |
|
lappend INDEX_OPERATIONS listindex-nested |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {lindex $leveldata ${$subindices}} leveldata]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} |
|
}] |
|
# -- --- --- |
|
#append script \n $returnline \n |
|
append script [tstr -return string $return_template] |
|
return $script |
|
# -- --- --- |
|
} |
|
if {[string match @@* $selector]} { |
|
#part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc |
|
set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' |
|
set keypath [string range $selector 2 end] |
|
set keylist [split $keypath /] |
|
lappend INDEX_OPERATIONS dict_path |
|
if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { |
|
#pure keylist for dict - process in one go |
|
#dict exists will return 0 if not a valid dict. |
|
#<keylist> is equivalent to {*}keylist when substituted |
|
append script \n [tstr -return string -allowcommands { |
|
if {[dict exists $leveldata ${$keylist}]} { |
|
set leveldata [dict get $leveldata ${$keylist}] |
|
} else { |
|
#set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
append script [tstr -return string $return_template] |
|
return $script |
|
# -- --- --- |
|
} |
|
#else |
|
#compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) |
|
#process level by level |
|
} |
|
|
|
|
|
|
|
set i_keyindex 0 |
|
append script \n {set i_keyindex 0} |
|
#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 index_operation "unspecified" |
|
set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script |
|
set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] |
|
append script \n "# ------- START index:$index subpath:$SUBPATH ------" |
|
set lhs $index |
|
append script \n "set lhs {$index}" |
|
|
|
set assigned "" |
|
append script \n {set assigned ""} |
|
|
|
#got_not shouldn't need to be in script |
|
set get_not 0 |
|
if {[tcl::string::index $index 0] eq "!"} { |
|
append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} |
|
set index [tcl::string::range $index 1 end] |
|
set get_not 1 |
|
} |
|
|
|
# do_bounds_check shouldn't need to be in script |
|
set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. |
|
#thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. |
|
#append script \n {set do_boundscheck 0} |
|
switch -exact -- $index { |
|
# - @# { |
|
#list length |
|
set active_key_type "list" |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS not-list |
|
append script \n {# set active_key_type "list" index_operation: not-list} |
|
append script \n { |
|
if {[catch {llength $leveldata}]} { |
|
#not a list - not-length is true |
|
set assigned 1 |
|
} else { |
|
#is a list - not-length is false |
|
set assigned 0 |
|
} |
|
} |
|
} else { |
|
lappend INDEX_OPERATIONS list-length |
|
append script \n {# set active_key_type "list" index_operation: list-length} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} assigned]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
## { |
|
#dict size |
|
set active_key_type "dict" |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS not-dict |
|
append script \n {# set active_key_type "dict" index_operation: not-dict} |
|
append script \n { |
|
if {[catch {dict size $leveldata}]} { |
|
set assigned 1 ;#not a dict - not-size is true |
|
} else { |
|
set assigned 0 ;#is a dict - not-size is false |
|
} |
|
} |
|
} else { |
|
lappend INDEX_OPERATIONS dict-size |
|
append script \n {# set active_key_type "dict" index_operation: dict-size} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} assigned]} { |
|
#set action ?mismatch-not-a-dict |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
%# { |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%# not string length is not supported" |
|
} |
|
#string length - REVIEW - |
|
lappend INDEX_OPERATIONS string-length |
|
append script \n {# set active_key_type "" index_operation: string-length} |
|
append script \n {set assigned [string length $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
%%# { |
|
#experimental |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%%# not string length is not supported" |
|
} |
|
#string length - REVIEW - |
|
lappend INDEX_OPERATIONS ansistring-length |
|
append script \n {# set active_key_type "" index_operation: ansistring-length} |
|
append script \n {set assigned [ansistring length $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
%str { |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%str - not string-get is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-get |
|
append script \n {# set active_key_type "" index_operation: string-get} |
|
append script \n {set assigned $leveldata} |
|
set level_script_complete 1 |
|
} |
|
%sp { |
|
#experimental |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%sp - not string-space is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-space |
|
append script \n {# set active_key_type "" index_operation: string-space} |
|
append script \n {set assigned " "} |
|
set level_script_complete 1 |
|
} |
|
%empty { |
|
#experimental |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%empty - not string-empty is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-empty |
|
append script \n {# set active_key_type "" index_operation: string-empty} |
|
append script \n {set assigned ""} |
|
set level_script_complete 1 |
|
} |
|
@words { |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%words - not list-words-from-string is not supported" |
|
} |
|
lappend INDEX_OPERATIONS list-words-from-string |
|
append script \n {# set active_key_type "" index_operation: list-words-from-string} |
|
append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
@chars { |
|
#experimental - leading character based on result not input(?) |
|
#input type is string - but output is list |
|
set active_key_type "list" |
|
if {$get_not} { |
|
error "!%chars - not list-chars-from-string is not supported" |
|
} |
|
lappend INDEX_OPERATIONS list-from_chars |
|
append script \n {# set active_key_type "" index_operation: list-chars-from-string} |
|
append script \n {set assigned [split $leveldata ""]} |
|
set level_script_complete 1 |
|
} |
|
@join { |
|
#experimental - flatten one level of list |
|
#join without arg - output is list |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!@join - not list-join-list is not supported" |
|
} |
|
lappend INDEX_OPERATIONS list-join-list |
|
append script \n {# set active_key_type "" index_operation: list-join-list} |
|
append script \n {set assigned [join $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
%join { |
|
#experimental |
|
#input type is list - but output is string |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%join - not string-join-list is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-join-list |
|
append script \n {# set active_key_type "" index_operation: string-join-list} |
|
append script \n {set assigned [join $leveldata ""]} |
|
set level_script_complete 1 |
|
} |
|
%ansiview { |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%# not string-ansiview is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-ansiview |
|
append script \n {# set active_key_type "" index_operation: string-ansiview} |
|
append script \n {set assigned [ansistring VIEW $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
%ansiviewstyle { |
|
set active_key_type "string" |
|
if {$get_not} { |
|
error "!%# not string-ansiviewstyle is not supported" |
|
} |
|
lappend INDEX_OPERATIONS string-ansiviewstyle |
|
append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} |
|
append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} |
|
set level_script_complete 1 |
|
} |
|
@ { |
|
#as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) |
|
#This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 |
|
|
|
|
|
#append script \n {puts stderr [uplevel 1 [list info vars]]} |
|
|
|
#NOTE: |
|
#v_list_idx in context of _multi_bind_result |
|
#we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) |
|
append script \n {upvar 2 v_list_idx v_list_idx} |
|
|
|
set active_key_type "list" |
|
append script \n {# set active_key_type "list" index_operation: list-get-next} |
|
#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 |
|
#dynamic index - need the index variable in the script - can't hard-code |
|
#set index [expr {$next_this_level -1}] |
|
|
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS list-has-next |
|
append script \n [tstr -return string -allowcommands { |
|
set index [expr {[set v_list_idx(@)]}] ;#test without moving index - review |
|
if {[catch {llength $leveldata} len]} { |
|
#not a list |
|
set assigned 1 |
|
} elseif {$index+1 > $len} { |
|
set assigned 1 |
|
} else { |
|
set assigned 0 |
|
} |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS get-next |
|
append script \n [tstr -return string -allowcommands { |
|
set index [expr {[incr v_list_idx(@)]-1}] |
|
|
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {$index+1 > $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} else { |
|
set assigned [lindex $leveldata $index] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
@* { |
|
set active_key_type "list" |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS list-is-empty |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {$len == 0} { |
|
set assigned 1 ;#list is empty |
|
} else { |
|
set assigned 0 |
|
} |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS list-get-all |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
set assigned [lrange $leveldata 0 end] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
@@ { |
|
#stateful: tracking of index using v_dict_idx |
|
set active_key_type "dict" |
|
lappend INDEX_OPERATIONS get-next-value |
|
append script \n {# set active_key_type "dict" index_operation: get-next-value} |
|
append script \n {upvar v_dict_idx v_dict_idx} ;#review! |
|
|
|
#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} |
|
# but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. |
|
# (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) |
|
#review - might be more useful if they shared an index ? |
|
# It is analogous to v1@,v2@ for lists. |
|
# @pairs is more useful for repeated operations |
|
|
|
|
|
set indent " " |
|
set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { |
|
if {($keyindex + 1) <= $dsize} { |
|
set k [lindex [dict keys $leveldata] $keyindex] |
|
set assigned [list $k [dict get $leveldata $k]] |
|
} else { |
|
${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} |
|
} |
|
}] |
|
|
|
set assignment_script [tstr -ret string -allowcommands $assignment_script] |
|
|
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
set next_this_level [incr v_dict_idx(${$SUBPATH})] |
|
set keyindex [expr {$next_this_level -1}] |
|
${$assignment_script} |
|
} |
|
}] |
|
set level_script_complete 1 |
|
} |
|
@?@ { |
|
#stateful: tracking of index using v_dict_idx |
|
set active_key_type "dict" |
|
lappend INDEX_OPERATIONS get?-next-value |
|
append script \n {# set active_key_type "dict" index_operation: get?-next-value} |
|
append script \n {upvar v_dict_idx v_dict_idx} ;#review! |
|
set indent " " |
|
set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { |
|
if {($keyindex + 1) <= $dsize} { |
|
set k [lindex [dict keys $leveldata] $keyindex] |
|
set assigned [dict get $leveldata $k] |
|
} else { |
|
set assigned [list] |
|
} |
|
}] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
set next_this_level [incr v_dict_idx(${$SUBPATH})] |
|
set keyindex [expr {$next_this_level -1}] |
|
${$assignment_script} |
|
} |
|
}] |
|
set level_script_complete 1 |
|
} |
|
@??@ { |
|
set active_key_type "dict" |
|
lappend INDEX_OPERATIONS get?-next-pair |
|
append script \n {# set active_key_type "dict" index_operation: get?-next-pair} |
|
append script \n {upvar v_dict_idx v_dict_idx} ;#review! |
|
set indent " " |
|
set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { |
|
if {($keyindex + 1) <= $dsize} { |
|
set k [lindex [dict keys $leveldata] $keyindex] |
|
set assigned [list $k [dict get $leveldata $k]] |
|
} else { |
|
set assigned [list] |
|
} |
|
}] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
set next_this_level [incr v_dict_idx(${$SUBPATH})] |
|
set keyindex [expr {$next_this_level -1}] |
|
${$assignment_script} |
|
} |
|
}] |
|
set level_script_complete 1 |
|
} |
|
@vv@ - @VV@ - @kk@ - @KK@ { |
|
error "unsupported index $index" |
|
} |
|
default { |
|
|
|
#assert rules for values within @@ |
|
#glob search is done only if there is at least one * within @@ |
|
#if there is at least one ? within @@ - then a non match will not raise an error (quiet) |
|
|
|
#single or no char between @@: |
|
#lookup/search is based on key - return is values |
|
|
|
#double char within @@: |
|
#anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ |
|
#anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ |
|
#anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value |
|
#e.g @k*@ returns keys - search on values |
|
#e.g @*k@ returns keys - search on keys |
|
#e.g @v*@ returns values - search on values |
|
#e.g @*v@ returns values - search on keys |
|
|
|
switch -glob -- $index { |
|
@@* { |
|
#exact key match - return value |
|
#noisy get value - complain if key non-existent |
|
#doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped |
|
set active_key_type "dict" |
|
set key [string range $index 2 end] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS exactkey-get-value-not |
|
#review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here |
|
#this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: exactkey-get-value-not |
|
if {[dict exists $leveldata ${$key}]} { |
|
set assigned [dict values [dict remove $leveldata ${$key}]] |
|
} else { |
|
#set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS exactkey-get-value |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict index_operation: exactkey-get-value" |
|
if {[dict exists $leveldata ${$key}]} { |
|
set assigned [dict get $leveldata ${$key}] |
|
} else { |
|
#set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@\?@*} { |
|
#exact key match - quiet get value |
|
#silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict |
|
#note - dict remove will raise error on non-dict-shaped value whilst dict exists will not |
|
set active_key_type "dict" |
|
set key [string range $index 3 end] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS exactkey?-get-value-not |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: exactkey?-get-value-not |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
set assigned [dict values [dict remove $leveldata ${$key}]] |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS exactkey?-get-value |
|
#dict exists test is safe - no need for catch |
|
append script \n [string map [list <key> $key] { |
|
# set active_key_type "dict" index_operation: exactkey?-get-value |
|
if {[dict exists $leveldata <key>]} { |
|
set assigned [dict get $leveldata <key>] |
|
} else { |
|
set assigned [dict create] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@\?\?@*} { |
|
#quiet get pairs |
|
#this is silent too.. so how do we do a checked return of dict key+val? |
|
set active_key_type "dict" |
|
set key [string range $index 4 end] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS exactkey?-get-pair-not |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: exactkey?-get-pair-not |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
set assigned [dict remove $leveldata ${$key}] |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS exactkey?-get-pair |
|
append script \n [string map [list <key> $key] { |
|
# set active_key_type "dict" index_operation: exactkey?-get-pair |
|
if {[dict exists $leveldata <key>]} { |
|
set assigned [dict create <key> [dict get $leveldata <key>]] |
|
} else { |
|
set assigned [dict create] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
@..@* - @kk@* - @KK@* { |
|
#noisy get pairs by key |
|
set active_key_type "dict" |
|
set key [string range $index 4 end] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS exactkey-get-pairs-not |
|
#review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here |
|
#this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: exactkey-get-pairs-not |
|
if {[dict exists $leveldata ${$key}]} { |
|
set assigned [tcl::dict::remove $leveldata ${$key}] |
|
} else { |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS exactkey-get-pairs |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict index_operation: exactkey-get-pairs" |
|
if {[dict exists $leveldata ${$key}]} { |
|
tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] |
|
} else { |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
|
|
} |
|
@vv@* - @VV@* { |
|
#noisy(?) get pairs by exact value |
|
#return mismatch on non-match even when not- specified |
|
set active_key_type "dict" |
|
set keyglob [string range $index 4 end] |
|
set active_key_type "dict" |
|
set key [string range $index 4 end] |
|
if {$get_not} { |
|
#review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist |
|
#The utility of this is debatable |
|
lappend INDEX_OPERATIONS exactvalue-get-pairs-not |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: exactvalue-get-pairs-not |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
set nonmatches [dict create] |
|
tcl::dict::for {k v} $leveldata { |
|
if {![string equal ${$key} $v]} { |
|
dict set nonmatches $k $v |
|
} |
|
} |
|
|
|
if {[dict size $nonmatches] < [dict size $leveldata]} { |
|
#our key matched something |
|
set assigned $nonmatches |
|
} else { |
|
#our key didn't match anything - don't return the nonmatches |
|
#set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS exactvalue-get-pairs |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict index_operation: exactvalue-get-pairs-not" |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
set matches [list] |
|
tcl::dict::for {k v} $leveldata { |
|
if {[string equal ${$key} $v]} { |
|
lappend matches $k $v |
|
} |
|
} |
|
if {[llength $matches]} { |
|
set assigned $matches |
|
} else { |
|
#set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
|
|
} |
|
{@\*@*} - {@\*v@*} - {@\*V@*} { |
|
#dict key glob - return values only |
|
set active_key_type "dict" |
|
if {[string match {@\*@*} $index]} { |
|
set keyglob [string range $index 3 end] |
|
} else { |
|
#vV |
|
set keyglob [string range $index 4 end] |
|
} |
|
#if $keyglob eq "" - needs to query for dict key that is empty string. |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globkey-get-values-not |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
# set active_key_type "dict" index_operation: globkey-get-values-not |
|
set matched [dict keys $leveldata {${$keyglob}}] |
|
set assigned [dict values [dict remove $leveldata {*}$matched]] |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS globkey-get-values |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" index_operation: globkey-get-values |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
set matched [dict keys $leveldata {${$keyglob}}] |
|
set assigned [list] |
|
foreach m $matched { |
|
lappend assigned [dict get $leveldata $m] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
|
|
} |
|
{@\*.@*} { |
|
#dict key glob - return pairs |
|
set active_key_type "dict" |
|
set keyglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globkey-get-pairs-not |
|
append script \n [string map [list <keyglob> $keyglob] { |
|
# set active_key_type "dict" index_operation: globkey-get-pairs-not |
|
set matched [dict keys $leveldata {<keyglob>}] |
|
set assigned [dict remove $leveldata {*}$matched] |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS globkey-get-pairs |
|
append script \n [string map [list <keyglob> $keyglob] { |
|
# set active_key_type "dict" index_operations: globkey-get-pairs |
|
set matched [dict keys $leveldata {<keyglob>}] |
|
set assigned [dict create] |
|
foreach m $matched { |
|
dict set assigned $m [dict get $leveldata $m] |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@\*k@*} - {@\*K@*} { |
|
#dict key glob - return keys |
|
set active_key_type "dict" |
|
set keyglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globkey-get-keys-not |
|
append script \n [string map [list <keyglob> $keyglob] { |
|
# set active_key_type "dict" index_operation: globkey-get-keys-not |
|
set matched [dict keys $leveldata {<keyglob>}] |
|
set assigned [dict keys [dict remove $leveldata {*}$matched]] |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS globkey-get-keys |
|
append script \n [string map [list <keyglob> $keyglob] { |
|
# set active_key_type "dict" index_operation: globkey-get-keys |
|
set assigned [dict keys $leveldata {<keyglob>}] |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@k\*@*} - {@K\*@*} { |
|
#dict value glob - return keys |
|
set active_key_type "dict" |
|
set valglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globvalue-get-keys-not |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" index_operation: globvalue-get-keys-not |
|
set assigned [list] |
|
tcl::dict::for {k v} $leveldata { |
|
if {![string match {<valglob>} $v]} { |
|
lappend assigned $k |
|
} |
|
} |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS globvalue-get-keys |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" index_operation: globvalue-get-keys |
|
set assigned [list] |
|
tcl::dict::for {k v} $leveldata { |
|
if {[string match {<valglob>} $v]} { |
|
lappend assigned $k |
|
} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@.\*@*} { |
|
#dict value glob - return pairs |
|
set active_key_type "dict" |
|
set valglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globvalue-get-pairs-not |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" index_operation: globvalue-get-pairs-not |
|
set assigned [dict create] |
|
tcl::dict::for {k v} $leveldata { |
|
if {![string match {<valglob>} $v]} { |
|
dict set assigned $k $v |
|
} |
|
} |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS globvalue-get-pairs |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" index_operation: globvalue-get-pairs |
|
set assigned [dict create] |
|
tcl::dict::for {k v} $leveldata { |
|
if {[string match {<valglob>} $v]} { |
|
dict set assigned $k $v |
|
} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
} |
|
{@V\*@*} - {@v\*@*} { |
|
#dict value glob - return values |
|
set active_key_type dict |
|
set valglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globvalue-get-values-not |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" ;# index_operation: globvalue-get-values-not |
|
set assigned [list] |
|
tcl::dict::for {k v} $leveldata { |
|
if {![string match {<valglob>} $v]} { |
|
lappend assigned $v |
|
} |
|
} |
|
}] |
|
|
|
} else { |
|
lappend INDEX_OPERATIONS globvalue-get-values |
|
append script \n [string map [list <valglob> $valglob] { |
|
# set active_key_type "dict" ;#index_operation: globvalue-get-value |
|
set assigned [dict values $leveldata <valglob>] |
|
}] |
|
} |
|
set level_script_complete 1 |
|
|
|
} |
|
{@\*\*@*} { |
|
#dict val/key glob return pairs) |
|
set active_key_type "dict" |
|
set keyvalglob [string range $index 4 end] |
|
append script [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata}]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} |
|
}] |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not |
|
error "globkeyvalue-get-pairs-not todo" |
|
} else { |
|
lappend INDEX_OPERATIONS globkeyvalue-get-pairs |
|
append script \n [string map [list <keyvalglob> $keyvalglob] { |
|
# set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not |
|
set assigned [dict create] |
|
tcl::dict::for {k v} $leveldata { |
|
if {[string match {<keyvalglob>} $k] || [string match {<keyvalglob>} $v]} { |
|
dict set assigned $k $v |
|
} |
|
} |
|
}] |
|
} |
|
set level_script_complete 1 |
|
puts stderr "globkeyvalue-get-pairs review" |
|
} |
|
@* { |
|
set active_key_type "list" |
|
set do_bounds_check 1 |
|
|
|
set index [string trimleft $index @] |
|
append script \n [string map [list <idx> $index] { |
|
# set active_key_type "list" index_operation: ? |
|
set index <idx> |
|
}] |
|
} |
|
%* { |
|
set active_key_type "string" |
|
set do_bounds_check 0 |
|
set index [string range $index 1 end] |
|
append script \n [string map [list <idx> $index] { |
|
# set active_key_type "string" index_operation: ? |
|
set index <idx> |
|
}] |
|
} |
|
default { |
|
puts "destructure_func_build_body unmatched index $index" |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {!$level_script_complete} { |
|
|
|
|
|
#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" |
|
|
|
#append script \n [string map [list <listmsg> $listmsg] {set listmsg "<listmsg>"}] |
|
|
|
|
|
|
|
#we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against |
|
#need to set a corresponding action |
|
if {$active_key_type in [list "" "list"]} { |
|
set active_key_type "list" |
|
append script \n {# set active_key_type "list"} |
|
#for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) |
|
switch -exact -- $index { |
|
0 { |
|
if {$get_not} { |
|
append script \n "# index_operation listindex-int-not" \n |
|
lappend INDEX_OPERATIONS listindex-zero-not |
|
set assignment_script {set assigned [lrange $leveldata 1 end]} |
|
} else { |
|
lappend INDEX_OPERATIONS listindex-zero |
|
set assignment_script {set assigned [lindex $leveldata 0]} |
|
if {$do_bounds_check} { |
|
append script \n "# index_operation listindex-int (bounds checked)" \n |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {[llength $leveldata] == 0} { |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} else { |
|
append script \n "# index_operation listindex-int" \n |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
} |
|
} |
|
head { |
|
#NOTE: /@head and /head both do bounds check. This is intentional |
|
if {$get_not} { |
|
append script \n "# index_operation listindex-head-not" \n |
|
lappend INDEX_OPERATIONS listindex-head-not |
|
set assignment_script {set assigned [lrange $leveldata 1 end]} |
|
} else { |
|
append script \n "# index_operation listindex-head" \n |
|
lappend INDEX_OPERATIONS listindex-head |
|
set assignment_script {set assigned [lindex $leveldata 0]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {$len == 0} { |
|
#set action ?mismatch-list-index-out-of-range-empty |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} |
|
} else { |
|
#alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
end { |
|
if {$get_not} { |
|
append script \n "# index_operation listindex-end-not" \n |
|
lappend INDEX_OPERATIONS listindex-end-not |
|
#on single element list Tcl's lrange will do what we want here and return nothing |
|
set assignment_script {set assigned [lrange $leveldata 0 end-1]} |
|
} else { |
|
append script \n "# index_operation listindex-end" \n |
|
lappend INDEX_OPERATIONS listindex-end |
|
set assignment_script {set assigned [lindex $leveldata end]} |
|
} |
|
if {$do_bounds_check} { |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {$len == 0} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} else { |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
} |
|
tail { |
|
#NOTE: /@tail and /tail both do bounds check. This is intentional. |
|
# |
|
#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 {$get_not} { |
|
append script \n "# index_operation listindex-tail-not" \n |
|
lappend INDEX_OPERATIONS listindex-tail-not |
|
set assignment_script {set assigned [lindex $leveldata 0]} |
|
} else { |
|
append script \n "# index_operation listindex-tail" \n |
|
lappend INDEX_OPERATIONS listindex-tail |
|
set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} elseif {$len == 0} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
anyhead { |
|
#allow returning of head or nothing if empty list |
|
if {$get_not} { |
|
append script \n "# index_operation listindex-anyhead-not" \n |
|
lappend INDEX_OPERATIONS listindex-anyhead-not |
|
set assignment_script {set assigned [lrange $leveldata 1 end]} |
|
} else { |
|
append script \n "# index_operation listindex-anyhead" \n |
|
lappend INDEX_OPERATIONS listindex-anyhead |
|
set assignment_script {set assigned [lindex $leveldata 0]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
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 {$get_not} { |
|
append script \n "# index_operation listindex-anytail-not" \n |
|
lappend INDEX_OPERATIONS listindex-anytail-not |
|
set assignment_script {set assigned [lindex $leveldata 0]} |
|
} else { |
|
append script \n "# index_operation listindex-anytail" \n |
|
lappend INDEX_OPERATIONS listindex-anytail |
|
set assignment_script {set assigned [lrange $leveldata 1 end]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
init { |
|
#all but last element - same as haskell 'init' |
|
#counterintuitively, get-notinit can therefore return first element if it is a single element list |
|
#does bounds_check for get-not@init make sense here? maybe - review |
|
if {$get_not} { |
|
append script \n "# index_operation listindex-init-not" \n |
|
lappend INDEX_OPERATIONS listindex-init-not |
|
set assignment_script {set assigned [lindex $leveldata end]} |
|
} else { |
|
append script \n "# index_operation listindex-init" \n |
|
lappend INDEX_OPERATIONS listindex-init |
|
set assignment_script {set assigned [lrange $leveldata 0 end-1]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
list { |
|
#get_not? |
|
#allow returning of entire list even if empty |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS list-getall-not |
|
set assignment_script {set assigned {}} |
|
} else { |
|
lappend INDEX_OPERATIONS list-getall |
|
set assignment_script {set assigned $leveldata} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
raw { |
|
#get_not - return nothing?? |
|
#no list checking.. |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS getraw-not |
|
append script \n {set assigned {}} |
|
} else { |
|
lappend INDEX_OPERATIONS getraw |
|
append script \n {set assigned $leveldata} |
|
} |
|
} |
|
keys { |
|
#@get_not?? |
|
#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 {$get_not} { |
|
lappend INDEX_OPERATIONS list-getkeys-not |
|
set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values |
|
} else { |
|
lappend INDEX_OPERATIONS list-getkeys |
|
set assignment_script {set assigned [dict keys $leveldata]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
#set action ?mismatch-not-a-dict |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
values { |
|
#get_not ?? |
|
#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 {$get_not} { |
|
lappend INDEX_OPERATIONS list-getvalues-not |
|
set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys |
|
} else { |
|
lappend INDEX_OPERATIONS list-getvalues |
|
set assignment_script {set assigned [dict values $leveldata]} |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
#set action ?mismatch-not-a-dict |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
${$assignment_script} |
|
} |
|
}] |
|
} |
|
pairs { |
|
#get_not ?? |
|
if {$get_not} { |
|
#review - return empty list instead like not-list and not-raw? |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] |
|
} else { |
|
lappend INDEX_OPERATIONS list-getpairs |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {dict size $leveldata} dsize]} { |
|
#set action ?mismatch-not-a-dict |
|
${[tstr -ret string $tpl_return_mismatch_not_a_dict]} |
|
} else { |
|
set pairs [list] |
|
tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} |
|
set assigned [lindex [list $pairs [unset pairs]] 0] |
|
} |
|
}] |
|
} |
|
default { |
|
if {[regexp {[?*]} $index]} { |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS listsearch-not |
|
set assign_script [string map [list <idx> $index] { |
|
set assigned [lsearch -all -inline -not $leveldata <idx>] |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS listsearch |
|
set assign_script [string map [list <idx> $index] { |
|
set assigned [lsearch -all -inline $leveldata <idx>] |
|
}] |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assign_script} |
|
} |
|
}] |
|
} elseif {[string is integer -strict $index]} { |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS listindex-not |
|
set assign_script [string map [list <idx> $index] { |
|
#not- was specified (already handled not-0) |
|
set assigned [lreplace $leveldata <idx> <idx>] |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS listindex |
|
set assign_script [string map [list <idx> $index] {set assigned [lindex $leveldata <idx>]}] |
|
} |
|
|
|
if {$do_bounds_check} { |
|
if {$index < 0} { |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] |
|
} |
|
set max [expr {$index + 1}] |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
# bounds_check due to @ directly specified in original index section |
|
if {${$max} > $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} else { |
|
${$assign_script} |
|
} |
|
} |
|
}] |
|
} else { |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assign_script} |
|
} |
|
}] |
|
} |
|
} elseif {[string first "end" $index] >=0} { |
|
if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { |
|
|
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS listindex-endoffset-not |
|
set assign_script [string map [list <idx> $index] { |
|
#not- was specified (already handled not-0) |
|
set assigned [lreplace $leveldata <idx> <idx>] |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS listindex-endoffset |
|
set assign_script [string map [list <idx> $index ] {set assigned [lindex $leveldata <idx>]}] |
|
} |
|
|
|
if {$do_bounds_check} { |
|
#tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. |
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
set action ?mismatch-not-a-list |
|
} else { |
|
#bounds-check is true |
|
#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 |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} else { |
|
${$assign_script} |
|
} |
|
} |
|
}] |
|
} else { |
|
append script \n [tstr -ret string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} else { |
|
${$assign_script} |
|
} |
|
}] |
|
} |
|
|
|
} elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS list-range-not |
|
set assign_script [string map [list <s> $start <e> $end ] { |
|
#not- was specified (already handled not-0) |
|
set assigned [lreplace $leveldata <s> <e>] |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS list-range |
|
set assign_script [string map [list <s> $start <e> $end] {set assigned [lrange $leveldata <s> <e>]}] |
|
} |
|
|
|
append script \n [tstr -ret string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} |
|
}] |
|
|
|
if {$do_bounds_check} { |
|
if {[string is integer -strict $start]} { |
|
if {$start < 0} { |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
set start ${$start} |
|
if {$start+1 > $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} |
|
}] |
|
} elseif {$start eq "end"} { |
|
#noop |
|
} else { |
|
set startoffset [string range $start 3 end] ;#include the - from end- |
|
set startoffset [expr $startoffset] ;#don't brace! |
|
if {$startoffset > 0} { |
|
#e.g end+1 |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] |
|
|
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
set startoffset ${$startoffset} |
|
if {abs($startoffset) >= $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} |
|
}] |
|
} |
|
if {[string is integer -strict $end]} { |
|
if {$end < 0} { |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
set end ${$end} |
|
if {$end+1 > $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} |
|
}] |
|
} elseif {$end eq "end"} { |
|
#noop |
|
} else { |
|
set endoffset [string range $end 3 end] ;#include the - from end- |
|
|
|
set endoffset [expr $endoffset] ;#don't brace! |
|
if {$endoffset > 0} { |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] |
|
} |
|
append script \n [tstr -return string -allowcommands { |
|
set endoffset ${$endoffset} |
|
if {abs($endoffset) >= $len} { |
|
#set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} |
|
}] |
|
} |
|
} |
|
|
|
append script \n [string map [list <assign_script> $assign_script] { |
|
if {![string match ?mismatch-* $action]} { |
|
<assign_script> |
|
} |
|
}] |
|
|
|
} else { |
|
#fail now - no need for script |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
} elseif {[string first - $index] > 0} { |
|
#e.g @1-3 gets here |
|
#JMN |
|
if {$get_not} { |
|
lappend INDEX_OPERATIONS list-range-not |
|
} else { |
|
lappend INDEX_OPERATIONS list-range |
|
} |
|
|
|
append script \n [tstr -return string -allowcommands { |
|
if {[catch {llength $leveldata} len]} { |
|
#set action ?mismatch-not-a-list |
|
${[tstr -ret string $tpl_return_mismatch_not_a_list]} |
|
} |
|
}] |
|
|
|
#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 "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
lassign $parts start end |
|
|
|
#review - Tcl lrange just returns nothing silently. |
|
#if we don't intend to implement reverse indexing - we should probably not emit an error |
|
if {$start > $end} { |
|
puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
if {$do_bounds_check} { |
|
#append script [string map [list <s> $start <e> $end] { |
|
# set start <s> |
|
# set end <e> |
|
# if {$start+1 > $len || $end+1 > $len} { |
|
# set action ?mismatch-list-index-out-of-range |
|
# } |
|
#}] |
|
#set eplusone [expr {$end+1}] |
|
append script [tstr -return string -allowcommands { |
|
if {$len < ${[expr {$end+1}]}} { |
|
set action ?mismatch-list-index-out-of-range |
|
${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} |
|
} |
|
}] |
|
} |
|
|
|
|
|
if {$get_not} { |
|
set assign_script [string map [list <s> $start <e> $end] { |
|
#not- was specified (already handled not-0) |
|
set assigned [lreplace $leveldata <s> <e>] |
|
}] |
|
} else { |
|
set assign_script [string map [list <s> $start <e> $end] {set assigned [lrange $leveldata <s> <e>]}] |
|
} |
|
|
|
|
|
} else { |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
|
|
append script \n [string map [list <assign_script> $assign_script] { |
|
if {![string match ?mismatch-* $action]} { |
|
<assign_script> |
|
} |
|
}] |
|
|
|
} else { |
|
#keyword 'pipesyntax' at beginning of error message |
|
#pipesyntax error - no need to even build script - can fail now |
|
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] |
|
} |
|
} |
|
} |
|
} elseif {$active_key_type eq "string"} { |
|
if {[string match *-* $index]} { |
|
lappend INDEX_OPERATIONS string-range |
|
set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} |
|
#todo - support more complex indices: 0-end-1 etc |
|
|
|
lassign [split $index -] a b |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "string" |
|
set assigned [string range $leveldata ${$a} ${$b}] |
|
}] |
|
|
|
} else { |
|
if {$index eq "*"} { |
|
lappend INDEX_OPERATIONS string-all |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "string" |
|
set assigned $leveldata |
|
}] |
|
} elseif {[regexp {[?*]} $index]} { |
|
lappend INDEX_OPERATIONS string-globmatch |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "string" |
|
if {[string match $index $leveldata]} { |
|
set assigned $leveldata |
|
} else { |
|
set assigned "" |
|
} |
|
}] |
|
} else { |
|
lappend INDEX_OPERATIONS string-index |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "string" |
|
set assigned [string index $leveldata ${$index}] |
|
}] |
|
} |
|
} |
|
|
|
} else { |
|
#treat as dict key |
|
if {$get_not} { |
|
#dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? |
|
append script \n [tstr -return string { |
|
set assigned [dict remove $leveldata ${$index}] |
|
}] |
|
} else { |
|
append script \n [tstr -return string -allowcommands { |
|
# set active_key_type "dict" |
|
if {[dict exists $leveldata {${$index}}]} { |
|
set assigned [dict get $leveldata {${$index}}] |
|
} else { |
|
set action ?mismatch-dict-key-not-found |
|
${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} |
|
} |
|
}] |
|
} |
|
|
|
} |
|
|
|
|
|
} ;# end if $level_script_complete |
|
|
|
|
|
append script \n { |
|
set leveldata $assigned |
|
} |
|
incr i_keyindex |
|
append script \n "# ------- END index $index ------" |
|
} ;# end foreach |
|
|
|
|
|
|
|
#puts stdout "----> destructure rep leveldata: [rep $leveldata]" |
|
#puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" |
|
|
|
#maintain key order - caller unpacks using lassign |
|
#append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} |
|
append script \n [tstr -return string $return_template] \n |
|
return $script |
|
} |
|
|
|
|
|
|
|
|
|
#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 |
|
#todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) |
|
# non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline |
|
proc _multi_bind_result {multivar data args} { |
|
#puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$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 |
|
#JMN2 - changed to list based destructuring |
|
return [dict create ismatch 1 result $data setvars {} script {}] |
|
#return [dict create ismatch 1 result [list $data] setvars {} script {}] |
|
} |
|
set returndict [dict create ismatch 0 result "" setvars {}] |
|
set script "" |
|
|
|
set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] |
|
set opts [dict merge $defaults $args] |
|
set unset [dict get $opts -unset] |
|
set lvlup [dict get $opts -levelup] |
|
set get_mismatchinfo [dict get $opts -mismatchinfo] |
|
|
|
|
|
|
|
#first classify into var_returntype of either "pipeline" or "segment" |
|
#segment returntype is indicated by leading % |
|
|
|
set varinfo [punk::pipe::lib::_var_classify $multivar] |
|
set var_names [dict get $varinfo var_names] |
|
set var_class [dict get $varinfo var_class] |
|
set varspecs_trimmed [dict get $varinfo varspecs_trimmed] |
|
|
|
set var_actions [list] |
|
set expected_values [list] |
|
#e.g {a = abc} {b set ""} |
|
foreach classinfo $var_class vname $var_names { |
|
lassign [lindex $classinfo 0] v |
|
lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version |
|
lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default |
|
} |
|
|
|
#puts stdout "var_actions: $var_actions" |
|
#puts stdout "expected_values: $expected_values" |
|
|
|
|
|
#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 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 |
|
# matchatom-set names is an atom to be matched |
|
# matchglob-set |
|
# set |
|
# 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 |
|
#assertion 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 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 |
|
# |
|
# TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! |
|
set vkeys_seen [list] |
|
foreach v_and_key $varspecs_trimmed { |
|
set vspec [join $v_and_key ""] |
|
lassign $v_and_key v vkey |
|
|
|
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 |
|
|
|
lassign [destructure_func $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 |
|
|
|
#update the setvars/unsetvars elements |
|
if {[string length $v]} { |
|
dict set returndict_setvars $v $assigned |
|
} |
|
|
|
#JMN2 |
|
#special case expansion for empty varspec (e.g ,<something> or <something>,,<something>) |
|
#if {$vspec eq ""} { |
|
# lappend assigned_values {*}$assigned |
|
#} else { |
|
lappend assigned_values $assigned |
|
#} |
|
incr i |
|
} |
|
|
|
#todo - fix! this isn't the actual tclvars that were set! |
|
dict set returndict setvars $returndict_setvars |
|
|
|
#assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec |
|
#For booleans the final val may later be normalised to 0 or 1 |
|
|
|
|
|
#assertion all var_actions were set with leading question mark |
|
#perform assignments only if matched ok |
|
|
|
|
|
#0 - novar |
|
#1 - atom ' |
|
#2 - pin ^ |
|
#3 - boolean & |
|
#4 - integer |
|
#5 - double |
|
#6 - var |
|
#7 - glob (no classifier and contains * or ?) |
|
if 0 { |
|
debug.punk.pipe.var {VAR_CLASS: $var_class} 5 |
|
debug.punk.pipe.var {VARACTIONS: $var_actions} 5 |
|
debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 |
|
|
|
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] ?] |
|
unset -nocomplain v |
|
unset -nocomplain nm |
|
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 { |
|
#val comes from -assigned |
|
lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" |
|
set varname [lindex $var_names $i] |
|
|
|
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 var $varname spec $lhsspec info mismatch lhs ? rhs $val] |
|
break |
|
} |
|
|
|
|
|
set class_key [lindex $var_class $i 1] |
|
lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan |
|
foreach ck $class_key { |
|
switch -- $ck { |
|
1 {set isatom 1} |
|
2 {set ispin 1} |
|
3 {set isbool 1} |
|
4 {set isint 1} |
|
5 {set isdouble 1} |
|
6 {set isvar 1} |
|
7 {set isglob 1} |
|
8 {set isnumeric 1} |
|
9 {set isgreaterthan 1} |
|
10 {set islessthan 1} |
|
} |
|
} |
|
|
|
|
|
#set isatom [expr {$class_key == 1}] |
|
#set ispin [expr {2 in $class_key}] |
|
#set isbool [expr {3 in $class_key}] |
|
#set isint [expr {4 in $class_key}] |
|
#set isdouble [expr {5 in $class_key}] |
|
#set isvar [expr {$class_key == 6}] |
|
#set isglob [expr {7 in $class_key}] |
|
#set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) |
|
##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? |
|
#set isgreaterthan [expr {9 in $class_key}] |
|
#set islessthan [expr {10 in $class_key}] |
|
|
|
|
|
|
|
if {$isatom} { |
|
#puts stdout "==>isatom $lhsspec" |
|
set lhs [string range $lhsspec 1 end] |
|
if {[string index $lhs end] eq "'"} { |
|
set lhs [string range $lhs 0 end-1] |
|
} |
|
lset var_actions $i 1 matchatom-set |
|
if {$lhs eq $val} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] |
|
incr i |
|
continue |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
# - 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 |
|
|
|
|
|
#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 $lhsspec" |
|
if {$act in [list "?set" "?matchvar-set"]} { |
|
lset var_actions $i 1 matchvar-set |
|
#attempt to read |
|
upvar $lvlup $varname the_var |
|
#if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} |
|
if {![catch {set the_var} existingval]} { |
|
|
|
if {$isbool} { |
|
#isbool due to 2nd classifier i.e ^& |
|
lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] |
|
#normalise to LHS! |
|
lset assigned_values $i $existingval |
|
} elseif {$isglob} { |
|
#isglob due to 2nd classifier ^* |
|
lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] |
|
} elseif {$isnumeric} { |
|
#flagged as numeric by user using ^# classifiers |
|
set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) |
|
if {[string is integer -strict $testexistingval]} { |
|
set isint 1 |
|
lset assigned_values $i $existingval |
|
lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] |
|
} elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { |
|
#test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) |
|
set isdouble 1 |
|
#doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var |
|
lset assigned_values $i $existingval |
|
|
|
lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] |
|
} else { |
|
#user's variable doesn't seem to have a numeric value |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] |
|
break |
|
} |
|
|
|
} 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 var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] |
|
break |
|
} else { |
|
lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] |
|
} |
|
} |
|
|
|
} else { |
|
#puts stdout "pinned var $varname 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 var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] |
|
break |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
if {$isint} { |
|
#note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. |
|
#expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] |
|
|
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $lhsspec ;#literal integer in the pattern |
|
} |
|
if {$isgreaterthan || $islessthan} { |
|
set lhs [string range $lhsspec 0 end-1] |
|
set testlhs $lhs |
|
} |
|
if {[string index $lhs 0] eq "."} { |
|
set testlhs $lhs |
|
} else { |
|
set testlhs [join [scan $lhs %lld%s] ""] |
|
} |
|
if {[string index $val 0] eq "."} { |
|
set testval $val |
|
} else { |
|
set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) |
|
} |
|
if {[string is integer -strict $testval]} { |
|
if {$isgreaterthan} { |
|
#puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" |
|
if {$testlhs <= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {$islessthan} { |
|
if {$testlhs >= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
if {$testlhs == $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} elseif {[string is double -strict $testval]} { |
|
#dragons. (and shimmering) |
|
if {[string first "e" $val] != -1} { |
|
#scientific notation - let expr compare |
|
if {$isgreaterhthan} { |
|
if {$testlhs <= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {$islessthan} { |
|
if {$testlhs >= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
if {$testlhs == $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec 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 {$isgreaterthan} { |
|
if {$testlhs <= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {$islessthan} { |
|
if {$testlhs >= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
if {$testlhs == $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} else { |
|
if {[punk::pipe::float_almost_equal $testlhs $testval]} { |
|
lset match_state $i 1 |
|
} else { |
|
if {$isgreaterthan} { |
|
if {$testlhs <= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] |
|
break |
|
} |
|
} elseif {$islessthan} { |
|
if {$testlhs >= $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] |
|
break |
|
} |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} |
|
} else { |
|
#e.g rhs not a number.. |
|
if {$testlhs == $testval} { |
|
lset match_state $i 1 |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} elseif {$isdouble} { |
|
#dragons (and shimmering) |
|
# |
|
# |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $lhsspec ;#literal integer in the pattern |
|
} |
|
if {$isgreaterthan || $islessthan} { |
|
error "+/- not yet supported for lhs float" |
|
set lhs [string range $lhsspec 0 end-1] |
|
set testlhs $lhs |
|
} |
|
if {[string index $val 0] eq "."} { |
|
set testval $val ;#not something with some number of leading zeros |
|
} else { |
|
set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) |
|
} |
|
#expr handles leading 08.1 0009.1 etc without triggering octal |
|
#so we don't need to scan lhs |
|
if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { |
|
if {$lhs == $testval} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-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 == $testval} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-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::pipe::float_almost_equal $lhs $testval]} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
} elseif {$isbool} { |
|
#Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. |
|
#e.g &x/0,&x/1,&x/2= {1 2 yes} |
|
# all resolve to true so the cross-binding is ok. |
|
# Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) |
|
# todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? |
|
# |
|
#punk::pipe::boolean_equal $a $b |
|
set extra_match_info "" ;# possible crossbind indication |
|
set is_literal_boolean 0 |
|
if {$ispin} { |
|
#for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! |
|
#As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix |
|
|
|
if {![string length $lhs]} { |
|
#empty varname - ok |
|
if {[string is boolean -strict $val] || [string is double -strict $val]} { |
|
lset match_state $i 1 |
|
lset var_actions $i 1 "return-normalised-value" |
|
lset assigned_values $i [expr {bool($val)}] |
|
lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] |
|
break |
|
} |
|
} elseif {$lhs in [list 0 1]} { |
|
#0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. |
|
set is_literal_boolean 1 |
|
} elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { |
|
#literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern |
|
#we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. |
|
set is_literal_boolean 1 |
|
set lhs [string range $lhs 1 end-1] ;#strip off squotes |
|
} else { |
|
#todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. |
|
set tclvar $lhs |
|
if {[string is double $tclvar]} { |
|
error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] |
|
#proc _multi_bind_result {multivar data args} |
|
} |
|
#treat as variable - need to check cross-binding within this pattern group |
|
set first_bound [lsearch -index 0 $var_actions $lhsspec] |
|
if {$first_bound == $i} { |
|
#test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) |
|
if {[string is boolean -strict $val] || [string is double -strict $val]} { |
|
lset match_state $i 1 |
|
lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound |
|
#review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline |
|
#Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval |
|
#puts stderr "==========[lindex $assigned_values $i]" |
|
lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 |
|
lset assigned_values $i [lindex $var_actions $i 2] |
|
#puts stderr "==========[lindex $assigned_values $i]" |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] |
|
break |
|
} |
|
} else { |
|
set expectedinfo [lindex $expected_values $first_bound] |
|
set expected_earlier [dict get $expectedinfo rhs] |
|
set extra_match_info "-crossbind-first" |
|
set lhs $expected_earlier |
|
} |
|
} |
|
} |
|
|
|
|
|
#may have already matched above..(for variable) |
|
if {[lindex $match_state $i] != 1} { |
|
if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { |
|
if {$ismatch} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info 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 var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] |
|
break |
|
} |
|
} |
|
|
|
} elseif {$isglob} { |
|
if {$ispin} { |
|
set existing_expected [lindex $expected_values $i] |
|
set lhs [dict get $existing_expected lhs] |
|
} else { |
|
set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix |
|
} |
|
if {[string match $lhs $val]} { |
|
lset match_state $i 1 |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] |
|
} else { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] |
|
break |
|
} |
|
|
|
} elseif {$ispin} { |
|
#handled above.. leave case in place so we don't run else for pins |
|
|
|
} else { |
|
#puts stdout "==> $lhsspec" |
|
#NOTE - pinned var of same name is independent! |
|
#ie ^x shouldn't look at earlier x bindings in same pattern |
|
#unpinned non-atoms |
|
#cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) |
|
# |
|
switch -- $varname { |
|
"" { |
|
#don't attempt cross-bind on empty-varname |
|
lset match_state $i 1 |
|
#don't change var_action $i 1 to set |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] |
|
} |
|
"_" { |
|
#don't cross-bind on the special 'don't-care' varname |
|
lset match_state $i 1 |
|
lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] |
|
} |
|
default { |
|
set first_bound [lsearch -index 0 $var_actions $varname] |
|
#assertion first_bound >=0, we will always find something - usually self |
|
if {$first_bound == $i} { |
|
lset match_state $i 1 |
|
lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] |
|
} else { |
|
assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] |
|
set expectedinfo [lindex $expected_values $first_bound] |
|
set expected_earlier [dict get $expectedinfo rhs] |
|
if {$expected_earlier ne $val} { |
|
lset match_state $i 0 |
|
lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] |
|
break |
|
} else { |
|
lset match_state $i 1 |
|
#don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example |
|
#lset var_actions $i 1 [string range $act 1 end] |
|
lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
incr i |
|
} |
|
|
|
#JMN2 - review |
|
#set returnval [lindex $assigned_values 0] |
|
if {[llength $assigned_values] == 1} { |
|
set returnval [join $assigned_values] |
|
} else { |
|
set returnval $assigned_values |
|
} |
|
#puts stdout "----> > rep returnval: [rep $returnval]" |
|
|
|
|
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
|
#Variable assignments (set) 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 |
|
if {$match_count == $match_count_needed} { |
|
#do assignments |
|
for {set i 0} {$i < [llength $var_actions]} {incr i} { |
|
if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { |
|
#isvar |
|
if {[lindex $var_actions $i 1] eq "set"} { |
|
upvar $lvlup $varname the_var |
|
set the_var [lindex $var_actions $i 2] |
|
} |
|
} |
|
} |
|
dict set returndict ismatch 1 |
|
#set i 0 |
|
#foreach va $var_actions { |
|
# #set isvar [expr {[lindex $var_class $i 1] == 6}] |
|
# if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { |
|
# #isvar |
|
# lassign $va lhsspec act val |
|
# upvar $lvlup $varname the_var |
|
# if {$act eq "set"} { |
|
# set the_var $val |
|
# } |
|
# #if {[lindex $var_actions $i 1] eq "set"} { |
|
# # set the_var $val |
|
# #} |
|
# } |
|
# 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 less important than moving on quickly |
|
set vidx 0 |
|
#set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] |
|
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 |
|
} |
|
} |
|
#REVIEW 2025 |
|
#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 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 "Cannot match right hand side to pattern $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 varname |
|
if {$status eq "mismatch"} { |
|
# varname 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] |
|
set type "" |
|
if {2 in $varclass} { |
|
append type "pinned " |
|
} |
|
|
|
if {$varclass == 1} { |
|
set type "atom" |
|
} elseif {$varclass == 2} { |
|
set type "pinned var" |
|
} elseif {3 in $varclass} { |
|
append type "boolean" |
|
} elseif {4 in $varclass} { |
|
append type "int" |
|
} elseif {5 in $varclass} { |
|
append type "double" |
|
} elseif {$varclass == 6} { |
|
set type "var" |
|
} elseif {7 in $varclass} { |
|
append type "glob" |
|
} elseif {8 in $varclass} { |
|
append type "numeric" |
|
} |
|
if {$type eq ""} { |
|
set type "<undetermined>" |
|
} |
|
|
|
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: '$varname' $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 $var_names]} { |
|
#var_name entries can be blank - but it will still be a list |
|
#JMN2 |
|
#dict set returndict result [list $data] |
|
dict set returndict result $data |
|
} else { |
|
assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} |
|
dict set returndict result $returnval |
|
} |
|
return $returndict |
|
} |
|
|
|
######################################################## |
|
# dragons. |
|
# using an error as out-of-band way to signal mismatch is the easiest. |
|
# It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) |
|
# The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. |
|
# We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! |
|
# A proper solution may involve a callback? tailcall some_mismatch_func? |
|
# There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match <info>} {internalresult mismatch <info>} and be careful to not let boxed data escape ?? |
|
# make sure there is good test coverage before experimenting with this |
|
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] |
|
return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] |
|
} else { |
|
return [dict get $d result] |
|
} |
|
} |
|
# initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch |
|
proc _handle_bind_result_experimental1 {d} { |
|
#set match_caller [info level 2] |
|
#debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 |
|
if {![dict exists $d result]} { |
|
tailcall return [dict get $d mismatch] |
|
} else { |
|
return [dict get $d result] |
|
} |
|
} |
|
######################################################## |
|
|
|
#timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. |
|
#Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' |
|
#there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. |
|
#proc listset1 {listvarname args} { |
|
# tailcall set $listvarname $args |
|
#} |
|
#interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} |
|
#interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} |
|
proc pipeset {pipevarname args} { |
|
upvar $pipevarname the_pipe |
|
set the_pipe $args |
|
} |
|
|
|
#pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created |
|
proc pipealias {targetcmd args} { |
|
set cmdcopy [punk::objclone $args] |
|
set nscaller [uplevel 1 [list namespace current]] |
|
tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] |
|
} |
|
proc pipealias_extract {targetcmd} { |
|
set applybody [lindex [interp alias "" $targetcmd] 1 1] |
|
#strip off trailing " {*}$args" |
|
return [lrange [string range $applybody 0 end-9] 0 end] |
|
} |
|
#although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower |
|
proc pipealias2 {targetcmd args} { |
|
set cmdcopy [punk::objclone $args] |
|
set nscaller [uplevel 1 [list namespace current]] |
|
tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] |
|
} |
|
|
|
|
|
#same as used in unknown func for initial launch |
|
#variable re_assign {^([^\r\n=\{]*)=(.*)} |
|
#variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} |
|
variable re_assign {^([^ \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 {scopepattern equalsrhs args} { |
|
#review - :: is legal in atoms! |
|
if {[string match "*::*" $scopepattern]} { |
|
error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." |
|
} |
|
#puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" |
|
set fulltail $args |
|
set cmdns ::punk::pipecmds |
|
set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] |
|
|
|
#we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW |
|
#(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) |
|
|
|
set pipecmd ${cmdns}::$scopepattern=$namemapping |
|
|
|
#pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. |
|
if {$pipecmd in [info commands $pipecmd]} { |
|
#puts "==nscaller: '[uplevel 1 [list namespace current]]'" |
|
#uplevel 1 [list ::namespace import $pipecmd] |
|
set existing_path [uplevel 1 [list ::namespace path]] |
|
if {$cmdns ni $existing_path} { |
|
uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] |
|
} |
|
tailcall $pipecmd {*}$args |
|
} |
|
|
|
|
|
#NOTE: |
|
#we need to ensure for case: |
|
#= x=y |
|
#that the second arg is treated as a raw value - never a pipeline command |
|
|
|
#equalsrhs is set if there is a segment-insertion-pattern *directly* after the = |
|
#debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 |
|
#can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. |
|
|
|
# allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c |
|
# |
|
#to assign an entire pipeline to a var - use pipeset varname instead. |
|
|
|
# in our script's handling of args: |
|
#avoid use of regexp match on each element - or we will unnecessarily force string reps on lists |
|
#same with lsearch with a string pattern - |
|
#wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps |
|
set script [string map [list <scopep> $scopepattern <rhs> $equalsrhs] { |
|
#script built by punk::match_assign |
|
if {[llength $args]} { |
|
#scan for existence of any pipe operator (|*> or <*|) only - we don't need position |
|
#all pipe operators must be a single element |
|
#we don't first check llength args == 1 because for example: |
|
# x= <| |
|
# x= |> |
|
#both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) |
|
foreach a $args { |
|
if {![catch {llength $a} sublen]} { |
|
#don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} |
|
if {[string match |*> $a] || [string match <*| $a]} { |
|
tailcall punk::pipeline = "<scopep>" "<rhs>" {*}$args |
|
} |
|
} |
|
} |
|
if {[llength $args] == 1} { |
|
set segmenttail [lindex $args 0] |
|
} else { |
|
error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign <scopep> <rhs> $args" [list pipedata segment too_many_elements segment_type =] |
|
} |
|
} else { |
|
#set segmenttail [purelist] |
|
set segmenttail [lreplace x 0 0] |
|
} |
|
}] |
|
|
|
|
|
|
|
|
|
if {[string length $equalsrhs]} { |
|
# as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. |
|
# review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. |
|
# We are probably only here if testing in the repl - in which case the error messages are important. |
|
set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] |
|
#we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" |
|
# x='ok'>0/0 data |
|
# => {ok data} |
|
# we won't examine for vars as there is no pipeline - ignore |
|
# also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) |
|
# we will differentiate between / and @ in the same way that general pattern matching works. |
|
# /x will simply call linsert without reference to length of list |
|
# @x will check for out of bounds |
|
# |
|
# !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? |
|
|
|
|
|
|
|
foreach v_pos $var_index_position_list { |
|
lassign $v_pos v indexspec positionspec |
|
#e.g =v1/1>0 A <v1| {X Y} |
|
#Here, we are not assigning to v1 - but matching the index spec /0 with the data from v1 |
|
#ie Y is inserted at position 0 to get A Y |
|
#(Note the difference from lhs) |
|
#on lhs v1/1= {X Y} |
|
#would pattern match against the *data* A B and set v1 to B |
|
|
|
#in this point of an assign (= as opposed to .=) IF we have already determined there is no trailing pipeline |
|
#There will therefore be no variable names active in the pipeline's scope. |
|
#This is ok, given that we can more easily inject directly from calling scope |
|
#eg out= list a $callervar c |
|
#or alternatively use .= instead |
|
# |
|
#HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments |
|
#At the moment - this is handled in the script above by diverting to punk::pipeline to handle |
|
#The only vars/data we can possibly have to insert, come from the <var,etc/0| spec and any trailing args into the pipeline |
|
#The rest of the pipeline can't affect what we have available to insert here - so this could (possibly?) be done - and then |
|
#call the pipeline recursively (because we need to return the entire pipeline result - even though we set our scopepattern vars only to what we have from the current segment) |
|
#difficulty is getting the result from this segment into the subsequent command. |
|
#we can't supply it as an argument to a .= function so we need a helper such as pipeline in any case. |
|
#This should be revisited when pipeline is potentially adjusted to be a coroutine style processor that yields results for the next command |
|
#(similar to >pattern predator system) |
|
# |
|
#todo - review |
|
# |
|
# |
|
#for now - the script only needs to handle the case of a single segment pipeline (no |> <|) |
|
|
|
|
|
#temp - needs_insertion |
|
#we can safely output no script for variable insertions for now - because if there was data available, |
|
#we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. |
|
#tag: positionspechandler |
|
if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { |
|
#(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense |
|
#- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" |
|
#review |
|
if {[string length $indexspec]} { |
|
error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] |
|
} |
|
if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { |
|
set datasource [string range $v 1 end-1] |
|
} elseif {[string is integer -strict $v]} { |
|
set datasource $v |
|
} |
|
append script [string map [list <value> $datasource] { |
|
set insertion_data "<value>" ;#atom could have whitespace |
|
}] |
|
|
|
set needs_insertion 1 |
|
} elseif {$v eq ""} { |
|
#default variable is 'data' |
|
set needs_insertion 0 |
|
} else { |
|
append script [string map [list <var> $v] { |
|
#uplevel? |
|
#set insertion_data [set <var>] |
|
}] |
|
set needs_insertion 0 |
|
} |
|
if {$needs_insertion} { |
|
set script2 [punk::list_insertion_script $positionspec segmenttail <data>] |
|
set script2 [string map [list <data> "\$insertion_data" ] $script2] |
|
append script $script2 |
|
} |
|
|
|
|
|
} |
|
|
|
|
|
} |
|
|
|
if {![string length $scopepattern]} { |
|
append script { |
|
return $segmenttail |
|
} |
|
} else { |
|
append script [string map [list <scopep> $scopepattern] { |
|
#we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail |
|
set d [punk::_multi_bind_result {<scopep>} $segmenttail] |
|
#return [punk::_handle_bind_result $d] |
|
#maintenance: inlined |
|
if {![dict exists $d result]} { |
|
#uplevel 1 [list error [dict get $d mismatch]] |
|
#error [dict get $d mismatch] |
|
return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] |
|
} else { |
|
return [dict get $d result] |
|
} |
|
}] |
|
} |
|
|
|
debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 |
|
uplevel 1 [list ::proc $pipecmd args $script] |
|
set existing_path [uplevel 1 [list ::namespace path]] |
|
if {$cmdns ni $existing_path} { |
|
uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] |
|
} |
|
tailcall $pipecmd {*}$args |
|
} |
|
|
|
#return a script for inserting data into listvar |
|
#review - needs updating for list-return semantics of patterns? |
|
proc list_insertion_script {keyspec listvar {data <data>}} { |
|
set positionspec [string trimright $keyspec "*"] |
|
set do_expand [expr {[string index $keyspec end] eq "*"}] |
|
if {$do_expand} { |
|
set exp {{*}} |
|
} else { |
|
set exp "" |
|
} |
|
#NOTE: linsert and lreplace can take multiple values at tail ie expanded data |
|
|
|
set ptype [string index $positionspec 0] |
|
if {$ptype in [list @ /]} { |
|
set index [string range $positionspec 1 end] |
|
} else { |
|
#the / is optional (default) at first position - and we have already discarded the ">" |
|
set ptype "/" |
|
set index $positionspec |
|
} |
|
#puts stderr ">> >> $index" |
|
set script "" |
|
set isint [string is integer -strict $index] |
|
if {$index eq "."} { |
|
#do nothing - this char signifies no insertion |
|
} elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { |
|
if {$ptype eq "@"} { |
|
#compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) |
|
if {$isint} { |
|
append script [string map [list <listvar> $listvar <idx> $index] { |
|
if {(<idx> > [llength $<listvar>])} { |
|
#not a pipesyntax error |
|
error "pipedata insertionpattern index out of bounds. index:<idx> vs len: [llength $<listvar>] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] |
|
} |
|
}] |
|
} |
|
#todo check end-x bounds? |
|
} |
|
if {$isint} { |
|
append script [string map [list <listvar> $listvar <idx> $index <exp> $exp <val> $data] { |
|
set <listvar> [linsert [lindex [list $<listvar> [unset <listvar>]] 0] <idx> <exp><val>] |
|
}] |
|
} else { |
|
append script [string map [list <listvar> $listvar <idx> $index <exp> $exp <val> $data] { |
|
#use inline K to make sure the list is unshared (optimize for larger lists) |
|
set <listvar> [linsert [lindex [list $<listvar> [unset <listvar>]] 0] <idx> <exp><val>] |
|
}] |
|
|
|
} |
|
} elseif {[string first / $index] < 0 && [string first - $index] > 0} { |
|
if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { |
|
#also - range checks for @ which must go into script !!! |
|
append script [string map [list <listvar> $listvar <start> $start <end> $end <exp> $exp <val> $data] { |
|
set <listvar> [lreplace [lindex [list $<listvar> [unset <listvar>]] 0] <start> <end> <exp><val>] |
|
}] |
|
} else { |
|
error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] |
|
} |
|
} elseif {[string first / $index] >= 0} { |
|
#nested insertion e.g /0/1/2 /0/1-1 |
|
set parts [split $index /] |
|
set last [lindex $parts end] |
|
if {[string first - $last] >=0} { |
|
lassign [split $last -] a b |
|
if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { |
|
error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] |
|
} |
|
if {$a eq $b} { |
|
if {!$do_expand} { |
|
#we can do an lset |
|
set lsetkeys [list {*}[lrange $parts 0 end-1] $a] |
|
append script [string map [list <listvar> $listvar <keys> $lsetkeys <val> $data] { |
|
lset <listvar> <keys> <val> |
|
}] |
|
} else { |
|
#we need to lreplace the containing item |
|
append script [string map [list <listvar> $listvar <containerkeys> [lrange $parts 0 end-1] <lastkey> $a <val> $data] { |
|
set target [lindex $<listvar> <containerkeys>] |
|
lset target <lastkey> {*}<val> |
|
lset <listvar> <containerkeys> $target |
|
}] |
|
} |
|
} else { |
|
#we need to lreplace a range at the target level |
|
append script [string map [list <listvar> $listvar <containerkeys> [lrange $parts 0 end-1] <start> $a <end> $b <exp> $exp <val> $data] { |
|
set target [lindex $<listvar> <containerkeys>] |
|
set target [lreplace $target <start> <end> <exp><val>] |
|
lset <listvar> <containerkeys> $target |
|
}] |
|
} |
|
} else { |
|
#last element has no -, so we are inserting at the final position - not replacing |
|
append script [string map [list <listvar> $listvar <containerkeys> [lrange $parts 0 end-1] <lastkey> $last <exp> $exp <val> $data] { |
|
set target [lindex $<listvar> <containerkeys>] |
|
set target [linsert $target <lastkey> <exp><val>] |
|
lset <listvar> <containerkeys> $target |
|
}] |
|
} |
|
|
|
|
|
} else { |
|
error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] |
|
} |
|
return $script |
|
} |
|
|
|
|
|
|
|
|
|
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 or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] |
|
} |
|
|
|
|
|
#NOTE: 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 |
|
#possibly also *_ for expanded _ ? |
|
#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 or from pipeline args <|) |
|
# |
|
#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 |
|
} |
|
|
|
|
|
# -- |
|
#consider possible tilde templating version ~= vs .= |
|
#support ~ and ~* placeholders only. |
|
#e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* |
|
#The ~ being mapped to $data in the pipeline. |
|
#This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. |
|
#possibility to mix as we can already with .= and = |
|
#e.g |
|
#x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max |
|
# -- |
|
proc pipeline {segment_op initial_returnvarspec equalsrhs args} { |
|
set fulltail $args |
|
#unset args ;#leave args in place for error diagnostics |
|
debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 |
|
#debug.punk.pipe.rep {[rep_listname fulltail]} 6 |
|
|
|
|
|
#--------------------------------------------------------------------- |
|
# test if we have an initial x.=y.= or x.= y.= |
|
|
|
#nextail is tail for possible recursion based on first argument in the segment |
|
#set nexttail [lassign $fulltail next1] ;#tail head |
|
|
|
set next1 [lindex $args 0] |
|
switch -- $next1 { |
|
pipematch { |
|
set nexttail [lrange $args 1 end] |
|
set results [uplevel 1 [list pipematch {*}$nexttail]] |
|
debug.punk.pipe {>>> pipematch results: $results} 1 |
|
|
|
set d [_multi_bind_result $initial_returnvarspec $results] |
|
return [_handle_bind_result $d] |
|
} |
|
pipecase { |
|
set msg "pipesyntax\n" |
|
append msg "pipecase does not return a value directly in the normal way\n" |
|
append msg "It will return a casemismatch dict on mismatch\n" |
|
append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" |
|
append msg "This 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 |
|
} |
|
} |
|
|
|
#temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. |
|
set ::_pipescript "" |
|
|
|
|
|
|
|
#NOTE: |
|
#important that for assignment: |
|
#= x=y .. |
|
#The second element is always treated as a raw value - not a pipeline instruction. |
|
#whereas... for execution: |
|
#.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. |
|
#Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - |
|
#- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway |
|
#This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines |
|
# |
|
if {$segment_op ne "="} { |
|
#handle for example: |
|
#var1.= var2= "etc" |> string toupper |
|
# |
|
#var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) |
|
# |
|
|
|
if {([set nexteposn [string last = $next1]] >= 0) && (![punk::pipe::lib::arg_is_script_shaped $next1]) } { |
|
set nexttail [lrange $args 1 end] |
|
#*SUB* pipeline recursion. |
|
#puts "======> recurse based on next1:$next1 " |
|
if {[string index $next1 $nexteposn-1] eq {.}} { |
|
#var1.= var2.= ... |
|
#non pipelined call to self - return result |
|
set results [uplevel 1 [list $next1 {*}$nexttail]] |
|
#debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 |
|
#debug.punk.pipe {>>> results: $results} 1 |
|
return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] |
|
} |
|
#puts "======> recurse assign based on next1:$next1 " |
|
#if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { |
|
#} |
|
#non pipelined call to plain = assignment - return result |
|
set results [uplevel 1 [list $next1 {*}$nexttail]] |
|
#debug.punk.pipe {>>> results: $results} 1 |
|
set d [_multi_bind_result $initial_returnvarspec $results] |
|
return [_handle_bind_result $d] |
|
} |
|
} |
|
|
|
set procname $initial_returnvarspec.=$equalsrhs |
|
|
|
#--------------------------------------------------------------------- |
|
|
|
#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 |
|
#Take the *first* <| we encounter as a distince list element. (not that this doesn't prevent the existence of sub-pipelines containing <|) |
|
# |
|
# |
|
# |
|
|
|
set firstargpipe_posn [lsearch $fulltail "<*|"] |
|
if {$firstargpipe_posn >=0} { |
|
set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] |
|
set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. |
|
set argpipe [lindex $fulltail $firstargpipe_posn] |
|
set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from "<x,etc|" |
|
} else { |
|
set tailremaining $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 |
|
debug.punk.pipe {initial list (excluding argpipespec <$argpipespec| ): $tailremaining} 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 $equalsrhs |
|
|
|
set segment_first_is_script 0 ;#default assumption until tested |
|
|
|
set segment_first_word [lindex $segment_members 0] |
|
if {$segment_op ne "="} { |
|
if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { |
|
set segment_first_is_script 1 |
|
} |
|
} else { |
|
if {[llength $segment_members] > 1} { |
|
error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] |
|
#proc pipeline {segment_op initial_returnvarspec equalsrhs args} |
|
} |
|
set segment_members $segment_first_word |
|
} |
|
|
|
|
|
|
|
#tailremaining includes x=y during the loop. |
|
set returnvarspec $initial_returnvarspec |
|
if {![llength $argslist]} { |
|
unset -nocomplain 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_first_is_script:$segment_first_is_script} 4 |
|
if {$segment_first_is_script} { |
|
debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 |
|
} |
|
|
|
|
|
|
|
#examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position |
|
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] |
|
#temp debug |
|
#if {[dict exists $d result]} { |
|
#set jjj [dict get $d result] |
|
#puts "!!!!! [rep $jjj]" |
|
#} |
|
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 |
|
debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} |
|
|
|
|
|
if {$i == $max_iterations} { |
|
puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" |
|
set more_pipe_segments 0 |
|
} |
|
|
|
set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* |
|
set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] |
|
#if {$segment_has_insertions} { |
|
# puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" |
|
#} |
|
|
|
debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 |
|
debug.punk.pipe.rep {[rep_listname segment_members]} 4 |
|
|
|
|
|
|
|
|
|
#whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) |
|
#pipedvars comes from either previous segment |>, or <| args |
|
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 {vname val} $pipedvars { |
|
#add additionally specified vars and allow overriding of %args% and %data% by not setting them here |
|
if {$vname eq "data"} { |
|
#already potentially overridden |
|
continue |
|
} |
|
dict set dict_tagval $vname $val |
|
} |
|
|
|
#todo! |
|
#segment_script - not in use yet. |
|
#will require non-iterative pipeline processor to use ... recursive.. or coroutine based |
|
set script "" |
|
|
|
if {!$segment_has_insertions} { |
|
#debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 |
|
#add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) |
|
#set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists |
|
#insertion-specs with a trailing * can be used to insert data in args format |
|
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 {processing insertion_pattern dict_tagval: $dict_tagval} 4 |
|
set segment_members_filled [list] |
|
set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign |
|
|
|
set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] |
|
set cmdname "::punk::pipecmds::insertion::_$rhsmapped" |
|
#glob chars have been mapped - so we can test by comparing info commands result to empty string |
|
if {[info commands $cmdname] eq ""} { |
|
|
|
set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" |
|
foreach v_pos $insertion_patterns { |
|
#puts stdout "v_pos '$v_pos'" |
|
lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) |
|
#puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" |
|
#julz |
|
|
|
append insertion_script \n [string map [list <v_pos> $v_pos] { |
|
lassign [list <v_pos>] v indexspec positionspec |
|
}] |
|
|
|
if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { |
|
set v [string range $v 1 end-1] ;#assume trailing ' is present! |
|
if {[string length $indexspec]} { |
|
error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] |
|
} |
|
append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) |
|
} elseif {[string is double -strict $v]} { |
|
#don't treat numbers as variables |
|
if {[string length $indexspec]} { |
|
error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] |
|
} |
|
append insertion_script \n {set insertion_data $v} |
|
} else { |
|
#todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls |
|
append insertion_script \n [string map [list <cmdname> $cmdname] { |
|
#puts ">>> v: $v dict_tagval:'$dict_tagval'" |
|
if {$v eq ""} { |
|
set v "data" |
|
} |
|
if {[dict exists $dict_tagval $v]} { |
|
set insertion_data [dict get $dict_tagval $v] |
|
#todo - use destructure_func |
|
set d [punk::_multi_bind_result $indexspec $insertion_data] |
|
set insertion_data [punk::_handle_bind_result $d] |
|
} else { |
|
#review - skip error if varname is 'data' ? |
|
#e.g we shouldn't really fail for: |
|
#.=>* list a b c <| |
|
#??? Technically |
|
#we need to be careful not to insert empty-list as an argument by default |
|
error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" "<cmdname> pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] |
|
} |
|
|
|
}] |
|
} |
|
|
|
|
|
|
|
|
|
#append script [string map [list <v> $getv]{ |
|
# |
|
#}] |
|
#maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) |
|
#tag: positionspechandler |
|
|
|
|
|
#puts stdout "=== list_insertion_script '$positionspec' segmenttail <data>" |
|
set script2 [punk::list_insertion_script $positionspec segmenttail <data>] |
|
set script2 [string map [list <data> "\$insertion_data" ] $script2] |
|
append insertion_script \n $script2 |
|
|
|
} |
|
append insertion_script \n {set segmenttail} |
|
append insertion_script \n "}" |
|
#puts stderr "$insertion_script" |
|
debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 |
|
eval $insertion_script |
|
} |
|
|
|
set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] |
|
|
|
#set segment_members_filled $segmenttail |
|
#note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) |
|
|
|
} |
|
set rhs [string map $dict_tagval $rhs] ;#obsolete? |
|
|
|
debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 |
|
|
|
|
|
# script index could have changed!!! todo fix! |
|
|
|
#we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) |
|
if {(!$segment_first_is_script ) && $segment_op eq ".="} { |
|
#no scriptiness detected |
|
|
|
#debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 |
|
|
|
set cmdlist_result [uplevel 1 $segment_members_filled] |
|
#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 d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] |
|
|
|
set segment_result [_handle_bind_result $d] |
|
#puts stderr ">>forward_result: $forward_result segment_result $segment_result" |
|
|
|
|
|
} elseif {$segment_op eq "="} { |
|
#slightly different semantics for assigment! |
|
#We index into the DATA - not the position within the segment! |
|
#(an = segment must take a single argument, as opposed to a .= segment) |
|
#(This was a deliberate design choice for consistency with set, and to reduce errors.) |
|
#(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) |
|
#(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) |
|
# |
|
#we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data |
|
#v= {a b c} |> = |
|
# must return: {a b c} not a b c |
|
# |
|
if {!$segment_has_insertions} { |
|
set segment_members_filled $segment_members |
|
if {[dict exists $dict_tagval data]} { |
|
if {![llength $segment_members_filled]} { |
|
set segment_members_filled [dict get $dict_tagval data] |
|
} else { |
|
lappend segment_members_filled [dict get $dict_tagval data] |
|
} |
|
} |
|
} |
|
|
|
set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] |
|
set segment_result [_handle_bind_result $d] |
|
|
|
|
|
} elseif {$segment_first_is_script || $segment_op eq "script"} { |
|
#script |
|
debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 |
|
|
|
set script [lindex $segment_members 0] |
|
|
|
#build argument lists for 'apply' |
|
set segmentargnames [list] |
|
set segmentargvals [list] |
|
foreach {k val} $dict_tagval { |
|
if {$k eq "args"} { |
|
#skip args - it is manually added at the end of the apply list if it's a valid tcl list |
|
continue |
|
} |
|
lappend segmentargnames $k |
|
lappend segmentargvals $val |
|
} |
|
|
|
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 |
|
#puts "------> rep prevr argsdatalist: [rep $argsdatalist]" |
|
set add_argsdata 0 |
|
if {[dict exists $dict_tagval "args"]} { |
|
set argsdatalist [dict get $dict_tagval "args"] |
|
#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 args read punk::pipeline_args_read_trace_error\n" |
|
set script $pre_script |
|
append script $segment_first_word |
|
set add_argsdata 0 |
|
} else { |
|
set add_argsdata 1 |
|
} |
|
} |
|
|
|
debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 |
|
set ns [uplevel 1 {::namespace current}] |
|
if {!$add_argsdata} { |
|
debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 |
|
#puts stderr " script: $script" |
|
#puts stderr " vals: $segmentargvals" |
|
set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] |
|
} else { |
|
debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 |
|
#puts stderr " script: $script" |
|
#puts stderr " vals: $segmentargvals $argsdatalist" |
|
#pipeline script context should be one below calling context - so upvar v v will work |
|
#ns with leading colon will fail with apply |
|
set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] |
|
} |
|
|
|
debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 |
|
#puts "---> rep script evaluation result: [rep $evaluation]" |
|
#set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] |
|
|
|
#trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! |
|
set tail_scripts [lrange $segment_members 1 end] |
|
if {[llength $tail_scripts]} { |
|
set r [pipedata $evaluation {*}$tail_scripts] |
|
} else { |
|
set r $evaluation |
|
} |
|
set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] |
|
set segment_result [_handle_bind_result $d] |
|
} else { |
|
#tags ? |
|
#debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 |
|
if {false} { |
|
#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 $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 $segment_members $pscript] |
|
|
|
} |
|
} |
|
|
|
set cmdlist_result [uplevel 1 $segment_members_filled] |
|
#set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] |
|
set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] |
|
|
|
#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 segment_result [_handle_bind_result $d] |
|
} |
|
#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" |
|
|
|
debug.punk.pipe.rep {[rep_listname segment_result]} 3 |
|
|
|
|
|
|
|
|
|
|
|
#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 script_like_first_word 0 |
|
if {[llength $tailremaining] || $next_pipe_posn >= 0} { |
|
|
|
if {$next_pipe_posn >=0} { |
|
set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for |
|
set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] |
|
|
|
} else { |
|
set next_all_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 "" |
|
set segment_first_is_script 0 |
|
if {[llength $next_all_members]} { |
|
if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { |
|
set segment_first_word [lindex $next_all_members 0] |
|
set segment_first_is_script 1 |
|
set segment_op "" |
|
set segment_members $next_all_members |
|
} else { |
|
set possible_assignment [lindex $next_all_members 0] |
|
#set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} |
|
if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { |
|
set segment_op ".=" |
|
set segment_first_word [lindex $next_all_members 1] |
|
set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] |
|
if {$script_like_first_word} { |
|
set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= |
|
} |
|
set segment_members [lrange $next_all_members 1 end] |
|
} elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { |
|
set segment_op "=" |
|
#never scripts |
|
#must be at most a single element after the = ! |
|
if {[llength $next_all_members] > 2} { |
|
#raise this as pipesyntax as opposed to pipedata? |
|
error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] |
|
} |
|
set segment_first_word [lindex $next_all_members 1] |
|
if {[catch {llength $segment_first_word}]} { |
|
set segment_is_list 0 ;#only used for segment_op = |
|
} else { |
|
set segment_is_list 1 ;#only used for segment_op = |
|
} |
|
|
|
set segment_members $segment_first_word |
|
} else { |
|
#no assignment operator and not script shaped |
|
set segment_op "" |
|
set returnvarspec "" |
|
set segment_first_word [lindex $next_all_members 0] |
|
set segment_first_word [lindex $next_all_members 1] |
|
set segment_members $next_all_members |
|
#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 |
|
#JMN2 |
|
set previous_result $segment_result |
|
#set previous_result [join $segment_result] |
|
} else { |
|
debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 |
|
#output pipe spec at tail of pipeline |
|
|
|
set pipedvars [dict create] |
|
if {[string length $pipespec($i,out)]} { |
|
set d [apply {{mv res} { |
|
punk::_multi_bind_result $mv $res -levelup 1 |
|
}} $pipespec($i,out) $segment_result] |
|
set segment_result [_handle_bind_result $d] |
|
set pipedvars [dict get $d setvars] |
|
} |
|
|
|
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 |
|
#JMN2 |
|
#lappend segment_result_list [join $segment_result] |
|
lappend segment_result_list $segment_result |
|
incr i |
|
incr j |
|
} ;# end while |
|
|
|
return [lindex $segment_result_list end] |
|
#JMN2 |
|
#return $segment_result_list |
|
#return $forward_result |
|
} |
|
|
|
|
|
#just an experiment |
|
#what advantage/difference versus [llength [lrange $data $start $end]] ??? |
|
proc data_range_length {data start end} { |
|
set datalen [llength $data] |
|
|
|
#normalize to s and e |
|
if {$start eq "end"} { |
|
set s [expr {$datalen - 1}] |
|
} elseif {[string match end-* $start]} { |
|
set stail [string range $start 4 end] |
|
set posn [expr {$datalen - $stail -1}] |
|
if {$posn < 0} { |
|
return 0 |
|
} |
|
set s $posn |
|
} else { |
|
#int |
|
if {($start < 0) || ($start > ($datalen -1))} { |
|
return 0 |
|
} |
|
set s $start |
|
} |
|
if {$end eq "end"} { |
|
set e [expr {$datalen - 1}] |
|
} elseif {[string match end-* $end]} { |
|
set etail [string range $end 4 end] |
|
set posn [expr {$datalen - $etail -1}] |
|
if {$posn < 0} { |
|
return 0 |
|
} |
|
set e $posn |
|
} else { |
|
#int |
|
if {($end < 0)} { |
|
return 0 |
|
} |
|
set e $end |
|
} |
|
if {$s > ($datalen -1)} { |
|
return 0 |
|
} |
|
if {$e > ($datalen -1)} { |
|
set e [expr {$datalen -1}] |
|
} |
|
|
|
|
|
|
|
if {$e < $s} { |
|
return 0 |
|
} |
|
|
|
return [expr {$e - $s + 1}] |
|
} |
|
|
|
# unknown -- |
|
# This procedure is called when a Tcl command is invoked that doesn't |
|
# exist in the interpreter. It takes the following steps to make the |
|
# command available: |
|
# |
|
# 1. See if the autoload facility can locate the command in a |
|
# Tcl script file. If so, load it and execute it. |
|
# 2. If the command was invoked interactively at top-level: |
|
# (a) see if the command exists as an executable UNIX program. |
|
# If so, "exec" the command. |
|
# (b) see if the command requests csh-like history substitution |
|
# in one of the common forms !!, !<number>, or ^old^new. If |
|
# so, emulate csh's history substitution. |
|
# (c) see if the command is a unique abbreviation for another |
|
# command. If so, invoke the command. |
|
# |
|
# Arguments: |
|
# args - A list whose elements are the words of the original |
|
# command, including the command name. |
|
|
|
#review - we shouldn't really be doing this |
|
#We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one |
|
|
|
proc ::unknown args { |
|
#puts stderr "unk>$args" |
|
variable ::tcl::UnknownPending |
|
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode |
|
|
|
if {[info exists errorInfo]} { |
|
set savedErrorInfo $errorInfo |
|
} |
|
if {[info exists errorCode]} { |
|
set savedErrorCode $errorCode |
|
} |
|
|
|
set name [lindex $args 0] |
|
if {![info exists auto_noload]} { |
|
# |
|
# Make sure we're not trying to load the same proc twice. |
|
# |
|
if {[info exists UnknownPending($name)]} { |
|
return -code error "self-referential recursion\ |
|
in \"unknown\" for command \"$name\"" |
|
} |
|
set UnknownPending($name) pending |
|
set ret [catch { |
|
auto_load $name [uplevel 1 {::namespace current}] |
|
} msg opts] |
|
unset UnknownPending($name) |
|
if {$ret != 0} { |
|
dict append opts -errorinfo "\n (autoloading \"$name\")" |
|
return -options $opts $msg |
|
} |
|
if {![array size UnknownPending]} { |
|
unset UnknownPending |
|
} |
|
if {$msg} { |
|
if {[info exists savedErrorCode]} { |
|
set ::errorCode $savedErrorCode |
|
} else { |
|
unset -nocomplain ::errorCode |
|
} |
|
if {[info exists savedErrorInfo]} { |
|
set errorInfo $savedErrorInfo |
|
} else { |
|
unset -nocomplain errorInfo |
|
} |
|
set code [catch {uplevel 1 $args} msg opts] |
|
if {$code == 1} { |
|
# |
|
# Compute stack trace contribution from the [uplevel]. |
|
# Note the dependence on how Tcl_AddErrorInfo, etc. |
|
# construct the stack trace. |
|
# |
|
set errInfo [dict get $opts -errorinfo] |
|
set errCode [dict get $opts -errorcode] |
|
set cinfo $args |
|
if {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
|
set cinfo [string range $cinfo 0 150] |
|
while {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
|
set cinfo [string range $cinfo 0 end-1] |
|
} |
|
append cinfo ... |
|
} |
|
set tail "\n (\"uplevel\" body line 1)\n invoked\ |
|
from within\n\"uplevel 1 \$args\"" |
|
set expect "$msg\n while executing\n\"$cinfo\"$tail" |
|
if {$errInfo eq $expect} { |
|
# |
|
# The stack has only the eval from the expanded command |
|
# Do not generate any stack trace here. |
|
# |
|
dict unset opts -errorinfo |
|
dict incr opts -level |
|
return -options $opts $msg |
|
} |
|
# |
|
# Stack trace is nested, trim off just the contribution |
|
# from the extra "eval" of $args due to the "catch" above. |
|
# |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] != [string length $errInfo]} { |
|
# Very likely cannot happen |
|
return -options $opts $msg |
|
} |
|
set errInfo [string range $errInfo 0 $last-1] |
|
set tail "\"$cinfo\"" |
|
set last [string last $tail $errInfo] |
|
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo $errInfo $msg |
|
} |
|
set errInfo [string range $errInfo 0 $last-1] |
|
set tail "\n invoked from within\n" |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] == [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo [string range $errInfo 0 $last-1] $msg |
|
} |
|
set tail "\n while executing\n" |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] == [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo [string range $errInfo 0 $last-1] $msg |
|
} |
|
return -options $opts $msg |
|
} else { |
|
dict incr opts -level |
|
return -options $opts $msg |
|
} |
|
} |
|
} |
|
#set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] |
|
set isrepl [punk::repl::codethread::is_running] ;#may not be reading though |
|
if {$isrepl} { |
|
#set ::tcl_interactive 1 |
|
} |
|
if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) |
|
&& ([info exists tcl_interactive] && $tcl_interactive))} { |
|
if {![info exists auto_noexec]} { |
|
set new [auto_execok $name] |
|
if {$new ne ""} { |
|
set redir "" |
|
if {[namespace which -command console] eq ""} { |
|
set redir ">&@stdout <@stdin" |
|
} |
|
|
|
|
|
#windows experiment todo - use twapi and named pipes |
|
#twapi::namedpipe_server {\\.\pipe\something} |
|
#Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones |
|
#These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc |
|
# |
|
|
|
if {[string first " " $new] > 0} { |
|
set c1 $name |
|
} else { |
|
set c1 $new |
|
} |
|
|
|
# -- --- --- --- --- |
|
set idlist_stdout [list] |
|
set idlist_stderr [list] |
|
#set shellrun::runout "" |
|
#when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks |
|
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
#lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
|
|
|
if {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} { |
|
#TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it |
|
#not a trivial task |
|
|
|
#This runs external executables in a context in which they are not attached to a terminal |
|
#VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output |
|
#ctrl-c propagation also needs to be considered |
|
|
|
set teehandle punksh |
|
uplevel 1 [list ::catch \ |
|
[list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
|
|
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { |
|
dict set ::tcl::UnknownOptions -code error |
|
set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" |
|
} else { |
|
#no point returning "exitcode 0" if that's the only non-error return. |
|
#It is misleading. Better to return empty string. |
|
set ::tcl::UnknownResult "" |
|
} |
|
} else { |
|
set repl_runid [punk::get_repl_runid] |
|
#set ::punk::last_run_display [list] |
|
|
|
set redir ">&@stdout <@stdin" |
|
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] |
|
#we can't detect stdout/stderr output from the exec |
|
#for now emit an extra \n on stderr |
|
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
|
#This is probably a tricky problem - especially to do cross-platform |
|
# |
|
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
|
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
|
set c green |
|
set m "ok" |
|
} else { |
|
set c yellow |
|
set m "errorCode $::errorCode" |
|
} |
|
set chunklist [list] |
|
lappend chunklist [list "info" "[a $c]$m[a] " ] |
|
if {$repl_runid != 0} { |
|
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
|
} |
|
|
|
} |
|
|
|
foreach id $idlist_stdout { |
|
shellfilter::stack::remove stdout $id |
|
} |
|
foreach id $idlist_stderr { |
|
shellfilter::stack::remove stderr $id |
|
} |
|
# -- --- --- --- --- |
|
|
|
|
|
#uplevel 1 [list ::catch \ |
|
# [concat exec $redir $new [lrange $args 1 end]] \ |
|
# ::tcl::UnknownResult ::tcl::UnknownOptions] |
|
|
|
#puts "===exec with redir:$redir $::tcl::UnknownResult ==" |
|
dict incr ::tcl::UnknownOptions -level |
|
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
|
} |
|
} |
|
|
|
if {$name eq "!!"} { |
|
set newcmd [history event] |
|
} elseif {[regexp {^!(.+)$} $name -> event]} { |
|
set newcmd [history event $event] |
|
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { |
|
set newcmd [history event -1] |
|
catch {regsub -all -- $old $newcmd $new newcmd} |
|
} |
|
if {[info exists newcmd]} { |
|
tclLog $newcmd |
|
history change $newcmd 0 |
|
uplevel 1 [list ::catch $newcmd \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
dict incr ::tcl::UnknownOptions -level |
|
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
|
} |
|
|
|
set ret [catch {set candidates [info commands $name*]} msg] |
|
if {$name eq "::"} { |
|
set name "" |
|
} |
|
if {$ret != 0} { |
|
dict append opts -errorinfo \ |
|
"\n (expanding command prefix \"$name\" in unknown)" |
|
return -options $opts $msg |
|
} |
|
# Filter out bogus matches when $name contained |
|
# a glob-special char [Bug 946952] |
|
if {$name eq ""} { |
|
# Handle empty $name separately due to strangeness |
|
# in [string first] (See RFE 1243354) |
|
set cmds $candidates |
|
} else { |
|
set cmds [list] |
|
foreach x $candidates { |
|
if {[string first $name $x] == 0} { |
|
lappend cmds $x |
|
} |
|
} |
|
} |
|
|
|
#punk - disable prefix match search |
|
set default_cmd_search 0 |
|
if {$default_cmd_search} { |
|
if {[llength $cmds] == 1} { |
|
uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
dict incr ::tcl::UnknownOptions -level |
|
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
|
} |
|
if {[llength $cmds]} { |
|
return -code error "ambiguous command name \"$name\": [lsort $cmds]" |
|
} |
|
} else { |
|
#punk hacked version - report matches but don't run |
|
if {[llength $cmds]} { |
|
return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" |
|
} |
|
|
|
} |
|
|
|
|
|
} |
|
return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" |
|
} |
|
|
|
proc know {cond body} { |
|
set existing [info body ::unknown] |
|
#assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) |
|
##This means we can't have 2 different conds with same body if we test for body in unknown. |
|
##if {$body ni $existing} { |
|
set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered |
|
#tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. |
|
|
|
#tclint-disable-next-line |
|
proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { |
|
#--------------------------------------- |
|
if {![catch {expr {@c@}} res] && $res} { |
|
debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 |
|
return [eval {@b@}] |
|
} else { |
|
debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 |
|
} |
|
#--------------------------------------- |
|
}]$existing |
|
#} |
|
} |
|
|
|
proc know? {{len 2000}} { |
|
puts [string range [info body ::unknown] 0 $len] |
|
} |
|
proc decodescript {b64} { |
|
if {[ catch { |
|
base64::decode $b64 |
|
} scr]} { |
|
return "<couldn't decode cond script>" |
|
} else { |
|
return "($scr)" |
|
} |
|
} |
|
|
|
# --------------------------- |
|
# commands that should be aliased in safe interps that need to use punk repl |
|
# |
|
proc get_repl_runid {} { |
|
if {[interp issafe]} { |
|
if {[info commands ::tsv::exists] eq ""} { |
|
puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" |
|
error "punk::get_repl_runid punk repl aliases not installed" |
|
} |
|
#if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands |
|
} |
|
if {[tsv::exists repl runid]} { |
|
return [tsv::get repl runid] |
|
} else { |
|
return 0 |
|
} |
|
} |
|
#ensure we don't get into loop in unknown when in safe interp - which won't have tsv |
|
proc set_repl_last_unknown {args} { |
|
if {[interp issafe]} { |
|
if {[info commands ::tsv::set] eq ""} { |
|
puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" |
|
return |
|
} |
|
#tsv::* somehow working - possibly custom aliases for tsv functionality ? review |
|
} |
|
if {[info commands ::tsv::set] eq ""} { |
|
puts stderr "set_repl_last_unknown - tsv unavailable!" |
|
return |
|
} |
|
tsv::set repl last_unknown {*}$args |
|
} |
|
# --------------------------- |
|
|
|
#---------------- |
|
#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 |
|
|
|
proc ::punk::val [list [list v [purelist]]] {return $v} |
|
#---------------- |
|
|
|
proc configure_unknown {} { |
|
#----------------------------- |
|
#these are critical e.g core behaviour or important for repl displaying output correctly |
|
|
|
|
|
#can't use know - because we don't want to return before original unknown body is called. |
|
proc ::unknown {args} [string cat { |
|
#set ::punk::last_run_display [list] |
|
#set ::repl::last_unknown [lindex $args 0] ;#jn |
|
#tsv::set repl last_unknown [lindex $args 0] ;#REVIEW |
|
punk::set_repl_last_unknown [lindex $args 0] |
|
}][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.. |
|
|
|
#todo - repl output info that it was evaluated as an expression |
|
#know {[expr $args] || 1} {expr $args} |
|
know {[expr $args] || 1} {tailcall expr $args} |
|
|
|
#it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc |
|
#punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) |
|
know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} |
|
|
|
|
|
#NOTE: |
|
#we don't allow setting namespace qualified vars in the lhs assignment pattern. |
|
#The principle is that we shouldn't be setting vars outside of the immediate calling scope. |
|
#(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) |
|
#Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever |
|
#We will require that the namespace already exists - which is consistent with if the command were to be run without unknown |
|
proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { |
|
set tail [lassign $args hd] |
|
#puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" |
|
if {$hd ne $matchedon} { |
|
if {[llength $tail]} { |
|
error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" |
|
} |
|
#regexp $punk::re_assign $hd _ pattern equalsrhs |
|
#we assume the whole pipeline has been provided as the head |
|
#regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail |
|
regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs |
|
lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail |
|
} |
|
#NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah |
|
# we only look at leftmost namespace-like thing and need to take account of the pattern syntax |
|
# e.g for ::etc,'::x'= |
|
# the ns is :: and the tail is etc,'::x'= |
|
# (Tcl's namespace qualifiers/tail won't help here) |
|
if {[string match ::* $hd]} { |
|
set patterns [punk::pipe::lib::_split_patterns_memoized $hd] |
|
#get a pair-list something like: {::x /0} {etc {}} |
|
set ns [namespace qualifiers [lindex $patterns 0 0]] |
|
set nslen [string length $ns] |
|
set patterntail [string range $ns $nslen end] |
|
} else { |
|
set ns "" |
|
set patterntail $pattern |
|
} |
|
if {[string length $ns] && ![namespace exists $ns]} { |
|
error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" |
|
} else { |
|
set nscaller [uplevel 1 [list ::namespace current]] |
|
#jmn |
|
set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] |
|
set commands [uplevel 1 [list ::info commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk |
|
#we must check for exact match of the command in the list - because command could have glob chars. |
|
if {"$pattern=$rhsmapped" in $commands} { |
|
puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" |
|
#we call the namespaced function - we don't evaluate it *in* the namespace. |
|
#REVIEW |
|
#warn for now...? |
|
#tailcall $pattern=$equalsrhs {*}$args |
|
tailcall $pattern=$rhsmapped {*}$tail |
|
} |
|
} |
|
#puts "--->nscurrent [uplevel 1 [list ::namespace current]]" |
|
#ignore the namespace.. |
|
#We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. |
|
#But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. |
|
#namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created |
|
tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail |
|
#return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] |
|
} |
|
#variable re_assign {^([^\r\n=\{]*)=(.*)} |
|
#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 |
|
# |
|
#know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} |
|
#know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} |
|
|
|
|
|
|
|
proc ::punk::_unknown_compare {val1 val2 args} { |
|
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}] |
|
} |
|
} |
|
} |
|
#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]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} |
|
#.= 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]] |
|
# } |
|
# |
|
|
|
|
|
|
|
proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { |
|
#puts stderr ". unknown dispatch $partzerozero" |
|
set argstail [lassign $args hd] |
|
|
|
#this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. |
|
#we should require explicit {*} expansion if the intention is for the args to be joined in at that level. |
|
#expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } |
|
|
|
if {$hd ne $partzerozero} { |
|
if {[llength $argstail]} { |
|
error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" |
|
} |
|
#regexp $punk::re_assign $hd _ pattern equalsrhs |
|
#we assume the whole pipeline has been provided as the head |
|
#regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail |
|
#regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail |
|
|
|
regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs |
|
lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail |
|
} |
|
#tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail |
|
|
|
|
|
return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] |
|
|
|
} |
|
|
|
# |
|
know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} |
|
know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} |
|
|
|
#variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} |
|
#know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} |
|
#know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} |
|
#know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} |
|
#know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} |
|
know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} |
|
|
|
#add escaping backslashes to a value |
|
#matching odd keys in dicts using pipeline syntax can be tricky - as |
|
#e.g |
|
#set ktest {a"b} |
|
#@@[escv $ktest].= list a"b val |
|
#without escv: |
|
#@@"a\\"b".= list a"b val |
|
#with more backslashes in keys the escv use becomes more apparent: |
|
#set ktest {\\x} |
|
#@@[escv $ktest].= list $ktest val |
|
#without escv we would need: |
|
#@@\\\\\\\\x.= list $ktest val |
|
proc escv {v} { |
|
#https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically |
|
#thanks to DKF |
|
regsub -all {\W} $v {\\&} |
|
} |
|
interp alias {} escv {} punk::escv |
|
#review |
|
#set v "\u2767" |
|
#<char> |
|
#escv $v |
|
#\<char> |
|
#the |
|
|
|
|
|
#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]] |
|
#} |
|
|
|
} |
|
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 ".="} { |
|
tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] |
|
} |
|
|
|
set is_script [punk::pipe::lib::arg_is_script_shaped $assign] |
|
|
|
if {!$is_script && [string index $assign end] eq "="} { |
|
#set re_dotequals {^([^ \t\r\n=\{]*)\.=$} |
|
#set dumbeditor {\}} |
|
#set re_equals {^([^ \t\r\n=\{]*)=$} |
|
#set dumbeditor {\}} |
|
if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] |
|
} elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] |
|
} else { |
|
error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] |
|
} |
|
} else { |
|
if {$is_script} { |
|
set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] |
|
} else { |
|
set cmdlist [list ::punk::pipeline ".=" "" "" {*}$args] |
|
} |
|
} |
|
tailcall {*}$cmdlist |
|
|
|
|
|
#result-based mismatch detection can probably never work nicely.. |
|
#we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! |
|
# |
|
set result [uplevel 1 $cmdlist] |
|
#pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' |
|
#.. but if we use certain string methods - we shimmer the case where the main result is a list |
|
#string match doesn't seem to change the rep.. though it does generate a string rep. |
|
#puts >>1>[rep $result] |
|
if {[catch {lrange $result 0 1} first2wordsorless]} { |
|
#if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' |
|
return $result |
|
} else { |
|
if {$first2wordsorless eq {binding mismatch}} { |
|
error $result |
|
} else { |
|
#puts >>2>[rep $result] |
|
return $result |
|
} |
|
} |
|
} |
|
|
|
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::pipeline .= "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] |
|
} elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { |
|
#set re_dotequals {^([^ \t\r\n=\{]*)\.=$} |
|
# set dumbeditor {\}} |
|
#set re_equals {^([^ \t\r\n=\{]*)=$} |
|
# set dumbeditor {\}} |
|
if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] |
|
} elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { |
|
set cmdlist [list $assign {*}$arglist] |
|
#set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] |
|
} else { |
|
error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] |
|
} |
|
} else { |
|
set cmdlist $args |
|
#script? |
|
#set cmdlist [list ::punk::pipeline .= "" "" {*}$args] |
|
} |
|
|
|
if {[catch {uplevel 1 $cmdlist} result erroptions]} { |
|
#puts stderr "pipematch erroptions:$erroptions" |
|
#debug.punk.pipe {pipematch error $result} 4 |
|
set ecode [dict get $erroptions -errorcode] |
|
switch -- [lindex $ecode 0] { |
|
binding { |
|
if {[lindex $ecode 1] eq "mismatch"} { |
|
#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]] |
|
#puts stderr "pipematch converting error to {error {mismatch <result>}}" |
|
return [list error [list mismatch $result]] |
|
} |
|
} |
|
pipesyntax { |
|
#error $result |
|
return -options $erroptions $result |
|
} |
|
casematch { |
|
return $result |
|
} |
|
} |
|
#return [dict create error [dict create reason $result]] |
|
return [list error [list reason $result]] |
|
} else { |
|
return [list ok [list result $result]] |
|
#debug.punk.pipe {pipematch result $result } 4 |
|
#return [dict create ok [dict create 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" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] |
|
} |
|
#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::pipeline .= "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] |
|
} elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] |
|
} elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { |
|
set cmdlist [list ::punk::pipeline = $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 erroptions]} { |
|
set ecode [dict get $erroptions -errorcode] |
|
debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 |
|
if {[lindex $ecode 0] eq "pipesyntax"} { |
|
set errordict [dict create error [dict create pipesyntax $result]] |
|
set nomatchvar $errordict |
|
return -options $erroptions $result |
|
} |
|
if {[lrange $ecode 0 1] eq "binding mismatch"} { |
|
#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 |
|
return -options $erroptions $result |
|
} |
|
set errordict [dict create error [dict create reason $result]] |
|
set nomatchvar $errordict |
|
#re-raise the error for pipeswitch to deal with |
|
return -options $erroptions $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::pipeline .= "" "" {*}$arglist] |
|
} elseif {$assign eq "="} { |
|
#set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] |
|
set cmdlist [list ::= {*}$arglist] |
|
} elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { |
|
#set re_dotequals {^([^ \t\r\n=\{]*)\.=$} |
|
#set dumbeditor {\}} |
|
#set re_equals {^([^ \t\r\n=\{]*)=$} |
|
#set dumbeditor {\}} |
|
|
|
if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { |
|
set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] |
|
} elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { |
|
set cmdlist [list $assign {*}$arglist] |
|
#set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] |
|
} else { |
|
error "pipesyntax pipecase unable to interpret pipeline '$args'" |
|
} |
|
#todo - account for insertion-specs e.g x=* x.=/0* |
|
} else { |
|
#script? |
|
set cmdlist [list ::punk::pipeline .= "" "" {*}$args] |
|
} |
|
|
|
|
|
if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { |
|
#puts stderr "====>>> result: $result erroptions" |
|
set ecode [dict get $erroptions -errorcode] |
|
switch -- [lindex $ecode 0] { |
|
pipesyntax { |
|
#error $result |
|
return -options $erroptions $result |
|
} |
|
casenomatch { |
|
return -options $erroptions $result |
|
} |
|
binding { |
|
if {[lindex $ecode 1] eq "mismatch"} { |
|
#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]] |
|
# |
|
#NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) |
|
return [dict create casemismatch $result] |
|
} |
|
} |
|
} |
|
|
|
#we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode |
|
#todo - use errorCode instead |
|
if {[catch {lindex $result 0} word1]} { |
|
#tailcall error $result |
|
return -options $erroptions $result |
|
} else { |
|
switch -- $word1 { |
|
switcherror - funerror { |
|
error $result "pipecase [lsearch -all -inline $args "*="]" |
|
} |
|
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] |
|
} |
|
ignore { |
|
#suppress error, but use normal return |
|
return [dict create error [dict create suppressed $result]] |
|
} |
|
default { |
|
#normal tcl error |
|
#return [dict create error [dict create reason $result]] |
|
tailcall error $result "pipecase $args" [list caseerror] |
|
} |
|
} |
|
} |
|
} else { |
|
tailcall return -errorcode [list casematch] [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] |
|
} |
|
#static-closure version - because we shouldn't be writing back to calling context vars directly |
|
#Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! |
|
#pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) |
|
proc pipeswitchc {pipescript args} { |
|
set binding {} |
|
if {[info level] == 1} { |
|
#up 1 is global |
|
set get_vars [list info vars] |
|
} else { |
|
set get_vars [list info locals] |
|
} |
|
set vars [uplevel 1 {*}$get_vars] |
|
set posn [lsearch $vars switchargs] |
|
set vars [lreplace $vars $posn $posn] |
|
foreach v $vars { |
|
upvar 1 $v var |
|
if {(![array exists var]) && [info exists var]} { |
|
lappend binding [list $v $var] ;#values captured as defaults for apply args. |
|
} |
|
} |
|
lappend binding [list switchargs $args] |
|
apply [list $binding $pipescript [uplevel 1 {::namespace current}]] |
|
} |
|
|
|
proc pipedata {data args} { |
|
#puts stderr "'$args'" |
|
set r $data |
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set e [lindex $args $i] |
|
#review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? |
|
if {![string is list $e]} { |
|
#not a list - assume script and run anyway |
|
set r [apply [list {data} $e] $r] |
|
} else { |
|
if {[llength $e] == 1} { |
|
switch -- $e { |
|
> { |
|
#output to calling context. only pipedata return value and '> varname' should affect caller. |
|
incr i |
|
uplevel 1 [list set [lindex $args $i] $r] |
|
} |
|
% - pipematch - ispipematch { |
|
incr i |
|
set e2 [lindex $args $i] |
|
#set body [list $e {*}$e2] |
|
#append body { $data} |
|
|
|
set body [list $e {*}$e2] |
|
append body { {*}$data} |
|
|
|
|
|
set applylist [list {data} $body] |
|
#puts stderr $applylist |
|
set r [apply $applylist $r] |
|
} |
|
pipeswitch - pipeswitchc { |
|
#pipeswitch takes a script not a list. |
|
incr i |
|
set e2 [lindex $args $i] |
|
set body [list $e $e2] |
|
#pipeswitch takes 'args' - so expand $data when in pipedata context |
|
append body { {*}$data} |
|
#use applylist instead of uplevel when in pipedata context! |
|
#can use either switchdata/data but not vars in calling context of 'pipedata' command. |
|
#this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. |
|
set applylist [list {data} $body] |
|
#puts stderr $applylist |
|
set r [apply $applylist $r] |
|
} |
|
default { |
|
#puts "other single arg: [list $e $r]" |
|
append e { $data} |
|
set r [apply [list {data} $e] $r] |
|
} |
|
} |
|
} elseif {[llength $e] == 0} { |
|
#do nothing - pass data through |
|
#leave r as is. |
|
} else { |
|
set r [apply [list {data} $e] $r] |
|
} |
|
} |
|
} |
|
return $r |
|
} |
|
|
|
|
|
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 |
|
} |
|
|
|
|
|
#useful for aliases e.g treemore -> xmore tree |
|
proc xmore {args} { |
|
if {[llength $args]} { |
|
uplevel #0 [list {*}$args | more] |
|
} else { |
|
error "usage: punk::xmore args where args are run as {*}\$args | more" |
|
} |
|
} |
|
|
|
|
|
#environment path as list |
|
# |
|
#return *appendable* pipeline - i.e no args via <| |
|
proc path_list_pipe {{glob *}} { |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set sep ";" |
|
} else { |
|
# : ok for linux/bsd ... mac? |
|
set sep ":" |
|
} |
|
set cond [string map [list <glob> $glob] {expr {[string length $item] && [string match <glob> $item]}}] |
|
#env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) |
|
return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] |
|
} |
|
proc path_list {{glob *}} { |
|
set pipe [punk::path_list_pipe $glob] |
|
{*}$pipe |
|
} |
|
proc path {{glob *}} { |
|
set pipe [punk::path_list_pipe $glob] |
|
{*}$pipe |> list_as_lines |
|
} |
|
|
|
#------------------------------------------------------------------- |
|
#sh 'test' equivalent - to be used with exitcode of process |
|
# |
|
|
|
#single evaluation to get exitcode |
|
proc sh_test {args} { |
|
set a1 [lindex $args 0] |
|
if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { |
|
set a2 [lindex $args 1] |
|
if {![catch { |
|
set attrinfo [file attributes $a2] |
|
} errM]} { |
|
if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { |
|
puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." |
|
} |
|
} |
|
} |
|
tailcall run test {*}$args |
|
} |
|
|
|
#whether v is an integer from perspective of unix test command. |
|
#can be be bigger than a tcl int or wide ie bignum - but must be whole number |
|
#test doesn't handle 1.0 - so we shouldn't auto-convert |
|
proc is_sh_test_integer {v} { |
|
if {[string first . $v] >=0 || [string first e $v] >= 0} { |
|
return false |
|
} |
|
#if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' |
|
if {[string is double -strict $v]} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} |
|
#can use double-evaluation to get true/false |
|
#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 (?) |
|
#Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! |
|
#We will stick with the Tcl view of the file system. |
|
#User can use their own direct calls to external utils if |
|
#Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] |
|
proc sh_TEST {args} { |
|
upvar ? lasterr |
|
set lasterr 0 |
|
set a1 [lindex $args 0] |
|
set a2 [lindex $args 1] |
|
set a3 [lindex $args 2] |
|
set fileops [list -b -c -d -e -f -h -L -s -S -x -w] |
|
if {[llength $args] == 1} { |
|
#equivalent of -n STRING |
|
set boolresult [expr {[string length $a1] != 0}] |
|
} elseif {[llength $args] == 2} { |
|
if {$a1 in $fileops} { |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
#e.g trailing dot or trailing space |
|
if {[punk::winpath::illegalname_test $a2]} { |
|
#protect with \\?\ to stop windows api from parsing |
|
#will do nothing if already prefixed with \\?\ |
|
|
|
set a2 [punk::winpath::illegalname_fix $a2] |
|
} |
|
} |
|
} |
|
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]} { |
|
set boolresult [expr {[file type $a2] eq "blockSpecial"}] |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
-c { |
|
#e.g on windows CON,NUL |
|
if {[file exists $a2]} { |
|
set boolresult [expr {[file type $a2] eq "characterSpecial"}] |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
-d { |
|
set boolresult [file isdirectory $a2] |
|
} |
|
-e { |
|
set boolresult [file exists $a2] |
|
} |
|
-f { |
|
#e.g on windows CON,NUL |
|
if {[file exists $a2]} { |
|
set boolresult [expr {[file type $a2] eq "file"}] |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
-h - |
|
-L { |
|
set boolresult [expr {[file type $a2] eq "link"}] |
|
} |
|
-s { |
|
set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] |
|
} |
|
-S { |
|
if {[file exists $a2]} { |
|
set boolresult [expr {[file type $a2] eq "socket"}] |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
-x { |
|
set boolresult [expr {[file exists $a2] && [file executable $a2]}] |
|
} |
|
-w { |
|
set boolresult [expr {[file exists $a2] && [file writable $a2]}] |
|
} |
|
-z { |
|
set boolresult [expr {[string length $a2] == 0}] |
|
} |
|
-n { |
|
set boolresult [expr {[string length $a2] != 0}] |
|
} |
|
default { |
|
puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" |
|
#set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] |
|
set callinfo [runx test {*}$args] |
|
set errinfo [dict get $callinfo stderr] |
|
set exitcode [dict get $callinfo exitcode] |
|
if {[string length $errinfo]} { |
|
puts stderr "sh_TEST error in external call to 'test $args': $errinfo" |
|
set lasterr $exitcode |
|
} |
|
if {$exitcode == 0} { |
|
set boolresult true |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
} |
|
} elseif {[llength $args] == 3} { |
|
switch -- $a2 { |
|
"=" { |
|
#test does string comparisons |
|
set boolresult [string equal $a1 $a3] |
|
} |
|
"!=" { |
|
#string comparison |
|
set boolresult [expr {$a1 ne $a3}] |
|
} |
|
"-eq" { |
|
#test expects a possibly-large integer-like thing |
|
#shell scripts will |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 == $a3}] |
|
} |
|
"-ge" { |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 >= $a3}] |
|
} |
|
"-gt" { |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 > $a3}] |
|
} |
|
"-le" { |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 <= $a3}] |
|
} |
|
"-lt" { |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 < $a3}] |
|
} |
|
"-ne" { |
|
if {![is_sh_test_integer $a1]} { |
|
puts stderr "sh_TEST: invalid integer '$a1'" |
|
set lasterr 2 |
|
return false |
|
} |
|
if {![is_sh_test_integer $a3]} { |
|
puts stderr "sh_TEST: invalid integer '$a3'" |
|
set lasterr 2 |
|
return false |
|
} |
|
set boolresult [expr {$a1 != $a3}] |
|
} |
|
default { |
|
puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" |
|
#set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] |
|
set callinfo [runx test {*}$args] |
|
set errinfo [dict get $callinfo stderr] |
|
set exitcode [dict get $callinfo exitcode] |
|
if {[string length $errinfo]} { |
|
puts stderr "sh_TEST error in external call to 'test $args': $errinfo" |
|
set lasterr $exitcode |
|
} |
|
if {$exitcode == 0} { |
|
set boolresult true |
|
} else { |
|
set boolresult false |
|
} |
|
|
|
} |
|
} |
|
} else { |
|
puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" |
|
#set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] |
|
set callinfo [runx test {*}$args] |
|
set errinfo [dict get $callinfo stderr] |
|
set exitcode [dict get $callinfo exitcode] |
|
if {[string length $errinfo]} { |
|
puts stderr "sh_TEST error in external call to 'test $args': $errinfo" |
|
set lasterr $exitcode |
|
} |
|
if {$exitcode == 0} { |
|
set boolresult true |
|
} else { |
|
set boolresult false |
|
} |
|
} |
|
|
|
#normalize 1,0 etc to true,false |
|
#we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. |
|
if {$boolresult} { |
|
return true |
|
} else { |
|
if {$lasterr == 0} { |
|
set lasterr 1 |
|
} |
|
return false |
|
} |
|
|
|
|
|
} |
|
proc sh_echo {args} { |
|
tailcall run echo {*}$args |
|
} |
|
proc sh_ECHO {args} { |
|
#execute the result of the run command - which is something like: 'exitcode n' - to get true/false |
|
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 exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore |
|
|
|
#namespace ensemble create |
|
|
|
|
|
|
|
|
|
#tilde |
|
#These aliases work fine for interactive use - but the result is always a string int-rep |
|
#interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) |
|
#interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} |
|
proc ~ {args} { |
|
set hdir [punk::objclone $::env(HOME)] |
|
file pathtype $hdir |
|
set d $hdir |
|
#use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions |
|
foreach a $args { |
|
set d [file join $d $a] |
|
} |
|
file pathtype $d |
|
return [punk::objclone $d] |
|
} |
|
interp alias {} ~ {} punk::~ |
|
|
|
|
|
#maint - punk::args has similar |
|
#this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args |
|
#textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions |
|
#todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? |
|
#JMN |
|
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values |
|
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. |
|
#only supports -flag val pairs, not solo options |
|
#If an option is supplied multiple times - only the last value is used. |
|
#TODO - remove |
|
proc get_leading_opts_and_values {defaults rawargs args} { |
|
if {[llength $defaults] %2 != 0} { |
|
error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" |
|
} |
|
dict for {k v} $defaults { |
|
if {![string match -* $k]} { |
|
error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" |
|
} |
|
} |
|
#puts "--> [info frame -2] <--" |
|
set cmdinfo [dict get [info frame -2] cmd] |
|
#we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work |
|
#hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc |
|
#we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) |
|
set caller [regexp -inline {\S+} $cmdinfo] |
|
|
|
#if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" |
|
if {$caller eq "namespace"} { |
|
set caller "get_leading_opts_and_values called from namespace" |
|
} |
|
|
|
# ------------------------------ |
|
if {$caller ne "get_leading_opts_and_values"} { |
|
#check our own args |
|
lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues |
|
if {[llength $ownvalues] > 0} { |
|
error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues <int> and -maxvalues <int> - got extra arguments: '$ownvalues'" |
|
} |
|
set opt_minvalues [dict get $ownopts -minvalues] |
|
set opt_maxvalues [dict get $ownopts -maxvalues] |
|
set opt_anyopts [dict get $ownopts -anyopts] |
|
} else { |
|
#don't check our own args if we called ourself |
|
set opt_minvalues 0 |
|
set opt_maxvalues 0 |
|
set opt_anyopts 0 |
|
} |
|
# ------------------------------ |
|
|
|
if {[set eopts [lsearch $rawargs "--"]] >= 0} { |
|
set values [lrange $rawargs $eopts+1 end] |
|
set arglist [lrange $rawargs 0 $eopts-1] |
|
} else { |
|
if {[lsearch $rawargs -*] >= 0} { |
|
#to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex |
|
set i 0 |
|
foreach {k v} $rawargs { |
|
if {![string match -* $k]} { |
|
break |
|
} |
|
if {$i+1 >= [llength $rawargs]} { |
|
#no value for last flag |
|
error "bad options for $caller. No value supplied for last option $k" |
|
} |
|
incr i 2 |
|
} |
|
set arglist [lrange $rawargs 0 $i-1] |
|
set values [lrange $rawargs $i end] |
|
} else { |
|
set values $rawargs ;#no -flags detected |
|
set arglist [list] |
|
} |
|
} |
|
if {$opt_maxvalues == -1} { |
|
#only check min |
|
if {[llength $values] < $opt_minvalues} { |
|
error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" |
|
} |
|
} else { |
|
if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { |
|
if {$opt_minvalues == $opt_maxvalues} { |
|
error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" |
|
} else { |
|
error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" |
|
} |
|
} |
|
} |
|
|
|
if {!$opt_anyopts} { |
|
set checked_args [dict create] |
|
for {set i 0} {$i < [llength $arglist]} {incr i} { |
|
#allow this to error out with message indicating expected flags |
|
dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] |
|
incr i ;#skip val |
|
} |
|
} else { |
|
set checked_args $arglist |
|
} |
|
set opts [dict merge $defaults $checked_args] |
|
|
|
#maintain order of opts $opts values $values as caller may use lassign. |
|
return [dict create opts $opts values $values] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#-------------------------------------------------- |
|
#some haskell-like operations |
|
#group equivalent |
|
#http://zvon.org/other/haskell/Outputlist/group_f.html |
|
#as we can't really distinguish a single element list from a string we will use 2 functions |
|
proc group_list1 {lst} { |
|
set out [list] |
|
set prev [lindex $lst 0] |
|
set g [list] |
|
foreach i $lst { |
|
if {$i eq $prev} { |
|
lappend g $i |
|
} else { |
|
lappend out $g |
|
set g [list $i] |
|
} |
|
set prev $i |
|
} |
|
lappend out $g |
|
return $out |
|
} |
|
proc group_list {lst} { |
|
set out [list] |
|
set next [lindex $lst 1] |
|
set tail [lassign $lst x] |
|
set g [list $x] |
|
set y [lindex $tail 0] |
|
set last_condresult [expr {$x}] |
|
set n 1 ;#start at one instead of zero for lookahead |
|
foreach x $tail { |
|
set y [lindex $tail $n] |
|
set condresult [expr {$x}] |
|
if {$condresult eq $last_condresult} { |
|
lappend g $x |
|
} else { |
|
lappend out $g |
|
set g [list $x] |
|
set last_condresult $condresult |
|
} |
|
incr n |
|
} |
|
lappend out $g |
|
return $out |
|
} |
|
|
|
#NOT attempting to match haskell other than in overall concept. |
|
# |
|
#magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. |
|
#Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time |
|
#We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. |
|
# |
|
#vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond |
|
#(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) |
|
#group by cond result or first 3 wordlike parts of error |
|
#e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} |
|
proc group_list_by {cond lst} { |
|
set out [list] |
|
set prev [list] |
|
set next [lindex $lst 1] |
|
set tail [lassign $lst item] |
|
set g [list $item] |
|
set next [lindex $tail 0] |
|
if {$prev eq ""} { |
|
set prev0 0 |
|
set prev1 1 |
|
set prevr $item |
|
} else { |
|
set prev0 $prev |
|
set prev1 $prev |
|
set prevr $prev |
|
} |
|
if {$next eq ""} { |
|
set next0 0 |
|
set next1 1 |
|
set nextr $item |
|
} else { |
|
set next0 $next |
|
set next1 $next |
|
set nextr $next |
|
} |
|
set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { |
|
if {[catch {expr $cond} r]} { |
|
puts stderr "index: 0 ERROR $r" |
|
set wordlike_parts [regexp -inline -all {\S+} $r] |
|
set r [list ERROR {*}[lrange $wordlike_parts 0 2]] |
|
} |
|
set r |
|
} |
|
} 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] |
|
set n 1 ;#start at one instead of zero for lookahead |
|
#note - n also happens to matchi zero-based index of original list |
|
set prev $item |
|
foreach item $tail { |
|
set next [lindex $tail $n] |
|
if {$prev eq ""} { |
|
set prev0 0 |
|
set prev1 1 |
|
set prevr $item |
|
} else { |
|
set prev0 $prev |
|
set prev1 $prev |
|
set prevr $prev |
|
} |
|
if {$next eq ""} { |
|
set next0 0 |
|
set next1 1 |
|
set nextr $item |
|
} else { |
|
set next0 $next |
|
set next1 $next |
|
set nextr $next |
|
} |
|
set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { |
|
if {[catch {expr $cond} r]} { |
|
puts stderr "index: $index ERROR $r" |
|
set wordlike_parts [regexp -inline -all {\S+} $r] |
|
set r [list ERROR {*}[lrange $wordlike_parts 0 2]] |
|
} |
|
set r |
|
} |
|
} $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] |
|
if {$condresult eq $last_condresult} { |
|
lappend g $item |
|
} else { |
|
lappend out $g |
|
set g [list $item] |
|
set last_condresult $condresult |
|
} |
|
incr n |
|
set prev $item |
|
} |
|
lappend out $g |
|
return $out |
|
} |
|
|
|
#group_numlist ? preserve representation of numbers rather than use string comparison? |
|
|
|
|
|
# - group_string |
|
#.= punk::group_string "aabcccdefff" |
|
# aa b ccc d e fff |
|
proc group_string {str} { |
|
lmap v [group_list [split $str ""]] {string cat {*}$v} |
|
} |
|
|
|
#lists may be of unequal lengths |
|
proc transpose_lists {list_rows} { |
|
set res {} |
|
#set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] |
|
set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] |
|
for {set j 0} {$j < $widest} {incr j} { |
|
set newrow {} |
|
foreach oldrow $list_rows { |
|
if {$j >= [llength $oldrow]} { |
|
continue |
|
} else { |
|
lappend newrow [lindex $oldrow $j] |
|
} |
|
} |
|
lappend res $newrow |
|
} |
|
return $res |
|
} |
|
proc transpose_strings {list_of_strings} { |
|
set charlists [lmap v $list_of_strings {split $v ""}] |
|
set tchars [transpose_lists $charlists] |
|
lmap v $tchars {string cat {*}$v} |
|
} |
|
|
|
package require struct::matrix |
|
#transpose a serialized matrix using the matrix command |
|
#Note that we can have missing row values below and to right |
|
#e.g |
|
#a |
|
#a b |
|
#a |
|
proc transpose_matrix {matrix_rows} { |
|
set mcmd [struct::matrix] |
|
#serialization format: numcols numrows rowlist |
|
set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] |
|
$mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] |
|
$mcmd transpose |
|
set result [lindex [$mcmd serialize] 2] ;#strip off dimensions |
|
$mcmd destroy |
|
return $result |
|
} |
|
|
|
set objname [namespace current]::matrixchain |
|
if {$objname ni [info commands $objname]} { |
|
oo::class create matrixchain { |
|
variable mcmd |
|
constructor {matrixcommand} { |
|
puts "wrapping $matrixcommand with [self]" |
|
set mcmd $matrixcommand |
|
} |
|
destructor { |
|
puts "matrixchain destructor called for [self] (wrapping $mcmd)" |
|
$mcmd destroy |
|
} |
|
method unknown {args} { |
|
if {[llength $args]} { |
|
switch -- [lindex $args 0] { |
|
add - delete - insert - transpose - sort - set - swap { |
|
$mcmd {*}$args |
|
return [self] ;#result is the wrapper object for further chaining in pipelines |
|
} |
|
default { |
|
tailcall $mcmd {*}$args |
|
} |
|
} |
|
} else { |
|
#will error.. but we should pass that on |
|
tailcall $mcmd |
|
} |
|
} |
|
} |
|
} |
|
|
|
#review |
|
#how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? |
|
#Perhaps will be solved by: Tip 550: Garbage collection for TclOO |
|
#Theoretically this should allow tidy up of objects created within the pipeline automatically |
|
#If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. |
|
proc matrix_command_from_rows {matrix_rows} { |
|
set mcmd [struct::matrix] |
|
set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] |
|
$mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] |
|
#return $mcmd |
|
set wrapper [punk::matrixchain new $mcmd] |
|
} |
|
|
|
#-------------------------------------------------- |
|
|
|
proc list_filter_cond {itemcond listval} { |
|
set filtered_list [list] |
|
set binding {} |
|
if {[info level] == 1} { |
|
#up 1 is global |
|
set get_vars [list ::info vars] |
|
} else { |
|
set get_vars [list ::info locals] |
|
} |
|
set vars [uplevel 1 {*}$get_vars] |
|
set posn [lsearch $vars item] |
|
set vars [lreplace $vars $posn $posn] |
|
foreach v $vars { |
|
upvar 1 $v var |
|
if {(![array exists var]) && [info exists var]} { |
|
lappend binding [list $v $var] ;#values captured as defaults for apply args. |
|
} |
|
} |
|
#lappend binding [list item $args] |
|
|
|
#puts stderr "binding: [join $binding \n]" |
|
#apply [list $binding $pipescript [uplevel 1 ::namespace current]] |
|
foreach item $listval { |
|
set bindlist [list {*}$binding [list item $item]] |
|
if {[apply [list $bindlist $itemcond [uplevel 1 ::namespace current]] ]} { |
|
lappend filtered_list $item |
|
} |
|
} |
|
return $filtered_list |
|
} |
|
|
|
|
|
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 |
|
} |
|
} |
|
|
|
|
|
|
|
#linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient |
|
#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 nlsplit [split $a \n] |
|
lappend linelist {*}$nlsplit |
|
} |
|
#return [split $text \n] |
|
return $linelist |
|
} |
|
proc linelist1 {args} { |
|
set linelist [list] |
|
foreach {a} $args { |
|
set nlsplit [split $a \n] |
|
set start 0 |
|
set end "end" |
|
|
|
if {[lindex $nlsplit 0] eq ""} { |
|
set start 1 |
|
} |
|
if {[lindex $nlsplit end] eq ""} { |
|
set end "end-1" |
|
} |
|
set alist [lrange $nlsplit $start $end] |
|
lappend linelist {*}$alist |
|
} |
|
return $linelist |
|
} |
|
|
|
|
|
punk::args::define { |
|
@dynamic |
|
@id -id ::punk::LOC |
|
@cmd -name punk::LOC -help\ |
|
"LOC - lines of code. |
|
An implementation of a notoriously controversial metric" |
|
-return -default showdict -choices {dict showdict} |
|
-dir -default "\uFFFF" |
|
-exclude_dupfiles -default 1 -type boolean |
|
${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]} |
|
-antiglob_files -default "" -type list -help\ |
|
"Exclude if file tail matches any of these patterns" |
|
-exclude_punctlines -default 1 -type boolean |
|
-show_largest -default 0 -type integer -help\ |
|
"Report the top largest linecount files. |
|
The value represents the number of files |
|
to report on." |
|
} " |
|
#we could map away whitespace and use string is punct - but not as flexible? review |
|
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } |
|
" |
|
#An implementation of a notoriously controversial metric. |
|
proc LOC {args} { |
|
set argd [punk::args::parse $args withid ::punk::LOC] |
|
lassign [dict values $argd] leaders opts values received |
|
set searchspecs [dict values $values] |
|
|
|
# -- --- --- --- --- --- |
|
set opt_return [dict get $opts -return] |
|
set opt_dir [dict get $opts -dir] |
|
if {$opt_dir eq "\uFFFF"} { |
|
set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list |
|
} |
|
# -- --- --- --- --- --- |
|
set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] |
|
set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars |
|
set opt_punctchars [dict get $opts -punctchars] |
|
set opt_largest [dict get $opts -show_largest] |
|
set opt_antiglob_paths [dict get $opts -antiglob_paths] |
|
set opt_antiglob_files [dict get $opts -antiglob_files] |
|
# -- --- --- --- --- --- |
|
|
|
|
|
set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs] |
|
set loc 0 |
|
set dupfileloc 0 |
|
set seentails [dict create] |
|
set seencksums [dict create] ;#key is cksum value is list of paths |
|
set largestloc [dict create] |
|
set dupfilecount 0 |
|
set extensions [list] |
|
set purepunctlines 0 |
|
set dupinfo [dict create] |
|
set has_hashfunc [expr {![catch {package require sha1}]}] |
|
set notes "" |
|
if {$has_hashfunc} { |
|
set dupfilemech sha1 |
|
if {$opt_exclude_punctlines} { |
|
append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" |
|
} else { |
|
append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" |
|
} |
|
} else { |
|
set dupfilemech filetail |
|
append notes "dupfilemech filetail because sha1 not loadable\n" |
|
} |
|
foreach fpath $filepaths { |
|
set isdupfile 0 |
|
set floc 0 |
|
set fpurepunctlines 0 |
|
set ext [file extension $fpath] |
|
if {$ext ni $extensions} { |
|
lappend extensions $ext |
|
} |
|
if {[catch {fcat $fpath} contents]} { |
|
puts stderr "Error processing $fpath\n $contents" |
|
continue |
|
} |
|
set lines [linelist -line {trimright} -block {trimall} $contents] |
|
if {!$opt_exclude_punctlines} { |
|
set floc [llength $lines] |
|
set comparedlines $lines |
|
} else { |
|
set mapawaypunctuation [list] |
|
foreach p $opt_punctchars empty {} { |
|
lappend mapawaypunctuation $p $empty |
|
} |
|
set comparedlines [list] |
|
foreach ln $lines { |
|
if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { |
|
incr floc |
|
lappend comparedlines $ln |
|
} else { |
|
incr fpurepunctlines |
|
} |
|
} |
|
} |
|
if {$opt_largest > 0} { |
|
dict set largestloc $fpath $floc |
|
} |
|
if {$has_hashfunc} { |
|
set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] |
|
if {[dict exists $seencksums $cksum]} { |
|
set isdupfile 1 |
|
incr dupfilecount |
|
incr dupfileloc $floc |
|
dict lappend seencksums $cksum $fpath |
|
} else { |
|
dict set seencksums $cksum [list $fpath] |
|
} |
|
} else { |
|
if {[dict exists $seentails [file tail $fpath]]} { |
|
set isdupfile 1 |
|
incr dupfilecount |
|
incr dupfileloc $floc |
|
} |
|
} |
|
if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { |
|
incr loc $floc |
|
incr purepunctlines $fpurepunctlines |
|
} |
|
|
|
dict lappend seentails [file tail $fpath] $fpath |
|
#lappend seentails [file tail $fpath] |
|
} |
|
if {$has_hashfunc} { |
|
dict for {cksum paths} $seencksums { |
|
if {[llength $paths] > 1} { |
|
dict set dupinfo checksums $cksum $paths |
|
} |
|
} |
|
} |
|
dict for {tail paths} $seentails { |
|
if {[llength $paths] > 1} { |
|
dict set dupinfo sametail $tail $paths |
|
} |
|
} |
|
|
|
if {$opt_exclude_punctlines} { |
|
set result [dict create\ |
|
loc $loc\ |
|
filecount [llength $filepaths]\ |
|
dupfiles $dupfilecount\ |
|
dupfilemech $dupfilemech\ |
|
dupfileloc $dupfileloc\ |
|
dupinfo $dupinfo\ |
|
extensions $extensions\ |
|
purepunctuationlines $purepunctlines\ |
|
notes $notes\ |
|
] |
|
} else { |
|
set result [dict create\ |
|
loc $loc\ |
|
filecount [llength $filepaths]\ |
|
dupfiles $dupfilecount\ |
|
dupfilemech $dupfilemech\ |
|
dupfileloc $dupfileloc\ |
|
dupinfo $dupinfo\ |
|
extensions $extensions\ |
|
notes $notes\ |
|
] |
|
} |
|
if {$opt_largest > 0} { |
|
set largest_n [dict create] |
|
set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] |
|
set kidx 0 |
|
for {set i 0} {$i < $opt_largest} {incr i} { |
|
if {$kidx+1 > [llength $sorted]} {break} |
|
dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] |
|
incr kidx 2 |
|
} |
|
dict set result largest $largest_n |
|
} |
|
if {$opt_return eq "showdict"} { |
|
return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] |
|
} |
|
return $result |
|
} |
|
|
|
|
|
|
|
#!!!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 nlsplit [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 $nlsplit { |
|
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 |
|
} |
|
|
|
|
|
proc ooinspect {obj} { |
|
set obj [uplevel 1 [list namespace which -command $obj]] |
|
set isa [lmap type {object class metaclass} { |
|
if {![info object isa $type $obj]} continue |
|
set type |
|
}] |
|
foreach tp $isa { |
|
switch -- $tp { |
|
class { |
|
lappend info {class superclasses} {class mixins} {class filters} |
|
lappend info {class methods} {class methods} |
|
lappend info {class variables} {class variables} |
|
} |
|
object { |
|
lappend info {object class} {object mixins} {object filters} |
|
lappend info {object methods} {object methods} |
|
lappend info {object variables} {object variables} |
|
lappend info {object namespace} {object vars} ;#{object commands} |
|
} |
|
} |
|
} |
|
|
|
set result [dict create isa $isa] |
|
foreach args $info { |
|
dict set result $args [info {*}$args $obj] |
|
foreach opt {-private -all} { |
|
catch { |
|
dict set result [list {*}$args $opt] [info {*}$args $obj $opt] |
|
} |
|
} |
|
} |
|
dict filter $result value {?*} |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::inspect |
|
@cmd -name punk::inspect -help\ |
|
"Function to display values - used pimarily in a punk pipeline. |
|
The raw value arguments (not options) are always returned to pass |
|
forward in the pipeline. |
|
(pipeline data inserted at end of each |...> segment is passed as single item unless |
|
inserted with an expanding insertion specifier such as .=>* ) |
|
e.g1: |
|
.= list a b c |v1,/1-end,/0>\\ |
|
.=>* inspect -label i1 -- |>\\ |
|
.=v1> inspect -label i2 -- |>\\ |
|
string toupper |
|
(3) i1: {a b c} {b c} a |
|
(1) i2: a b c |
|
|
|
- A B C |
|
" |
|
-label -type string -default "" -help\ |
|
"An optional label to help distinguish output when multiple |
|
inspect statements are in a pipeline. This appears after the |
|
bracketed count indicating number of values supplied. |
|
e.g (2) MYLABEL: val1 val2 |
|
The label can include ANSI codes. |
|
e.g |
|
inspect -label [a+ red]mylabel -- val1 val2 val3 |
|
" |
|
-limit -type int -default 20 -help\ |
|
"When multiple values are passed to inspect - limit the number |
|
of elements displayed in -channel output. |
|
When truncation has occured an elipsis indication (...) will be appended. |
|
e.g |
|
.= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ |
|
(11) 20 23 26 29... |
|
|
|
- 385 |
|
|
|
For no limit - use -limit -1 |
|
" |
|
-channel -type string -default stderr -help\ |
|
"An existing open channel to write to. If value is any of nul, null, /dev/nul |
|
the channel output is disabled. This effectively disables inspect as the args |
|
are simply passed through in the return to continue the pipeline. |
|
" |
|
-showcount -type boolean -default 1 -help\ |
|
"Display a leading indicator in brackets showing the number of arg values present." |
|
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { |
|
0 "Strip ANSI codes from display |
|
of values. The disply output will |
|
still be colourised if -ansibase has |
|
not been set to empty string or |
|
[a+ normal]. The stderr or stdout |
|
channels may also have an ansi colour. |
|
(see 'colour off' or punk::config)" |
|
1 "Leave value as is" |
|
2 "Display the ANSI codes and |
|
other control characters inline |
|
with replacement indicators. |
|
e.g esc, newline, space, tab" |
|
VIEW "Alias for 2" |
|
3 "Display as per 2 but with |
|
colourised ANSI replacement codes." |
|
VIEWCODES "Alias for 3" |
|
4 "Display ANSI and control |
|
chars in default colour, but |
|
apply the contained ansi to |
|
the text portions so they display |
|
as they would for -ansi 1" |
|
VIEWSTYLE "Alias for 4" |
|
} |
|
-ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ |
|
"Base ansi code(s) that will apply to output written to the chosen -channel. |
|
If there are ansi resets in the displayed values - output will revert to this base. |
|
Does not affect return value." |
|
-- -type none -help\ |
|
"End of options marker. |
|
It is advisable to use this, as data in a pipeline may often begin with -" |
|
|
|
@values -min 0 -max -1 |
|
arg -type string -optional 1 -multiple 1 -help\ |
|
"value to display" |
|
} |
|
#pipeline inspect |
|
#e.g |
|
#= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} |
|
proc inspect {args} { |
|
set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] |
|
set flags [list] |
|
set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- |
|
if {$endoptsposn >= 0} { |
|
set flags [lrange $args 0 $endoptsposn-1] |
|
set pipeargs [lrange $args $endoptsposn+1 end] |
|
} else { |
|
#no explicit end of opts marker |
|
#last trailing elements of args after taking *known* -tag v pairs is the value to inspect |
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set k [lindex $args $i] |
|
if {$k in [dict keys $defaults]} { |
|
lappend flags {*}[lrange $args $i $i+1] |
|
incr i |
|
} else { |
|
#first unrecognised option represents end of flags |
|
break |
|
} |
|
} |
|
set pipeargs [lrange $args $i end] |
|
} |
|
foreach {k v} $flags { |
|
if {$k ni [dict keys $defaults]} { |
|
#error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" |
|
punk::args::get_by_id ::punk::inspect $args |
|
} |
|
} |
|
set opts [dict merge $defaults $flags] |
|
# -- --- --- --- --- |
|
set label [dict get $opts -label] |
|
set channel [dict get $opts -channel] |
|
set showcount [dict get $opts -showcount] |
|
if {[string length $label]} { |
|
set label "${label}: " |
|
} |
|
set limit [dict get $opts -limit] |
|
set opt_ansiraw [dict get $opts -ansi] |
|
set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] |
|
switch -- [string tolower $opt_ansi] { |
|
0 - 1 - 2 - 3 - 4 {} |
|
view {set opt_ansi 2} |
|
viewcodes {set opt_ansi 3} |
|
viewstyle {set opt_ansi 4} |
|
default { |
|
error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" |
|
} |
|
} |
|
# -- --- --- --- --- |
|
|
|
set more "" |
|
if {[llength $pipeargs] == 1} { |
|
#usual case is data as a single element |
|
set val [lindex $pipeargs 0] |
|
set count 1 |
|
} else { |
|
#but the pipeline segment could have an insertion-pattern ending in * |
|
set val $pipeargs |
|
set count [llength $pipeargs] |
|
} |
|
switch -- [string tolower $channel] { |
|
nul - null - /dev/null { |
|
return $val |
|
} |
|
} |
|
set displayval $val ;#default - may be overridden based on -limit |
|
|
|
if {$count > 1} { |
|
#val is a list |
|
set llen [llength $val] |
|
if {$limit > 0 && ($limit < $llen)} { |
|
set displayval [lrange $val 0 $limit-1] |
|
if {$llen > $limit} { |
|
set more "..." |
|
} |
|
} |
|
} else { |
|
#not a valid tcl list - limit by lines |
|
if {$limit > 0} { |
|
set rawlines [split $val \n] |
|
set llen [llength $rawlines] |
|
set displaylines [lrange $rawlines 0 $limit-1] |
|
set displayval [join $displaylines "\n"] |
|
if {$llen > $limit} { |
|
set more "\n..." |
|
} |
|
} |
|
|
|
} |
|
if {$showcount} { |
|
set displaycount "[a purple bold]($count)[a] " |
|
if {$showcount} { |
|
set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space |
|
set margin [string repeat " " $countspace] |
|
set displayval [string map [list \r "" \n "\n$margin"] $displayval] |
|
} |
|
} else { |
|
set displaycount "" |
|
} |
|
|
|
set ansibase [dict get $opts -ansibase] |
|
if {$ansibase ne ""} { |
|
#-ansibase default is hardcoded into punk::args definition |
|
#run a test using any ansi code to see if colour is still enabled |
|
if {[a+ red] eq ""} { |
|
set ansibase "" ;#colour seems to be disabled |
|
} |
|
} |
|
|
|
switch -- $opt_ansi { |
|
0 { |
|
set displayval $ansibase[punk::ansi::ansistrip $displayval] |
|
} |
|
1 { |
|
#val may have ansi - including resets. Pass through ansibase_lines to |
|
if {$ansibase ne ""} { |
|
set displayval [::textblock::ansibase_lines $displayval $ansibase] |
|
} |
|
} |
|
2 { |
|
set displayval $ansibase[ansistring VIEW $displayval] |
|
if {$ansibase ne ""} { |
|
set displayval [::textblock::ansibase_lines $displayval $ansibase] |
|
} |
|
} |
|
3 { |
|
set displayval $ansibase[ansistring VIEWCODE $displayval] |
|
if {$ansibase ne ""} { |
|
set displayval [::textblock::ansibase_lines $displayval $ansibase] |
|
} |
|
} |
|
4 { |
|
set displayval $ansibase[ansistring VIEWSTYLE $displayval] |
|
if {$ansibase ne ""} { |
|
set displayval [::textblock::ansibase_lines $displayval $ansibase] |
|
} |
|
} |
|
} |
|
|
|
if {![string length $more]} { |
|
puts $channel "$displaycount$label$displayval[a]" |
|
} else { |
|
puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" |
|
} |
|
return $val |
|
} |
|
|
|
|
|
|
|
#return list of {chan chunk} elements |
|
proc help_chunks {args} { |
|
set chunks [list] |
|
set linesep [string repeat - 76] |
|
set mascotblock "" |
|
catch { |
|
package require patternpunk |
|
#lappend chunks [list stderr [>punk . rhs]] |
|
append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] |
|
} |
|
|
|
set topic [lindex $args end] |
|
set argopts [lrange $args 0 end-1] |
|
|
|
|
|
set title "[a+ brightgreen] Punk core navigation commands: " |
|
|
|
#todo - load from source code annotation? |
|
set cmdinfo [list] |
|
lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] |
|
lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] |
|
lappend cmdinfo [list ./ "?subdir?" "view/change directory"] |
|
lappend cmdinfo [list ../ "" "go up one directory"] |
|
lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] |
|
lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] |
|
lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] |
|
lappend cmdinfo [list "nn/" "" "go up one namespace"] |
|
lappend cmdinfo [list "n/new" "<ns>" "make child namespace and switch to it"] |
|
lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] |
|
lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] |
|
|
|
#set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] |
|
#set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] |
|
#set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] |
|
#set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] |
|
set t [textblock::class::table new -show_seps 0] |
|
#foreach c $cmds d $descr { |
|
# $t add_row [list $c $d] |
|
#} |
|
foreach row $cmdinfo { |
|
$t add_row $row |
|
} |
|
set width_0 [$t column_datawidth 0] |
|
$t configure_column 0 -minwidth [expr {$width_0 + 2}] |
|
set width_1 [$t column_datawidth 1] |
|
$t configure_column 1 -minwidth [expr {$width_1 + 1}] |
|
$t configure -title $title |
|
|
|
set text "" |
|
append text [$t print] |
|
|
|
|
|
set warningblock "" |
|
set introblock $mascotblock |
|
append introblock \n $text |
|
|
|
#if {[catch {package require textblock} errM]} { |
|
# append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" |
|
#} else { |
|
# set introblock [textblock::join -- " " \n$mascotblock " " $text] |
|
#} |
|
|
|
|
|
lappend chunks [list stdout $introblock] |
|
|
|
|
|
if {$topic in [list tcl]} { |
|
if {[punk::lib::check::has_tclbug_script_var]} { |
|
append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" |
|
} |
|
if {[punk::lib::check::has_tclbug_safeinterp_compile]} { |
|
set indent " " |
|
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n |
|
append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n |
|
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" |
|
append warningblock [a] |
|
} |
|
if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { |
|
set indent " " |
|
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n |
|
append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n |
|
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" |
|
append warningblock [a] |
|
} |
|
if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { |
|
set indent " " |
|
append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n |
|
append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n |
|
append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" |
|
} |
|
} |
|
|
|
set text "" |
|
if {$topic in [list env environment]} { |
|
#todo - move to punk::config? |
|
upvar ::punk::config::punk_env_vars_config punkenv_config |
|
upvar ::punk::config::other_env_vars_config otherenv_config |
|
|
|
set known_punk [dict keys $punkenv_config] |
|
set known_other [dict keys $otherenv_config] |
|
append text \n |
|
set usetable 1 |
|
if {$usetable} { |
|
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
#If any env vars have been set to empty string - this is considered a deletion of the variable on windows. |
|
#The Tcl ::env array is linked to the underlying process view of the environment |
|
#- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. |
|
#an 'array get' will resynchronise. |
|
#Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. |
|
array get ::env |
|
} |
|
#do an array read on ::env |
|
foreach {v vinfo} $punkenv_config { |
|
if {[info exists ::env($v)]} { |
|
set c2 [set ::env($v)] |
|
} else { |
|
set c2 "(NOT SET)" |
|
} |
|
set help "" |
|
if {[dict exists $vinfo help]} { |
|
set help [dict get $vinfo help] |
|
} |
|
$t add_row [list $v $c2 $help] |
|
} |
|
$t configure_column 0 -headers [list "Punk environment vars"] |
|
$t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} |
|
|
|
set punktable [$t print] |
|
$t destroy |
|
|
|
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] |
|
foreach {v vinfo} $otherenv_config { |
|
if {[info exists ::env($v)]} { |
|
set c2 [set ::env($v)] |
|
} else { |
|
set c2 "(NOT SET)" |
|
} |
|
$t add_row [list $v $c2] |
|
} |
|
$t configure_column 0 -headers [list "Other environment vars"] |
|
$t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} |
|
|
|
set othertable [$t print] |
|
$t destroy |
|
append text [textblock::join -- $punktable " " $othertable]\n |
|
} else { |
|
|
|
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_punk { |
|
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] |
|
} |
|
|
|
if {$topic in [list console terminal]} { |
|
set indent [string repeat " " [string length "WARNING: "]] |
|
lappend cstring_tests [dict create\ |
|
type "PM "\ |
|
msg "PRIVACY MESSAGE"\ |
|
f7 punk::ansi::controlstring_PM\ |
|
f7desc "7bit ESC ^"\ |
|
f8 punk::ansi::controlstring_PM8\ |
|
f8desc "8bit \\x9e"\ |
|
] |
|
lappend cstring_tests [dict create\ |
|
type SOS\ |
|
msg "STRING"\ |
|
f7 punk::ansi::controlstring_SOS\ |
|
f7desc "7bit ESC X"\ |
|
f8 punk::ansi::controlstring_SOS8\ |
|
f8desc "8bit \\x98"\ |
|
] |
|
lappend cstring_tests [dict create\ |
|
type APC\ |
|
msg "APPLICATION PROGRAM COMMAND"\ |
|
f7 punk::ansi::controlstring_APC\ |
|
f7desc "7bit ESC _"\ |
|
f8 punk::ansi::controlstring_APC8\ |
|
f8desc "8bit \\x9f"\ |
|
] |
|
|
|
foreach test $cstring_tests { |
|
set m [[dict get $test f7] [dict get $test msg]] |
|
set hidden_width_m [punk::console::test_char_width $m] |
|
set m8 [[dict get $test f8] [dict get $test msg]] |
|
set hidden_width_m8 [punk::console::test_char_width $m8] |
|
if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { |
|
if {$hidden_width_m == 0} { |
|
set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" |
|
} else { |
|
set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" |
|
} |
|
if {$hidden_width_m8 == 0} { |
|
set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]" |
|
} else { |
|
set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" |
|
} |
|
append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" |
|
} |
|
} |
|
if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { |
|
if {$result} { |
|
append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." |
|
append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." |
|
append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" |
|
append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" |
|
append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" |
|
} |
|
} else { |
|
append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" |
|
} |
|
|
|
if {![catch {punk::console::check::has_bug_zwsp} result]} { |
|
if {$result} { |
|
append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." |
|
append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" |
|
} |
|
} else { |
|
append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" |
|
} |
|
|
|
|
|
set grapheme_support [punk::console::grapheme_cluster_support] |
|
#mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) |
|
if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { |
|
append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." |
|
if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { |
|
append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" |
|
} |
|
} else { |
|
if {![dict get $grapheme_support available]} { |
|
switch -- [dict get $grapheme_support mode] { |
|
"unset" { |
|
append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." |
|
} |
|
"permanently_unset" { |
|
append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." |
|
} |
|
"BAD_RESPONSE" { |
|
append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." |
|
} |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
lappend chunks [list stderr $warningblock] |
|
if {$topic in [list topics help]} { |
|
set text "" |
|
set topics [dict create\ |
|
"topics|help" "List help topics"\ |
|
"tcl" "Tcl version warnings"\ |
|
"env|environment" "punkshell environment vars"\ |
|
"console|terminal" "Some console behaviour tests and warnings"\ |
|
] |
|
|
|
set t [textblock::class::table new -show_seps 0] |
|
$t add_column -headers [list "Topic"] |
|
$t add_column |
|
foreach {k v} $topics { |
|
$t add_row [list $k $v] |
|
} |
|
set widest0 [$t column_datawidth 0] |
|
$t configure_column 0 -minwidth [expr {$widest0 + 4}] |
|
append text \n[$t print] |
|
|
|
lappend chunks [list stdout $text] |
|
} |
|
|
|
return $chunks |
|
} |
|
proc help {args} { |
|
set chunks [help_chunks {*}$args] |
|
foreach chunk $chunks { |
|
lassign $chunk chan text |
|
puts -nonewline $chan $text |
|
} |
|
} |
|
proc mode {{raw_or_line query}} { |
|
package require punk::console |
|
tailcall ::punk::console::mode $raw_or_line |
|
} |
|
|
|
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. |
|
interp alias {} mode {} punk::mode |
|
|
|
proc aliases {{glob *}} { |
|
tailcall punk::lib::aliases $glob |
|
} |
|
proc alias {{aliasorglob ""} args} { |
|
tailcall punk::lib::alias $aliasorglob {*}$args |
|
} |
|
|
|
|
|
#pipeline-toys - put in lib/scriptlib? |
|
##geometric mean |
|
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i| |
|
#straight apply approx 30x faster |
|
#alias gmean2 apply {args {expr [tcl::mathop::* {*}$args] ** [expr 1.0/[llength $args]]}} |
|
|
|
#know is critical to the punk repl for proper display output |
|
interp alias {} know {} punk::know |
|
interp alias {} know? {} punk::know? |
|
|
|
#interp alias {} val {} punk::val |
|
|
|
interp alias {} exitcode {} punk::exitcode |
|
interp alias {} hide {} punkapp::hide_console ;#will only work if controllable toplevels exist |
|
|
|
|
|
|
|
#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 {} help {} punk::help |
|
interp alias {} treemore {} punk::xmore tree |
|
|
|
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| |
|
|
|
|
|
|
|
|
|
|
|
#interp alias {} c {} clear ;#external executable 'clear' may not always be available |
|
#todo - review |
|
interp alias {} clear {} ::punk::reset |
|
interp alias {} c {} ::punk::reset |
|
proc reset {} { |
|
if {[llength [info commands ::punk::repl::reset_terminal]]} { |
|
#punk::repl::reset_terminal notifies prompt system of reset |
|
punk::repl::reset_terminal |
|
} else { |
|
puts -nonewline stdout [punk::ansi::reset] |
|
} |
|
} |
|
|
|
|
|
|
|
#fileutil::cat except with checking for windows illegal path names (when on windows platform) |
|
interp alias {} fcat {} punk::mix::util::fcat |
|
|
|
#---------------------------------------------- |
|
interp alias {} linelistraw {} punk::linelistraw |
|
|
|
# 'path' collides with kettle path in kettle::doc function - todo - patch kettle? |
|
interp alias {} PATH {} punk::path |
|
|
|
interp alias {} path_list {} punk::path_list |
|
interp alias {} list_filter_cond {} punk::list_filter_cond |
|
|
|
|
|
interp alias {} inspect {} punk::inspect |
|
interp alias {} ooinspect {} punk::ooinspect |
|
|
|
interp alias {} linedict {} punk::linedict |
|
interp alias {} dictline {} punk::dictline |
|
|
|
#todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) |
|
interp alias {} % {} punk::% |
|
interp alias {} pipeswitch {} punk::pipeswitch |
|
interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct |
|
interp alias {} pipecase {} punk::pipecase |
|
interp alias {} pipematch {} punk::pipematch |
|
interp alias {} ispipematch {} punk::ispipematch |
|
interp alias {} pipenomatchvar {} punk::pipenomatchvar |
|
interp alias {} pipedata {} punk::pipedata |
|
interp alias {} pipeset {} punk::pipeset |
|
interp alias {} pipealias {} punk::pipealias |
|
interp alias {} listset {} punk::listset ;#identical to pipeset |
|
|
|
|
|
#non-core aliases |
|
interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list |
|
interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list |
|
|
|
|
|
|
|
#interp alias {} = {} ::punk::pipeline = "" "" |
|
#interp alias {} = {} ::punk::match_assign "" "" |
|
interp alias {} .= {} ::punk::pipeline .= "" "" |
|
#proc .= {args} { |
|
# #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] |
|
# tailcall ::punk::pipeline .= "" "" {*}$args |
|
#} |
|
|
|
|
|
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 {} shellrun::runconsole 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 {} dir {} shellrun::runconsole dir |
|
|
|
# punk::nav::fs |
|
package require punk::nav::fs |
|
interp alias {} ./ {} punk::nav::fs::d/ |
|
interp alias {} ../ {} punk::nav::fs::dd/ |
|
interp alias {} d/ {} punk::nav::fs::d/ |
|
interp alias {} dd/ {} punk::nav::fs::dd/ |
|
|
|
interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different |
|
interp alias {} dirlist {} punk::nav::fs::dirlist |
|
interp alias {} dirfiles {} punk::nav::fs::dirfiles |
|
interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict |
|
|
|
interp alias {} ./new {} punk::nav::fs::d/new |
|
interp alias {} d/new {} punk::nav::fs::d/new |
|
interp alias {} ./~ {} punk::nav::fs::d/~ |
|
interp alias {} d/~ {} punk::nav::fs::d/~ |
|
interp alias "" x/ "" punk::nav::fs::x/ |
|
|
|
|
|
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} { |
|
#see also powershell runspaces etc: |
|
# powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() |
|
# $ps = [Powershell]::Create() |
|
|
|
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 {} shellrun::runconsole pwsh -nop -nolo -c ls |
|
interp alias {} psps {} shellrun::runconsole 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 |
|
} |
|
proc psencode {cmdline} { |
|
|
|
} |
|
proc psdecode {encodedcmd} { |
|
|
|
} |
|
|
|
proc repl {startstop} { |
|
switch -- $startstop { |
|
stop { |
|
if {[punk::repl::codethread::is_running]} { |
|
puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" |
|
set ::repl::done 1 |
|
} |
|
} |
|
start { |
|
if {[punk::repl::codethread::is_running]} { |
|
repl::start stdin |
|
} |
|
} |
|
default { |
|
error "repl unknown action '$startstop' - must be start or stop" |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
# -- --- --- --- |
|
#Load decks. commandset packages are not loaded until the deck is called. |
|
# -- --- --- --- |
|
package require punk::mod |
|
#punk::mod::cli set_alias pmod |
|
punk::mod::cli set_alias app |
|
|
|
#todo - change to punk::dev |
|
package require punk::mix |
|
punk::mix::cli set_alias dev |
|
punk::mix::cli set_alias deck ;#deprecate! |
|
|
|
#todo - add punk::deck for managing cli modules and commandsets |
|
|
|
package require punkcheck::cli |
|
punkcheck::cli set_alias pcheck |
|
punkcheck::cli set_alias punkcheck |
|
# -- --- --- --- |
|
|
|
package provide punk [namespace eval punk { |
|
#FUNCTL |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
|
|
|
|
|