Browse Source

update of various scripts in tests folder

master
Julian Noble 2 years ago
parent
commit
3861235ad7
  1. 38
      scriptlib/tests/Lfilter.tcl
  2. 9
      scriptlib/tests/block_padleft.tcl
  3. 29
      scriptlib/tests/curry_assign.tcl
  4. 14
      scriptlib/tests/first_assign.tcl
  5. 320
      scriptlib/tests/fn.tcl
  6. 392
      scriptlib/tests/fun.tcl
  7. 219
      scriptlib/tests/html.tcl
  8. 62
      scriptlib/tests/json.tcl
  9. 39
      scriptlib/tests/linetest.tcl
  10. 129
      scriptlib/tests/listbuilder.tcl
  11. 17
      scriptlib/tests/listrep_bug.tcl
  12. 21
      scriptlib/tests/listrep_bug2.tcl
  13. 93
      scriptlib/tests/monadtest.tcl
  14. 2
      scriptlib/tests/multireturn.tcl
  15. 42
      scriptlib/tests/nameservers.tcl
  16. 4
      scriptlib/tests/pipeindex.tcl
  17. 31
      scriptlib/tests/pipeline1.tcl
  18. 27
      scriptlib/tests/pipeswitch.tcl
  19. 17
      scriptlib/tests/quicksort.tcl
  20. 22
      scriptlib/tests/reverse.tcl
  21. 23
      scriptlib/tests/sample1.json
  22. 48
      scriptlib/tests/simplepipe.tcl
  23. 73
      scriptlib/tests/simplepipe2.tcl
  24. 0
      scriptlib/tests/space file.txt
  25. 10
      scriptlib/tests/unbalanced.tcl
  26. 18
      scriptlib/tests/wanted.tcl

38
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} <in|
}
pipeset pipeb @@ok/result.= {
pipeswitch {
pipecase .= ,'b'.= string range $switchargs 0 0 |> {val 1}
val {ok {result 0}}
} $in
} <in|
puts stdout [struct::list::Lfilter {a apple b aardvark banana blah c} $pipeb]
pipeset pipec @@ok/result.=in/end \
pipeswitch {
pipecase .= ,'c'.= string range $switchargs 0 0 |> {val 1}
val {ok {result 0}}
} <in|
puts stdout [struct::list::Lfilter {a apple b aardvark banana blah c charlie chocolate} $pipec]
#>f . reduce {.=* list |> {join $data ":"} <|} {a b c d e f}

9
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 <input/0,indent/1|
puts stdout "block_padleft pipeline"
puts stdout "[alias block_padleft]"
puts stderr "block_padleft \[>punk . logo] 50"
puts stdout "[block_padleft [>punk . logo] 50]"

29
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-"

14
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 "

320
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> $end] {uplevel 1 [list if 1 <end> ]}]
} 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> $end] {uplevel 1 [list if 1 <end> ]}]
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
}

392
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 <argspec> at beginning?
set test_case_template {
pipecase <argspec>.= list {*}$arglist |args> {
<body>
} <<argspec>| {*}$arglist
}
set case_template1 {
pipecase .= list {*}$arglist |args> {
<body>
} <<argspec>| {*}$arglist
}
set case_template {
pipecase .= {
<body>
} <<argspec>| {*}$switchargs
}
set pipecases ""
set definitions [dict get $funs $name defs]
dict for {a b} $definitions {
set impl [string map [list <argspec> $a <body> $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> $pipecases] {
pipeswitchc {
<pipecases>
} $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 <argspec> $a <body> $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> $pipecases] {
# % .= {
# pipeswitch {
# <pipecases>
# }
# } <arglist| {*}$args
#}]
puts "creating alias '$name'"
interp alias {} $name {} pipeswitchc $pipecases
}
interp alias {} fun {} pipefun::fun
interp alias {} funs {} pipefun::funs
interp alias {} funclear {} pipefun::funclear
interp alias {} funinfo {} pipefun::funinfo
interp alias {} funclause {} pipefun::funclause
fun age argc#,v@0-end {
#always runs for age - falls through to other implementations
puts "age called with argc:$argc args:$v"
error [list ignore]
}
#only runs for exactly 2 args
fun age a@,m@,2# {
puts "You're $a! $m"
# pipematch r@@ok/resultx.= age $a
}
#experiment with match but return error instead of ok {result xxx}
fun age a {
% switchresult.= pipeswitch {
#puts "testing-arguments: $a"
if {![info exists a]} {
error [list ignore no-arg]
}
pipecase .= val $a |a@0> \
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 <value>}' 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

219
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 "</$tag>"
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 "</$tag>"
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
} <pipeargs| -type optionlist
#test version.. doesn't set vars, or go into subpipelines
proc make_o {pipeline} {
set oline [list] ;#o combinator list
set segment [list]
set idx 0
#find first .=
foreach x $pipeline {
if {[string match *.=* $x]} {
set posn [string first .= $x]
set rhs [string range $x $posn+2 end]
if {[string length $rhs]} {
lappend oline [string range $x 0 $posn+1]
lappend segment $rhs
} else {
lappend oline $x
}
incr idx
break
} else {
lappend oline $x
}
incr idx
}
#lappend oline o_of
foreach x [lrange $pipeline $idx end] {
if {[string match "|*>" $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]
}

62
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
}
} <ch/0,input/1| $ch
}
#generate a functor on a pipeline targeting a specific section of the 'value' in: ok {result value}
proc fmap {cmdlist pipeline {restructure ""}} {
pipeset functor .= {
pipeswitch {
pipecase .= list $cmd $p $s $input |cmd@,pipe@,s@,input@> \
,'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
}
} <cmd@,p@,s@,input@| $cmdlist $pipeline $restructure
}
#JSON Parser 100% From Scratch in Haskell (only 111 lines)
#https://www.youtube.com/watch?v=N9RUqGYuGfw
# see also: Understanding parser combinators: a deep dive - Scott Wlaschin https://www.youtube.com/watch?v=RDalzi7mhdY
#produce a pipeline for inner pipeline producing: ok {result {tailchars headchar}}
#where cmdlist is applied to headchar
proc charP_functor {cmdlist pipeline} {
pipeset functor .= {
pipeswitch {
pipecase .= list $p $input $cmd |pipe@0,input@1,cmd@2> \
,'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
}
} <p@,cmd@,input/2| $pipeline $cmdlist
}
proc scanc {ch} {
scan $ch %c
}
p.= charP p
fc.= charP_functor scanc $p

