#! /bin/env tclsh
package require {ycl list}
namespace import [yclprefix]::list::sl
namespace import ::tcl::mathop::*
#package require {ycl shelf shelf}
#namespace import [yclprefix]::shelf::shelf
package require {ycl shelf tcloo object}
namespace import [yclprefix]::shelf::tcloo::object
rename object shelf
namespace import [yclprefix]::shelf::util::asmethod
proc suite_main {} {
package require {ycl test}
[yclprefix]::test::init
namespace import [yclprefix]::test::cleanup1
foreach varname [info vars [namespace current]::*] {
variable $varname
}
test basis {
adjust the basis of a shelf
} -setup {} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
shelf2 .eval {
proc p1 _ {
return val1
}
}
shelf2 .method p1
lappend res [shelf2 p1]
shelf .spawn shelf3
shelf3 .basis shelf2
catch {shelf3 p1} cres copts
lappend res $cres
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
val1 val1
}]
test basis2 {
} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
lappend res [shelf2 .basis]
shelf2 .method new [list [namespace which new2]]
shelf2 new shelf3
lappend res [shelf3 $ var1]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1
{mutually-assured non sequitor}
}]
test clone {} -setup {} -body {
shelf .spawn shelf1
rename shelf1 {}
catch {namespace delete shelf1}
shelf .clone shelf1
rename shelf1 {}
return
} -cleanup [cleanup1] -result [sl {
}]
test clone_existing {} -setup {} -body {
namespace eval shelf1 {}
shelf .clone shelf1
return
} -cleanup [cleanup1] -result [sl {
}]
test clone_basis {
A clone has the same basis as the thing it was cloned from
} -setup {} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
shelf2 .clone shelf3
lappend res [expr {[namespace tail [shelf1 .basis]] eq [
namespace tail [shelf .namespace]]}]
lappend res [namespace tail [shelf2 .basis]]
lappend res [namespace tail [shelf3 .basis]]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
1 shelf1 shelf1
}]
test clone_spawn {
Spawn a clone
} -setup {} -body {
shelf .clone shelf1
lappend res [namespace tail [shelf1 .spawn shelf2]]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
shelf2
}]
test commands {
} -setup {} -body {
shelf .spawn shelf1
lappend res {*}[lsort [shelf1 .routines]]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{$} {$.exists} {$.locate} .apply .attribute .basis .clone .cloned
.configure .disposal .eject .eval .inject .inner .method .namespace
.plug .routine .routines .spawn .spawned .state .switch .wrap .wrapped
.~ configure init
}]
test current {
} -setup {} -body {
shelf .spawn shelf1
shelf1 $ var3 goodbye
shelf1 .spawn shelf2
shelf .spawn a
a .eval {
proc p _ {
set current [$_ .inner]
$_ $ var1 [$current $ var2]
set res [$current $ var3 uhoh]
return $res
}
}
a .method p
a $ var2 hello
shelf2 .inject a
shelf2 p
lappend res [shelf2 $ var1]
lappend res [shelf2 $ var3]
a .configure injected false
lappend res [shelf2 $ var3]
rename shelf2 {}
rename a {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
hello goodbye uhoh
}]
test current_plugin {
only explicitly named plugins get plugged in
} -setup {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc q _ {
return 13
}
}
shelf1 .method q
shelf1 .spawn shelf2
shelf .spawn a
a .eval {
proc p {_ shelf} {
return [list [$shelf q] [$_ q]]
}
proc q _ {
return 8
}
}
a .method p
a .method q
a $ var2 hello
shelf2 .plug a p
shelf2 p
lappend res [shelf2 q]
lappend res [shelf2 p]
rename shelf2 {}
rename a {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
13 {13 8}
}]
test disposal {
} -setup {} -body {
namespace eval ns2 {}
shelf .spawn shelf1
shelf1 .method dying [namespace which dying]
shelf1 .disposal dying
shelf1 .spawn shelf2
shelf1 .clone shelf3
shelf2 .clone shelf4
rename shelf4 {}
lappend res $ns2::deadyet
rename shelf3 {}
lappend res $ns2::deadyet
rename shelf2 {}
lappend res $ns2::deadyet
rename shelf1 {}
lappend res $ns2::deadyet
unset ns2::deadyet
return $res
} -cleanup [cleanup1] -result [sl {
{shelf4 still dying} {shelf3 still dying} {shelf2 still dying} {shelf1 still dying}
}]
test dispatch_chain {
Each dispatch happens relative to the current call location
} -body {
foreach x {{} 1 2} y {1 2 3} {
shelf${x} .spawn shelf${y}
if {$y == 1} {
shelf${y} .eval {
proc p {_ index} {
lappend ${_}::var1 [list [namespace tail $_] [
namespace tail [namespace current]] $index]
}
}
} else {
shelf${y} .eval {
proc p {_ index} {
lappend ${_}::var1 [list [namespace tail $_] [
namespace tail [namespace current]] $index]
uplevel 1 [list $_ .switch p [incr index]]
}
}
}
shelf${y} .method p
}
shelf3 p 5
shelf3 $ var1
lappend res [shelf3 $ var1]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{{shelf3 shelf3 5} {shelf3 shelf2 6} {shelf3 shelf1 7}}
}]
test eject {
} -setup {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc move _ {
return [list [namespace tail $_] is walking]
}
}
shelf1 .method move
shelf .spawn shelfa
shelfa .eval {
proc move _ {
return [list [namespace tail $_] is flying]
}
}
shelfa .method move
shelf1 .spawn shelf2
lappend res [shelf2 move]
shelf2 .inject shelfa
lappend res [shelf2 move]
shelf2 .spawn shelf3
lappend res [shelf3 move]
shelf2 .eject shelfa
lappend res [shelf2 move]
lappend res [shelf3 move]
rename shelf3 {}
rename shelf2 {}
rename shelfa {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{shelf2 is walking} {shelf2 is flying} {shelf3 is flying}
{shelf2 is walking} {shelf3 is walking}
}]
test inject {
} -setup {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc move {_ how} {
return [list [namespace tail $_] is $how]
}
proc walk _ {
$_ move walking
}
}
shelf1 .method walk
shelf1 .method move
shelf .spawn shelfa
shelfa .eval {
proc fly _ {
$_ move flying
}
}
shelfa .method fly
shelf1 .spawn shelf2
shelf2 .inject shelfa
lappend res [shelf2 walk]
lappend res [shelf2 fly]
rename shelf2 {}
rename shelfa {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{shelf2 is walking} {shelf2 is flying}
}]
test inject_all {
All methods listed as plugins plugged in when none are specified.
} -setup {} -body {
shelf .spawn shelf1
shelf .spawn shelfa
shelfa .eval {
proc fly {_ shelf} {
return [list [namespace tail $shelf] flying]
}
}
shelfa .method fly
shelfa .state set plugins fly
shelf1 .plug shelfa
lappend res [shelf1 fly]
rename shelf1 {}
rename shelfa {}
return $res
} -cleanup [cleanup1] -result [sl {
{shelf1 flying}
}]
test inject_switch {
injected shelf uses [.switch] to call method on the shelf that
injected it.
} -body {
shelf .spawn shelf1
shelf1 .eval {
proc method1 _ {
namespace upvar $_ var1 var1
lappend var1 two
}
}
shelf1 .method method1
shelf .spawn shelf2
shelf2 .eval {
proc method1 {_ shelf} {
namespace upvar $shelf var1 var1
lappend var1 one
set inner [$shelf .inner]
# The first time .switch is called, the inner shelf is already
# the shelf that the current command was resolved from .
uplevel 1 [list $shelf .switch method1]
# Can't use the default switch shelf here because it is now $shelf1
uplevel 1 [list $shelf .switch shelf [$inner .basis] method1]
}
}
shelf2 .method method1
shelf1 .spawn shelf1a
shelf2 .spawn shelf2a
shelf2a .eval [list variable shelf [namespace which shelf2]]
shelf2a .eval {
proc method1 {_ args} {
variable shelf
::tailcall $shelf method1 $_ {*}$args
}
}
shelf2a .method method1
shelf1a .inject shelf2a
shelf1a method1
lappend res [shelf1a $ var1]
rename shelf1a {}
rename shelf2a {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{one two two}
}]
test spawn_basis {
A spawn has the the thing it was spawned from as its basis
} -setup {} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
shelf2 .spawn shelf3
lappend res [expr {[namespace tail [shelf1 .basis]] eq [
namespace tail [namespace origin shelf]]}]
lappend res [namespace tail [shelf2 .basis]]
lappend res [namespace tail [shelf3 .basis]]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
1 shelf1 shelf2
}]
test spawn_dynamic {
A spawned shelf can use a method added to the parent after the shelf
was spawned.
} -setup {} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
shelf1 .eval {
proc greet _ {
return hello
}
}
shelf1 .method greet
lappend res [shelf2 greet]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
hello
}]
test shelf {} -setup {} -body {
shelf .spawn shelf1
shelf1 $ var1 val1
lappend res [shelf1 $.locate var1]
lappend res [shelf1 $ var1]
shelf1 .method greet [list ::apply [list {self args} {
list [namespace tail $self] $args
}]]
lappend res [shelf1 greet]
lappend res [shelf1 greet onearg]
shelf1 .clone shelf2
lappend res [shelf2 greet hello]
shelf1 .spawn shelf3
lappend res [shelf3 greet howdy]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
set res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::var1 val1 {shelf1 {}} {shelf1 onearg} {shelf2 hello} {shelf3 howdy}
}]
test shelf2 {} -setup {} -body {
namespace eval ns2 {
variable pea {}
}
shelf .spawn obj1
obj1 .method .~ [list [namespace which ~]]
namespace eval [obj1 .namespace] {
variable var1 yuck
}
#this tests $ functionality
catch {obj1 $ name} cres copts
if {[string is list $cres]} {
lappend res [lindex $cres 2]
} else {
lappend res $cres
}
obj1 .clone obj2
lappend res [obj2 $ var1]
obj2 .eval {
proc jump {_ args} {
return [list [namespace tail $_] jumping]
}
}
obj2 .method name [list [namespace current]::name]
obj2 .method jump
obj2 name Pasithea
lappend res [obj2 $ name]
# add an empty object in between
obj2 .spawn obj3
obj3 .spawn obj4
set located [obj4 $.locate name]
lappend res [namespace tail [namespace qualifiers $located]]
lappend res [namespace tail $located]
obj4 name Patroclus
lappend res [obj4 $ var1]
lappend res [obj4 $ name]
lappend res [obj2 $ name]
obj4 .method name [list [namespace current]::name2]
obj4 name Thersites
lappend res [obj4 $ name]
lappend res [obj4 jump]
lappend res [obj2 $ name]
obj4 .method .~ [list ::apply [
list args [list set [namespace current]::var1 "obj4 dying!"]]]
rename obj4 {}
obj1 .spawn obj5
obj1 .spawn obj6
# Ensure that the trace is fired when the namespace is deleted
obj5 .eval {namespace delete [namespace current]}
lappend res [set ns2::pea]
lappend res [set [namespace current]::var1]
obj6 .method [list [namespace which dying]]
obj6 .disposal dying
lappend res [lindex [obj6 .disposal] 0]
rename obj6 {}
rename obj3 {}
rename obj2 {}
rename obj1 {}
lappend res [set ns2::pea]
lappend res [set [namespace current]::ns2::deadyet]
return $res
} -cleanup [cleanup1] -result [sl {
{no such variable} yuck Pasithea
obj2 name yuck Patroclus Pasithea Agamemnon
{obj4 jumping}
Pasithea
obj5 {obj4 dying!}
dying
{obj5 obj3 obj2 obj1}
{obj6 still dying}
}]
test upstream_add_method {} -body {
shelf .spawn obj1
obj1 .spawn obj2
obj1 .eval {
proc jump {_ args} {
return [list [namespace tail $_] jumping]
}
}
obj1 .method jump
set res [obj2 jump]
rename obj2 {}
rename obj1 {}
return $res
} -cleanup [cleanup1] -result [sl {
obj2 jumping
}]
test .configure {} -body {
shelf .spawn shelf3
shelf3 .eval {
namespace eval doc {}
variable doc::init {
args {
arg1 {
name arg1a
}
arg2 {
default {}
automatic true
}
}
}
upvar 0 doc::init doc::.configure
proc init {_ args} {
variable arg1
$_ .configure {*}$args
}
[namespace current] .method init
}
shelf3 init arg1 val1
lappend res [shelf3 .configure arg1]
lappend res [shelf3 .configure]
shelf3 .eval {
dict set doc::init args arg1 default {}
}
catch {shelf3 .configure arg2 nope} cres copts
lappend res $cres
lappend res [shelf3 .configure ! arg2 yup]
lappend res [shelf3 .configure arg2]
set res
} -cleanup [cleanup1] -result [sl {
val1 {arg1 val1}
{{attempt to configure automatic setting} arg2} yup yup
}]
test configure {} -body {
shelf .spawn shelf1
shelf1 .eval {
variable doc::configure {
args {
normal1 {
default {}
}
}
}
}
shelf1 .spawn shelf2
shelf2 $ doc::.configure [shelf2 $ doc::.configure]
shelf2 .eval {
dict set doc::.configure args system1 {
default {}
}
}
shelf2 configure normal1 {i am normal}
lappend res [shelf2 configure normal1]
try {
shelf2 .configure normal1 {i am normal}
} on error {tres topts} {
lappend res $tres
}
shelf2 .configure system1 {i am system}
lappend res [shelf2 .configure system1]
try {
shelf2 configure system1 {i am system}
} on error {tres topts} {
lappend res $tres
}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{i am normal}
{{unknown argument} normal1 {i am normal}}
{i am system}
{{unknown argument} system1 {i am system}}
}]
test shelf_deletens {} -body {
lappend res [namespace exists shelf1]
shelf .spawn shelf1
shelf1 $ var1 3
lappend res [namespace exists shelf1]
lappend res [shelf1 $ var1]
shelf1 .spawn shelf2
rename shelf2 {}
lappend res [namespace exists shelf2]
rename shelf1 {}
lappend res [namespace exists shelf1]
set res
} -cleanup [cleanup1] -result [sl {
0 1 3 0 0
}]
test asmethod {} -setup {} -body {
variable method1
shelf .spawn shelf1
variable nsvar1 1
variable nsvar2 10
shelf1 $ instvar1 100
shelf1 $ instvar2 1000
shelf1 $ instvar3 5000
shelf1 $ instvar4 7000
shelf1 .method shelf1m1 [list ::apply [list {*}[asmethod $method1] [
namespace current]]]
lappend res {*}[shelf1 shelf1m1 pval1 pval2]
shelf1 .spawn shelf2
shelf2 $ instvar3 5500
shelf2 $ instvar4 7500
lappend res {*}[shelf2 shelf1m1 pval1 pval2]
lappend res $nsvar1
lappend res [set shelf2::instvar1]
lappend res $nsvar1
lappend res [set shelf1::instvar1]
rename shelf2 {}
rename shelf1 {}
set res
} -cleanup [cleanup1] -result [sl {
{pval1 pval2 100 1000 5000 7000 1 10}
{101 2}
{pval1 pval2 101 1000 5500 7500 2 10}
{102 3}
3 102
3 101
}]
test apply {} -setup {} -body {
shelf .spawn shelf1
lappend res [shelf1 .apply {{_ args} {
$_ $ name Alcinous
expr {$_ eq [namespace current]}
}}]
lappend res [shelf1 $ name]
} -cleanup [cleanup1] -result [sl {
1 Alcinous
}]
test attribute {} -setup {} -body {
shelf .spawn shelf1
shelf1 .attribute name
shelf1 name Alcinous
shelf1 name
} -cleanup [cleanup1] -result [sl {
Alcinous
}]
test method_qualified_notarget {
When a fully-qualified command is provided , but no target is provided
, the target is that fully-qualified command , and the method name is
the namespace tail of that command .
} -body {
shelf .spawn shelf1
shelf1 .method [list [namespace which name]]
shelf1 name Bob
shelf1 name
} -cleanup [cleanup1] -result {Bob}
test routine {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc p1 args {
::tcl::mathop::- {*}$args
}
proc p2 args {
::tcl::mathop::+ {*}$args
}
proc {p3 p4} {} {
uplevel {set nsvar1}
}
}
set errhandler {
if {[string is list $tres]} {
set tres0 [lindex $tres 0]
if {$tres0 eq {unknown command}} {
lappend res unknown
} else {
return -options $topts $tres
}
} else {
if {[string match {unknown method*} $tres]} {
lappend res unknown
} else {
return -options $topts $tres
}
}
}
try {shelf1 p1} on error {tres topts} $errhandler
shelf1 .routine p1
lappend res [shelf1 p1 8 5]
shelf1 .routine p2 p2
lappend res [shelf1 p2 3 5]
shelf1 .routine p2 p2 8
lappend res [shelf1 p2 8 5]
shelf1 .spawn shelf2
lappend res [shelf2 p1 8 5]
variable nsvar1 bean
shelf2 .routine {p3 p4} {p3 p4}
# If this doesn't fail, ensemble prefixes are enabled, but they shouldn't be
try {shelf2 p3} on error {tres topts} $errhandler
lappend res [shelf2 {p3 p4}]
rename shelf2 {}
rename shelf1 {}
set res
} -cleanup [cleanup1] -result {unknown 3 8 21 3 unknown bean}
test routine_qualified_notarget {
When a fully-qualified command is provided , but no target is provided
, the target is that fully-qualified command , and the method name is
the namespace tail of that command .
} -body {
shelf .spawn shelf1
shelf1 .routine [namespace which name]
shelf1 name [namespace which shelf1] Bob
} -cleanup [cleanup1] -result {Bob}
test routine_submethod {
Pass the shelf to a namespace ensemble subcommand
} -body {
shelf .spawn shelf1
shelf1 $ var1 1
namespace eval util {
namespace export *
namespace ensemble create
proc add {_ args} {
::tcl::mathop::+ [$_ $ var1] {*}$args
}
}
shelf1 .method add [list [namespace which util] add] [list 2 3]
namespace eval util2 {
namespace export *
namespace ensemble create -parameters _
proc mult {_ args} {
::tcl::mathop::* [$_ $ var1] {*}$args
}
}
shelf1 .method util2 [list [namespace which util2]]
lappend res [shelf1 add 5]
lappend res [shelf1 util2 mult 5]
shelf1 .spawn shelf2
shelf2 $ var1 8
lappend res [shelf2 add 5 9]
shelf1 .clone shelf3
lappend res [shelf3 add 10 13]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
11 5 27 29
}]
test switch {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc one {_ arg} {
namespace upvar $_ var1 var1
lappend var1 [list one $arg]
}
[namespace current] .method one
}
shelf1 .spawn shelf2
shelf2 .eval {
proc one _ {
namespace upvar $_ var1 var1
lappend var1 two
$_ .switch one hello
}
[namespace current] .method one
}
shelf2 one
lappend res [shelf2 $ var1]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{two {one hello}}
}]
test namespace_path {} -body {
shelf .spawn shelf1
shelf1 .eval {
namespace eval imports {}
namespace path [list {*}[namespace path] [namespace current]::imports]
}
shelf1 $ var1 val1
shelf1 $ var1
} -cleanup [cleanup1] -result [sl {
val1
}]
apply [list {} {
foreach create {clone spawn} {if 1 [string map [
list @create@ [list $create]] {
test basecmd_@create@ {} -body {
shelf .spawn shelf1
shelf1 .eval {
variable doc::init {
args {
_ {}
var1 {
default {$_ $ var1 {To have, or not to have}}
}
}
}
proc init {_ args} {
set epoch [info cmdcount]
checkargs [$_ $ doc::init] {*}$args
}
}
shelf1 .method init
shelf1 .spawn shelf2
shelf2 .eval {
proc var1 _ {
set ${_}::var1
}
}
shelf2 .method var1
shelf2 .method init [list [namespace which init1]]
shelf2 .@create@ shelf3
shelf3 init
lappend res [shelf3 var1]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{To have, or not to have}
}]
}]
}} [namespace current]]
test variable_lookup {
} -body {
shelf .spawn shelf1
shelf1 $ var1 {a dream}
shelf1 .spawn shelf2
shelf2 .eval {
variable var1
}
lappend res [shelf2 $ var1]
shelf2 .spawn shelf3
lappend res [shelf3 $ var1]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{a dream} {a dream}
}]
cleanupTests
}
proc ~ args {
lappend ns2::pea [namespace tail [lindex $args 0]]
}
proc dying {_ args} {
set ns2::deadyet [list [namespace tail $_] still dying]
}
proc init1 {_ args} {
uplevel 1 [list $_ .switch init {*}$args]
return $_
}
variable method1 {{pvar1 pvar2} {instvar3 {instvar4 instvar5}} {nsvar1 nsvar2} {
lappend res [list $pvar1 $pvar2 [$_ $ instvar1] [$_ $ instvar2] \
$instvar3 $instvar5 $nsvar1 $nsvar2]
$_ $ instvar1 [+ [$_ $ instvar1] 1]
set nsvar1 [+ $nsvar1 1]
lappend res [list [$_ $ instvar1] $nsvar1]
set res
}}
proc name {self args} {
if {![llength $args]} {
return [set ${self}::name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set ${self}::name [lindex $args 0]
}
proc name2 {self args} {
if {![llength $args]} {
return [set ${self}::name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set ${self}::name Agamemnon
}
proc new2 {_ args} {
set new [[$_ .basis] .spawn {*}$args]
$new $ var1 {mutually-assured non sequitor}
return $new
}