#! /bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl list} {
lindex
lmap
sl
take
}
{ycl ns} {
nscall
nsjoin join
this
which
}
{ycl proc} {
checkargs
}
}
alias [nsjoin {} tcl mathop *]
alias [nsjoin tcl mathop +]
package require {ycl ns}
alias [nsjoin [yclprefix] ns]
alias lindex_ [nsjoin {} lindex]
package require {ycl shelf util}
namespace import [nsjoin [yclprefix] shelf util asmethod]
proc suite_main {} {
package require {ycl test}
[yclprefix] test init
aliases {
{ycl shelf multi}
{ycl test} {
cleanup1
}
}
foreach varname [info vars [nsjoin [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 shelf1
namespace eval ext1 {
proc p1 {_ args} {
list [namespace current]::p1 $_ $args
}
}
shelf1 .extend ext1
shelf1 .clone shelf2
namespace eval ext2 {
proc p1 {_ args} {
list [namespace current]::p1 $_ $args
}
}
shelf2 .extend ext2
}
foreach shelftype {nsshelf tclooshelf} {
test ${shelftype}_basis {
adjust the basis of a shelf
} -setup $setup1 -body {
namespace eval ext3 {}
interp alias {} [nsjoin ext3 p1] {} [namespace which p1]
shelf2 .extend ext3
set res1 [shelf2 p1]
lappend res {external p1} [
inns [::lindex $res1 0] [namespace current]]
shelf shelf3
shelf3 .extend ext1
set res1 [shelf3 p1]
lappend res $res1
return $res
} -cleanup [cleanup1] -result [sl {
{external p1} 1
[list [nsjoin [namespace current] ext1 p1] [
nsjoin [namespace current] shelf3] {}]
}]
test ${shelftype}_basis_newbasis {
adjust the basis of a shelf
} -setup $setup1 -body {
namespace eval ext3 {}
interp alias {} [nsjoin ext3 p1] {} [namespace which p1]
set res1 [shelf2 p1 hello]
lappend res {*}$res1
namespace eval ext4 {
proc p2 {_ args} {
list [namespace current]::p1 $_ {*}$args
}
}
shelf2 .extend ext4
lappend res {*}[shelf2 p2 hello]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::ext2::p1
[namespace current]::shelf2
hello
[namespace current]::ext4::p1
[namespace current]::shelf2
hello
}]
test ${shelftype}_basis_ancestorchanged {
} -setup $setup1 -body {
shelf1 .spawn shelf3
shelf3 .spawn shelf4
shelf1 .eval {
proc p2 {_ args} {
list [namespace current]::p1 $_ $args
}
}
shelf4 p2
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1::p1 [namespace current]::shelf4 {}
}]
test ${shelftype}_clone {} -setup $setup0 -body {
shelf shelf1
rename shelf1 {}
catch {namespace delete shelf1} cres
lappend res $cres
shelf shelf1
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{unknown namespace "shelf1" in namespace delete command}
}]
test ${shelftype}_clone_existing {} -setup $setup1 -body {
namespace eval shelf1 {}
shelf shelf1
return
} -cleanup [cleanup1] -result [sl {
}]
test ${shelftype}_clone_path {
A clone has the same basis as the thing it was cloned from
} -setup $setup0 -body {
shelf shelf1
shelf1 .spawn shelf2
shelf2 .clone shelf3
set shelf2path [shelf2 .nscall namespace path]
set shelf3path [shelf3 .nscall namespace path]
lappend res [expr {
$shelf2path eq $shelf3path
}]
lappend res [expr {
[lindex_ $shelf2path 0]
eq
[nsjoin [namespace current] shelf1]
}]
return $res
} -cleanup [cleanup1] -result [sl {
1 1
}]
test ${shelftype}_clone_spawn {
Spawn a clone
} -setup $setup0 -body {
shelf 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 {
lappend res {*}[lsort [shelf1 .routines]]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{$} {$.exists} .act .apply .attribute .call .clone .cloned
.configure .dispatch .disposal .doattribute .doroutine .eject .eval
.extend .forward .insert .invoke .my .name .namespace .next .nscall
.routine .routines .setup .spawn .state .unknown .upcall .varexists
.varname .vars .wrap = configure p1
}]
test ${shelftype}_current {
} -setup $setup0 -body {
shelf shelf1
shelf1 .extend [nsjoin [yclprefix] shelf multi]
shelf1 = var3 nägemist
shelf1 .spawn shelf2
shelf b
b .spawn a
namespace eval atype {
proc p _ {
$_ = var1 [$_ $ var2]
$_ $ var3
}
}
a .extend atype
a = var2 tere
shelf2 .extend atype
shelf2 = var2 puuk
shelf2 .extend atype
lappend res [shelf2 p]
lappend res [shelf2 $ var1]
lappend res [shelf2 $ var3]
rename shelf2 {}
rename a {}
rename b {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
nägemist puuk nägemist
}]
test ${shelftype}_current_plugin {
only explicitly named plugins get plugged in
} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
proc q _ {
return 13
}
}
shelf1 .spawn shelf2
shelf a
alias [nsjoin [a .namespace] nsjoin] nsjoin
a .eval {
proc p {_ component args} {
lappend res [$_ q $component]
lappend res [$_ $ var1]
return $res
}
proc q {_ component} {
lappend res 8
lappend res [$component q]
return $res
}
proc .connect {_ ns} {
$_ .vars other
interp alias {} [nsjoin $ns p] {} [nsjoin [namespace current] p] $ns
return $ns
}
}
a = var2 hello
set bname [nsjoin [shelf2 .namespace] private b]
a .spawn $bname
shelf2 .routine b $bname
shelf2 b = var1 tere
shelf2 .insert [shelf2 b .connect [shelf2 b .namespace]]
lappend res [shelf2 q]
lappend res [shelf2 p]
rename shelf2 {}
rename a {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
13 {{8 13} tere}
}]
test ${shelftype}_disposal {
} -setup $setup0 -body {
set res {}
namespace eval ns2 {
set deadyet {}
}
shelf shelf1
namespace eval ext3 {}
shelf1 .disposal [namespace which 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 $setup0 -body {
namespace eval ns2 {}
shelf shelf1
shelf1 .eval {
proc p1 _ {
rename $_ {}
}
}
shelf1 p1
} -cleanup [cleanup1] -result {}
test ${shelftype}_dispatch_chain {
Each dispatch happens relative to the current call location
} -setup $setup0 -body {
namespace eval type1 {
proc p {_ index} {
lappend [$_ .namespace]::var1 [list [
namespace tail $_] [namespace tail [
namespace current]] $index]
set routine [$_ .next p]
tailcall $routine $_ [incr index]
}
}
foreach x {{} 1 2} y {{} 2 3} {
if {$y == {}} {
shelf shelf1
shelf1 .eval {
proc p {_ index} {
lappend [$_ .namespace]::var1 [
list [namespace tail $_] [namespace tail [
namespace current]] $index]
}
}
} else {
shelf${x} .spawn shelf${y}
shelf${y} .extend type1
}
}
shelf3 p 5
shelf3 $ var1
lappend res [shelf3 $ var1]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{{shelf3 type1 5} {shelf3 shelf1 6}}
}]
test ${shelftype}_eject {
} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
proc move _ {
return [list [namespace tail $_] is walking]
}
}
shelf shelfa
shelfa .eval {
proc move _ {
return [list [namespace tail $_] is flying]
}
}
shelf1 .spawn shelf2
lappend res [shelf2 move]
shelf2 .extend [shelfa .namespace]
lappend res [shelf2 move]
shelf2 .spawn shelf3
lappend res [shelf3 move]
shelf2 .eject [shelfa .namespace]
lappend res [shelf2 move]
shelf3 .eject [shelfa .namespace]
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 shelf1
shelf1 .eval {
proc move {_ how} {
return [list [namespace tail $_] is $how]
}
proc identify {} {
return Toby
}
proc walk _ {
$_ move walking
}
}
shelf shelfa
shelfa .eval {
proc fly _ {
$_ move flying
}
}
shelfa .spawn shelfb
shelf1 .spawn shelf2
shelf2 .extend shelfb
lappend res [shelf2 walk]
lappend res [shelf2 fly]
shelfa .eval {
proc crawl _ {
$_ move crawling
}
}
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}_insert_switch {
inserted shelf uses [.switch] to call method on the shelf that
injected it.
} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
proc method1 _ {
$_ .vars var1
lappend var1 two
}
}
shelf shelf2
namespace eval type1 {
proc method1 {_ } {
$_ .vars var1
lappend var1 one
set routine [$_ .next method1]
tailcall $routine $_
}
}
shelf2 .extend type1
shelf1 .spawn shelf1a
shelf2 .spawn shelf2a
shelf2a .eval [list variable shelf [namespace which shelf2]]
namespace eval type2 {
proc method1 {_ args} {
variable shelf
set routine [$_ .next method1]
tailcall $routine $_ {*}$args
}
}
shelf2a .extend type2
shelf1a .extend shelf2a
shelf1a method1
lappend res [shelf1a $ var1]
rename shelf1a {}
rename shelf2a {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{one two}
}]
test ${shelftype}_invoke {
adjust the basis of a shelf
} -setup $setup1 -body {
lappend res [shelf1 .upcall try {
namespace current
}]
return $res
} -cleanup [cleanup1] -result [sl {
[namespace current]::shelf1
}]
test ${shelftype}_method_alias {
previously was a more complicated test
may no longer be needed
} -setup $setup0 -body {
shelf shelf1
namespace eval ext1 {
proc fly {_ plugin} {
return [list [namespace tail $_] flying]
}
proc info {_ arg1 arg2 arg3} {
return [list $arg1 $arg3 reporting for duty]
}
}
shelf1 .extend ext1
lappend res [shelf1 info x [namespace which shelfb] y]
lappend res [shelf1 fly [namespace which shelfb]]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{x y reporting for duty} {shelf1 flying}
}]
test ${shelftype}_renamed {
} -setup $setup0 -body {
shelf shelf1
namespace eval type1 {
proc p1 {} {
return 3
}
}
shelf1 .extend type1
shelf1 .routine [namespace which [nsjoin type1 p1]]
rename shelf1 shelf2
lappend res [shelf2 p1]
return $res
} -cleanup [cleanup1] -result [sl {
3
}]
test ${shelftype}_shelf {} -setup $setup0 -body {
shelf shelf1
shelf1 = var1 val1
lappend res [shelf1 .varname var1]
lappend res [shelf1 $ var1]
shelf1 .eval {
proc greet {_ args} {
list [namespace tail [$_ .namespace]] $args
}
}
lappend res [shelf1 greet]
lappend res [shelf1 greet onearg]
shelf shelf2
shelf2 .extend [shelf1 .namespace]
lappend res [shelf2 greet hello]
shelf1 .clone 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 {
set res {}
namespace eval ns2 {
variable pea {}
}
shelf obj1
obj1 .extend extension2
obj1 .disposal .~
namespace eval [obj1 .namespace] {
variable var1 yuck
}
#this tests $ functionality
catch {obj1 $ something} cres copts
if {
(
[string is list $cres]
&&
[::lindex $cres 0] eq {no such variable}
) ||
(
$cres eq {can't read "var": no such variable}
)
} {
lappend res {no such variable} 1
} else {
return -options $copts $cres
}
lappend res {obj1 var1} [obj1 $ var1]
obj1 .clone obj2
lappend res {obj2 path length} 2
lappend res {obj2 var1} [obj2 $ var1]
obj2 = var1 one
lappend res {obj2 var1} [obj2 $ var1]
lappend res {obj1 var1} [obj1 $ var1]
obj2 .eval {
proc jump {_ args} {
return [list [namespace tail [$_ .namespace]] jumping]
}
}
lappend res [obj2 jump]
obj2 .extend [nsjoin [yclprefix] shelf multi]
namespace eval ext3 {}
interp alias {} [nsjoin ext3 name] {} [namespace which name]
obj2 .extend ext3
obj2 name Pasithea
lappend res {obj2 name} [obj2 $ name]
# add an empty object in between
obj2 .clone obj3
obj3 .extend obj2
lappend res [obj3 jump]
lappend res {obj3 name} [obj3 $ name]
obj3 .eval unset name
obj3 .clone obj4
#obj4 .extend obj3
lappend res {obj4 name} [obj4 $ name]
set located [obj4 .varexists name]
lappend res {obj4 name exists} $located
set found [obj4 .varfind name]
lappend res [namespace tail [namespace qualifiers $found]]
lappend res [namespace tail $found]
obj4 name Patroclus
lappend res [obj4 $ var1]
lappend res [obj4 $ name]
namespace eval ext4 {}
interp alias {} [nsjoin ext4 name] {} [namespace which name2]
obj4 .extend ext4
obj4 name Thersites
lappend res [obj4 $ name]
lappend res [obj4 jump]
lappend res {obj2 name} [obj2 $ name]
namespace eval ext4 {
proc .~ args {
namespace upvar [namespace parent] var1 var1
set var1 "obj4 dying!"
}
}
obj4 .disposal .~
rename obj4 {}
lappend res [set [nsjoin [namespace current] var1]]
obj1 .clone obj5
obj1 .clone obj6
# The trace must fire when the namespace is deleted
obj5 .eval {
namespace delete [namespace current]
}
lappend res [set [nsjoin ns2 pea]]
namespace eval ext6 {}
interp alias {} [nsjoin ext6 dying] {} [namespace which dying]
obj6 .extend ext6
obj6 dying
obj6 .disposal dying
lappend res {disposal for obj6} [namespace tail [::lindex [obj6 .disposal] 0]]
rename obj6 {}
rename obj3 {}
rename obj2 {}
rename obj1 {}
lappend res {pea report} [set [nsjoin ns2 pea]]
lappend res [set [nsjoin [namespace current] ns2 deadyet]]
return $res
} -cleanup [cleanup1] -result [sl {
{no such variable} 1
{obj1 var1} yuck
{obj2 path length} 2
{obj2 var1} yuck
{obj2 var1} one
{obj1 var1} yuck
{obj2 jumping}
{obj2 name} Pasithea
{obj3 jumping}
{obj3 name} Pasithea
{obj4 name} Pasithea
{obj4 name exists} 1
obj2 name one Patroclus
Agamemnon
{obj4 jumping}
{obj2 name} Pasithea
{obj4 dying!}
obj5
{disposal for obj6} dying
{pea report} {obj5 obj3 obj2 obj1}
{obj6 still dying}
}]
test ${shelftype}_shelf_renamed {} -setup $setup0 -body {
shelf shelf1
namespace eval ext1 {
proc greet {_ args} {
list [namespace tail [$_ .namespace]] $args
}
}
shelf1 .extend ext1
rename shelf1 shelf1a
shelf1a .clone shelf2
lappend res [shelf2 greet hello]
rename shelf2 {}
rename shelf1a {}
set res
} -cleanup [cleanup1] -result [sl {
{shelf2 hello}
}]
test ${shelftype}_basis_add_method {} -setup $setup0 -body {
shelf shelf1
shelf shelf2
shelf2 .extend [shelf1 .namespace]
shelf1 .eval {
proc jump {_ args} {
return [list [namespace tail [$_ .namespace]] jumping]
}
}
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 {} -setup $setup1 -body {
shelf 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
}
}
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 {} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
namespace eval doc {}
variable doc::configure {
args {
_ {
}
normal1 {
default {}
}
}
}
}
shelf1 .spawn shelf2
shelf2 .nscall namespace eval doc {}
shelf2 = doc::configure [shelf1 $ doc::configure]
shelf2 = doc::.configure {
args {
_ {}
}
}
shelf2 .eval {
namespace eval doc {}
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
}
return $res
} -cleanup [cleanup1] -result [sl {
{i am normal}
{{unknown argument} normal1}
{i am system}
{{unknown argument} system1}
}]
test ${shelftype}_shelf_deletens {} -setup $setup0 -body {
lappend res [namespace exists shelf1]
shelf shelf1
shelf1 = var1 3
lappend res [namespace exists shelf1]
lappend res [shelf1 $ var1]
shelf1 .clone 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 $setup1 -body {
variable method1
variable nsvar1 1
variable nsvar2 10
shelf1 = instvar1 100
shelf1 = instvar2 1000
shelf1 = instvar3 5000
shelf1 = instvar4 7000
namespace eval ext3 {}
interp alias {} [nsjoin ext3 shelf1m1] {} ::apply [
list {*}[asmethod $method1] [namespace current]]
shelf1 .extend ext3
lappend res {*}[shelf1 shelf1m1 pval1 pval2]
shelf shelf2
shelf2 .extend [nsjoin [yclprefix] shelf multi]
shelf2 .extend [shelf1 .namespace]
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}_act {} -setup $setup0 -body {
shelf shelf1
lappend res [shelf1 .act {_ args} {
$_ = name Alcinous
expr {$_ eq [namespace current]}
}]
lappend res [shelf1 $ name]
} -cleanup [cleanup1] -result [sl {
1 Alcinous
}]
test ${shelftype}_apply {} -setup $setup0 -body {
shelf shelf1
lappend res [shelf1 .apply {_ args} {
$_ = name Alcinous
expr {$_ eq [namespace current]}
} [which shelf1]]
lappend res [shelf1 $ name]
} -cleanup [cleanup1] -result [sl {
1 Alcinous
}]
test ${shelftype}_attribute {} -setup $setup0 -body {
shelf shelf1
shelf1 .attribute name
shelf1 name Alcinous
shelf1 name
} -cleanup [cleanup1] -result [sl {
Alcinous
}]
test ${shelftype}_method_name {
method names can include namespace qualifiers
} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
namespace eval bloop {}
}
set childcount1 [llength [namespace children [shelf1 .namespace]]]
namespace eval bleep {}
interp alias {} [nsjoin bleep bloop] {} [namespace which p1]
shelf1 .extend bleep
lappend res [shelf1 bloop]
lappend res [expr {[shelf1 .nscall namespace which bloop] ne {}}]
set childcount2 [llength [namespace children [shelf1 .namespace]]]
return $res
} -cleanup [cleanup1] -result [sl {
[list [namespace current]::p1 [namespace current]::shelf1]
1
}]
test ${shelftype}_method_qualified_notarget {
when a fully-qualified command is provided
but no target is provided
the target is that fully-qualified command
the method name is
the namespace tail of that command
} -setup $setup0 -body {
shelf shelf1
namespace eval ext1 {}
interp alias {} [nsjoin ext1 name] {} [which name]
shelf1 .extend ext1
shelf1 name Bob
shelf1 name
} -cleanup [cleanup1] -result {Bob}
test ${shelftype}_method_unknown1 {
} -setup $setup0 -body {
shelf shelf1
interp alias {} [nsjoin ext1 name] {} [which name]
shelf1 .extend ext1
shelf1 name Bob
set status [catch {shelf1 blub} cres copts]
lappend res {blub unknown} [errorhandler2 $cres $copts \
{$res eq {invalid command name "blub"}}]
return $res
} -cleanup [cleanup1] -result [sl {
{blub unknown} true
}]
test ${shelftype}_method_unknown_specialized {
} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
proc handler args {
error [list special handler invoked for {*}$args]
}
}
shelf1 .unknown [shelf1 .namespace]::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}_routine {} -setup $setup1 -body {
shelf1 .eval {
namespace eval routines {}
proc routines::p1 args {
list [namespace current]::p1 {*}$args
}
proc routines::p2 args {
::tcl::mathop::+ {*}$args
}
proc {routines::p3 p4} args {
upvar nsvar1 nsvar1
list "[namespace current]::p3\ p4" {*}$args $nsvar1
}
}
catch {shelf1 p1} cres copts
shelf1 .routine p1 [which 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 .routine p2 [nsjoin [shelf1 .namespace] p2]
shelf1 .routine p2 [nsjoin [shelf1 .namespace] routines p2]
lappend res {shelf1 p2} [shelf1 p2 3 5]
shelf1 .routine p2 [nsjoin [shelf1 .namespace] routines p2] 8
lappend res {shelf1 p2 curried} [shelf1 p2 8 5]
shelf shelf2
set ns [shelf2 .namespace]
rename shelf2 {}
lappend res {shelf2 namespace gone} [expr {![namespace exists $ns]}]
shelf shelf2
shelf2 .extend [shelf1 .namespace]
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 .routine one [
nsjoin routines {p3 p4}] p5 p6} cres copts
set res2 [lassign [shelf2 one] res1]
lappend res {{p3 p4} correct namespace} [expr {
$res1 eq [nsjoin [namespace current] shelf1 routines {p3 p4}]
}]
lappend res $res2
lappend res {shelf2 map empty} [expr {
[namespace ensemble configure shelf2 -map] eq {}}]
shelf1 .routine one [nsjoin [shelf1 .namespace] routines {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, name prefix matching is enabled
lappend res {recognize prefixes?} [
namespace ensemble configure [shelf1 .namespace] -prefixes]
return $res
} -cleanup [cleanup1] -result [sl {
{shelf1 p1 external} 1 8 5
{shelf1 p2} 8
{shelf1 p2 curried} 21
{shelf2 namespace gone} 1
{shelf1 p2 external} 1
{shelf1 p2 args} {8 5}
{shelf2 routines} {.my .state}
{{p3 p4} correct namespace} 1
{p5 p6 bean}
{shelf2 map empty} 1
{result of shelf1 one} {p6 p7 bean}
{recognize prefixes?} 0
}]
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 .
} -setup $setup0 -body {
shelf shelf1
shelf1 .routine p1 [namespace which 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 shelf1
shelf1 = var1 1
namespace eval util {
namespace export *
namespace ensemble create
proc add {_ args} {
::tcl::mathop::+ [$_ $ var1] {*}$args
}
}
interp alias {} [nsjoin ext1 add] {} ::apply [list {arg1 arg2 _ args} {
tailcall util add $_ $arg1 $arg2 {*}$args
} [namespace current]] 2 3
shelf1 .extend ext1
namespace eval ext2 {
namespace eval util2 {
namespace export *
namespace ensemble create -parameters _
proc mult {_ args} {
::tcl::mathop::* [$_ $ var1] {*}$args
}
}
}
shelf1 .extend ext2
lappend res [shelf1 add 5]
lappend res [shelf1 util2 mult 5]
shelf shelf2
shelf2 .extend shelf1
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 ${shelftype}_spawn_namespace {} -setup $setup0 -body {
shelf 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 {
} -setup $setup0 -body {
shelf shelf1
nscall [nsjoin ns1 system] alias nscall [which nscall]
nscall [nsjoin ns1 system] alias which [which which]
namespace eval ns1 {
namespace eval system {
namespace export *
proc p1 _ {
$_ return hello
return goodbye
}
proc return_ {_ args} {
tailcall return {*}$args
}
nscall [namespace parent] namespace import [which p1]
nscall [namespace parent] namespace import [which return_]
}
rename return_ return
}
shelf1 .extend ns1
set res [shelf1 p1]
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
hello
}]
test ${shelftype}_switch {} -setup $setup0 -body {
shelf shelf1
shelf1 .eval {
proc one {_ arg} {
# use [$_ .namespace] instead of [$_ . .namespace] to check
# that unknown method method (yes, "method method") names
# are forwarded to the object
namespace upvar [$_ .namespace] var1 var1
lappend var1 [list one $arg]
}
}
shelf1 .spawn shelf2
namespace eval type1 {
proc one {_ args} {
$_ .vars var1
lappend var1 two
set routine [$_ .next one]
tailcall $routine $_ hello
}
}
shelf2 .extend type1
shelf2 one
lappend res [shelf2 $ var1]
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{two {one hello}}
}]
test ${shelftype}_namespace_path {} -setup $setup0 -body {
shelf 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 shelf1
alias [nsjoin [shelf1 .namespace] checkargs] checkargs
shelf1 .eval {
namespace eval doc {}
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 .spawn shelf2
shelf2 .eval {
proc var1 _ {
set [$_ .namespace]::var1
}
}
shelf2 .extend extension1
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_declared_undefined {
} -setup $setup0 -body {
shelf shelf1
shelf1 = var1 {a dream}
shelf1 .extend [nsjoin [yclprefix] shelf multi]
shelf1 .spawn shelf2
shelf2 .eval {
variable var1
variable var2 {to sleep}
}
lappend res [shelf2 $ var1]
shelf2 .spawn shelf3
lappend res [shelf3 $ var2]
catch {shelf3 $ var1} cres copts
lappend res undefined? [expr {$cres eq "can't read \"[
shelf2 .namespace]::var1\": no such variable"}]
rename shelf3 {}
rename shelf2 {}
rename shelf1 {}
return $res
} -cleanup [cleanup1] -result [sl {
{a dream} {to sleep} undefined? 1
}]
test ${shelftype}_varstack {} -setup $setup0 -body {
shelf obj1
namespace eval [obj1 .namespace] {
variable var1 hello
}
#this tests $ functionality
catch {obj1 $ something}
lappend res [obj1 $ var1]
return $res
} -cleanup [cleanup1] -result [sl {
hello
}]
test ${shelftype}_wrap {
} -setup $setup0 -body {
variable res {}
shelf shelf1
shelf1 = var1 hello
shelf1 = var2 world
namespace eval ext1 {
proc m1 {_ resname} {
upvar #0 $resname res
$_ .vars var1
lappend res $var1
}
proc m2 {_ resname} {
upvar #0 $resname res
$_ .vars var2
lappend res $var2
}
}
shelf1 .extend ext1
shelf shelf2
namespace eval ext2 {
proc m1 {_ resname} {
upvar #0 $resname res
$_ .vars var1 wrapped
lappend res $var1
tailcall $_ .wrapped m1 $resname
}
}
#shelf2 = wrapped [which shelf1]
shelf2 = var1 goodbye
#shelf2 .extend ext1
#shelf2 .extend [shelf1 .namespace]
shelf2 .extend ext2
shelf2 .wrap shelf1
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
} -setup $setup0 -body {
namespace eval one {
namespace ensemble create
namespace export *
namespace eval two {
namespace ensemble create
namespace export *
proc p1 args {
return $args
}
}
}
shelf shelf1
shelf1 .wrap [list one two]
lappend res [shelf1 p1 dos tres]
} -cleanup [cleanup1] -result [sl {
{dos tres}
}]
}
cleanupTests
}
namespace eval extension2 {
namespace path [namespace parent]
proc .~ {_ args} {
lappend [nsjoin [namespace parent] 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 errorhandler2 {res opts args} {
lappend results $res
if {[string is list $res]} {
lappend results [::lindex $res 0]
}
if {[dict exists $opts -errorinfo]} {
lappend results [dict get $opts -errorinfo]
}
foreach expr $args {
if !($expr) {
return -options $opts $res
}
}
return true
}
proc init_nsshelf {} {
catch {
rename shelf {}
rename nsshelf {}
}
package require {ycl shelf shelf}
alias [nsjoin [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
}
namespace eval extension1 {
proc init1 {_ args} {
set routine [$_ .next init]
$routine $_ {*}$args
return $_
}
}
proc inns {value ns} {
expr {[namespace qualifiers $value] == $ns}
}
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 {_ args} {
set ns [$_ .namespace]
set name [nsjoin $ns name]
if {![llength $args]} {
return [set $name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set $name [lindex_ $args 0]
}
proc name2 {_ args} {
set ns [$_ .namespace]
set name [nsjoin $ns name]
if {![llength $args]} {
return [set $name]
} elseif {[llength $args] > 1} {
error [list {too many args} [llength $args] {should be 1}]
}
set $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
}