jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

update of various scripts in tests folder

master
Julian Noble 1 year ago
parent
2d4def515e
commit
3861235ad7
26 changed files with 1630 additions and 69 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  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. 37
      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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

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

37
scriptlib/tests/linetest.tcl
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

@ -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
Unescape View File

10
scriptlib/tests/unbalanced.tcl
Unescape View File

@ -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
Unescape View File

@ -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]
Write Preview
Loading…
Cancel
Save