From 2d4def515e2fcb6825612bdbe0b1afe8e76cd392 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 22 Jun 2023 05:52:32 +1000 Subject: [PATCH] patternmatch and pipeline fixes for booleans dicts and lists. Namespace navigation, env(path) display etc --- src/modules/punk-0.1.tm | 1790 ++++++++++++++++++++------ src/punk86.vfs/lib/app-punk/repl.tcl | 130 +- 2 files changed, 1482 insertions(+), 438 deletions(-) diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 877b2ad4..f9d51b1c 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -39,84 +39,7 @@ set punk_testd [dict create \ namespace eval ::repl { variable running 0 } -namespace eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running - variable known_punk_env_vars - - - variable vars - set vars [list \ - apps \ - scriptlib \ - color_stdout \ - color_stderr \ - logfile_stdout \ - logfile_stderr \ - syslog_stdout \ - syslog_stderr \ - exec_unknown \ - ] - #todo pkg punk::config - - #defaults - - dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run - dict set startup color_stdout [list cyan bold] - dict set startup color_stderr [list red bold] - dict set startup syslog_stdout "127.0.0.1:514" - dict set startup syslog_stderr "127.0.0.1:514" - #default file logs to logs folder at same location as exe if writable, or empty string - dict set startup logfile_stdout "" - dict set startup logfile_stderr "" - set exefolder [file dirname [info nameofexecutable]] - set log_folder $exefolder/logs - dict set startup scriptlib $exefolder/scriptlib - dict set startup apps $exefolder/../punkapps - if {[file exists $log_folder]} { - if {[file isdirectory $log_folder] && [file writable $log_folder]} { - dict set startup logfile_stdout $log_folder/repl-exec-stdout.txt - dict set startup logfile_stderr $log_folder/repl-exec-stderr.txt - } - } - - - #todo - load/write config file - - #env vars override the configuration - - #todo - define which configvars are settable in env - set known_punk_env_vars [list \ - PUNK_APPS \ - PUNK_SCRIPTLIB \ - PUNK_EXECUNKNOWN \ - PUNK_COLOR_STDERR \ - PUNK_COLOR_STDOUT \ - PUNK_LOGFILE_STDOUT \ - PUNK_LOGFILE_STDERR \ - PUNK_SYSLOG_STDOUT \ - PUNK_SYSLOG_STDERR \ - ] - - #override with env vars if set - variable evar - foreach evar $known_punk_env_vars { - if {[info exists ::env($evar)]} { - set f [set ::env($evar)] - if {$f ne "default"} { - #e.g PUNK_SCRIPTLIB -> scriptlib - set varname [string tolower [string range $evar 5 end]] - dict set startup $varname $f - } - } - } - unset -nocomplain evar - unset -nocomplain vars - - set running [dict create] - set running [dict merge $running $startup] -} +package require punk::config namespace eval punk { interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system @@ -127,6 +50,7 @@ namespace eval punk { control::control assert enabled 1 namespace import ::control::assert package require struct::list + package require fileutil #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) @@ -156,6 +80,7 @@ namespace eval punk { variable last_run_display [list] variable ansi_disabled 0 + variable ns_current "::" #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} proc ::punk::K {x y} { return $x} @@ -234,8 +159,75 @@ namespace eval punk { dict set output len [dict get $inf len] return $output } + namespace eval ensemble { + #wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + proc extend {routine extension} { + if {![string match ::* $routine]} { + set resolved [uplevel 1 [list ::namespace which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [namespace qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [namespace tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [namespace which namespace] current]]::$extension + } + + if {![namespace exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [namespace eval $extension [ + list [namespace which namespace] current]] + + namespace eval $extension [ + list [namespace which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[info cmdcount] + if {[namespace which $renamed] eq {}} break + } + + rename $routine $renamed + namespace eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + return $routine + } + } + + #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} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} $len || $index < 0} { + # 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 } @@ -751,7 +788,7 @@ namespace eval punk { } #leave the - from the end- as part of the offset set offset [expr $endspec] ;#don't brace! - if {$offset > 0 || abs($offset) >= $len} { + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { set action ?mismatch-list-index-out-of-range break } @@ -765,14 +802,14 @@ namespace eval punk { set action ?mismatch-not-a-list break } - if {[string is integer -strict $start]} { + 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 - } else { + } 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} { @@ -780,14 +817,14 @@ namespace eval punk { break } } - if {[string is integer -strict $end]} { + 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 - } else { + } 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} { @@ -867,6 +904,8 @@ namespace eval punk { #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 $data $args" #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 @@ -959,6 +998,9 @@ namespace eval punk { lappend var_class [list $v_key $classes] lappend varspecs_trimmed [list $vname $key] } elseif {$firstchar eq "&"} { + #we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. + #ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans + #allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. lappend var_class [list $v_key 3] set vname [string range $v 1 end] lappend varspecs_trimmed [list $vname $key] @@ -1043,11 +1085,13 @@ namespace eval punk { # # 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 already_actioned 0 ;#especially for list/dict subkeys so we don't set the default ?set action if we've already set it to something else set assigned "" #The binding spec begins at first @ or # or / @@ -1090,7 +1134,17 @@ namespace eval punk { set assigned [lrange $data $a $b] lset var_actions $i 1 ?set lset var_actions $i 2 $assigned - } elseif {$vkey in [list 0 head]} { + } elseif {$vkey eq "0"} { + if {[catch {lindex $data 0} hd]} { + lset var_actions $i 1 ?mismatch-not-a-list + lset var_actions $i 2 $data + break + } + set assigned $hd + lset var_actions $i 1 ?set + lset var_actions $i 2 $assigned + } elseif {$vkey eq "head"} { + #head is never allowed to match empty list - (vs anyhead to allow) if {[catch {lindex $data 0} hd]} { lset var_actions $i 1 ?mismatch-not-a-list lset var_actions $i 2 $data @@ -1124,6 +1178,10 @@ namespace eval punk { set assigned $dsize lset var_actions $i 1 ?set lset var_actions $i 2 $assigned + } elseif {$vkey eq "#?"} { + set assigned [string length $data] + lset var_actions $i 1 ?set + lset var_actions $i 2 $assigned } elseif {$vkey eq "@"} { #no dict key following @, this is a positional spec for list if {[catch {llength $data} len]} { @@ -1171,7 +1229,7 @@ namespace eval punk { set rawkeylist [split $vkey /] ;#first key retains @@ - may be just '@@' set keypath [string range $vkey 2 end] set keylist [split $keypath /] - if {([lindex $rawkeylist 0] ne "@@") && [lsearch $keylist @*] == -1} { + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1)} { #pure keylist for dict - process in one go #dict exists will return 0 if not a valid dict. if {[dict exists $data {*}$keylist]} { @@ -1197,40 +1255,18 @@ namespace eval punk { lset var_actions $i 1 $matchaction #todo - destructure should return more than just assigned..(?) lset var_actions $i 2 $assigned - set already_actioned 1 - } } else { # varname@x where x is positive or negative integer or zero - use x as lindex # or x is a range e.g 0-3 suitable for lrange - if {[string first "/@@" $vkey] >=0 || [string first "/#" $vkey] >= 0} { - #compound destructuring required - mix of list and dict keys - lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs - if {$matchaction eq "?match"} { - set matchaction "?set" - } - lset var_actions $i 1 $matchaction - - lset var_actions $i 2 $assigned - set already_actioned 1 - - } else { - - lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs - if {$matchaction eq "?match"} { - set matchaction "?set" - } - lset var_actions $i 1 $matchaction - lset var_actions $i 2 $assigned - set already_actioned 1 - - } - if {!$already_actioned} { - lset var_actions $i 1 ?set - lset var_actions $i 2 $assigned + lassign [destructure $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned } } else { #no vkey - whole of RHS to be applied @@ -1250,11 +1286,13 @@ namespace eval punk { incr i } + #todo - fix! this isn't the actual tclvars that were set! dict set returndict setvars $returndict_setvars - set returnval [lindex $assigned_values 0] + #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 + - #puts stdout "----> > rep returnval: [rep $returnval]" #assert all var_actions were set with leading question mark #perform assignments only if matched ok @@ -1313,28 +1351,22 @@ namespace eval punk { if {$isatom} { - #puts stdout "==>isatom $lhsspec" - set lhs [string range $lhsspec 1 end] - if {[string index $lhs end] eq "'"} { + #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] - } - if {$act eq "?set"} { - 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 - } - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info unkown-action-$act lhs $lhs rhs $val] - break - } + } + 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 + } } @@ -1358,6 +1390,8 @@ namespace eval punk { 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] @@ -1366,10 +1400,14 @@ namespace eval punk { 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 @@ -1385,6 +1423,8 @@ namespace eval punk { 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] } } @@ -1404,7 +1444,6 @@ namespace eval punk { #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 {$act eq "?set"} { if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] @@ -1476,10 +1515,8 @@ namespace eval punk { break } } - } } elseif {$isdouble} { #dragons (and shimmering) - if {$act eq "?set"} { if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] @@ -1496,60 +1533,126 @@ namespace eval punk { 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 expr-mismatch-sci lhs $lhs rhs $val] + 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 expr-mismatch-pure-digits lhs $lhs rhs $val] + 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::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 float_almost_equal-mismatch lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] break } } - } } elseif {$isbool} { - #punk::boolean_equal $a $b - if {$act eq "?set"} { + #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::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] ;#literal boolean (&yes,&false,&1,&0 etc) in the pattern - strip off & classifier prefix + 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' in pattern. (subset of legal tcl vars allowed in pattern context)" + } + #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 + } + } } - if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { - if {$ismatch} { - lset match_state $i 1 + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::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 boolean-mismatch lhs $lhs rhs $val] + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$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 boolean-badvalue lhs $lhs rhs $val] - break } - - } } elseif {$isglob} { - if {$act eq "?set"} { if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] @@ -1558,26 +1661,70 @@ namespace eval punk { } 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 "glob-mismatch" lhs $lhs rhs $val] + 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" - #unpinned non-atoms will be set- always considered a match - lset match_state $i 1 - lset var_actions $i 1 [string range $act 1 end] + #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) + # + if {$varname eq ""} { + #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] + } elseif {$varname eq "_"} { + #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] + } else { + + set first_bound [lsearch -index 0 $var_actions $varname] + #assert 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 + 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 } + set returnval [lindex $assigned_values 0] + #puts stdout "----> > rep returnval: [rep $returnval]" + + + + + #-------------------------------------------------------------------------- #Variable assignments (set) should only occur down here, and only if we have a match #-------------------------------------------------------------------------- @@ -1597,7 +1744,7 @@ namespace eval punk { set i 0 foreach va $var_actions { #set isvar [expr {[lindex $var_class $i 1] == 6}] - if {([lindex $var_class $i 1] == 6) && ([string length [set varname [lindex $var_names $i]]])} { + if {([lindex $var_class $i 1] in [list 6 3]) && ([string length [set varname [lindex $var_names $i]]])} { #isvar lassign $va lhsspec act val upvar $lvlup $varname the_var @@ -1740,6 +1887,9 @@ namespace eval punk { upvar $pipevarname the_pipe set the_pipe $args } + proc pipealias {targetcmd args} { + tailcall interp alias {} $targetcmd {} {*}$args + } #same as used in unknown func for initial launch #variable re_assign {^([^\r\n=\{]*)=(.*)} @@ -1757,19 +1907,28 @@ namespace eval punk { # #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 $scopepattern $equalsrhs] { if {[llength $args]} { - #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists - if {[lsearch $args "|*>"] >=0 || [lsearch $args "<*|"] >= 0} { - #defer to pipeline command for all pipelines. - tailcall punk::pipeline = "" "" {*}$args - } else { - if {[llength $args] == 1} { - set segmenttail [lindex $args 0] - } else { - error "pipesyntax = must take a single argument" + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + foreach a $args { + if {![catch {llength $a} sublen]} { + if {$sublen == 1} { + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = "" "" {*}$args + } + } } } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipesyntax = must take a single argument" + } } else { #set segmenttail [purelist] set segmenttail [lreplace x 0 0] @@ -1798,16 +1957,15 @@ namespace eval punk { foreach v_pos $var_position_list { lassign $v_pos v positionspec - set offset 0 if {[string index $v 0] eq "'"} { set positionspec [string trimright $positionspec "*"] set ptype [string index $positionspec 0] set index [string range $positionspec 1 end] set isint [string is integer -strict $index] - if {$isint || [string match "end*" $index]} { + if {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { set v [string range $v 1 end-1] ;#assume trailing ' is present! if {$ptype eq "@"} { - #compare position to *original* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + #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 $index] { if {( > [llength $segmenttail])} { @@ -1818,31 +1976,33 @@ namespace eval punk { #todo check end-x bounds? } if {$isint} { - #set segmenttail [linsert $segmenttail $index+$offset $v] - append script [string map [list $v [expr {$index + $offset}]] { + #set segmenttail [linsert $segmenttail $index+$offset $v] ?? (offset concept is dubious) + # + append script [string map [list $v $index] { #set segmenttail [linsert $segmenttail ] set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] }] } else { - #todo - review/test! - set endindex [string range $index 4 end] - if {[string length $endindex]} { - incr endindex -$offset - set idx "end-$endindex" - } else { - set idx "end" - } #set segmenttail [linsert $segmenttail $idx $v] - append script [string map [list $v $idx] { + append script [string map [list $v $index] { #set segmenttail [linsert $segmenttail ] #use inline K to make sure the list is unshared (optimize for larger lists) set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] }] } - incr offset + } elseif {[string first - $index]} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + set value [string range $v 1 end-1] ;#assume trailing ' is present! + #also - range checks for @ which must go into script !!! + append script [string map [list $value $start $end] { + set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" + } } else { - error "pipesyntax error in segment insertionpattern - v $v unable to interpret position spec" + error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" } } } @@ -1884,14 +2044,30 @@ namespace eval punk { # to substitute to lsearch -inline {a b c d} b* proc _split_equalsrhs {insertionpattern} { set var_position_list [punk::_split_patterns $insertionpattern] + set i 0 foreach v_pos $var_position_list { lassign $v_pos v positionspec - if {![string length $positionspec]} { - error "pipesyntax error in segment insertionpattern $insertionpattern - v $v missing position spec e.g /0" - } - if {[string index $positionspec 0] ni [list "/" "@"]} { - error "pipesyntax error in segment insertionpattern $insertionpattern - v $v bad position spec $positionspec" + if {($positionspec in [list "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { + set star "" + if {$v eq "*"} { + set v "" + set star "*" + } + if {[string index $positionspec end] eq "*"} { + set star "*" + } + #it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent + #as are /end and @end + lset var_position_list $i [list $v "/end$star"] + } else { + if {$positionspec eq ""} { + error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" + } + if {[string index $positionspec 0] ni [list "/" "@"]} { + error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad position spec '$positionspec'" + } } + incr i } return $var_position_list } @@ -1910,7 +2086,7 @@ namespace eval punk { #todo - option to disable these traces which provide clarifying errors (performance hit?) proc pipeline_args_read_trace_error {args} { - error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data instead of \$args." + 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." } @@ -2170,11 +2346,12 @@ namespace eval punk { set script_like_first_word 0 set rhs $equalsrhs - set segment_members_script_index [list] + set segment_first_is_script 0 ;#default assumption until tested + set segment_first_word [lindex $segment_members 0] if {$segment_op ne "="} { if {[arg_is_script_shaped $segment_first_word]} { - set segment_members_script_index 0 + set segment_first_is_script 1 } } else { if {[llength $segment_members] > 1} { @@ -2206,9 +2383,9 @@ namespace eval punk { debug.punk.pipe {[a+ yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a+]} 4 debug.punk.pipe {[a+ yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a+]} 4 debug.punk.pipe {[a+] inpipespec(prev [a+ yellow bold]|$pipespec($i,in)[a+]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a+])} 4 - debug.punk.pipe {[a+ cyan bold] segment_members_script_index:$segment_members_script_index} 4 - if {[llength $segment_members_script_index]} { - debug.punk.pipe {[a+ cyan bold] script segment: [lindex $segment_members $segment_members_script_index][a+]} 4 + 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 } @@ -2299,28 +2476,32 @@ namespace eval punk { foreach v_pos $insertion_patterns { lassign $v_pos v positionspec ;#v may be atom, or varname (in pipeline scope) #julz - set offset 0 if {[string index $v 0] eq "'"} { set v [string range $v 1 end-1] ;#assume trailing ' is present! + set getv $v } else { if {$v eq ""} { set v "data" } if {[dict exists $dict_tagval $v]} { set v [dict get $dict_tagval $v] + set getv "\$$v" } else { error "insertionpattern varname $v not present in pipeline context" } } + #append script [string map [list $getv]{ + # + #}] #maintenance - index logic should be identical to to match_assign - which only needs to process atoms because it delegates all pipeline ops here, so no vars available (single segment assign) set positionspecatomic [string trimright $positionspec "*"] set do_expand [expr {[string index $positionspec end] eq "*"}] ;#only applies to vars - as atoms don't have whitespace (review a proc can have whitespce - but it's harder to call.. atoms probably best kept simple) set ptype [string index $positionspecatomic 0] set index [string range $positionspecatomic 1 end] set isint [string is integer -strict $index] - if {$isint || [string match "end*" $index]} { + if {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { if {$ptype eq "@"} { - #compare position to *original* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + #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 $index] { if {( > [llength $segmenttail])} { @@ -2335,44 +2516,72 @@ namespace eval punk { #todo check end-x bounds? } if {$isint} { - #set segmenttail [linsert $segmenttail $index+$offset $v] #todo - expansion! - append script [string map [list $v [expr {$index + $offset}]] { + append script [string map [list $getv $index] { #set segmenttail [linsert $segmenttail ] - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] }] #temp - scriptalternative if {$do_expand} { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index+$offset {*}$v] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index {*}$v] } else { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index+$offset $v] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index $v] } } else { - #todo - review/test! - set endindex [string range $index 4 end] - if {[string length $endindex]} { - incr endindex -$offset - set idx "end-$endindex" - } else { - set idx "end" - } #set segmenttail [linsert $segmenttail $idx $v] #todo - expansion! - append script [string map [list $v $idx] { + append script [string map [list $getv $index] { #set segmenttail [linsert $segmenttail ] #use inline K to make sure the list is unshared (optimize for larger lists) - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] ] }] #temp - scriptalternative if {$do_expand} { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $idx {*}$v] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index {*}$v] } else { - set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $idx $v] + set segmenttail [linsert [lindex [list $segmenttail [unset segmenttail]] 0] $index $v] } } - incr offset + } elseif {[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]} { + #dragons? + #julz + #also - range checks for @ which must go into script !!! + #todo - disallow disordered specs such as: end-1-end-5 even though lreplace seems to accept them + + #TESTS! + #atoms? + if {$do_expand} { + set val {{*}} + append val $getv + } else { + set val $getv + } + + append script [string map [list $getv $start $end] { + set rangelen [llength [lrange ]] + }] + set rangelen [llength [lrange $v $start $end]] + + append script [string map [list $val $start $end] { + set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] ] + }] + + + if {$do_expand} { + #todo - + set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] $start $end {*}$v] + } else { + set segmenttail [lreplace [lindex [list $segmenttail [unset segmenttail]] 0] $start $end $v] + } + + + + } else { + error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" + } } else { - error "pipesyntax error in segment insertionpattern - v $v unable to interpret position spec" + error "pipesyntax error in segment insertionpattern - v '$v' positionspec:'$positionspec' unable to interpret position spec" } } set segment_members_filled $segmenttail @@ -2387,7 +2596,7 @@ namespace eval punk { # script index could have changed!!! todo fix! #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) - if {(![llength $segment_members_script_index]) && $segment_op eq ".="} { + 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 @@ -2405,6 +2614,12 @@ namespace eval punk { } 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 @@ -2424,15 +2639,17 @@ namespace eval punk { set segment_result [_handle_bind_result $d] - } elseif {[llength $segment_members_script_index] || $segment_op eq "script"} { + } 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 $segment_members_script_index] ;#default. May have pre_script prepended later + + 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 "argsdata"} { + 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 } @@ -2442,42 +2659,49 @@ namespace eval punk { 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 1 - if {[dict exists $dict_tagval "%argsdata%"]} { - set argsdatalist [dict get $dict_tagval "%argsdata%"] + 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 argsdata read punk::pipeline_args_read_trace_error\n" + 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 if {!$add_argsdata} { - debug.punk.pipe {APPLY1: args:$segmentargnames} 4 + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 #puts stderr " script: $script" #puts stderr " vals: $segmentargvals" - #set evaluation [apply [list $segmentargnames $script ::] {*}$segmentargvals] set evaluation [uplevel 1 [list apply [list $segmentargnames $script ::] {*}$segmentargvals]] } else { - debug.punk.pipe {APPLY2: args:$segmentargnames} 4 + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 #puts stderr " script: $script" #puts stderr " vals: $segmentargvals $argsdatalist" - #set evaluation [apply [list [concat $segmentargnames argsdata] $script ::] {*}$segmentargvals $argsdatalist] #pipeline script context should be one below calling context - so upvar v v will work - set evaluation [uplevel 1 [list apply [list [concat $segmentargnames argsdata] $script ::] {*}$segmentargvals $argsdatalist]] + set evaluation [uplevel 1 [list apply [list [concat $segmentargnames args] $script ::] {*}$segmentargvals {*}$argsdatalist]] } debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 #puts "---> rep script evaluation result: [rep $evaluation]" - #set forward_result $evaluation #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] - set d [_multi_bind_result $returnvarspec [lindex [list $evaluation [unset evaluation]] 0]] + + #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 ? @@ -2555,7 +2779,6 @@ namespace eval punk { set pipespec($j,out) $outpipespec - set segment_members_script_index [list] set script_like_first_word 0 if {[llength $tailremaining] || $next_pipe_posn >= 0} { @@ -2574,10 +2797,11 @@ namespace eval punk { set returnvarspec "" ;# the lhs of x=y set segment_op "" set rhs "" + set segment_first_is_script 0 if {[llength $next_all_members]} { if {[arg_is_script_shaped [lindex $next_all_members 0]]} { set segment_first_word [lindex $next_all_members 0] - set segment_members_script_index 0 + set segment_first_is_script 1 set segment_op "" set segment_members $next_all_members } else { @@ -2588,7 +2812,7 @@ namespace eval punk { set segment_first_word [lindex $next_all_members 1] set script_like_first_word [arg_is_script_shaped $segment_first_word] if {$script_like_first_word} { - set segment_members_script_index 0 ;#relative to segment_members which no longer includes the .= + 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]} { @@ -2629,6 +2853,17 @@ namespace eval punk { set previous_result $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 } @@ -2643,6 +2878,60 @@ namespace eval punk { #return $forward_result } + + #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}] + } + 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 (?) @@ -2720,12 +3009,18 @@ namespace eval punk { know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0 0] -> from to]} {punk::range $from $to} - proc ::punk::_unknown_assign_dispatch {partzerozero varspecs rhs args} { + proc ::punk::_unknown_assign_dispatch {partzerozero 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 $partzerozero} { - regexp $punk::re_assign $hd _ varspecs rhs + 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 } - tailcall ::punk::match_assign $varspecs $rhs {*}$tail + tailcall ::punk::match_assign $pattern $equalsrhs {*}$tail #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] } #variable re_assign {^([^\r\n=\{]*)=(.*)} @@ -2734,7 +3029,7 @@ namespace eval punk { #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=\{]*)\=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall ::punk::_unknown_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^ \t\r\n=\{]*)\=([^ \t\r\n]*)} [lindex $args 0 0] partzerozero pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $partzerozero $pattern $equalsrhs {*}$args} #variable re_assign {^([^\r\n=\{]*)=(.*)} #know {[regexp $punk::re_assign [lindex $args 0 0] partzerozero varspecs rhs]} { @@ -2788,26 +3083,27 @@ namespace eval punk { # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] # } # - proc ::punk::_unknown_dot_assign_dispatch {partzerozero varspecs rhs args} { + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { set argstail [lassign $args hd] - expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } - return [uplevel 1 [list ::punk::pipeline .= $varspecs $rhs {*}$tail]] - #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' - puts ")) $result" - return $result - } else { - if {$first2wordsorless eq {binding mismatch}} { - puts "))) $result" - error $result - } else { - #puts >>2>[rep $result] - puts ")))) $result" - return $result + #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 } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + } #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} @@ -2906,13 +3202,21 @@ namespace eval punk { 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] + } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} + 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::% unable to interpret pipeline '$args'" + } } else { set cmdlist $args - #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] } if {[catch {uplevel 1 $cmdlist} result]} { @@ -2920,7 +3224,7 @@ namespace eval punk { if {[string match "binding mismatch*" $result]} { #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch #return [dict create error [dict create mismatch $result]] - puts stderr "pipematch converting error to {error {mismatch }}" + #puts stderr "pipematch converting error to {error {mismatch }}" return [list error [list mismatch $result]] } if {[string match "pipesyntax*" $result]} { @@ -3018,13 +3322,15 @@ namespace eval punk { } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} #set re_equals {^([^ \t\r\n=\{]*)=$} - if {[regexp {^([^ \t\r\n=]*)\.=$} $assign _ returnvarspecs]} { + 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] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { error "pipesyntax punk::% unable to interpret pipeline '$args'" } + #todo - account for insertion-specs e.g x=* x.=/0* } else { #script? set cmdlist [list ::punk::pipeline .= "" "" {*}$args] @@ -3083,7 +3389,7 @@ namespace eval punk { } #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 affecting it, but is less performant. (particularly in global scope.. but that isn't an important usecase) + #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 isn't an important usecase) proc pipeswitchc {pipescript args} { set binding {} if {[info level] == 1} { @@ -3105,8 +3411,62 @@ namespace eval punk { 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] + if {[catch {llength $e} seglen]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + if {$e eq {>}} { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } elseif {$e in {% 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] + } elseif {$e in [list 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] + } else { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } - + #todo - implement colour resets like the perl module: + #https://metacpan.org/pod/Text::ANSI::Util + #(saves up all ansi color codes since previus color reset and replays the saved codes after our highlighting is done) proc ansi+ {args} { variable ansi_disabled if {$ansi_disabled == 1} { @@ -3237,28 +3597,78 @@ namespace eval punk { return [file dirname [punk::winpath $path]] } + #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] {expr {[string length $item] && [string match $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] + set attrinfo [file attributes $a2] + 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 } - - #double-evaluation to get true/fals + #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] if {[llength $args] == 1} { #equivalent of -n STRING - return [expr {[string length $a1] != 0}] + set boolresult [expr {[string length $a1] != 0}] } elseif {[llength $args] == 2} { switch -- $a1 { -b { @@ -3266,132 +3676,213 @@ namespace eval punk { #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' #Linux apparently uses them though if{[file exists $a2]} { - if {[file type $a2] eq "blockSpecial"} { - return true - } else { - return false - } + set boolresult [expr {[file type $a2] eq "blockSpecial"}] } else { - return false + set boolresult false } } -c { #e.g on windows CON,NUL if {[file exists $a2]} { - if {[file type $a2] eq "characterSpecial"} { - return true - } else { - return false - } + set boolresult [expr {[file type $a2] eq "characterSpecial"}] } else { - return false + set boolresult false } } -d { - return [file isdirectory $a2] + set boolresult [file isdirectory $a2] } -e { - return [file exists $a2] + set boolresult [file exists $a2] } -f { #e.g on windows CON,NUL if {[file exists $a2]} { - if {[file type $a2] eq "file"} { - return true - } else { - return false - } + set boolresult [expr {[file type $a2] eq "file"}] } else { - return false + set boolresult false } } -h - -L { - return [expr {[file type $a2] eq "link"}] + set boolresult [expr {[file type $a2] eq "link"}] } -s { - if {[file exists $a2] && ([file size $a2] > 0 )} { - return true - } else { - return false - } + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] } -S { if {[file exists $a2]} { - if {[file type $a2] eq "socket"} { - return true - } else { - return false - } + set boolresult [expr {[file type $a2] eq "socket"}] } else { - return false + set boolresult false } } -x { - if {[file exists $a2] && [file executable $a2]} { - return true - } else { - return false - } + set boolresult [expr {[file exists $a2] && [file executable $a2]}] } -w { - if {[file exists $a2] && [file writable $a2]} { - return true - } else { - return false - } + set boolresult [expr {[file exists $a2] && [file writable $a2]}] } -z { - return [expr {[string length $a2] == 0}] + set boolresult [expr {[string length $a2] == 0}] } -n { - return [expr {[string length $a2] != 0}] + set boolresult [expr {[string length $a2] != 0}] } default { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + 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 { "=" { - return [string equal $a1 $a3] + #test does string comparisons + set boolresult [string equal $a1 $a3] } "!=" { - return [expr {$a1 ne $a3}] + #string comparison + set boolresult [expr {$a1 ne $a3}] } "-eq" { - if {![string is integer -strict $a1]} { + #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 {![string is integer -strict $a3]} { + if {![is_sh_test_integer $a3]} { puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 return false } - return [expr {$a1 == $a3}] + set boolresult [expr {$a1 == $a3}] } "-ge" { - return [expr {$a1 >= $a3}] + 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" { - return [expr {$a1 > $a3}] + 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" { - return [expr {$a1 <= $a3}] + 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" { - return [expr {$a1 < $a3}] + 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" { - return [expr {$a1 != $a3}] + 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 { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + 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 { - tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args + 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 @@ -3418,12 +3909,169 @@ namespace eval punk { } #------------------------------------------------------------------- - namespace export help aliases alias cdwin cdwindir winpath windir app + namespace export help aliases alias cdwin cdwindir dirfiles dirfiles_dict exitcode winpath windir % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines is_list_all_in_list is_list_all_ni_list val treemore namespace ensemble create + proc nslist_dict {{glob "*"}} { + variable ns_current ;#keep fully qualified ie :: or ::etc + set glob_is_absolute [expr {[string match ::* $glob]}] + set nsquals [namespace qualifiers $glob] + if {[string length $nsquals]} { + if {$glob_is_absolute} { + set fqpath $nsquals + } else { + set fqpath ${ns_current}::${nsquals} + } + } else { + if {$glob_is_absolute} { + set fqpath :: + } else { + set fqpath $ns_current + } + } + puts stderr ">>fqpath $fqpath" + set nstail [namespace tail $glob] + if {[string first ? $nstail] >= 0 || [string first * $nstail] >=0} { + set location $fqpath + set glob $nstail + } else { + if {$fqpath eq "::"} { + set location ::${nstail} + } else { + if {[string length $nstail]} { + set location ${fqpath}::${nstail} + } else { + set location ${fqpath} + } + } + set glob * + } + + set allchildren [namespace children $location] ; #only returns 1 level deeper + set commands [.= nscommands ${location}::$glob |> linelist ] + set allexported [namespace eval $location {::namespace export}] + set allprocs [namespace eval $location {::info procs}] + set tails [lmap v $allchildren {namespace tail $v}] + if {$glob ne "*"} { + set tailmatches [lsearch -all -inline $tails $glob] + set fqchildren [lmap v $tailmatches {lindex ${location}::$v}] ;#lindex without indices is fast equivalent of 'val' + set exported [lsearch -all -inline $allexported $glob] + set procs [lsearch -all -inline $allprocs $glob] + } else { + set tailmatches $tails + set fqchildren $allchildren + set exported $allexported + set procs $allprocs + } + + + + return [list children [lsort $tailmatches] commands $commands procs $procs exported $exported location $location glob $glob] + + } + + proc nslist {{glob ""}} { + #2 columns for namespaces 4 for commands/procs - todo make less duplicated - generalize to specified number of columns for each? + package require overtype + set contents [nslist_dict $glob] + set ns [dict get $contents location] + set children [dict get $contents children] + set commands [dict get $contents commands] + set exported [dict get $contents exported] + set procs [dict get $contents procs] + + set numchildren [llength $children] + if {$numchildren} { + set mid [expr {int(ceil($numchildren/2.0))}] + set children1 [lrange $children 0 $mid-1] + set children2 [lrange $children $mid end] + } else { + set children1 [list] + set children2 [list] + } + + set numcommands [llength $commands] + if {$numcommands} { + set split1 [expr {int(ceil($numcommands/4.0))}] + set commands1 [lrange $commands 0 $split1-1] + set remaining3 [lrange $commands $split1 end] + + set numremaining3 [llength $remaining3] + set split2 [expr {int(ceil($numremaining3/3.0))}] + set commands2 [lrange $remaining3 0 $split2-1] + set remaining2 [lrange $remaining3 $split2 end] + + set numremaining2 [llength $remaining2] + set mid [expr {int(ceil($numremaining2/2.0))}] + set commands3 [lrange $remaining2 0 $mid-1] + set commands4 [lrange $remaining2 $mid end] + + } else { + set commands1 [list] + set commands2 [list] + set commands3 [list] + set commands4 [list] + } + + + + set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + + set cmdwidest1 [pipedata [list {*}$commands1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set cmdwidest2 [pipedata [list {*}$commands2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set cmdwidest3 [pipedata [list {*}$commands3 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set cmdwidest4 [pipedata [list {*}$commands4 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + + set displaylist [list] + set col1 [string repeat " " [expr {$chwidest1 + 2}]] + set col2 [string repeat " " [expr {$chwidest2 + 2}]] + set col3 [string repeat " " [expr {$cmdwidest1 + 2}]] + set col4 [string repeat " " [expr {$cmdwidest2 + 2}]] + set col5 [string repeat " " [expr {$cmdwidest3 + 2}]] + foreach ch1 $children1 ch2 $children2 cmd1 $commands1 cmd2 $commands2 cmd3 $commands3 cmd4 $commands4 { + set a1 [a+ cyan] + set c1 [a+ white] + set c2 [a+ white] + set c3 [a+ white] + set c4 [a+ white] + if {[string length $cmd1]} { + if {$cmd1 in $exported} { + set c1 [a+ green bold] + } elseif {$cmd1 ni $procs} { + set c1 [a+ red bold] + } + } + if {[string length $cmd2]} { + if {$cmd2 in $exported} { + set c2 [a+ green bold] + } elseif {$cmd2 ni $procs} { + set c2 [a+ red bold] + } + } + if {[string length $cmd3]} { + if {$cmd3 in $exported} { + set c3 [a+ green bold] + } elseif {$cmd3 ni $procs} { + set c3 [a+ red bold] + } + } + if {[string length $cmd4]} { + if {$cmd4 in $exported} { + set c4 [a+ green bold] + } elseif {$cmd4 ni $procs} { + set c4 [a+ red bold] + } + } + lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] + } + + return [list_as_lines $displaylist] + } + #todo - in thread #todo - streaming version - proc dirfiles_lists {{glob ""}} { + proc dirfiles_dict {{glob ""}} { set dir [pwd] if {$glob eq ""} { set glob "*" @@ -3431,7 +4079,7 @@ namespace eval punk { set dirname [file dirname $glob] ;# for * or something* will return just "." which is ok set ftail [file tail $glob] - if {[string first ? $glob] >= 0 || [string first * $glob] >=0} { + if {[string first ? $ftail] >= 0 || [string first * $ftail] >=0} { #has globchar (we only recognise in tail) set location $dirname set glob $ftail @@ -3440,36 +4088,104 @@ namespace eval punk { set glob * } + #also determine whether vfs. file system x is *much* faster than file attributes + set vfs [list] ;#dict keyed on dir/file name set dirs [glob -nocomplain -directory $location -type d -tail $glob] + foreach d $dirs { + if {[lindex [file system $d] 0] eq "tclvfs"} { + lappend vfs $d [file system $d] + } + } + set files [glob -nocomplain -directory $location -type f -tail $glob] - return [list dirs $dirs files $files] + return [list dirs $dirs vfs $vfs files $files location $location] } proc dirfiles {{glob ""}} { package require overtype - set contents [dirfiles_lists $glob] + set contents [dirfiles_dict $glob] set dirs [dict get $contents dirs] set files [dict get $contents files] + set vfs [dict get $contents vfs] - set widest 4 - foreach d $dirs { - set w [string length $d] - if {$w > $widest} { - set widest $w - } - } + set widest [pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] set displaylist [list] set col1 [string repeat " " [expr {$widest + 2}]] foreach d $dirs f $files { - lappend displaylist [overtype::left $col1 $d]$f + set a1 [a+ cyan] + set a2 [a+] + if {[string length $d]} { + if {[dict exists $vfs $d]} { + set a1 [a+ red bold] + set a2 [a+] + } + } + lappend displaylist $a1[overtype::left $col1 $d]$a2$f } return [list_as_lines $displaylist] } + #experimental... leading colon makes it hard (impossible?) to call directly + proc ns/ {args} { + variable ns_current + if {![llength $args]} { + set out [punk::nslist $ns_current] + #todo - cooperate with repl + # + append out "\n$ns_current" + return $out + } else { + set atail [lassign $args a1] + if {$a1 in [list :: ""]} { + set ns_current :: + tailcall punk::ns/ {*}$atail + } + set is_absolute [string match ::* $a1] + if {$is_absolute} { + if {[namespace exists $a1]} { + set ns_current $a1 + tailcall punk::ns/ {*}$atail + } + error "cannot change to namespace $a1" + } else { + if {$ns_current eq "::"} { + set nsnext ::$a1 + } else { + set nsnext ${ns_current}::$a1 + } + if {[namespace exists $nsnext]} { + set ns_current $nsnext + tailcall punk::ns/ {*}$atail + } else { + error "cannot change to namespace $nsnext" + } + } + } + } + interp alias {} :/ {} punk::ns/ + proc nsback/ {args} { + variable ns_current + if {$ns_current eq "::"} { + puts stderr "Already at global namespace '::'" + } else { + set out "" + set nsq [namespace qualifiers $ns_current] + if {$nsq eq ""} { + set ns_current "::" + #don't output commandlist every time we move back there.. + } else { + set out [punk::nslist $ns_current] + set ns_current $nsq + } + append out "\n$ns_current" + return $out + } + } + interp alias {} ::/ {} punk::nsback/ + #tailcall is important - #TODO - fix. conflicts with Tk toplevel command "." proc ./ {args} { set ::punk::last_run_display [list] @@ -3481,16 +4197,17 @@ namespace eval punk { if {![llength $args]} { #ls is too slow even over a fairly low-latency network #set out [runout -n ls -aFC] - set out [punk::dirfiles] - - #puts stdout $out - #puts stderr [a+ white]$out[a+] set result [pwd] - set chunklist [list] - lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] - lappend chunklist [list result $result] - set ::punk::last_run_display $chunklist if {$::repl::running} { + set out [punk::dirfiles] + + #puts stdout $out + #puts stderr [a+ white]$out[a+] + set chunklist [list] + lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] + lappend chunklist [list result $result] + set ::punk::last_run_display $chunklist + repl::term::set_console_title [file normalize $result] } return $result @@ -3569,6 +4286,49 @@ namespace eval punk { join $list $joinchar } + 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 is_list_all_in_list {a b} { + package require struct::list + package require struct::set + set a_in_b [lsort [struct::set intersect $a $b ]] + return [struct::list equal [lsort $a] $a_in_b] + } + proc is_list_all_ni_list {a b} { + package require struct::set + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + proc ls {args} { if {![llength $args]} { set args [list [pwd]] @@ -3660,6 +4420,16 @@ namespace eval punk { return $linelist } + #e.g linesort -decreasing $data + proc linesort {args} { + set lines [lindex $args end] + if {[llength $args] > 1} { + set opts [lrange $args 0 end-1] + } else { + set opts [list] + } + .= list $lines |@0,sortopts/1> linelist |> .=data/1,sortopts/1* lsort |> list_as_lines <| {*}$opts + } #!!!todo fix - linedict is unfinished and non-functioning #linedict based on indents @@ -3732,6 +4502,143 @@ namespace eval punk { return $lines } + + proc pdict {d args} { ;# analogous to parray (except that it takes the dict as a value) + #set maxl [::tcl::mathfunc::max {*}[map {string length} [dict keys $d]]] + #maxl.= $d |@keys> .=/2 lmap v {string length $v} |> .=* tcl::mathfunc::max + set maxl [pipedata $d {dict keys $data} {list {*}$data ""} {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data} ] + dict for {key value} $d { + puts stdout [format "%-*s = %s" $maxl $key $value] + } + } + + proc corp name { + #thanks to Richard Suchenwirth - wiki.tcl-lang.org/page/corp + if {[info exists ::auto_index($name)]} { + set body "# $::auto_index($name)\n" + } else {set body ""} + set upns [uplevel 1 [list namespace current]] + if {$upns eq "::"} { + set upns "" + } + append body [info body ${upns}::$name] + set argl {} + foreach a [info args ${upns}::$name] { + if {[info default ${upns}::$name $a def]} { + lappend a $def + } + lappend argl $a + } + list proc ${upns}::$name $argl $body + } + + 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 + }] + if {"class" in $isa} { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + if {"object" in $isa} { + 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 {?*} + } + + + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 50 -channel stderr] + 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 --" + } + } + + set opts [dict merge $defaults $flags] + set label [dict get $opts -label] + set channel [dict get $opts -channel] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + } + set displayval $val ;#default - may be overridden based on -limit + if {![catch {llength $val} llen]} { + #val is a list + 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 lines [split $val \n] + set lines [lrange $lines 0 $limit-1] + set displayval [join $lines \n] + if {$llen > $limit} { + set more "\n..." + } + } + + } + if {![string length $more]} { + puts $channel "[a+ green bold]$label$displayval[a+]" + } else { + puts $channel "[a+ green bold]$label$displayval[a+][a+ yellow bold]$more[a+]" + } + return $val + } + + + #return list of {chan chunk} elements proc help_chunks {} { set chunks [list] @@ -3764,6 +4671,10 @@ namespace eval punk { append text "Punk commands:\n" append text "punk help\n" lappend chunks [list stdout $text] + + if {[punkrepl::has_script_var_bug]} { + append text "Has script var bug! (string rep for list variable in script generated when script changed)" + } return $chunks } proc help {} { @@ -3773,30 +4684,6 @@ namespace eval punk { puts -nonewline $chan $text } } - proc app {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] - if {[file exists $apps_folder]} { - if {[file exists $apps_folder/$glob]} { - tailcall source $apps_folder/$glob/main.tcl - } - set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] - if {[llength $apps] == 0} { - if {[string first * $glob] <0 && [string first ? $glob] <0} { - #no glob chars supplied - only launch if exact match for name part - set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - if {[llength $namematches] > 0} { - set latest [lindex $namematches end] - lassign $latest nm ver - tailcall source $apps_folder/$latest/main.tcl - } - } - } - - return $apps - } - } #current interp aliases except those created by pattern package '::p::*' proc aliases {{glob *}} { #todo - way to configure and query what aliases are hidden @@ -3825,12 +4712,18 @@ namespace eval punk { puts -nonewline stderr $aliaslist return } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { set aliaslist [punk aliases $aliasorglob] puts -nonewline stderr $aliaslist return } - return [interp alias "" $aliasorglob] + return [list] } } @@ -3872,13 +4765,27 @@ namespace eval punk { interp alias {} aliases {} punk aliases interp alias {} alias {} punk alias interp alias {} treemore {} punk::xmore tree + interp alias {} fcat {} fileutil::cat #---------------------------------------------- interp alias {} linelistraw {} punk::linelistraw interp alias {} linelist {} punk::linelist ;#critical for = assignment features + interp alias {} linesort {} punk::linesort + interp alias {} path {} punk::path + interp alias {} path_list {} punk::path_list + interp alias {} list_as_lines {} punk::list_as_lines + interp alias {} list_filter_cond {} punk::list_filter_cond + interp alias {} is_list_all_in_list {} punk::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::is_list_all_ni_list + interp alias {} corp {} punk::corp + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + interp alias {} pdict {} punk::pdict + 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 @@ -3886,35 +4793,34 @@ namespace eval punk { 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 - interp alias {} nscommands {} ,'ok@0.= { + + interp alias {} nscommands {} ,'ok'@0.= { upvar caseresult caseresult - if {![info exists ns]} { - set ns "" - } #by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope # (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster ) pipeswitch { #no glob chars present pipecase \ - caseresult.= val $ns |input> \ + caseresult= $ns |input> \ 1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { uplevel #0 [list info commands ${input}::*] } #pipecase1 ns has one or more of glob chars * or ? pipecase \ - caseresult.= val $ns |input> { + caseresult= $ns |input> { uplevel #0 [list info commands ${input}] } } - } |data@@ok/result> {set data} |> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} f .. Method reduce {func sequence} { + struct::list::Lfold [lrange $sequence 1 end] [lindex $sequence 0] $func + } >f .. Method list_map {commandlist list} { tailcall lmap item $list $commandlist } @@ -3976,7 +4887,37 @@ namespace eval punk { set list [concat {*}$args] join $list \n } - >f .. Method list_filter_expr {} {} + >f .. Method list_filter_cond {itemcond listval} { + #maintenance - proc list_filter_cond + 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 + } >f .. Method sum_llength {total listval} { expr {$total + [llength $listval]} @@ -4008,8 +4949,25 @@ namespace eval punk { - #example of aliasing a punk pipeline - interp alias {} _commands {} .=info commands punk::%glob% |> .=lmap v %data% {namespace tail $v} .= { + if {$glob eq ""} { + set glob * + } + set glob + } |glob> .= {info commands punk::$glob} \ + |> .=/2 lmap v {namespace tail $v} |> lsort |> list_as_lines |> .=data/1,tail/end* pipedata {lmap v $data {uplevel 1 [list expr $v]}} <| + proc ::expr* args {lmap v $args {uplevel 1 [list expr $v]}} + + #---------------------------------------------- #leave the winpath related aliases available on all platforms @@ -4031,6 +4989,8 @@ namespace eval punk { 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 @@ -4043,7 +5003,12 @@ namespace eval punk { interp alias {} ./ {} punk::./ interp alias {} ../ {} punk::../ interp alias {} dirfiles {} punk::dirfiles + interp alias {} dirfiles_dict {} punk::dirfiles_dict interp alias {} df {} punk::dirfiles + + #namespace/command/proc query + interp alias {} nslist {} punk::nslist + interp alias {} nslist_dict {} punk::nslist if {$::tcl_platform(platform) eq "windows"} { set has_powershell 1 @@ -4076,4 +5041,21 @@ namespace eval punk { interp alias {} psps {} puts stderr $ps_missing } + #interp alias {} punkmod {} punk::mod::cli + proc punkmod {args} { + if {![llength $args]} { + tailcall punk::mod::cli help + } else { + tailcall punk::mod::cli {*}$args + } + } + interp alias {} punkmod {} punk::punkmod + } +package require punk::mod +package require punk::mix +punk::mix::clicommands set_alias punkmix + + + + diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index b798917f..493a74a2 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -5,6 +5,9 @@ namespace eval punkrepl { } +#list/string-rep bug +global run_commandstr "" + set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. @@ -67,6 +70,27 @@ namespace eval repl { namespace eval punkrepl { variable debug_repl 0 + + proc has_script_var_bug {} { + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep1] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + } @@ -118,7 +142,6 @@ interp alias {} smcup {} ::repl::term::screen_push_alt interp alias {} rmcup {} ::repl::term::screen_pop_alt - set outdevice [shellfilter::stack::new punkout -settings [list -tag "punkout" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stdout] -file [dict get $::punk::config::running logfile_stdout]]] set out [dict get $outdevice localchan] set errdevice [shellfilter::stack::new punkerr -settings [list -tag "punkerr" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stderr] -file [dict get $::punk::config::running logfile_stderr]]] @@ -150,7 +173,7 @@ set err [dict get $errdevice localchan] # command, including the command name. proc ::unknown args { - + #puts stderr "unk>$args" variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode @@ -533,6 +556,7 @@ proc repl::doprompt {prompt {col {green bold}}} { } proc repl::get_prompt_config {} { if {$::tcl_interactive} { + #todo make a+ stacking set resultprompt "[a+ green bold]-[a+] " set infoprompt "[a+ green bold]*[a+] " set debugprompt "[a+ purple bold]~[a+] " @@ -544,12 +568,12 @@ proc repl::get_prompt_config {} { return [list resultprompt $resultprompt infoprompt $infoprompt debugprompt $debugprompt] } proc repl::start {inchan} { - variable command + variable commandstr variable running variable reading variable done set running 1 - set command "" + set commandstr "" set prompt_config [get_prompt_config] doprompt "P% " fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] @@ -729,7 +753,6 @@ proc repl::newout2 {} { # rputs deliberately doesn't check screen_last_chars before emitting data (unless reporting an error in rputs itself) proc repl::rputs {args} { variable screen_last_chars - variable last_out_was_newline variable last_repl_char @@ -810,6 +833,7 @@ proc repl::screen_needs_clearance {} { proc repl::repl_handler {inputchan prompt_config} { variable prompt_reset_flag + #catch {puts stderr "xx--->[rep $::arglej]"} if {$prompt_reset_flag == 1} { set prompt_config [get_prompt_config] set prompt_reset_flag 0 @@ -817,7 +841,7 @@ proc repl::repl_handler {inputchan prompt_config} { variable last_repl_char "" ;#last char emitted by this handler to stdout/stderr variable lastoutchar "" variable lasterrchar "" - variable command + variable commandstr variable running variable reading variable post_script @@ -844,10 +868,11 @@ proc repl::repl_handler {inputchan prompt_config} { set debugprompt [dict get $prompt_config debugprompt] - append command $line\n + append commandstr $line\n + #puts "=============>$commandstr" set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin screen_last_char_add "\n" stdin $line - if {[info complete $command]} { + if {[info complete $commandstr]} { set ::repl::output_stdout "" set ::repl::output_stderr "" set outstack [list] @@ -855,7 +880,7 @@ proc repl::repl_handler {inputchan prompt_config} { #oneshot repl debug - set wordparts [regexp -inline -all {\S+} $command] + set wordparts [regexp -inline -all {\S+} $commandstr] lassign $wordparts cmd_firstword cmd_secondword if {$cmd_firstword eq "debugrepl"} { if {[string is integer -strict $cmd_secondword]} { @@ -863,7 +888,7 @@ proc repl::repl_handler {inputchan prompt_config} { } else { incr ::punkrepl::debug_repl } - set command "set ::punkrepl::debug_repl" + set commandstr "set ::punkrepl::debug_repl" } if {$::punkrepl::debug_repl > 0} { proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { @@ -889,7 +914,17 @@ proc repl::repl_handler {inputchan prompt_config} { proc debug_repl_emit {msg} {return} } - + #----------------------------------------- + #review! + #work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 + #https://wiki.tcl-lang.org/page/representation + #/scriptlib/tests/listrep_bug.tcl + #after the uplevel #0 $commandstr call + # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value + global run_command_string + set run_command_string "$commandstr\n" ;#add anything that won't affect script. + global run_command_cache + #----------------------------------------- set ::punk::last_run_display [list] set ::repl::last_unknown "" @@ -907,16 +942,20 @@ proc repl::repl_handler {inputchan prompt_config} { #chan configure stdout -buffering none fileevent $inputchan readable {} set reading 0 - #don't let unknown use 'args' to convert command to list + #don't let unknown use 'args' to convert commandstr to list #=============================================================================== #Actual command call + #puts "____>[rep $commandstr]" #=============================================================================== - if {[string equal -length [string length "repl_runraw "] "repl_runraw " $command]} { + if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { #pass unevaluated command to runraw - set status [catch {uplevel #0 [list runraw $command]} result] + set status [catch {uplevel #0 [list runraw $commandstr]} result] } else { #puts stderr "repl uplevel 0 '$command'" - set status [catch {uplevel #0 $command} result] + set status [catch { + #uplevel 1 $run_command_string + uplevel 1 {namespace eval $punk::ns_current $run_command_string} + } result] } #=============================================================================== flush stdout @@ -928,7 +967,16 @@ proc repl::repl_handler {inputchan prompt_config} { shellfilter::stack::remove stderr $s } - + #----------------------------------------- + #list/string-rep bug workaround part 2 + #todo - set flag based on punkrepl::has_script_var_bug + lappend run_command_cache $run_command_string + #puts stderr "run_command_string rep: [rep $run_command_string]" + if {[llength $run_command_cache] > 2000} { + set run_command_cache [lrange $run_command_cache 1750 end] + } + #----------------------------------------- + set lastoutchar [string index $::repl::output_stdout end] set lasterrchar [string index $::repl::output_stderr end] @@ -942,7 +990,7 @@ proc repl::repl_handler {inputchan prompt_config} { #also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout if { [string length $::repl::last_unknown] && \ - [string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $command] + [string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $line] } { #can't currently detect stdout/stderr writes from unknown's call to exec #add a clearance newline for direct unknown calls for now @@ -992,18 +1040,19 @@ proc repl::repl_handler {inputchan prompt_config} { # so may not be a well formed list e.g 'set x [list a "b"]' #- lindex will fail #if {[lindex $command 0] eq "runx"} {} - + + if { - [string equal -length [string length "./ "] "./ " $command] || \ - [string equal "./\n" $command] || \ - [string equal -length [string length "../ "] "../ " $command] || \ - [string equal "../\n" $command] || \ - [string equal -length [string length "runx "] "runx " $command] || \ - [string equal -length [string length "sh_runx "] "sh_runx " $command] || \ - [string equal -length [string length "runout "] "runout " $command] || \ - [string equal -length [string length "sh_runout "] "sh_runout " $command] || \ - [string equal -length [string length "runerr "] "runerr " $command] || \ - [string equal -length [string length "sh_runerr "] "sh_runerr " $command] + [string equal -length [string length "./ "] "./ " $commandstr] || \ + [string equal "./\n" $commandstr] || \ + [string equal -length [string length "../ "] "../ " $commandstr] || \ + [string equal "../\n" $commandstr] || \ + [string equal -length [string length "runx "] "runx " $commandstr] || \ + [string equal -length [string length "sh_runx "] "sh_runx " $commandstr] || \ + [string equal -length [string length "runout "] "runout " $commandstr] || \ + [string equal -length [string length "sh_runout "] "sh_runout " $commandstr] || \ + [string equal -length [string length "runerr "] "runerr " $commandstr] || \ + [string equal -length [string length "sh_runerr "] "sh_runerr " $commandstr] } { if {[llength $last_run_display]} { @@ -1012,12 +1061,20 @@ proc repl::repl_handler {inputchan prompt_config} { } } - + #an attempt to preserve underlying rep + #this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging + if {[catch {lrange $result 0 end} result_as_list]} { + set is_result_empty [expr {$result eq ""}] + + } else { + set is_result_empty [expr {[llength $result_as_list] == 0}] + } + #catch {puts stderr "yy--->[rep $::arglej]"} set reading 1 - if {$result ne ""} { + if {!$is_result_empty} { if {$status == 0} { if {[screen_needs_clearance]} { rputs -nonewline stderr \n @@ -1087,20 +1144,23 @@ proc repl::repl_handler {inputchan prompt_config} { doprompt "P% " } } - set command "" + #catch {puts stderr "zz1--->[rep $::arglej]"} + #puts stderr "??? $commandstr" if {$::punkrepl::debug_repl > 0} { incr ::punkrepl::debug_repl -1 } + set commandstr "" + #catch {puts stderr "zz2---->[rep $::arglej]"} } else { - #append command \n + #append commandstr \n if {$::repl::signal_control_c} { set ::repl::signal_control_c 0 rputs stderr "* console_control: control-c" set c [a+ yellow bold] set n [a+] rputs stderr "${c}repl interrupted$n" - #set command [list error "repl interrupted"] - set command "" + #set commandstr [list error "repl interrupted"] + set commandstr "" doprompt ">_ " } else { @@ -1108,6 +1168,8 @@ proc repl::repl_handler {inputchan prompt_config} { } } fileevent $inputchan readable [list [namespace current]::repl_handler $inputchan $prompt_config] + #fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] + #catch {puts stderr "zend--->[rep $::arglej]"} } #repl::start stdin #exit 0