39
scriptlib/tests/linetest.tcl

@ -1,17 +1,46 @@
set sep [string repeat - 40]
set x [list \
a b c\
d e f\
]
puts stdout $x
puts stdout "x: $x"
puts stdout $sep
if {[catch {
y.=list\
y.= .= list\
a b c\
d e f
d e f |> inspect -label inspect-y
} errmsg]} {
puts stderr "error: $errmsg"
} else {
puts stdout $y
}
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

129
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-

17
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"

21
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

93
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} <input| ]
}
proc pipet {subcommand} {
return [list % list $subcommand |sub/0,input/1> \
{clock micros} |start> {{*}$sub {*}$input} |res> {expr [clock micros] - $start} |t> {list $res $t} <input| ]
}
pipeset fast % {expr {$x + 1}} <x|
pipeset slow % {after 100} |> {expr {$x + 1}} <x|
pipeset slow2 % {after 150} |> {expr {$x + 2}} <x|
#naive chaining of time-wrapped commands.
#Requires unpacking/matching at each stage of pipeline and summing at end.
% .= val 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}]} <vt@,f@|
pipeset bind % {list $vt $f} |v@0/0,t@0/1> {{*}$f $v} |r2@,t2@> {list $r2 [expr {$t + $t2}]} <vt@,f@|
# requires nested binds .. a bit messy
{*}$bind [{*}$bind [{*}[pipet $::fast] 1] [pipet $::slow]] [pipet $::slow2]
#we can neaten it up with tcl aliases, but we still don't have a straightforward pipeline so it will get messier with more operations.
alias t_fast {*}[pipet $fast]
alias t_slow {*}[pipet $slow]
alias t_slow2 {*}[pipet $slow2]
alias bind {*}$bind
bind [bind [t_fast 1] t_slow] t_slow2
#now with oo approach
catch {timedvalue destroy}
oo::class create timedvalue {
variable o_value
variable o_time
constructor {value {time 0}} {
set o_value $value
set o_time $time
}
method value {} {return $o_value}
method time {} {return $o_time}
method bind {f} {
set timed_value [{*}$f $o_value]
set new_value [$timed_value value]
set new_time [expr {$o_time + [$timed_value time]}]
return [timedvalue new $new_value $new_time]
}
}
#we need a new timing wrapper that returns an object
proc pipet2 {subcommand} {
return [list % list $subcommand |sub/0,input/1> \
{clock micros} |start> {{*}$sub {*}$input} |res> {expr [clock micros] - $start} |t> {timedvalue new $res $t} <input| ]
}
alias o_fast {*}[pipet2 $fast]
alias o_slow {*}[pipet2 $slow]
alias o_slow2 {*}[pipet2 $slow2]
tvresult.= \
.= o_fast 1 \
|o> {$o bind o_slow} \
|o> {$o bind o_slow2}
puts "tvresult value: [$tvresult value]"
puts "tvresult time: [$tvresult time]"
#timedvalue class is a monad

2
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"

42
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
} <ns|
return $subpipe
}
proc pipe_nameserverlist {} {
return [list % {val $domain} |> {runout -n dig $data ns +short} |> linelist |> {listmap {{*}[pipe_webpub] $item} $data} <domain|]
}
#{*}[pipe_nameserverlist] precisium.com.au
proc nameserverlist {domain} {
tailcall {*}[pipe_nameserverlist] $domain
}
proc nameserverdisplay {domain} {
return [list % val $domain |> {{*}[pipe_nameserverlist] $data } |> lsort]
}
puts stdout "command available: nameserverlist <domain>"

4
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"

31
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
} \
<args| a b c
<args| "a b c" x y z
#-----------------------------------------------------------
set input [list a b c d e f g]
a.=val $input |> {
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"

27
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]"

17
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

22
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

23
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/"
}
}
}

48
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 *}

73
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

0
scriptlib/tests/space file.txt

10
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"
}

18
scriptlib/tests/wanted.tcl

@ -0,0 +1,18 @@
# this should run 'list a b c tail'
catch {
% x.=/0* tail |> {puts $data;set data} <in| list a b c
}
#should it then be able to run pipelines as 'args'
% x.=/0* |> {puts $data;set data} <in| % y.= list etc blah |> string toupper
#but then what would happen if the args pipeline also took input via another <| ?
#% x.=/0* |> {puts $data;set data} <in| % y.= list etc blah <| list data
#presumably pipelines shouldn't be passed in as expanded lists..
% out= x= |> {puts $data; set data} |p1/0> .= { {*}$p1 } |> {puts $data;set data} <in| [list % y.= list etc blah |> string toupper]
Loading…
Cancel
Save