#! /bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias [yclprefix]::proc::alias
package require {ycl list}
alias [yclprefix]::list::lindex
alias [yclprefix]::list::sl
alias [yclprefix]::list::lmap
alias ::tcl::mathop::*
alias ::tcl::mathop::+
package require {ycl ns}
alias [yclprefix]::ns
package require {ycl shelf util}
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
}
# stubs some things so that [cleanup1] doesn't delete them
proc shelf {} {}
proc nsshelf {} {}
proc tclooshelf {} {}
set setup0 {
init_$shelftype
}
set setup1 $setup0
append setup1 {
set res {}
shelf .spawn shelf1
shelf1 .eval {
proc p1 {_ args} {
list [namespace current]::p1 [$_ _] $args
}
}
shelf1 .spawn shelf2
shelf2 .eval {
proc p1 {_ args} {
list [namespace current]::p1 $_ $args
}
}
}
foreach shelftype {nsshelf tclooshelf} {
test ${shelftype}_bases {
} -setup $setup1 -body {
shelf2 .spawn shelf3
shelf3 .spawn shelf4
set bases [shelf4 .bases]
lmap base bases {
set tail [namespace tail $base]
if {$tail eq {system}} continue
set tail
}
} -cleanup [cleanup1] -result [sl {
shelf3 shelf2 shelf1 shelf
}]
test ${shelftype}_basis {
adjust the basis of a shelf
} -setup $setup1 -body {
shelf2 .method p1
lappend res {shelf2 basis is shelf1}
lappend res [shelf2 .basis]
set res1 [shelf2 p1]
lappend res {external p1} [
inns [::lindex $res1 0] [namespace current]]
shelf2 .eval .my .method p1
set res1 [shelf2 p1]
lappend res {internal p1} [
inns [::lindex $res1 0] [shelf2 .namespace]]
shelf .spawn shelf3
shelf3 .basis shelf1
catch {shelf3 p1} cres copts
lappend res {p1 is unknown in shelf3} [
expr {[errorhandler $cres $copts] eq {unknown}}]
lappend res {shelf3 p1 does not resolve to shelf1::p1}
catch {shelf3 .eval .my .method p1} cres cropts
lappend res [expr {[errorhandler $cres $copts] eq {unknown}}]
return $res
} -cleanup [cleanup1] -result [sl {
{shelf2 basis is shelf1} [namespace current]::shelf1
{external p1} 1
{internal p1} 1
{p1 is unknown in shelf3} 1
{shelf3 p1 does not resolve to shelf1::p1} 1
}]
test ${shelftype}_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 ${shelftype}_basis_update {
adjust the basis of a shelf
} -setup $setup1 -body {
catch {shelf2 p1 one two} cres copts
lappend res [expr {[errorhandler $cres $copts] eq {unknown}}]
shelf1 .invoke .my .method p1
lappend res {*}[shelf2 p1 one two]
return $res
} -cleanup [cleanup1] -result [sl {
1
[namespace current]::shelf1::p1
[namespace current]::shelf2
{one two}
}]
test ${shelftype}_basis_newbasis {
adjust the basis of a shelf
} -setup $setup1 -body {
shelf1 .invoke .my .method p1
set res1 [shelf2 p1 hello]
lappend res {*}$res1
shelf .spawn shelf4
shelf4 .eval {
proc p2 {_ args} {
list [namespace current]::p1 [$_ _] {*}$args
}
.my .method p2
}
shelf1 .basis shelf4
lappend res {*}[shelf2 p2 hello]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::p1
[namespace current]::shelf2
hello
[namespace current]::shelf4::p1
[namespace current]::shelf2
hello
}]
test ${shelftype}_basis_ancestorchanged {
} -setup $setup1 -body {
shelf2 .spawn shelf3
shelf1 .eval {
proc p2 {_ args} {
list [namespace current]::p1 [$_ _] $args
}
.my .method p2
}
shelf3 p2
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::p1 [namespace current]::shelf3 {}
}]
test ${shelftype}_basis_updated_method_epoch {
adjust the basis of a shelf
} -setup $setup1 -body {
shelf1 .invoke .my .method p1
set p1method [shelf2 .methodwhich p1]
set epoch1 [$p1method .epoch]
set res1 [shelf2 p1 hello]
lappend res {*}$res1
shelf1 .method p1
set p1method [shelf2 .methodwhich p1]
set epoch2 [$p1method .epoch]
lappend res {shelf2 p1 epoch changed} [
expr {$epoch1 != $epoch2}]
set res1 [shelf2 p1 hello]
lappend res {*}$res1
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::p1
[namespace current]::shelf2
hello
{shelf2 p1 epoch changed} 1
[namespace current]::p1
[namespace current]::shelf2
hello
}]
test ${shelftype}_clone {} -setup {} -body {
shelf .spawn shelf1
rename shelf1 {}
catch {namespace delete shelf1}
shelf .clone shelf1
rename shelf1 {}
return
} -cleanup [cleanup1] -result [sl {
}]
test ${shelftype}_clone_existing {} -setup {} -body {
namespace eval shelf1 {}
shelf .clone shelf1
return
} -cleanup [cleanup1] -result [sl {
}]
test ${shelftype}_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 ${shelftype}_clone_spawn {
Spawn a clone
} -setup $setup0 -body {
shelf .clone shelf1
lappend res [namespace tail [shelf1 .spawn shelf2]]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
shelf2
}]
test ${shelftype}_routines {
} -setup $setup1 -body {
shelf1 .invoke .my .routine p1
lappend res {*}[lsort [shelf1 .routines]]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
p1
}]
test ${shelftype}_methods {
} -setup $setup1 -body {
lappend res {*}[lsort [shelf1 .methods]]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{$} {$.exists} {$.locate} .apply .attribute .bases .basis
.basischanged .basismodifiedmethod .clone .cloned .configure
.disposal .eject .ejected .eval .inject .injecting .invoke .mdup
.mdup1 .method .methoddelete .methodexists .methodinfo .methodmake
.methodname .methods .methodwhich .namespace .new .next
.notifymethodmodified .plug .plugin .rdup .reflect .reflected
.renamed .resolve .routine .routines .spawn .spawned .spawnedadd
.spawnedlist .spawnedremove .state .switch .unknown .vars .wrap .~
configure init
}]
test ${shelftype}_current {
} -setup {} -body {
shelf .spawn shelf1
shelf1 $ var3 goodbye
shelf1 .spawn shelf2
shelf .spawn b
b .spawn a
a .eval {
proc p _ {
set basis [$_ . .basis]
set msite [$_ .site]
set ibasis [$_ . .state get injected $msite basis]
$_ . $ var1 [$basis $ var2]
set res [$ibasis $ var3 uhoh]
return $res
}
}
a .invoke .my .method p
a $ var2 hello
shelf2 .inject a
lappend res [shelf2 p]
lappend res [shelf2 $ var1]
lappend res [shelf2 $ var3]
lappend res [b $ var3]
rename shelf2 {}
rename a {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
uhoh hello goodbye uhoh
}]
test ${shelftype}_current_plugin {
only explicitly named plugins get plugged in
} -setup {} -body {
shelf .spawn shelf1
shelf1 .eval {
proc q _ {
return 13
}
}
shelf1 .invoke .my .method q
shelf1 .spawn shelf2
shelf .spawn a
a .eval {
proc p {_ plugin} {
set injected [$_ .injected]
set map [namespace ensemble configure $_ -map]
dict set map .action [list ::lindex q]
dict set map .site [list ::lindex $injected]
namespace ensemble configure $_ -map $map
set self [$_ _]
set res1 [$injected .switch $_]
set self [$_ _]
return [list $res1 [$_ . q] [expr {$injected eq $plugin}]]
}
proc q _ {
return 8
}
}
a .invoke .my .method p
a .invoke .my .method q
a $ var2 hello
a .spawn b
shelf2 .inject b
lappend res [shelf2 q]
lappend res [shelf2 p [namespace which b]]
rename shelf2 {}
rename a {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
8 {13 8 1}
}]
test ${shelftype}_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 ${shelftype}_disposal_self {
A method decides to delete its own object, and there is a disposal
method.
} -setup {} -body {
namespace eval ns2 {}
shelf .spawn shelf1
shelf1 .eval {
proc p1 _ {
rename $_ {}
}
.my .method p1
}
shelf1 p1
} -cleanup [cleanup1] -result {}
test ${shelftype}_dispatch_chain {
Each dispatch happens relative to the current call location
} -setup $setup0 -body {
foreach x {{} 1 2} y {1 2 3} {
shelf${x} .spawn shelf${y}
if {$y == 1} {
shelf${y} .eval {
proc p {_ index} {
lappend [$_ . .namespace]::var1 [
list [namespace tail [$_ _]] [namespace tail [
namespace current]] $index]
}
}
} else {
shelf${y} .eval {
proc p {_ index} {
lappend [$_ . .namespace]::var1 [list [
namespace tail [$_ _]] [namespace tail [
namespace current]] $index]
uplevel 1 [list $_ . .switch $_ [incr index]]
}
}
}
shelf${y} .invoke .my .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 ${shelftype}_eject {
} -setup $setup0 -body {
shelf .spawn shelf1
shelf1 .eval {
proc move _ {
return [list [namespace tail [$_ _]] is walking]
}
}
shelf1 .invoke .my .method move
shelf .spawn shelfa
shelfa .eval {
proc move _ {
return [list [namespace tail [$_ _]] is flying]
}
}
shelfa .invoke .my .method move
shelf1 .spawn shelf2
lappend res [shelf2 move]
puts [list bozoo]
shelf2 .inject shelfa
#puts [list ork [info class superclass shelf2]]
puts [list grunk [shelfa .spawnedlist]]
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 ${shelftype}_inject {
} -setup $setup0 -body {
shelf .spawn shelf1
shelf1 .eval {
proc move {_ how} {
return [list [namespace tail [$_ _]] is $how]
}
proc identify {} {
return Toby
}
proc walk _ {
$_ . move walking
}
}
shelf1 .invoke .my .method walk
shelf1 .invoke .my .method move
shelf .spawn shelfa
shelfa .eval {
proc fly _ {
$_ . move flying
}
}
shelfa .invoke .my .method fly
shelfa .spawn shelfb
shelf1 .spawn shelf2
shelf2 .inject shelfb
lappend res [shelf2 walk]
lappend res [shelf2 fly]
puts [list leez]
shelfa .eval {
proc crawl _ {
$_ . move crawling
}
}
shelfa .invoke .my .method crawl
lappend res [shelf2 crawl]
rename shelf2 {}
rename shelfb {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{shelf2 is walking} {shelf2 is flying} {shelf2 is crawling}
}]
test ${shelftype}_inject_switch {
injected shelf uses [.switch] to call method on the shelf that
injected it.
} -body {
shelf .spawn shelf1
shelf1 .eval {
proc method1 _ {
$_ . .vars var1
lappend var1 two
}
}
shelf1 .invoke .my .method method1
shelf .spawn shelf2
shelf2 .eval {
proc method1 {_ othermethod} {
set self [$othermethod _]
namespace upvar $self var1 var1
lappend var1 one
set site [$othermethod .site]
uplevel 1 [list $site .switch $othermethod]
uplevel 1 [list $site .switch $othermethod]
}
}
shelf2 .invoke .my .method method1
shelf1 .spawn shelf1a
shelf2 .spawn shelf2a
shelf2a .eval [list variable shelf [namespace which shelf2]]
shelf2a .eval {
proc method1 {_ args} {
variable shelf
uplevel 1 [::list $shelf method1 $_ {*}$args]
}
}
shelf2a .invoke .my .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 ${shelftype}_invoke {
adjust the basis of a shelf
} -setup $setup1 -body {
lappend res [shelf1 .invoke ::try {
namespace current
}]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1
}]
test ${shelftype}_plug_all {
All methods listed as plugins plugged in when none are specified.
} -setup {} -body {
shelf .spawn shelf1
shelf .spawn shelfa
shelfa .eval {
proc fly {_ plugin} {
set self [$_ _]
set site [$_ .site]
set injected [$_ .injected]
return [list [namespace tail $self] flying [
expr {$injected eq $plugin}]]
}
proc info_ {_ arg1 arg2 arg3} {
set injected [$_ .injected]
return [list $arg1 [expr {
$injected eq $arg2}] $arg3 reporting for duty]
}
}
shelfa .invoke .my .method fly
shelfa .invoke .my .method info info_
shelfa .plugin add fly
shelfa .spawn shelfb
shelf1 .inject shelfb
lappend res [shelf1 info x [namespace which shelfb] y]
lappend res [shelf1 fly [namespace which shelfb]]
rename shelf1 {}
rename shelfa {}
return $res
} -cleanup [cleanup1] -result [sl {
{x 1 y reporting for duty} {shelf1 flying 1}
}]
test ${shelftype}_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 ${shelftype}_shelf {} -setup $setup0 -body {
shelf .spawn shelf1
shelf1 $ var1 val1
lappend res [shelf1 $.locate var1]
lappend res [shelf1 $ var1]
shelf1 .method greet [list ::apply [list {_ args} {
puts [list bugga [$_ _]]
list [namespace tail [$_ . .namespace]] $args
}]]
lappend res [shelf1 greet]
lappend res [shelf1 greet onearg]
shelf1 .clone shelf2
puts zrrble
lappend res [shelf2 greet hello]
shelf1 .spawn shelf3
lappend res [shelf3 greet howdy]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::var1 val1 {shelf1 {}} {shelf1 onearg} {shelf2 hello} {shelf3 howdy}
}]
test ${shelftype}_shelf2 {} -setup $setup0 -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 $ something} cres copts
if {[string is list $cres]} {
lappend res [::lindex $cres 2]
} else {
lappend res $cres
}
obj1 .clone obj2
puts [list gooong [obj2 .methods]]
puts [list kuuug [obj2 .methodexists .apply]]
puts [list kuuug [obj2 .methodexists .~]]
lappend res [obj2 $ var1]
obj2 .eval {
proc jump {_ args} {
return [list [namespace tail [$_ . .namespace]] jumping]
}
}
obj2 .method name [list [namespace current]::name]
obj2 .invoke .my .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
# The trace must fire 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 {disposal for obj6} [::lindex [obj6 .disposal] 0]
rename obj6 {}
rename obj3 {}
rename obj2 {}
rename obj1 {}
lappend res {pea report} [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!}
{disposal for obj6} dying
{pea report} {obj5 obj3 obj2 obj1}
{obj6 still dying}
}]
test ${shelftype}_shelf_renamed {} -setup {} -body {
shelf .spawn shelf1
shelf1 .method greet [list ::apply [list {_ args} {
list [namespace tail [$_ . .namespace]] $args
}]]
shelf1 .routine p1
rename shelf1 shelf1a
shelf1a .spawn shelf2
lappend res [shelf2 greet hello]
rename shelf2 {}
rename shelf1a {}
set res
} -cleanup [cleanup1] -result [sl {
{shelf2 hello}
}]
test ${shelftype}_basis_add_method {} -body {
shelf .spawn shelf1
shelf1 .spawn shelf2
shelf1 .eval {
proc jump {_ args} {
return [list [namespace tail [$_ . .namespace]] jumping]
}
}
shelf1 .invoke .my .method jump
catch {shelf2 jump} cres copts
lappend res [errorhandler $cres $copts]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{shelf2 jumping}
}]
test ${shelftype}_.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
}
.my .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 ${shelftype}_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 system}
{{unknown argument} system1}
}]
test ${shelftype}_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 ${shelftype}_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 ${shelftype}_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 ${shelftype}_attribute {} -setup {} -body {
shelf .spawn shelf1
shelf1 .attribute name
shelf1 name Alcinous
shelf1 name
} -cleanup [cleanup1] -result [sl {
Alcinous
}]
test ${shelftype}_method_name {
method names can include namespace qualifiers
} -body {
shelf .spawn shelf1
set childcount1 [llength [namespace children [shelf1 .namespace]]]
shelf1 .method bleep::bloop p1
lappend res [shelf1 bleep::bloop]
lappend res [expr {[shelf1 .methodwhich bleep::bloop] ne {}}]
set childcount2 [llength [namespace children [shelf1 .namespace]]]
lappend res {no new namespaces} [expr {$childcount1 == $childcount2}]
return $res
} -cleanup [cleanup1] -result [sl {
[list [namespace current]::p1 [namespace current]::shelf1]
1
{no new namespaces} 1
}]
test ${shelftype}_method_delete {
} -body {
shelf .spawn shelf1
shelf1 .method [list [namespace which name]]
foreach method [shelf1 .methods] {
lappend mcmds [shelf1 .methodwhich $method]
}
rename shelf1 {}
set methodcount2 0
foreach mcmd $mcmds {
if {[namespace which $mcmd] ne {}} {
incr methodcount2
}
}
lappend res {first method count > 20} [expr {[llength $mcmds] > 20}]
lappend res {second method count} $methodcount2
return $res
} -cleanup [cleanup1] -result [sl {
{first method count > 20} 1 {second method count} 0
}]
test ${shelftype}_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 ${shelftype}_method_unknown1 {
} -body {
shelf .spawn shelf1
shelf1 .method [list [namespace which name]]
shelf1 name Bob
set status [catch {shelf1 blub} cres copts]
lappend res $status [errorhandler $cres $copts]
return $res
} -cleanup [cleanup1] -result [sl {
1 unknown
}]
test ${shelftype}_method_unknown_specialized {
} -body {
shelf .spawn shelf1
shelf1 .eval {
proc handler {_ args} {
error [list special handler invoked for {*}$args]
}
}
shelf1 .invoke .my .method .unknown handler
catch {shelf1 blub} cres copts
lappend res {*}$cres
return $res
} -cleanup [cleanup1] -result [sl {
special handler invoked for [namespace current]::shelf1 blub
}]
test ${shelftype}_prefixoff {} -setup $setup1 -body {
shelf1 .eval {
proc p1 args {
list [namespace current]::p1 {*}$args
}
}
shelf1 .routine p1routine
catch {shelf1 p1 8 5} cres copts
lappend res [errorhandler $cres $copts]
} -cleanup [cleanup1] -result [sl {
unknown
}]
test ${shelftype}_routine {} -setup $setup1 -body {
shelf1 .eval {
proc p1 args {
list [namespace current]::p1 {*}$args
}
proc p2 args {
::tcl::mathop::+ {*}$args
}
proc {p3 p4} args {
upvar nsvar1 nsvar1
list "[namespace current]::p3\ p4" {*}$args $nsvar1
}
}
catch {shelf1 p1} cres copts
lappend res [errorhandler $cres $copts]
shelf1 .routine p1 p1routine
set res1 [shelf1 p1 8 5]
lappend res {shelf1 p1 external} [
inns [::lindex $res1 0] [namespace current]]
lappend res {*}[lrange $res1 1 end]
shelf1 .eval .my .routine p2 p2
lappend res {shelf1 p2} [shelf1 p2 3 5]
shelf1 .eval .my .routine p2 p2 8
lappend res {shelf1 p2 curried} [shelf1 p2 8 5]
rename shelf2 {}
shelf1 .spawn shelf2
set res1 [shelf2 p1 8 5]
lappend res {shelf1 p2 external} [
inns [::lindex $res1 0] [namespace current]]
lappend res {shelf1 p2 args} [::lrange $res1 1 end]
set routines [info commands [shelf2 .namespace]::*]
lmap routine routines {
ns split routine
lindex routine end
if {$shelftype eq {tclooshelf} && $routine in {myclass my .myshelfmethod}} continue
if {[string match .shelfmethod_* $routine]} continue
set routine
}
lappend res {shelf2 routines} $routines
variable nsvar1 bean
catch {
shelf2 .eval [list .my .routine one {p3 p4} p5 p6]} cres copts
lappend res {don't resolve a routine in the namespace of a basis}
lappend res [expr {[errorhandler $cres $copts] eq {unknown}}]
shelf1 .eval [list .my .routine one {p3 p4} p6 p7]
lappend res {result of shelf1 one}
set res1 [shelf1 one]
set cmdname $res1
lindex cmdname 0
lappend res [lrange [shelf1 one] 1 end]
## If this doesn't fail, ensemble prefixes are enabled, but they shouldn't be
catch {shelf1 .invoke .my .routine {p3 p4}} cres copts
lappend res {command prefixes are disabled}
catch {shelf1 p3} cres copts
lappend res [expr {[errorhandler $cres $copts] eq {unknown}}]
set res
} -cleanup [cleanup1] -result [sl {
unknown
{shelf1 p1 external} 1 8 5
{shelf1 p2} 8
{shelf1 p2 curried} 21
{shelf1 p2 external} 1
{shelf1 p2 args} {8 5}
{shelf2 routines} .my
{don't resolve a routine in the namespace of a basis} 1
{result of shelf1 one} {p6 p7 bean}
{command prefixes are disabled} 1
}]
test ${shelftype}_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 p1 p1routine
lappend res {*}[shelf1 p1 Bob]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::p1routine Bob
}]
test ${shelftype}_routine_submethod {
Pass the shelf to a namespace ensemble subcommand
} -setup $setup0 -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] 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
puts [list dwoook shelf2 add]
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 ${shelftype}_spawn_namespace {} -body {
shelf .spawn shelf1
lappend res [shelf1 .eval {
namespace current
}]
shelf1 .spawn shelf2
lappend res [shelf2 .eval {
namespace current
}]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1
[namespace current]::shelf2
}]
test ${shelftype}_tailcall_return {
Spawn a clone
} -setup {} -body {
shelf .clone shelf1
shelf1 .eval {
proc return_ {_ args} {
tailcall return {*}$args
}
.my .method return return_
proc p1 _ {
$_ . return hello
return goodbye
}
.my .method p1
}
set res [shelf1 p1]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
hello
}]
test ${shelftype}_switch {} -setup $setup0 -body {
shelf .spawn shelf1
shelf1 .eval {
proc one {_ arg} {
namespace upvar [$_ . .namespace] var1 var1
lappend var1 [list one $arg]
}
.my .method one
}
shelf1 .spawn shelf2
shelf2 .eval {
proc one {_ args} {
set self [$_ _]
namespace upvar [$self .namespace] var1 var1
lappend var1 two
$self .switch $_ hello
}
.my .method one
}
shelf2 one
lappend res [shelf2 $ var1]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{two {one hello}}
}]
test ${shelftype}_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 {} {
upvar shelftype shelftype setup0 setup0
foreach create {clone spawn} {if 1 [string map [
list @create@ [list $create]] {
test ${shelftype}_basecmd_@create@ {} -setup $setup0 -body {
shelf .spawn shelf1
shelf1 .eval {
variable doc::init {
args {
_ {}
var1 {
default {$self $ var1 {To have, or not to have}}
}
}
}
proc init {_ args} {
set self [$_ _]
set epoch [info cmdcount]
checkargs [$self $ doc::init] {*}$args
}
}
shelf1 .invoke .my .method init
shelf1 .spawn shelf2
shelf2 .eval {
proc var1 _ {
set [$_ . .namespace]::var1
}
}
shelf2 .invoke .my .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 ${shelftype}_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}
}]
test ${shelftype}_wrap {
} -body {
variable res {}
shelf .spawn shelf1
shelf1 .eval {
variable var1 hello
variable var2 world
proc piddle _ {
}
proc m1 {_ resname} {
upvar #0 $resname res
namespace upvar [$_ _] var1 var1
lappend res $var1
}
proc m2 {_ resname} {
upvar #0 $resname res
namespace upvar [$_ _] var2 var2
lappend res $var2
}
}
shelf1 .invoke .my .method m1
shelf1 .invoke .my .method m2
shelf .spawn shelf2
shelf2 .eval {
variable var1 goodbye
proc m1 {_ resname} {
upvar #0 $resname res
namespace upvar [$_ _] var1 var1
lappend res $var1
[$_ . .wrapped] m1 $resname
}
}
shelf2 .invoke .my .method m1
shelf2 .wrap shelf1 m1
shelf2 m1 [namespace current]::res
shelf2 m2 [namespace current]::res
rename shelf2 {}
# TclOOshelf automatically deletes this
catch {rename shelf1 {}}
return $res
} -cleanup [cleanup1] -result [sl {
goodbye hello world
}]
test ${shelftype}_wrap_any {
wrap an arbitrary command ensemble
} -body {
namespace eval one {
namespace ensemble create
namespace export *
namespace eval two {
namespace ensemble create
namespace export *
proc p1 args {
return $args
}
}
}
shelf .spawn shelf1
shelf1 .wrap [list one two]
lappend res [shelf1 p1 dos tres]
} -cleanup [cleanup1] -result [sl {
{dos tres}
}]
}
cleanupTests
}
proc ~ {_ args} {
lappend ns2::pea [namespace tail [$_ . .namespace]]
}
proc dying {_ args} {
set ns [$_ . .namespace]
set ns2::deadyet [list [namespace tail $ns] still dying]
}
proc errorhandler {tres topts} {
lappend results $tres
if {[string is list $tres]} {
lappend results [::lindex $tres 0]
}
if {[dict exists $topts -errorinfo]} {
lappend results [dict get $topts -errorinfo]
}
# {to do} get rid of unneeded match patterns below
foreach result $results {
if {
[string match {unknown method*} $result]
||
[string match {unknown subcommand*} $result]
||
[string match {no such routine*} $result]
||
[string match {unknown or ambiguous subcommand*} $result]
||
[string match {unknown command*} $result]
||
[string match {\{unknown action*} $result]
} {
return unknown
}
}
return -options $topts $tres
}
proc init_nsshelf {} {
catch {
rename shelf {}
rename nsshelf {}
}
package require {ycl shelf shelf}
alias [yclprefix]::shelf::shelf
rename shelf nsshelf
proc init_nsshelf {} {
interp alias {} [namespace current]::shelf {} [
namespace current]::nsshelf
}
init_nsshelf
}
proc init_tclooshelf {} {
catch {
rename shelf {}
rename tclooshelf {}
}
package require {ycl shelf tcloo shelf}
namespace import [yclprefix]::shelf::tcloo::shelf
rename shelf tclooshelf
proc init_tclooshelf {} {
interp alias {} [namespace current]::shelf {} [
namespace current]::tclooshelf
}
init_tclooshelf
}
proc init1 {_ args} {
set map [namespace ensemble configure $_ -map]
uplevel 1 [list $_ . .switch $_ {*}$args]
return [$_ _]
}
proc inns {value ns} {
expr {[namespace qualifiers $value] == $ns}
}
variable method1 {{pvar1 pvar2} {instvar3 {instvar4 instvar5}} {nsvar1 nsvar2} {
set self [$_ _]
lappend res [list $pvar1 $pvar2 [$self $ instvar1] [$self $ instvar2] \
$instvar3 $instvar5 $nsvar1 $nsvar2]
$self $ instvar1 [+ [$self $ instvar1] 1]
set nsvar1 [+ $nsvar1 1]
lappend res [list [$self $ instvar1] $nsvar1]
set res
}}
proc name {_ args} {
set ns [$_ . .namespace]
if {![llength $args]} {
return [set ${ns}::name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set ${ns}::name [::lindex $args 0]
}
proc name2 {_ args} {
set ns [$_ . .namespace]
if {![llength $args]} {
return [set ${ns}::name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set ${ns}::name Agamemnon
}
proc new2 {_ args} {
set new [[$_ . .basis] .spawn {*}$args]
$new $ var1 {mutually-assured non sequitor}
return $new
}
proc p1 {_ args} {
list [namespace current]::p1 [$_ _] {*}$args
}
proc p1routine args {
list [namespace current]::p1routine {*}$args
}