diff --git a/scriptlib/tests/Lfilter.tcl b/scriptlib/tests/Lfilter.tcl new file mode 100644 index 00000000..89f378ad --- /dev/null +++ b/scriptlib/tests/Lfilter.tcl @@ -0,0 +1,38 @@ +struct::list::Lfilter {a apple b aardvark c} { + @@ok/result.= { + pipeswitch { + puts "c0: [string range $switchargs 0 0]" + pipecase .= ,'a'.= string range $switchargs 0 0 |> {val 1} + val {ok {result 0}} + } $in + } |> {puts $data; set data} {val 1} + val {ok {result 0}} + } $in + } {val 1} + val {ok {result 0}} + } f . reduce {.=* list |> {join $data ":"} <|} {a b c d e f} + + + diff --git a/scriptlib/tests/block_padleft.tcl b/scriptlib/tests/block_padleft.tcl new file mode 100644 index 00000000..e71c372b --- /dev/null +++ b/scriptlib/tests/block_padleft.tcl @@ -0,0 +1,9 @@ +package require punk +package require patternpunk + +pipealias block_padleft .= {list $input [string repeat " " $indent]} |/0,padding/1> linelist |> .= {lmap v $data {val "$padding$v"}} |> list_as_lines punk . logo] 50" +puts stdout "[block_padleft [>punk . logo] 50]" diff --git a/scriptlib/tests/curry_assign.tcl b/scriptlib/tests/curry_assign.tcl index 6e87c214..4fda31ce 100644 --- a/scriptlib/tests/curry_assign.tcl +++ b/scriptlib/tests/curry_assign.tcl @@ -1,21 +1,28 @@ -puts stdout "test long pipeline can be curried with simple c=x.=d e |> f etc assignment (no space after =)" +set sep [string repeat - 50] +puts stdout "test long pipeline can be curried with pipeset c= x.= d e |> f etc assignment " -puts stdout "c=x.={5*3} |p1> y.= expr 3 * |p2> {set debug \"val is \$data\";set data} |debug> z.= 2 + |> { set data} |> {puts stderr \"debug:\$debug\n p1:\$p1\np2:\$p2\"; set data}" +#puts stdout "pipeset c x.= expr 5 * |p1> y.= expr 3 * |p2> {set debug \"val is \$data\";inspect $data} |debug> z.= expr 2 + |> {puts stderr \"debug:\$debug\n p1:\$p1\n p2:\$p2\"; inspect $data} <|" -c=x.={5*3} |p1> y.= expr 3 * |p2> {set debug "val is $data";set data} |debug> z.= 2 + |> { set data} |> {puts stderr "debug:$debug\n p1:$p1\np2:$p2"; set data} -puts stdout "method1 using \$c" -$c -set answer [$c] +pipeset c x.=* expr 5 * |p1> y.= expr 3 * |p2> {set debug "val is $data";inspect -label inspect1 $data ; list $debug $data} |debug/0,data/1> z.= expr 2 + |> {puts stderr "debug:$debug\n p1:$p1\n p2:$p2"; inspect -label inspect2 $data} <| -puts stdout "set answer \[\$c\]" + +puts stderr $sep +puts stderr "$c" +puts stderr $sep + + + +puts stderr $sep +puts stdout "method1: set answer \[{*}\$c\ 3]" +set answer [{*}$c 3] puts stdout " $answer" +puts stderr $sep -puts stdout "method2 using eval \$c" -eval $c -set answer2 [eval $c] -puts stdout "set answer2 \[eval \$c\]" +puts stderr $sep +puts stdout "method2: set answer2 \[eval \$c\ 3]" +set answer2 [eval $c 3] puts stdout " $answer2" puts stdout "-done-" diff --git a/scriptlib/tests/first_assign.tcl b/scriptlib/tests/first_assign.tcl new file mode 100644 index 00000000..a6d7d67b --- /dev/null +++ b/scriptlib/tests/first_assign.tcl @@ -0,0 +1,14 @@ +#experiment with the dangers of substitution in the first position after = in pipelines + +puts stdout {set i {"a b "}} +set i {"a b "} + +catch { +% x=$i +} errm +puts stderr "% x=\$i -> $errm" + +% "x=$i" + +#%x="a b " + diff --git a/scriptlib/tests/fn.tcl b/scriptlib/tests/fn.tcl new file mode 100644 index 00000000..66b6eb67 --- /dev/null +++ b/scriptlib/tests/fn.tcl @@ -0,0 +1,320 @@ +package provide funcl [namespace eval funcl { + variable version + set version 0.1 +}] +#funcl = function list (nested call structure) +# +#a basic functional composition o combinator +#o(f,g)(x) == f(g(x)) + +namespace eval funcl { + + #from punk + proc arg_is_script_shaped {arg} { + if {[string first " " $arg] >= 0} { + return 1 + } elseif {[string first \n $arg] >= 0} { + return 1 + } elseif {[string first ";" $arg] >= 0} { + return 1 + } elseif {[string first \t $arg] >= 0} { + return 1 + } else { + return 0 + } + } + + + proc o args { + set closing [string repeat {]} [expr [llength $args]-1]] + set body "[join $args { [}] \$data $closing" + return $body + } + + proc o_ args { + set body "" + set tails [lrepeat [llength $args] ""] + puts stdout "tails: $tails" + + set end [lindex $args end] + if {[llength $end] == 1 && [arg_is_script_shaped $end]} { + set endfunc [string map [list $end] {uplevel 1 [list if 1 ]}] + } else { + set endfunc $end + } + if {[llength $args] == 1} { + return $endfunc + } + + set wrap { [} + append wrap $endfunc + append wrap { ]} + + set i 0 + foreach cmdlist [lrange $args 0 end-1] { + set is_script 0 + if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { + set is_script 1 + set script [lindex $cmdlist 0] + } + set t "" + if {$i > 0} { + append body { [} + } + set posn [lsearch $cmdlist _] + if {$posn <= 0} { + append body $cmdlist + if {$i == [expr {[llength $args] -2}]} { + #append body " \$data" + append body " $wrap" + } + if {$i > 0} { + set t {]} + } + } else { + append body [lrange $cmdlist 0 $posn-1] + if {$i == [expr {[llength $args] -2}]} { + #append body " \$data" + append body " $wrap" + } + set t [lrange $cmdlist $posn+1 end] + if {$i > 0} { + append t { ]} + } + } + lset tails $i $t + incr i + } + append body [join [lreverse $tails] " "] + puts stdout "tails: $tails" + + return $body + } + + #review - consider _call -- if count > 1 then they must all be callable cmdlists(?) + # what does it mean to have additional _fn wrapper with no other elements? (no actual function) + #e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} + # what type indicates running subtrees in parallel vs sequentially? + # any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. + # + # + # accept or return a funcl (or funcltree if multiple funcls in one commandlist) + # also accept/return a call - return empty list if passed a call + proc next_funcl {funcl_or_tree} { + if {[lindex $funcl_or_tree 0] eq "_call"} { + return [list] + } + if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { + set funcl $funcl_or_tree + } else { + error "funcltree not implemented" + } + + + set count [lindex $funcl 1] + if {$count == 0} { + #null funcl.. what is it? metadata/placeholder? + return $funcl + } + set indices [lrange $funcl 2 [expr {1 + $count}]] + set i 0 + foreach idx $indices { + if {$i > 0} { + #todo - return a funcltree + error "multi funcl not implemented" + } + set next [lindex $funcl $idx] + incr i + } + + return $next + + } + + #convert a funcl to a tcl script + proc funcl_script {funcl} { + if {![llength $funcl]} { + return "" + } + set body "" + set tails [list] + + set type [lindex $funcl 0] + if {$type ni [list "_fn" "_call"]} { + #todo - handle funcltree + error "type $type not implemented" + } + + + #only count of 1 with index 3 supported(?) + if {$type eq "_call"} { + #leaf + set cmdlist [lindex $funcl 3] + return $cmdlist + } + + #we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. + #by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) + # we would still need to maintain state to stitch it back together once returned from a subtree.. + # ie multiple tail parts + set count [lindex $funcl 1] + + if {$count == 1} { + set idx [lindex $funcl 2] + if {$idx == 3} { + set cmdlist_pre [list] + } else { + set cmdlist_pre [lrange $funcl 3 $idx-1] + } + append body $cmdlist_pre + set t [lrange $funcl $idx+1 end] + lappend tails $t + } else { + #?? + error "funcl_script branching not yet supported" + } + + + set get_next 1 + set i 1 + while {$get_next} { + set funcl [next_funcl $funcl] + if {![llength $funcl]} { + set get_next 0 + } + lassign $funcl type count idx ;#todo support count > 1 + if {$type eq "_call"} { + set get_next 0 + } + set t "" + if {$type eq "_call"} { + append body { [} + append body [lindex $funcl $idx] + append body { ]} + } else { + append body { [} + if {$idx == 3} { + set cmdlist_pre [list] + } else { + set cmdlist_pre [lrange $funcl 3 $idx-1] + } + append body $cmdlist_pre + set t [lrange $funcl $idx+1 end] + lappend tails $t + lappend tails { ]} + } + incr i + } + append body [join [lreverse $tails] " "] + #puts stdout "tails: $tails" + + return $body + } + + + interp alias "" o_of "" o_of_n 1 + + #o_of_n + #tcl list rep o combinator + # + # can take lists of ordinary commandlists, scripts and funcls + # _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) + # _fn 0 indicates next item is an unwrapped commandlist (terminal command) + # + #o_of is equivalent to o_of_n 1 (1 argument o combinator) + #last n args are passed to the prior function + #e.g for n=1 f a b = f(a(b)) + #e.g for n=2, e f a b = e(f(a b)) + proc o_of_n {n args} { + if {$n != 1} { + error "o_of_n only implemented for 1 sub-funcl" + } + set comp [list] ;#composition list + set end [lindex $args end] + if {[lindex $end 0] in [list "_fn" "_call"]} { + #is_funcl + set endfunc [lindex $args end] + } else { + if {[llength $end] == 1 && [arg_is_script_shaped $end]} { + #set endfunc [string map [list $end] {uplevel 1 [list if 1 ]}] + set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] + } else { + set endfunc [list _call 1 3 [list {*}$end]] + } + } + + if {[llength $args] == 1} { + return $endfunc + } + set comp $endfunc + set revlist [lreverse [lrange $args 0 end-1]] + foreach cmdlist $revlist { + if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { + set is_script 1 + set script [lindex $cmdlist 0] + set arglist [list data] + + set comp [list _fn 1 6 call_script $script $arglist $comp] + } else { + set posn1 [expr {[llength $cmdlist] + 2 + $n}] + set comp [list _fn $n $posn1 {*}$cmdlist $comp] + } + } + return $comp + } + proc call_script {script argnames args} { + uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] + } + proc funcl_script_test {scr} { + do_funcl_script_test $scr + } + proc do_funcl_script_test {scr} { + #set j "in do_funcl_script_test" + #set data "xxx" + #puts '$scr' + if 1 $scr + } + + #standard o_ with no script-handling + proc o_plain args { + set body "" + set i 0 + set tails [lrepeat [llength $args] ""] + #puts stdout "tails: $tails" + foreach cmdlist $args { + set t "" + if {$i > 0} { + append body { [} + } + set posn [lsearch $cmdlist _] + if {$posn <= 0} { + append body $cmdlist + if {$i == [expr {[llength $args] -1}]} { + append body " \$data" + } + if {$i > 0} { + set t {]} + } + } else { + append body [lrange $cmdlist 0 $posn-1] + if {$i == [expr {[llength $args] -1}]} { + append body " \$data" + } + set t [lrange $cmdlist $posn+1 end] + if {$i > 0} { + append t { ]} + } + } + lset tails $i $t + incr i + } + append body [join [lreverse $tails] " "] + #puts stdout "tails: $tails" + + return $body + } + #timings suggest no faster to split out the first item from the cmdlist loop +} + + + \ No newline at end of file diff --git a/scriptlib/tests/fun.tcl b/scriptlib/tests/fun.tcl new file mode 100644 index 00000000..03eb4aba --- /dev/null +++ b/scriptlib/tests/fun.tcl @@ -0,0 +1,392 @@ + +#slow - but basically works. Needs pipeline compilation to tcl script to speed up? funcl? +package require punk + + +#todo - pinned vars.. what scope? add a facility to bake values into proc body? (what equivalent is there for pipelines not bound to a proc scope? apply?) +#if a fun is intended to bind in the caller's scope - then we just need a way to return the fun contents as a runnable pipeline +# - conflict between build-time and run-time pinned vars? Is this really 2 separate concepts? +# - using a pin to help build up the pattern vs using the pin for pipelined/context data? +# - unpinned vars are clearly required in the implementation bodies - which is 'pipeline' scope only.. and limited to the running clause. +#pipefun::setvar ? +#consider oo version that uses properties of the object as the pinned vars in the pattern-spec? +#pinned vars are important to be able to pass more complex values than are allowed by the pattern mini-lang e.g paths /etc (or is that a misuse???) + +#what does a pin on the argspec <^var| even mean? other vars in <| are pure pipeline scope +# pins in intermediate pipes.. e.g |^somevar@1> could be used as sanity checks for pipeline-scope vars.. but is there a real need/usecase? + + +namespace eval pipefun { + variable funs [dict create] +} + + +#note this isn't a 'standard' closure in the sense that the captured vars aren't modifiable - a coro or object could be used to hold state if that is required. +proc pipefun::closure0 {body} { + set binding {} + foreach v [uplevel 1 info locals] { + upvar 1 $v var + if {[info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + return [list apply [list $binding $body [uplevel 1 namespace current]]] +} + +#much slower attempting to upvar all at once with different varnames +proc pipefun::closure1 {body} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"] + lassign $upinfo vars ns + #puts stdout ">>> got vars:$vars ns:$ns" + + set pairs [lmap v $vars i [lsearch -all $vars *] {list $v v$i}] + set flatpairs [concat {*}$pairs] + upvar 1 {*}$flatpairs + #puts stdout ">>> $flatpairs" + foreach {v vi} $flatpairs { + if {![array exists $vi] && [info exists $vi]} { + lappend binding [list $v [set $vi]] ;#values captured as defaults for apply args. + } + } + return [list apply [list $binding $body $ns]] +} +proc pipefun::closure1 {body} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"] + lassign $upinfo vars ns + #puts stdout ">>> got vars:$vars ns:$ns" + 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. + } + } + return [list apply [list $binding $body $ns]] +} +proc pipefun::closure {body} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + #set upinfo [uplevel 1 "list \[{*}$get_vars\] \[namespace current\]"] + #lassign $upinfo vars ns + #puts stdout ">>> got vars:$vars ns:$ns" + foreach v [uplevel 1 {*}$get_vars] { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + return [list apply [list $binding $body [uplevel 1 namespace current]]] +} + + +proc pipefun::funs {{glob *}} { + variable funs + return [dict keys $funs $glob] +} + +proc pipefun::testpattern {pattern val} { + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pattern $val] + #set r [_handle_bind_result $d] + #set pipedvars [dict get $d setvars] + return $d +} + +proc pipefun::funclear {nameglob} { + variable funs + foreach k [dict keys $funs $nameglob] { + dict unset funs $k + } +} +proc pipefun::funinfo {name} { + package require overtype + variable funs + set keys [dict keys [dict get $funs $name defs]] + set out "fun: $name\n" + append out "clause_count: [llength $keys]\n" + #append out [punk::list_as_lines $keys] + set maxwidth [expr {[string length Pattern] + 2}] + foreach k $keys { + set w [string length $k] + if {$w > $maxwidth} { + set maxwidth $w + } + } + set col1 [string repeat " " [expr {$maxwidth + 2}]] + set linewidth [expr {[string length $col1] + 1 + [string length LineCount]}] + set dashes [string repeat - $linewidth] + append out $dashes\n + append out "[overtype::left $col1 Pattern] LineCount\n" + append out $dashes\n + foreach k $keys { + set body [dict get $funs $name defs $k] + set linecount [llength [split $body \n]] + append out "[overtype::left $col1 $k] [$linecount]\n" + } + append out $dashes\n + return $out +} +proc pipefun::funclause {name match args} { + variable funs + set defaults [list -delete 0 -active 1] + if {([llength $args] % 2) != 0} { + error "funclause options must be in pairs. Known options: [dict keys $defaults]" + } + set opts [dict merge $defaults $args] + + if {[dict exists $funs $name defs $match]} { + set body [dict get $funs $name defs $match] + if {[dict get $opts -delete]} { + dict unset funs $name defs $match + } + + return $body + } else { + return "no clause '$match'" + } +} + +#todo - examine arity of call and limit cases tested? +proc pipefun::fun_proc {name argspec body} { + variable funs + + if {[dict exists $funs $name]} { + set definitions [dict get $funs $name defs] + dict set definitions $argspec $body ;#add or override + dict set funs $name defs $definitions ;#write-back + } else { + #first implementations + dict set funs $name defs [dict create $argspec $body] + } + + if {[llength [info commands $name]]} { + if {[catch {info body $name} body1]} { + error "fun: unable to update function '$name' - not a proc" + } + } else { + set body1 "" + } + + #what is the point of at beginning? + set test_case_template { + pipecase .= list {*}$arglist |args> { + + } <| {*}$arglist + } + set case_template1 { + pipecase .= list {*}$arglist |args> { + + } <| {*}$arglist + } + set case_template { + pipecase .= { + + } <| {*}$switchargs + } + + set pipecases "" + + set definitions [dict get $funs $name defs] + dict for {a b} $definitions { + set impl [string map [list $a $b] $case_template] + append pipecases ${impl} + } + set nsup [uplevel 1 [list namespace current]] + if {$nsup eq "::"} { + set nsup "" + } + if {![string match "::*" $name]} { + set name "${nsup}::$name" + } + + proc $name args [string map [list $pipecases] { + pipeswitchc { + + } $args + }] + + +} + +proc pipefun::fun {name argspec body} { + variable funs + if {[dict exists $funs $name]} { + set definitions [dict get $funs $name defs] + dict set definitions $argspec $body ;#add or override + dict set funs $name defs $definitions ;#write-back + } else { + #first implementations + dict set funs $name defs [dict create $argspec $body] + } + if {[llength [info commands $name]]} { + if {![llength [interp alias "" $name]]} { + error "fun: unable to update function '$name' - not an alias" + } + } + + set pipecases "" + set definitions [dict get $funs $name defs] + dict for {a b} $definitions { + #set impl [string map [list $a $b] $case_template] + #append pipecases ${impl} + + set case [list pipecase .= $b <$a|] + + #set case [list pipecase ,$a= |$a> .= $b <|] + + + append case { {*}$switchargs} + #we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx) + append pipecases $case\n + } + set nsup [uplevel 1 [list namespace current]] + if {$nsup eq "::"} { + set nsup "" + } + #if {![string match "::*" $name]} { + # set name "${nsup}::$name" + #} + + #proc $name args [string map [list $pipecases] { + # % .= { + # pipeswitch { + # + # } + # } \ + 0.= { + string is integer -strict $a + } |> { + puts stderr "age must be an integer" + val " bad arg '$a' - must be an integer" + } + + } + #puts stdout ">>> $switchresult" + % status@@/@0.= val $switchresult + % contents@1.= val $switchresult + puts stdout ">>> $switchresult" + + #an ordinary return value (extracted from @@ok/result above) will get wrapped in 'ok {result }' which can be confusing if the result is supposed to indicate a fault + #return $status + #even worse if we return switchresult as we would get a double @@ok/result + + #pipeswitch can return @@ok/result or @@error + # we could use something like: + #if {[$status eq "error"]} {...} + # or + #if {$status eq "ok"} {...} + # or just use error "switcherror ..." directly in the above pipecase, which would propagate through as an error + + + + #wrapping in own error-bag doesn't really help as the outer ok wrapping will still get applied + #return [list error {reason "bad arg"}] + + #raising a normal error in the above pipeswitch or anywhere in the fun results in an @@error/reason *return value* + #(as opposed to an @@error/mismatch *return value* for a failed binding) + #i.e later implementations will still be run as this will still just be a non-match + #error "$contents" + + + #will work to raise an error, but bad form to fake a pipesyntax error + #error "pipesyntax bad-arg" + + #to cause pipewitch above this to raise an error and stop processing cases.. + #use 'switcherror' or 'funerror' as first element of a list e.g + #error [list funerror [list reason "$contents"]] + + #attempting to raise a normal error in the above switch - but then a bad match here.. will only cause this implementation to be a non-match + # and so other implementations will still be run + #return [@@ok/result.= val $switchresult] + + #in this example - we want to force a terminal error (see switcherror above) or a terminal *result* that isn't wrapped in 'ok', + #but only if we *don't* have a mismatch. + #i.e we require an @@error/mismatch to proceed to other implementations + #puts stderr "=--->$switchresult" + if {[ispipematch r@@error/mismatch.= val $switchresult]} { + #all good - simulate an @@error/mismatch - or raise an 'ignore' error so that this implementation is considered to be unmatched and we fall through to others. + #puts stdout "=ispipematch true" + error [list ignore [list argcheck passed]] + #error "binding mismatch" + } else { + #puts stdout "=ispipematch false" + #error [list resultfunerror $contents] + error [list funerror $contents] + } + +} + + + + + +fun age 1 {puts "welcome!"} +fun age 18 {puts "yay!"} +fun age 42 { + error "Test that error is raised." + } +fun age ''/0 {puts "enter an age, and optionally a message";return "no-value-supplied"} +fun age a,100 {puts "congrats!"; return "congrats-$a"} +fun age b {puts "cool"; return "cool-$b"} +#fun age a,3+/# {puts stderr "too many args"; return} + +age 100 + + + + + diff --git a/scriptlib/tests/html.tcl b/scriptlib/tests/html.tcl new file mode 100644 index 00000000..05570069 --- /dev/null +++ b/scriptlib/tests/html.tcl @@ -0,0 +1,219 @@ + + +proc html_deep {indent tag attrs args} { + set out "" + set a "" + if {[dict size $attrs]} { + dict for {k v} $attrs { + append a "$k=\"$v\" " + } + set a [string range $a 0 end-1] + append out "<$tag $a>\n" + } else { + append out "<$tag>\n" + } + foreach a $args { + foreach ln [split $a \n] { + append out "$indent$ln\n" + } + } + append out "" + return $out +} + + +#html 'block' elements +interp alias {} html {} html_deep " " "html" +interp alias {} head {} html_deep " " "head" +interp alias {} script {} html_deep " " "script" +interp alias {} body {} html_deep " " "body" +interp alias {} div {} html_deep " " "div" +interp alias {} p {} html_deep " " "p" +interp alias {} content {} html_deep " " "content" +interp alias {} table {} html_deep " " "table" +interp alias {} tr {} html_deep " " "tr" +interp alias {} th {} html_deep " " "th" +interp alias {} footer {} html_deep " " "footer" +#still an html 'block' element - but output horizontally e.g h1-h6 +interp alias {} h1 {} html_shallow " " "h1" +interp alias {} h2 {} html_shallow " " "h2" +interp alias {} h3 {} html_shallow " " "h3" +interp alias {} h4 {} html_shallow " " "h4" +interp alias {} h5 {} html_shallow " " "h5" +interp alias {} h6 {} html_shallow " " "h6" + + +#html "inline" elements +interp alias {} a {} html_shallow "a" +interp alias {} em {} html_shallow "em" +interp alias {} strong {} html_shallow "strong" +interp alias {} span {} html_shallow "span" + + +interp alias {} title {} html_shallow "title" + + +proc html_shallow {tag attrs args} { + set out "" + set a "" + if {[dict size $attrs]} { + dict for {k v} $attrs { + append a "$k=\"$v\" " + } + set a [string range $a 0 end-1] + append out "<$tag $a>" + } else { + append out "<$tag>" + } + foreach a $args { + append out "$a" + } + append out "" + return $out +} +interp alias {} attrs {} dict create + +pipeset htmldoc .= list "julian@precisium.com.au" "info@precisium.com" |email_admin/0,email_info/1> \ + { + list [title [attrs] "a test"] [script [attrs]] + } { + } |> \ + { + head [attrs] {*}$data + } |h> \ + { + + + + } |> { + + div [attrs id div1] + } |d1> { + + + + } |> { + a [attrs href "mailto:$email_admin,$email_info"] "Send Email" + } |> p [attrs] |> div [attrs id div-main] |divmain> { + + # we can mix imperative style blocks in + set divs [list] + lappend divs $d1 + + lappend divs $divmain + + lappend divs [div [attrs id div3]] + + return $divs + } |divlist> { + + + + + } |> .= { + + set elements $divlist + #puts "---->$pipeargs" + #puts "----[/#.= val $pipeargs]" + + footer.= result@1/@@result.= \ + pipeswitch { + + pipecase \ + .= val $pipeargs |argd> \ + 1.= { + dict exists $argd -author + } { + + + } |> \ + author.= { + dict get $argd -author + } { + + + } |> \ + { + return "Author: $data" + } + + pipecase .= val "Author: unknown" |> div [attrs hidden hidden] + + } |> p [attrs] |> footer [attrs] + + + #puts "author: $author" + #puts "result: $result" + + lappend elements $footer + lappend elements [script [attrs] ""] + + return $elements + } |> bodydebug.= { + body [attrs] {*}$data + } |b> { + list $h $b + } |> { + html [attrs lang en] {*}$data + } |> { + + #args -author name + return $data + } " $x]} { + #end of segment + lappend oline o_of [list $segment] $x + set segment [list] + } else { + lappend segment $x + } + } + if {[llength $segment]} { + lappend oline o_of [list $segment] + } + puts stdout "-- oline :$oline" + return $oline +} + +proc make_funcl {pipeline} { + set o [make_o $pipeline] + set funcl [$o] +} + +proc make_script {pipeline} { + funcl::funcl_script [make_funcl $pipeline] +} + +proc run_pipe {pipeline} { + funcl::funcl_script_test [make_script $pipeline] +} + + diff --git a/scriptlib/tests/json.tcl b/scriptlib/tests/json.tcl new file mode 100644 index 00000000..bc9f53d1 --- /dev/null +++ b/scriptlib/tests/json.tcl @@ -0,0 +1,62 @@ +#another experiment +package require fileutil +set data [fileutil::cat [pwd]/sample1.json] +puts stdout $data +proc charP {ch} { + pipeset parser .= { + pipeswitch { + #puts "-->$input" + pipecase = $input |> \ + ,'${ch}'@1.= {list [string range $data 1 end] [string index $data 0] } |> { + set data + } + return nothing + } + } \ + ,'result'@@ok/@0.= { + .= list $pipe $input |p@,i@> {{*}$p $i} + } |result@@ok/result> { + #todo - we need inverse of the destructure operation of pattern-matching + #i.e we need restructure - which puts the values in at the matched locations + #- (return the updated result without necessarily knowing its full specific structure) + + } + + return nothing-functor + } + } \ + ,'result'@@ok/@0.= { + .= list $pipe $input |p@,i@> {{*}$p $i} + } |tail@@ok/result/@0,char@@ok/result/@1> {list $tail [{*}$cmd $char] } | + + return nothing-functor + } + } inspect -label inspect-y } errmsg]} { puts stderr "error: $errmsg" } else { - puts stdout $y -} \ No newline at end of file + puts stdout "y: $y" +} +puts stdout $sep + +z.= = " +a b c +d e f +" |> inspect -label inspect-z |> .=* list + +puts stdout "z: $z" +puts stdout $sep + + +j.= = " +a b c +d e f +" |> inspect -label inspect-j |> linelist + +puts stdout "linelist: $j" +puts stdout $sep + +k.= = { +a b c +d e f +} |> inspect -label inspect-k |> linelist + +puts stdout "linelist: $k" +puts stdout $sep diff --git a/scriptlib/tests/listbuilder.tcl b/scriptlib/tests/listbuilder.tcl index 4e4a72e6..56302dd4 100644 --- a/scriptlib/tests/listbuilder.tcl +++ b/scriptlib/tests/listbuilder.tcl @@ -1,44 +1,129 @@ +set sep [string repeat - 50] +puts stderr $sep + +#display pipeline in alternative color +proc pipeputs {pipeline} { + puts stdout [a+ purple bold]$pipeline[a+] +} + set data1 d1 set data2 [list a b c] -x.=list " +x/0.= list " item1 [list $data1] [list $data2] +$data2 [pwd] " -puts stdout "4 element list built with x.=list \" (multiline) \" syntax" -puts stdout $x +puts stdout "7 element list built with x/0.=list \" (multiline) \" syntax" +puts stdout "x: $x" +puts stdout "len: [llength $x]" +puts stderr $sep + +puts stdout "Using linelist to restrict to the intended 5 elements" +out.= = $x |> linelist +puts stdout "out.= = \$x |> linelist" +puts stdout "out: $out" +puts stdout "len: [llength $out]" +puts stderr $sep -x.=list " -{[set x aaa]} -{$x} + +y.= list " +{[set j aaa]} +{$j etc} blah " -puts stdout "strange but possibly useful" -puts stdout $x +puts stdout "y: $y" +puts stderr $sep + -puts stdout "building a dict" -d@0="list " +puts stdout "building a dict - with some impurities! (pwd)" +puts stdout "Note that the commands in the dict-building string are resolved at pipeline construction time" +puts stdout "To resolve commands at pipeline run-time, we can pass as arguments (see extrakey key), or put them in a script block in the pipeline (see runtimedir key)" +puts stdout "Some alternatives not demonstrated here are to use 'subst' or compose pipelines" + +pipeset dictpipe result.= inputdict_with_args,k@keys,p@@k2/patchlevel,etc/@@k4/etc=* " k1 - {[pwd]} + {dir {[pwd]}} k2 - {[info patchlevel]} + {patchlevel [info patchlevel]} k3 - {something} -" -puts stdout "dict: $d" + {something etc} +k4 + { + hmmm well + etc blah + dir {[pwd]} + } +" |> finald,rtkey/@@runtimedir.= { + #a very impure script block! + set origdir [pwd] + set parent [file dirname [pwd]] + cd $parent + dict set data runtimedir [pwd] + cd $origdir + set data +} |@@k4/dir> <| extrakey [pwd] anotherkey foo + + +puts stdout "dictpipe:" +pipeputs $dictpipe +{*}$dictpipe +puts stdout "dict: $finald" +#todo - a function to repack a nested dict into a flat structure (no linefeeds unless a leaf can't be interpreted as a dict)? +# i.e - k4 is constructed as a string - but we may want to discard the stringrep and rebuild it as a pure list/dict +puts stdout "keys: $k" +puts stdout "k2/patchlevel: $p" +puts stdout "k4/etc: $etc" +puts stdout "runtimedir: $rtkey" +puts stdout "result(k4/dir): $result" +puts stderr $sep + + +puts stdout "script block comment test (using multiple scripts in segment via implicit pipedata mechanism" + +pipeset commentpipe normallist.= rawlist/0.= { +#a not terribly useful comment block +#comments +# etc +#blah +} {inspect -channel stderr -label inspect_no_data $data} {list \ + { + data + over here + etc + } +} { +#more comments - but we need to pass the pipeline data through here - so 'set data' required at end. +set data +} |> string trim |> linelist |> .=/2 lmap v {string trim $v} + +pipeputs $commentpipe +{*}$commentpipe + +puts stdout "rawlist:$rawlist" +puts stdout "normallist:$normallist" +puts stderr $sep + + +pipeset pipe2 alt.= = $rawlist |> .=/1 lrange 0 end +puts stdout "Alternative interpretation of list data" +puts stdout "pipe2:" +pipeputs $pipe2 +{*}$pipe2 +puts stdout "alt: $alt" + +pipeset pipe3 alt.= = $rawlist |> .=* list +puts stdout "Or.." +puts stdout "pipe3:" +pipeputs $pipe3 +{*}$pipe3 +puts stdout "alt: $alt" -puts stdout "comment test" -x="# " -testing -comments -here -" -puts stdout "x:$x" puts stdout -done- diff --git a/scriptlib/tests/listrep_bug.tcl b/scriptlib/tests/listrep_bug.tcl new file mode 100644 index 00000000..22a4272e --- /dev/null +++ b/scriptlib/tests/listrep_bug.tcl @@ -0,0 +1,17 @@ +#string rep generated for variable when script is changed or unset + +set script {set j [list a] ; list} +append script "\n" +uplevel #0 $script +puts stdout [tcl::unsupported::representation $j] +puts stdout [tcl::unsupported::representation $j] +puts stdout [tcl::unsupported::representation $j] +set script "" +puts stdout [tcl::unsupported::representation $j] +puts stdout [tcl::unsupported::representation $j] + +#value is a list with a refcount of 3, object pointer at 0x833d30, internal representation 0x878810:0x0, no string representation +#value is a list with a refcount of 3, object pointer at 0x833d30, internal representation 0x878810:0x0, no string representation +#value is a list with a refcount of 3, object pointer at 0x833d30, internal representation 0x878810:0x0, no string representation +#value is a list with a refcount of 2, object pointer at 0x833d30, internal representation 0x878810:0x0, string representation "a" +#value is a list with a refcount of 2, object pointer at 0x833d30, internal representation 0x878810:0x0, string representation "a" \ No newline at end of file diff --git a/scriptlib/tests/listrep_bug2.tcl b/scriptlib/tests/listrep_bug2.tcl new file mode 100644 index 00000000..983a1a32 --- /dev/null +++ b/scriptlib/tests/listrep_bug2.tcl @@ -0,0 +1,21 @@ + +#source this file.. +# get value is a list with a refcount of 4 .. no string representation +interp alias "" rep "" tcl::unsupported::representation +set j [list a];list +rep $j +set command {set j [list a];list} +uplevel #0 $command\n +rep $j +set j [list a];list +rep $j + +#then type following line in shell: +#$rep j + +#value is a list with a refcount of 3 string representation "a" + + +set x [rep $j];list +puts stdout $x + diff --git a/scriptlib/tests/monadtest.tcl b/scriptlib/tests/monadtest.tcl new file mode 100644 index 00000000..e257073f --- /dev/null +++ b/scriptlib/tests/monadtest.tcl @@ -0,0 +1,93 @@ +package require punk + +#https://www.youtube.com/watch?v=26jVysJHB-s +#based on Monads in Python: Why and How? + +#some function timer +proc xxxpipet {subcommand} { + return [list % val $subcommand |sub> { + if {![info exists input]} { + set input "" + } else { + set input + } + } |input> {clock micros} |start> {{*}$sub {*}$input} |res> {expr [clock micros] - $start} |t> {list $res $t} \ + {clock micros} |start> {{*}$sub {*}$input} |res> {expr [clock micros] - $start} |t> {list $res $t} {expr {$x + 1}} {expr {$x + 2}} .= {{*}[pipet $::fast] $data} |d@0,t@1> {{*}[pipet $::slow] $d} |d@,t2@> {{*}[pipet $::slow2] $d} |d@,t3@> {list $d [expr {$t + $t2 + $t3}]} + + +#method 2 - abstract away the extraction and summation in a bind function +# x2, t = bind(bind(fast(1), slow), slow2) +# % bind=% {list $vt $f} |v@0/0,t@0/1> {{*}$f $v} |r2@,t2@> {list $r2 [expr {$t + $t2}]} {{*}$f $v} |r2@,t2@> {list $r2 [expr {$t + $t2}]} \ + {clock micros} |start> {{*}$sub {*}$input} |res> {expr [clock micros] - $start} |t> {timedvalue new $res $t} {$o bind o_slow} \ +|o> {$o bind o_slow2} + +puts "tvresult value: [$tvresult value]" +puts "tvresult time: [$tvresult time]" +#timedvalue class is a monad + + + + + + + + + \ No newline at end of file diff --git a/scriptlib/tests/multireturn.tcl b/scriptlib/tests/multireturn.tcl index d86648d2..12869d9b 100644 --- a/scriptlib/tests/multireturn.tcl +++ b/scriptlib/tests/multireturn.tcl @@ -18,7 +18,7 @@ puts stdout "scriptline: d@end-3-end-1= {a b c d e f}" puts stdout "d: $d" set dict {key0 000 key1 111 key2 222 key3 333 key4 444} -pipeline=.= e@@key1,f@@key3,g= $dict +pipeset pipeline .= e@@key1,f@@key3,g= $dict puts stdout "pipeline: $pipeline" $pipeline puts stdout "e: $e" diff --git a/scriptlib/tests/nameservers.tcl b/scriptlib/tests/nameservers.tcl new file mode 100644 index 00000000..aee4573b --- /dev/null +++ b/scriptlib/tests/nameservers.tcl @@ -0,0 +1,42 @@ + +proc listmap {commandlist list} { + tailcall lmap item $list $commandlist +} + +proc pipe_webpub {} { +pipeset subpipe % .= { + pipeswitch { + pipecase \ + .= val [lindex $switchargs 0] \ + |> {string trimright $data .} |server> {split $data .} \ + |> 'webpub.net'.= { + join [lrange $data 1 2] . + } \ + |> { + list type internal server $server + } + + pipecase .= val [list type external server [lindex $switchargs 0]] + #val [list type external server [lindex $switchargs 0]] + + } $ns +} {runout -n dig $data ns +short} |> linelist |> {listmap {{*}[pipe_webpub] $item} $data} {{*}[pipe_nameserverlist] $data } |> lsort] +} + +puts stdout "command available: nameserverlist " \ No newline at end of file diff --git a/scriptlib/tests/pipeindex.tcl b/scriptlib/tests/pipeindex.tcl index 60b0c119..e2ba8a57 100644 --- a/scriptlib/tests/pipeindex.tcl +++ b/scriptlib/tests/pipeindex.tcl @@ -3,13 +3,13 @@ catch {unset result} dict= {a aaa b {z zzz x xxx y yyy}} -pipeline=result.= in.= val $dict |> string toupper |> @@B/X= +pipeset pipeline result.= in.= val $dict |> string toupper |> @@B/X= puts stdout "pipeline: $pipeline" $pipeline puts stdout "result: $result" punk::assert {$result eq "XXX"} -pipeline=result.= in.= val $dict |> string toupper |> @tail/end/not-head/not-tail/0/0= +pipeset pipeline result.= in.= val $dict |> string toupper |> @tail/end/not-head/not-tail/0/0= puts stdout "pipeline: $pipeline" $pipeline puts stdout "result: $result" diff --git a/scriptlib/tests/pipeline1.tcl b/scriptlib/tests/pipeline1.tcl index afc36d4e..45b2f49c 100644 --- a/scriptlib/tests/pipeline1.tcl +++ b/scriptlib/tests/pipeline1.tcl @@ -3,27 +3,30 @@ # a formatting experiment #----------------------------------------------------------- -x.= val { +x.= concat \ +" a b c +[runout -n pwd] +trailing space d e f g h i -} |> { +" |> { - set data} |> { + set data } |> { set data} |> { - puts "raw: $data" + puts "raw input + pipeline args: $data" set data } \ |> \ \ \ -l.=linelist %data%\ +l.=/1 linelist \ \ |> \ { @@ -31,27 +34,27 @@ l.=linelist %data%\ puts "args: $args" set data } \ - { +a.= val $input |> { - .=lrange $data 1 end-1 |>\ - b.=string toupper + .= lrange $data 1 end-1 |>\ + b.= string toupper puts stdout "==================================" - puts stdout [info vars] + puts stdout "info vars: [info vars]" foreach v [info vars] { - puts stderr " '$v'" + puts stderr " '$v' [set $v]" } puts stdout "==================================" return $b -} |> b.=val +} |> b.= val -puts $a -puts $b +puts "a:$a" +puts "b:$b" diff --git a/scriptlib/tests/pipeswitch.tcl b/scriptlib/tests/pipeswitch.tcl index 32d558a1..ef35576d 100644 --- a/scriptlib/tests/pipeswitch.tcl +++ b/scriptlib/tests/pipeswitch.tcl @@ -11,7 +11,7 @@ proc test1 {} { pipeswitch { puts stderr "pre pipecase code always runs" - pipecase pipenomatchvar nomatch1 ,'p1v0@0.= val {p1v0x b c} |> { + pipecase pipenomatchvar nomatch1 ,'p1v0'@0.= val {p1v0x b c} |> { puts stdout "pipecase1 $data" set data } @@ -19,14 +19,14 @@ proc test1 {} { # in between puts stderr "code after unmatched but before matched will run" - pipecase pipenomatchvar nomatch2 input,'p2v1@1.= val {x p2v1 z} |> { + pipecase pipenomatchvar nomatch2 input,'p2v1'@1.= val {x p2v1 z} |> { puts stdout "pipecase2 $data" return [list source pipecase2 data $data] } |> { string toupper $data } - pipecase ,'p3v3@2.= val {d e p3v3x} |> { + pipecase ,'p3v3'@2.= val {d e p3v3x} |> { puts stdout "pipecase3 $data" set data } @@ -37,7 +37,7 @@ proc test1 {} { puts stdout "returnvalue of pipeswitch return is: $returnvalue" puts stdout "[a+ yellow bold]nomatch var pipe1: $nomatch1[a+]" - puts stdout "nomatch destructured to 'matchinfo': [mi@@error/reason/matchinfo= $nomatch1]" + puts stdout "nomatch destructured to 'matchinfo': [mi@@error/mismatch/matchinfo= $nomatch1]" puts stdout "[a+ green bold]nomatch var pipe2 (empty if there was a match): $nomatch2[a+]" puts stdout "value of pipeswitch result is: $result" puts stdout "status of pipeswitch is: $status" @@ -48,25 +48,28 @@ test1 puts stderr "proc test follows" proc match_args {args} { - procresult,'ok@0.= pipeswitch { - pipecase p1,'a@0.= val $args |> string toupper |> { - + set arglist $args + procresult,'ok'@0.= pipeswitch { + puts stdout "----$arglist" + pipecase p1,'a'@0.= val $args |> string toupper |> { + puts stderr "p1 data:'$data'" return [list source pipecase1 data $data] } - pipecase p2,'x@0,'y@1.=val $args |> { + pipecase p2,'x'@0,'y'@1.= val $args |> { return [list source pipecase2 data $data] } - pipecase p3,'x@0.=val $args |> { + pipecase p3,'x'@0.= val $args |> { return [list source pipecase3 data [list transformed {*}$data]] } - pipecase .=val $args |> { - puts "catchall pipe4" + pipecase .= val $args |> { + puts "catchall pipe4 $data" return $data } - } + } {*}$args + #scope is ok - but pipeswitch overrides'args' so we need to either pass them in, or set another variable - Review. } puts "match_args a b c : [match_args a b c]" puts "match_args x y z : [match_args x y z]" diff --git a/scriptlib/tests/quicksort.tcl b/scriptlib/tests/quicksort.tcl new file mode 100644 index 00000000..cd479b05 --- /dev/null +++ b/scriptlib/tests/quicksort.tcl @@ -0,0 +1,17 @@ +#testing. + + + +proc quicksort {m} { + if {[llength $m] <= 1} { + return $m + } + set pivot [lindex $m 0] + set less [set equal [set greater [list]]] + foreach x $m { + lappend [expr {$x < $pivot ? "less" : $x > $pivot ? "greater" : "equal"}] $x + } + return [concat [quicksort $less] $equal [quicksort $greater]] +} + +puts [quicksort {8 6 4 2 1 3 5 7 9}] ;# => 1 2 3 4 5 6 7 8 9 \ No newline at end of file diff --git a/scriptlib/tests/reverse.tcl b/scriptlib/tests/reverse.tcl new file mode 100644 index 00000000..cb91b28a --- /dev/null +++ b/scriptlib/tests/reverse.tcl @@ -0,0 +1,22 @@ + + +fun reverse list/0,1# {@@ok/result.= do_reverse $list [list]} +fun do_reverse h/0/head,t/0/tail,reversed/1 {tailcall @@ok/result.= do_reverse $t [list $h {*}$reversed]} +fun do_reverse 0/0/#,reversed/1 {return $reversed} + + + +#2023-06 initial punk version.. creates string rep, no compiled pattern matching - extremely slow +#set x [list a b c d e f g h i j];list +#P% llength $x +#- 10 +#P% rep $x +#- value is a list with a refcount of 4, object pointer at 00000000097F65F0, internal representation 0000000004ABCE90:0000000000000000, no string representation +#P% reverse $x; list +#P% rep $x +#- value is a list with a refcount of 4, object pointer at 00000000097F65F0, internal representation 0000000004ABCE90:0000000000000000, string representation "a b c d e f #g..." +#P% time {reverse $x} 100 +#- 2457.0330000000004 microseconds per iteration +#P% time {reverse $x} 1000 +#- 2460.8575 microseconds per iteration + diff --git a/scriptlib/tests/sample1.json b/scriptlib/tests/sample1.json new file mode 100644 index 00000000..4ad328db --- /dev/null +++ b/scriptlib/tests/sample1.json @@ -0,0 +1,23 @@ +{ + "name": "grpc/grpc", + "type": "library", + "description": "gRPC library for PHP", + "keywords": ["rpc"], + "homepage": "https://grpc.io", + "license": "Apache-2.0", + "require": { + "php": ">=7.0.0" + }, + "require-dev": { + "google/auth": "^v1.3.0" + }, + "suggest": { + "ext-protobuf": "For better performance, install the protobuf C extension.", + "google/protobuf": "To get started using grpc quickly, install the native protobuf library." + }, + "autoload": { + "psr-4": { + "Grpc\\": "src/php/lib/Grpc/" + } + } +} diff --git a/scriptlib/tests/simplepipe.tcl b/scriptlib/tests/simplepipe.tcl new file mode 100644 index 00000000..91282769 --- /dev/null +++ b/scriptlib/tests/simplepipe.tcl @@ -0,0 +1,48 @@ +proc pipe* args { + set r [uplevel 1 [lindex $args 0]] + for {set i 1} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + if {[llength $e] == 1} { + if {$e eq {>}} { + incr i + uplevel 1 [list set [lindex $args $i] $r] + } else { + set r [uplevel 1 [list $e $r]] + } + } else { + set cmd {} + set substdone 0 + foreach arg $e { + if {$arg eq {*}} { + lappend cmd $r + set substdone 1 + } else { + lappend cmd $arg + } + } + if {$substdone == 0} { + lappend cmd $r + } + set r [uplevel 1 $cmd] + } + } + return $r +} + +set s " supercalifragilistichespiralitoso " +pipe* {string trim $s} {split * {}} {lsort -unique} {join * {}} > s \ + {string length} > l +puts $s +puts $l + +#test running of patternmatching pipelines within pipe* +set x [list a b blah etc] +pipe* {set x} {,'a'@0/0= |@0> {puts $data; set data} <| *} {val *} + +pipe* {set x} {,'a'@0/0= |@0> { + puts $data + set data + } <| *} {val *} + + + diff --git a/scriptlib/tests/simplepipe2.tcl b/scriptlib/tests/simplepipe2.tcl new file mode 100644 index 00000000..c2b12743 --- /dev/null +++ b/scriptlib/tests/simplepipe2.tcl @@ -0,0 +1,73 @@ +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 +} + +set s " supercalifragilistichespiralitoso " +pipedata $s {string trim $data} {split $data {}} {lsort -unique $data} {join $data {}} > s \ + {string length $data} > l +puts $s +puts $l + +#test running of patternmatching pipelines within pipe* +set x [list a b blah etc] +puts "-1" +pipedata $x {,'a'@0/0= |@0> {puts $data; set data} <| $data} {val $data} + +puts "-2" +pipedata $x {,'a'@0/0= |@0> { + puts $data + set data + } <| $data} {val $data} + +pipeset pipe1 ,'a'@0/0= |/0-1> {puts $data; set data} |> string toupper <| +puts "-3" +pipedata $x pipematch $pipe1 \ No newline at end of file diff --git a/scriptlib/tests/space file.txt b/scriptlib/tests/space file.txt new file mode 100644 index 00000000..e69de29b diff --git a/scriptlib/tests/unbalanced.tcl b/scriptlib/tests/unbalanced.tcl index 8afad07e..feadbafb 100644 --- a/scriptlib/tests/unbalanced.tcl +++ b/scriptlib/tests/unbalanced.tcl @@ -1,9 +1,15 @@ #test of commands with unbalanced characters to see how they are handled in a script -x=$$"} +x= $$"} puts $x + +if {[catch { + y=" -puts $y +} errM]} { + puts "got error $errM" +} + diff --git a/scriptlib/tests/wanted.tcl b/scriptlib/tests/wanted.tcl new file mode 100644 index 00000000..252d69af --- /dev/null +++ b/scriptlib/tests/wanted.tcl @@ -0,0 +1,18 @@ + +# this should run 'list a b c tail' +catch { + +% x.=/0* tail |> {puts $data;set data} {puts $data;set data} string toupper + +#but then what would happen if the args pipeline also took input via another <| ? +#% x.=/0* |> {puts $data;set data} {puts $data; set data} |p1/0> .= { {*}$p1 } |> {puts $data;set data} string toupper]