# -*- Tcl -*- package require XOTcl 1 namespace import -force xotcl::* proc ::errorCheck {got expected msg} { if {$got != $expected} { puts stderr "[self] FAILED: $msg\nGot: $got\nExpected: $expected" foreach g $got e $expected { set result [expr {$g == $e}] if {[string length $g]>60} { puts "$result g='$g'\n e='$e'" } else { puts "$result g='$g' e='$e'" } } exit -1 } } proc ::cutSpaces {string} { regsub -all " " $string "" result regsub -all "\n" $result " " result return $result } Class TestX \ -instmixin [Class TestXM -instproc run args {next; puts "[self] PASSED"}] @ @File {description { This is a file which provides a regression test for the features of the XOTcl - Language. } } @ Class TestX @ TestX nestingClasses { description {Regression test object testing the class nesting feature.} } TestX nestingClasses -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class x($i) Class x($i)::y ::errorCheck [x($i) info commands y] "y" " -- creating Nested Class " Class x($i)::z Class x($i)::z::t Class x($i)::t ::errorCheck [x($i) info classchildren] "::x($i)::t ::x($i)::y ::x($i)::z" \ "info classchildren" ::errorCheck [x($i)::z info classparent] "::x($i)" \ "info classparent" ::errorCheck [x($i) info commands t] "t" \ "-- MakeClass " x($i) a x($i)::z a x($i)::z::t a x($i)::z::t move x($i)::z::rt x($i)::z::rt a ::errorCheck [x($i)::z info commands rt] "rt" \ "renaming leaf " x($i)::z move x($i)::rz ::errorCheck [x($i) info commands rz] "rz" \ "renaming node (node itself)" ::errorCheck [x($i)::rz info commands rt] "rt" \ "renaming node (leaf in node)" ::errorCheck [x($i)::rz info classchildren] "::x($i)::rz::rt" \ "info classchildren (2)" ::errorCheck [x($i)::rz::rt info classparent] "::x($i)::rz" \ "info classparent (2)" x($i) move rx ::errorCheck [rx info commands rz] "rz" \ "renaming root " ::errorCheck [info commands rx] "rx" \ "renaming root " rx destroy } } @ TestX nestingObjects { description {Regression test object testing the object nesting feature.} } TestX nestingObjects -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class C($i) C($i) instproc testinstproc {} { return } C($i) o o proc testproc {} { return } o testproc; o testinstproc C($i) o::y ::errorCheck [o info commands y] y "creating Nested Object " C($i) o::z C($i) o::z::t C($i) o::t ::errorCheck [o info children] "::o::t ::o::y ::o::z" "info children" ::errorCheck [o::t info parent] "::o" "info parent" ::errorCheck [o info commands t] t "MakeObject" o::z::t move o::z::rt ::errorCheck [o::z info commands rt] rt "renaming leaf" o::z move o::rz ::errorCheck [o::rz info commands rt] rt "renaming node" ::errorCheck [o info commands rz] rz "renaming node" o move rx ::errorCheck [rx info commands rz] rz "renaming root " ::errorCheck [info commands rx] rx "renaming root" rx destroy C($i) destroy Class A A instproc x {a1 args} { my set var $a1 } A a A a::n -x "1 2 3" ::errorCheck [::a::n set var] "1 2 3" "arg passing - init dash" } } @ TestX assertions { description {Regression test object testing the assertions.} } TestX assertions -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class C($i) C($i) invar { {$a > 2} {$c < 3} {$d > 5} {#a} {#b} } C($i) instinvar { {$a > 2} {$c < 3} {$d > 5} {#a} {#b} } ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ "Class invar " ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ "Class instinvar " Object b($i) b($i) invar { {$a > 2} {$c < 3} {$d > 5} {#a} {#b} } ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ "Object invar " b($i) proc p {a b c} { return p } {pre1 pre2 pre3} {post1 post2 post3} ::errorCheck [b($i) info pre p] {{pre1} {pre2} {pre3}} \ "Obj proc pre assertion " ::errorCheck [b($i) info post p] {{post1} {post2} {post3}} \ "Obj proc post assertion " C($i) instproc p {a b c} { return p } {} {post1 post2 post3} ::errorCheck [C($i) info instpre p] "" \ "CL proc pre assertion " ::errorCheck [C($i) info instpost p] {{post1} {post2} {post3}} \ "CL proc post assertion " C(0) set a 3; C(0) set c 2; C(0) set d 7; C(0) set f 50; C(0) check all C(0) proc checkit {} { C(0) instvar a c d f ::errorCheck [my info check] {invar instinvar pre post} \ "check options != all" # turn obj-invar off C(0) check {pre post instinvar} C(0) set c 10 ::errorCheck [my info check] {instinvar pre post} \ "check options != instinvar pre post" } {{$f > 10}} {{$f < 100}} C(0) checkit } for {set i 0} {$i < $n} {incr i} { b($i) destroy C($i) destroy } Object b b proc p {a b c} { return p } {pre1 pre2 pre3} {post1 post2 post3} ::rename b a ::errorCheck [a info pre p] {{pre1} {pre2} {pre3}} \ "Obj proc pre assertion " ::errorCheck [a info post p] {{post1} {post2} {post3}} \ "Obj proc post assertion " Class Sensor -parameter {{value 1}} Sensor instinvar { {[regexp {^[0-9]$} [my value]] == 1} } Sensor s s check all Sensor instproc x {} { s value } { {[regexp {^[0-9]$} [my value]] == 1} } {} s x s value # inheritance Class A -parameter {{x 1} {y 1}} A instinvar {{$x == 1}} A instproc xTo2 args { my set x 2 } A instproc yTo2 args { my set y 2 } {} {{$y == 1}} A a -check all if {![catch {a xTo2} err]} { set err "ok" } else { a check {} a set x 1 a check all } ::errorCheck $err {Assertion failed check: {$x == 1} in proc 'xTo2'} \ "inheritance a xTo2" if {![catch {a yTo2} err]} { set err "ok" } ::errorCheck $err {Assertion failed check: {$y == 1} in proc 'yTo2'} \ "inheritance a yTo2" Class B -superclass A B b -check all if {![catch {b xTo2} err]} { set err "ok" } else { b check {} b set x 1 b check all } ::errorCheck $err {Assertion failed check: {$x == 1} in proc 'xTo2'} \ "inheritance b xTo2" if {![catch {b yTo2} err]} { set err "ok" } ::errorCheck $err {Assertion failed check: {$y == 1} in proc 'yTo2'} \ "inheritance b yTo2" } @ TestX filterAddRemove { description {Regression test object testing adding/removing of filters.} } TestX filterAddRemove -proc run {{n 20}} { set ::filterCount 0 for {set i 0} {$i < $n} {incr i} { Class SA($i) Class SB($i) Class SC($i) -superclass [list SB($i) SA($i)] SA($i) instproc fa args { incr ::filterCount my set x 150 return "[next]-[self class]::[self proc]" } SA($i) instproc f2 args { incr ::filterCount my set x 150 return "[next]-[self class]::[self proc]" } SB($i) instproc f2 args { incr ::filterCount my set x 150 return "[next]-[self class]::[self proc]" } SB($i) instproc fb args { incr ::filterCount my set x 150 return "[next]-[self class]::[self proc]" } SC($i) instproc fc args { incr ::filterCount my set x 150 return "[next]-[self class]::[self proc]" } SC($i) instfilter fc SB($i) instfilter {fb f2} SA($i) instfilter {fa f2} Class T T proc s {} { return } Class Filtered${i} -superclass SC($i) Filtered${i} instproc testfilter args { incr ::filterCount T s return "[next]-[self class]::[self proc]" } Filtered${i} instfilter testfilter Filtered${i} instproc a args { return "in a" } Filtered${i} f${i} set erg [f${i} a] ::errorCheck $erg \ "in a-::SA(${i})::f2-::SA(${i})::fa-::SB(${i})::f2-::SB(${i})::fb-::SC(${i})::fc-::Filtered${i}::testfilter" \ "Filter Test - add" SC($i) instfilter {} SB($i) instfilter fb SA($i) instfilter {} set erg [f${i} a] ::errorCheck $erg "in a-::SB(${i})::fb-::Filtered${i}::testfilter" \ "Filter Test - remove" f${i} proc procFilter args { return "[next]-[self class]::[self proc]" } f${i} filter {fa f2 procFilter} set erg [f${i} a] ::errorCheck $erg "in a-::SB(${i})::fb-::Filtered${i}::testfilter-::procFilter-::SB(${i})::f2-::SA(${i})::fa" \ "Obj Filter Test call three filter + instfilter" ::errorCheck "[f${i} info filter]-[SB($i) info instfilter]-[SC($i) info instfilter]" \ "fa f2 procFilter-::SB(${i})::fb-::Filtered${i}::testfilter-::procFilter-::SB(${i})::f2-::SA(${i})::fa-fb-"\ "filter infos" ::errorCheck [f${i} filtersearch fa]-[f${i} filtersearch fb]-[f${i} filtersearch procFilter] "::SA(${i}) instproc fa-::SB(${i})::fb-::Filtered${i}::testfilter-::procFilter-::SB(${i})::f2-::SA(${i})::fa-::SB(${i}) instproc fb-::SB(${i})::fb-::Filtered${i}::testfilter-::procFilter-::SB(${i})::f2-::SA(${i})::fa-::f${i} proc procFilter-::SB(${i})::fb-::Filtered${i}::testfilter-::procFilter-::SB(${i})::f2-::SA(${i})::fa" "filtersearch" Filtered${i} instfilter {} SB($i) instfilter {} set erg [f${i} a] ::errorCheck $erg "in a-::procFilter-::SB(${i})::f2-::SA(${i})::fa" \ "only obj filter" f${i} filter {} set erg [f${i} a] ::errorCheck $erg "in a" \ "obj filter remove" } for {set i 0} {$i < $n} {incr i} { SA($i) destroy SB($i) destroy SC($i) destroy } ::errorCheck $::filterCount 960 \ "Filter Test - Filter Count -- Got: $::filterCount" # # instvar test # Object o o set x 1 Object o1 o1 set x 11 Object o2 o2 proc t {} { # multiple imports for existing (x) and not existing vars (y) o instvar x y append result "x: $x " append result "y: i.e. [info exists y] me [my exists y] " \ "iv '[info vars y]' oe [o exists y] oiv '[o info vars y]' // " set y 100 append result "y: i.e. [info exists y] me [my exists y] " \ "iv '[info vars y]' oe [o exists y] oiv '[o info vars y]'" ::errorCheck $result \ "x: 1 y: i.e. 0 me 0 iv 'y' oe 0 oiv '' // y: i.e. 1 me 0 iv 'y' oe 1 oiv 'y'" \ "instvar test 1 failed" set result "" o1 instvar x y append result "x: $x " append result "y: i.e. [info exists y] me [my exists y] " \ "iv '[info vars y]' oe [o1 exists y] oiv '[o1 info vars y]' // " set y 101 append result "y: i.e. [info exists y] me [my exists y] " \ "iv '[info vars y]' oe [o1 exists y] oiv '[o1 info vars y]'" ::errorCheck $result \ "x: 11 y: i.e. 0 me 0 iv 'y' oe 0 oiv '' // y: i.e. 1 me 0 iv 'y' oe 1 oiv 'y'" \ "instvar test 2 failed" } o2 t o destroy o1 destroy o2 destroy global filterResult set filterResult "" Object a a set o 12 a set p 13 Class A A set m 14 Object instproc f args { global filterResult a instvar o p A instvar m ::append filterResult " [self] [self calledproc] [self callingproc]" ::append filterResult " $o $p $m" next } proc x {} { set ::a::e xxx } Object instfilter f x ::errorCheck $::a::e xxx \ "filterAddRemove: instvar test -- proc set failed" a set e yyy ::errorCheck $::a::e yyy \ "filterAddRemove: instvar test -- obj set failed" ::errorCheck $filterResult " ::A instvar f 12 13 14 ::a set run 12 13 14" \ "filterAddRemove: instvar test -- instvar filter failed" Object instfilter "" Object instproc f args { next } Object instfilter f ::errorCheck [Object o] "::o" \ "filterAddRemove: Object creation with filter" # This produces a bug, if not # RUNTIME_STATE(in)->returnCode = TCL_OK; # in ObjDispatch -> UNKNOWN handling */ # abrupt stop of program because result is set to XOTCL_UNKNOWN # instead of TCL_ERROR, as it should be catch {puts ${ZZZZZZZZZZZZZZZ::ZZZZZ}} o set r 43 ::errorCheck [o set r] "43" \ "filterAddRemove: Object creation with filter: setting var" Object instfilter "" # test for CmdListReplaceCmd set ::r "" Class A A instproc f2 args {lappend ::r [self class]-[self proc]; next} Class C -superclass A Class D -superclass C D instfilter {f2} D d d filter {f2} C instproc f2 args {lappend ::r [self class]-[self proc]; next} set ::r "" d set r 1 ::errorCheck $::r "::C-f2 ::A-f2" \ "filter method addition" o proc m {} { } o proc f args { my incr count next } o set count 0 o filter f o m ::errorCheck [o set count] 2 "filter count" o filter "" set filterstate [::xotcl::configure filter off] o set count 0 o m ::errorCheck [o set count]-$filterstate 0-1 "filter off + old state" o filter "" ::xotcl::configure filter on set ::r "" Object instproc f args { set r [next] lappend ::r [self]-[self calledproc] return $r } Class D D filter f D d1 ::errorCheck $::r "::D-d1 ::D-alloc ::D-create ::D-unknown" "filter state after next" } @ TestX filterClassChange { description {Regression test object testing class changes of filters.} } TestX filterClassChange -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class A($i) Class B A($i) instproc f args { set result pre*[self]*[self proc]*$args lappend result [next] post*[self]*[self proc] return $result } A($i) o($i) o($i) proc change {} { my class B } o($i) proc call {} { return in-call } A($i) instfilter f set erg [o($i) call] ::errorCheck $erg "pre*::o($i)*f* in-call post*::o($i)*f" \ "Filter Class Change -- Call before change" o($i) change set erg [o($i) call] ::errorCheck $erg "in-call" \ "Filter Class Change -- Call after change" # testing deleting a filter proc Class F F instproc testf args {return filtered} F instfilter testf F f1 ::errorCheck [f1 set r 45] "filtered" "Deleting a filter proc ... before" F instproc testf {} {} ::errorCheck [f1 set r 45] "45" "Deleting a filter proc ... after" # testing remove a superclass Class F1 Class F2 -superclass F1 Class F3 -superclass F2 F1 instproc testf args {return [next]-filtered} F2 instproc testf2 args {return [next]-filtered} F3 instfilter {testf testf2} F3 f2 ::errorCheck [f2 filtersearch testf2] "::F2 instproc testf2-filtered-filtered" "filtersearch 2" ::errorCheck [f2 set r 45] "45-filtered-filtered" \ "Removing a superclass ... before" F3 superclass [F1 info superclass] ::errorCheck [f2 filtersearch testf2] "" "filtersearch 2 after" ::errorCheck [f2 set r 45] "45" "Class F2 removed from classtree ... after" } B destroy for {set i 0} {$i < $n} {incr i} {A($i) destroy} } @ TestX filterGuards { description {Regression test object testing filter guards.} } TestX filterGuards -proc run {{n 20}} { global filterResult for {set i 0} {$i < $n} {incr i} { set ::filterResult "" Class A A instproc f2 args { global filterResult append filterResult "-[self]-[self proc]-[self class]-[self calledproc]" next } Class B -superclass A B instproc f1 args { global filterResult append filterResult "-[self]-[self proc]-[self class]-[self calledproc]" next } B instproc f3 args { global filterResult append filterResult "-[self]-[self proc]-[self class]-[self calledproc]" next } B instfilter {{f1 -guard "1<0"}} B b ::errorCheck $filterResult "" "Filter guard: Filter never to be applied" b destroy A instproc f1 args { global filterResult append filterResult "-[self]-[self proc]-[self class]-[self calledproc]" next } set filterResult "" B b ::errorCheck $filterResult "" \ "Filter guard: Filter never to be applied + filter inheritance on this filter" # filter w/o guard -> has to be applied A instfilter f1 b destroy set filterResult "" B b ::errorCheck $filterResult "-::b-f1-::A-configure-::b-f1-::A-init" \ "Filter guard: two different filters, same name + different class, one guarded, one not" # two filter w/o guard -> both have to be applied B instfilter f1 b destroy set filterResult "" B b ::errorCheck $filterResult "-::b-f1-::B-configure-::b-f1-::A-configure-::b-f1-::B-init-::b-f1-::A-init" \ "Filter guard: two different filters, both not guarded anymore" # three filters with guards, not to be applied, in one chain b destroy A instfilter {} B instfilter {{f1 -guard {0}} {f3 -guard {0}} {f2 -guard {0}}} set filterResult "" B b ::errorCheck $filterResult "" "Filter guard: three filters in one chain" # three times the same filter --> guards are and-combined set filterResult "" B instfilter {{f2 -guard {[self calledproc] eq "set" || [self] == "::b2"}}} A instfilter {{f2 -guard {[self] == "::b2"}}} B b1 B b2 if {$i == 0} { ::errorCheck $filterResult "-::b2-f2-::A-configure-::b2-f2-::A-init" \ "Filter guard: creation with less restrictive guards" } else { ::errorCheck $filterResult "-::b2-f2-::A-cleanup-::b2-f2-::A-configure-::b2-f2-::A-init" \ "Filter guard: creation with less restrictive guards (b)" } set filterResult "" b1 set x 45 ::errorCheck $filterResult "-::b1-f2-::A-set" \ "Filter guard: setting restricted object" set filterResult "" b1 info class ::errorCheck $filterResult "" \ "Filter guard: info restricted object (no guard applies)" set filterResult "" b2 info class ::errorCheck $filterResult "-::b2-f2-::A-info" \ "Filter guard: setting restricted object (2nd guard applies)" b1 filter {{f2 -guard {[self calledproc] eq "info"}}} set filterResult "" b1 proc a {} { # } ::errorCheck $filterResult "" \ "Filter guard: proc on restricted object (no guard applies)" set filterResult "" b1 info class ::errorCheck $filterResult "-::b1-f2-::A-info" \ "Filter guard: info filtered by object filter guard" # checking infos ::errorCheck [b1 info filterguard f2]-[B info instfilterguard f2]-[A info instfilterguard f2] \ {[self calledproc] eq "info"-[self calledproc] eq "set" || [self] == "::b2"-[self] == "::b2"} \ "Filter guard: info filtered by object filter guard" # checking info -guards option Class A A instproc f1 args {next} A instproc fx args {next} Class B -superclass A B instproc f1 args {next} B instproc f2 args {next} B b B instfilter {{f1 -guard {[self] eq "::b"}} {f2 -guard 0} f1} b filter {{f1 -guard {[self] eq "::b"}} {f2 -guard 0}} ::errorCheck [B info instfilter]-[B info instfilter -guards]-[b info filter]-[b info filter -guards] \ {f1 f2-f1 {f2 -guard 0}-f1 f2-{f1 -guard {[self] eq "::b"}} {f2 -guard 0}}\ {[self] -- Filter guard: -guards option} A instfilter {f1 fx} A a a proc x args {next} a filter x ::errorCheck [b info filter -order]-[a info filter -order] "{::B instproc f1} {::B instproc f2} {::A instproc f1} {::A instproc fx}-{::a proc x} {::A instproc f1} {::A instproc fx}" \ {[self] -- Filter guard: -order option} ::errorCheck [b info filter -order -guards]-[a info filter -order -guards] {{f1 -guard {[self] eq "::b"}} {f2 -guard 0} f1 fx-x f1 fx} \ {[self] -- Filter guard: -order -guards options} Class Foo Foo instproc init {args} {my set bar hello} Foo instproc baz {args} { my instvar bar return $bar } Foo instproc myFilter {args} { lappend ::r myFilter->[self calledproc] my set r 4 next } Foo instfilter myFilter Foo instfilterguard myFilter { ([self calledproc] eq "baz") } Foo instfilterguard myFilter { ([self calledproc] eq "baz") } set f [Foo new] $f baz ::errorCheck [$f baz] "hello" {Filter guard from method call} Foo instfilterguard myFilter {} set ::r "" Foo create f f filter myFilter f filterguard myFilter { ([self calledproc] eq "baz") } lappend ::r [f baz] [f set r 1] f filterguard myFilter {} lappend ::r [f baz] [f set r 1] ::errorCheck $::r [list myFilter->configure myFilter->init \ myFilter->set myFilter->filter \ myFilter->filterguard myFilter->baz \ hello 1 myFilter->baz \ myFilter->instvar myFilter->set hello 1] \ {Filter guard from method call} f destroy Class Room Room instproc open {} {lappend ::r [self proc]} Room instproc x {} {lappend ::r [self proc]} Room instproc loggingFilter args { lappend ::r [self proc]-[self calledproc] next } Room instproc callsMethod {method calledproc} { return [string match $calledproc $method] } Room instproc callsLevel2 {} { set level [self guardedlevel] lappend ::r $level set calledproc [uplevel $level self calledproc] lappend ::r $calledproc } Room instfilter loggingFilter Room instfilterguard loggingFilter {[my callsMethod open [self calledproc]]} Room r set ::r "" r open r x ::errorCheck $::r "loggingFilter-open open x" {info guarded scope} } } @ TestX mixinGuards { description {Regression test object testing mixin guards.} } TestX mixinGuards -proc run {{n 20}} { set ::r "" Class Fly Fly instproc fly {} {lappend ::r "[my signature]: yippee, fly like an eagle!"} Class Sing Sing instproc sing {} {lappend ::r "[my signature]: what a difference a day make"} Class Animal -parameter age Animal instproc unknown args { lappend ::r "[my signature]: how should i $args?"} Animal instproc signature {} { return "[self] [my info class] ([my age] years)" } Class Bird -superclass Animal Class Penguine -superclass Bird Class Parrot -superclass Bird Class Duck -superclass Bird Parrot tweedy -age 1 Penguine pingo -age 5 Duck donald -age 4 Parrot lora -age 6 Bird instmixin {{Fly -guard {[my age]>2 && ![my istype Penguine]}} Sing} foreach bird {tweedy pingo donald lora} { $bird fly } ::errorCheck [set ::r] [list \ {::tweedy ::Parrot (1 years): how should i fly?} \ {::pingo ::Penguine (5 years): how should i fly?} \ {::donald ::Duck (4 years): yippee, fly like an eagle!} \ {::lora ::Parrot (6 years): yippee, fly like an eagle!}] \ {Simple Instmixin Guard} set ::r "" tweedy age 3 pingo class Duck lora class Penguine foreach bird {tweedy pingo donald lora} { $bird fly } ::errorCheck [set ::r] [list \ {::tweedy ::Parrot (3 years): yippee, fly like an eagle!} \ {::pingo ::Duck (5 years): yippee, fly like an eagle!} \ {::donald ::Duck (4 years): yippee, fly like an eagle!} \ {::lora ::Penguine (6 years): how should i fly?}] \ {Simple Instmixin Guard ... Class Change} set ::r "" pingo mixin {{Fly -guard {[my age]>2}} Sing} foreach i { {Bird info instmixin -guards} {pingo info mixin -guards} {pingo info mixin -order -guards}} { lappend ::r "$i [eval $i]" } ::errorCheck [set ::r] [list \ {Bird info instmixin -guards {::Fly -guard {[my age]>2 && ![my istype Penguine]}} ::Sing} \ {pingo info mixin -guards {::Fly -guard {[my age]>2}} ::Sing} \ {pingo info mixin -order -guards {::Fly -guard {[my age]>2}} ::Sing}] \ {Simple Instmixin Guard ... Info} set ::r "" Class POM-start Class POM-end Class PCM-start Class PCM-end pingo mixin {POM-start {Fly -guard {[my age]>2}} Sing POM-end} Bird instmixin {PCM-start {Fly -guard {[my age]>2 && ![my istype Penguine]}} Sing PCM-end} pingo class Penguine foreach i { {Bird info instmixin -guards} {pingo info mixin -guards} {pingo info mixin -order -guards}} { lappend ::r "$i [eval $i]" } ::errorCheck [set ::r] [list \ {Bird info instmixin -guards ::PCM-start {::Fly -guard {[my age]>2 && ![my istype Penguine]}} ::Sing ::PCM-end} \ {pingo info mixin -guards ::POM-start {::Fly -guard {[my age]>2}} ::Sing ::POM-end} \ {pingo info mixin -order -guards ::POM-start ::POM-end ::PCM-start {::Fly -guard {[my age]>2}} ::Sing ::PCM-end}] \ {Same Mixin Guard ... Info} set ::r "" pingo fly ::errorCheck [set ::r] [list \ {::pingo ::Penguine (5 years): yippee, fly like an eagle!}] \ {Same Mixin Guard ... most specific counts} set ::r "" Animal a -set age 20 a mixin Fly a mixinguard ::Fly {[my age] > 3} a fly lappend ::r [a info mixin -guards] lappend ::r [a info mixin -order -guards] a set age 2 a fly a mixinguard ::Fly {[my age] > 4} a fly set info "" lappend info [a info mixinguard Fly] lappend ::r [a info mixin -guards] lappend ::r [a info mixin -order -guards] a mixinguard ::Fly {} a fly lappend ::r [a info mixin -guards] lappend info [a info mixinguard Fly] lappend ::r [a info mixin -order -guards] ::errorCheck [set ::r] [list \ {::a ::Animal (20 years): yippee, fly like an eagle!} \ {{::Fly -guard {[my age] > 3}}} {{::Fly -guard {[my age] > 3}}} \ {::a ::Animal (2 years): how should i fly?} \ {::a ::Animal (2 years): how should i fly?} \ {{::Fly -guard {[my age] > 4}}} {{::Fly -guard {[my age] > 4}}} \ {::a ::Animal (2 years): yippee, fly like an eagle!} \ ::Fly ::Fly] \ {mixinguard method} set ::r "" Class A -superclass Animal A a -set age 20 A instmixin Fly A instmixinguard ::Fly {[my age] > 3} lappend info [A info instmixinguard ::Fly] a fly lappend ::r [A info instmixin -guards] lappend ::r [a info mixin -order -guards] a set age 2 a fly A instmixinguard ::Fly {[my age] > 4} lappend info [A info instmixinguard ::Fly] a fly lappend ::r [A info instmixin -guards] lappend ::r [a info mixin -order -guards] A instmixinguard ::Fly {} lappend info [A info instmixinguard ::Fly] a fly lappend ::r [A info instmixin -guards] lappend ::r [a info mixin -order -guards] ::errorCheck [set ::r] [list \ {::a ::A (20 years): yippee, fly like an eagle!} \ {{::Fly -guard {[my age] > 3}}} {{::Fly -guard {[my age] > 3}}} \ {::a ::A (2 years): how should i fly?} \ {::a ::A (2 years): how should i fly?} \ {{::Fly -guard {[my age] > 4}}} {{::Fly -guard {[my age] > 4}}} \ {::a ::A (2 years): yippee, fly like an eagle!} \ ::Fly ::Fly] \ {instmixinguard method} ::errorCheck [set info] [list {[my age] > 4} {} {[my age] > 3} \ {[my age] > 4} {} ] {info (inst)mixinguard} } @ TestX filterSimpleObserver { description {Regression test object testing a simple observer using filters. } } TestX filterSimpleObserver -proc run {{n 20}} { set ::filterCount 0 for {set i 0} {$i < $n} {incr i} { Class NetAccess$i Class Http$i -superclass NetAccess$i Class TransferDialog$i TransferDialog$i proc addObserver cl { $cl instproc observerFilter args { set calledMethod [self calledproc] set callingClass [my info class] incr ::filterCount set result [next] my set r 34 foreach var {args calledMethod callingClass result} { if {[info vars $var] != $var} { puts stderr "[self] -- Simple Observer - info vars in filter" exit } } return [self]-[self class]-[my info class]-$args-[self calledproc]-[self callingproc]-$result } $cl instfilter observerFilter } TransferDialog$i instproc show {i} { next TransferDialog${i} addObserver NetAccess$i [self class] instvar observingObjects lappend observingObjects(::NetAccess$i) [self] } Http$i parameter {a be bu} Http$i instproc path x { my set path $x } Http$i instproc query x { my set [self proc] $x } Http$i instproc init {args} { my set url abc next my instvar query path bu if {![info exists query] || ![info exists path] || ![info exists bu] || $query ne "q"} { puts stderr "FAILED - [self] -- Simple Observer - Variable Init"; exit } } Http$i instproc GET {x} { my instvar query url path if {[info exists query]} { append url ?$query append path ?$query } set ::baseLevel [info level] if {0 != [expr {[info level] - $::baseLevel}]} { puts stderr "FAILED - [self] -- Simple Observer - info level in filtered proc\n\ expected 0, got [expr {[info level] - $::baseLevel}]" exit } foreach var {x path query url} { if {[info vars $var] != $var} { puts stderr "FAILED - [self] -- Simple Observer - info vars in filtered proc"; exit } } return $url } TransferDialog$i t($i) t($i) show $i Http$i h($i) -query q -path p -bu b set erg [h($i) GET 1] ::errorCheck $erg "::h($i)-::NetAccess$i-::Http$i-1-GET-run-abc?q" \ "Simple Observer - Filter Return" } for {set i 0} {$i < $n} {incr i} { NetAccess$i instfilter {} h($i) destroy t($i) destroy Http$i destroy NetAccess$i destroy TransferDialog$i destroy } ::errorCheck $::filterCount 220 \ "Simple Observer - Filter Count" } @ TestX stdargs { description { Regression test object testing the ability of the next primitive to pass arguments without naming them. } } TestX stdargs -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class C Class D Class A -superclass {C D} Class B -superclass A C instproc t {} { next return } D instproc t args { ::errorCheck $args "" --noArgs next return } A instproc t {a b args} { if {$a != 1 || $b != 2 || $args != {3 4 5 6 7 8 9}} { puts stderr "FAILED - [self] -- StdArgs not computed"; exit } next --noArgs return } B instproc t {a b args} { if {$a != 1 || $b != 2 || $args != {3 4 5 6 7 8 9}} { puts stderr "FAILED -[self] -- StdArgs not computed"; exit } next return } B x x t 1 2 3 4 5 6 7 8 9 } foreach o {x A B C D} {$o destroy} } @ TestX filterInfo { description{ Regression test object testing introspection of filters. } } TestX filterInfo # Helper Procs proc ::showStack {{m 100}} { set r "" set max [info level] if {$m<$max} {set max $m} for {set i 0} {$i < $max} {incr i} { set r ${r}-$i=[info level [expr -$i]] } return $r } proc ::showCall {} { set n "" for {set level -1} {1} {incr level -1} { set p [info level $level] if {[lindex $p 0] eq "next"} {set n "next:"} break } return [showStack] } filterInfo proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { global FInfo set FInfo "" Class FI FI proc addFilter {classname} { $classname instproc infoFilter args { global FInfo lappend FInfo \ [list callingclass [self callingclass] \ filterreg [self filterreg] \ callingobject [self callingobject] \ callingproc [self callingproc] \ calledproc [self calledproc]] set r [next] lappend FInfo \ [list self [self] proc [self proc] class [self class] \ infoclass [my info class] r $r] return $r } $classname instfilter infoFilter } Class C0 FI addFilter C0 C0 instproc m1 {} { my instvar aa bb cc set cc 1 } Class C1 -superclass C0 C1 instproc init args { my set a 1 my set c 22 next } C1 instproc m1 args { set r [next] my instvar a b cc return $r--${a}--[set cc] } set safedObjFilters [Object info filter] Object instfilter "" C1 c1 Object instfilter $safedObjFilters if {$i == 0} { ::errorCheck "$FInfo" \ "{callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc configure} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 0} {callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc init} {callingclass ::C1 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc init calledproc set} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 1} {callingclass ::C1 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc init calledproc set} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 22} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r {}}" \ "Wrong filtering of instproc creation C/C1" } else { ::errorCheck "$FInfo" \ "{callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc cleanup} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r {}} {callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc configure} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 0} {callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc init} {callingclass ::C1 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc init calledproc set} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 1} {callingclass ::C1 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc init calledproc set} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 22} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r {}}" \ "Wrong filtering of instproc creation C/C1 (b)" } set FInfo "" set result [c1 m1] ::errorCheck $FInfo \ "{callingclass {} filterreg {::C0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc m1} {callingclass ::C0 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc m1 calledproc instvar} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r {}} {callingclass ::C1 filterreg {::C0 instfilter infoFilter} callingobject ::c1 callingproc m1 calledproc instvar} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r {}} {self ::c1 proc infoFilter class ::C0 infoclass ::C1 r 1--1--1}" \ "Wrong filtering of c1 m1" set FInfo "" ::errorCheck $result \ "1--1--1" "Wrong return result of Filter Example 2 'c1 m1' " Class T0 FI addFilter T0 T0 instproc m {} { set e -0=showStack-1=showCall-2=m-3=m-4=m-5=run-6=run if {[string first $e [showCall]] == -1} { puts stderr "FAILED - Wrong calling stack in T0 m: [showCall]" puts stderr "expected = '$e'" puts stderr "got = '[showCall]'" exit } return [self]-[self proc]-[self class]-[my info class] } Class T1 -superclass T0 T1 instproc m {} { set e 0=showStack-1=showCall-2=m-3=m-4=run-5=run if {[string first $e [showCall]] == -1} { puts stderr "FAILED - Wrong calling stack in T1 m: [showCall]" puts stderr "expected = '$e'" puts stderr "got = '[showCall]'" exit } set r1 before-[self]-[self proc]-[self class]-[my info class] set r2 [next] set r after-[self]-[self proc]-[self class]-[my info class]-${r1}-$r2 } T1 t set FInfo "" set result [t m] ::errorCheck $FInfo \ "{callingclass {} filterreg {::T0 instfilter infoFilter} callingobject ::filterInfo callingproc run calledproc m} {callingclass ::T1 filterreg {::T0 instfilter infoFilter} callingobject ::t callingproc m calledproc info} {self ::t proc infoFilter class ::T0 infoclass ::T1 r ::T1} {callingclass ::T0 filterreg {::T0 instfilter infoFilter} callingobject ::t callingproc m calledproc info} {self ::t proc infoFilter class ::T0 infoclass ::T1 r ::T1} {callingclass ::T1 filterreg {::T0 instfilter infoFilter} callingobject ::t callingproc m calledproc info} {self ::t proc infoFilter class ::T0 infoclass ::T1 r ::T1} {self ::t proc infoFilter class ::T0 infoclass ::T1 r after-::t-m-::T1-::T1-before-::t-m-::T1-::T1-::t-m-::T0-::T1}" \ "Wrong filtering of t m" set FInfo "" ::errorCheck $result \ "after-::t-m-::T1-::T1-before-::t-m-::T1-::T1-::t-m-::T0-::T1" \ "Wrong return result of Filter Example 2 \"t m\" " } c1 destroy for {set i 0} {$i < $n} {incr i} { global InfoTraceResult Object instfilter "" Object InfoTrace InfoTrace proc createInfoTrace cl { $cl instproc infoTraceFilter args { global InfoTraceResult ::set r [next] ::lappend InfoTraceResult [list \ $r-[self]-[self proc]-[self class] \ [my info class]-[self calledproc] \ [self callingproc]-[self callingobject] \ [self callingclass]-[self filterreg]] return $r } $cl instfilter infoTraceFilter } Class ObjectsClass ObjectsClass anObject Class aClass ObjectsClass instproc aProc {} {aClass create anotherObject} InfoTrace createInfoTrace Object set InfoTraceResult "" set r [anObject aProc] if {$i > 0} { ::errorCheck $InfoTraceResult \ "{-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-cleanup aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {-::xotcl::Class::Parameter-infoTraceFilter-::xotcl::Object ::xotcl::Class-searchDefaults aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {0-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-recreate aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ "FilterInfo InfoTrace: Filter information wrong (b)" } else { ::errorCheck $InfoTraceResult \ "{::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-alloc aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {-::xotcl::Class::Parameter-infoTraceFilter-::xotcl::Object ::xotcl::Class-searchDefaults aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {0-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ "FilterInfo InfoTrace: Filter information wrong" } } Object instfilter {} global fUplevelResult set fUplevelResult "" Class FilterMix FilterMix instproc calls args { global fUplevelResult set calledproc [uplevel 1 {self calledproc}] set calledclass [uplevel 1 {self calledclass}] append fUplevelResult "-[self class]-[self proc]-$calledproc-$calledclass" } Class FilterCL -instmixin FilterMix FilterCL instproc filterA args { global fUplevelResult append fUplevelResult -[self class]-[self proc]-[self calledproc]-[self calledclass] my calls next } FilterCL instproc fclproc args {} FilterCL instfilter filterA FilterCL fcl fcl fclproc # ::errorCheck $fUplevelResult "-::FilterCL-filterA-configure-::xotcl::Object-::FilterMix-calls-configure-::xotcl::Object-::FilterCL-filterA-init-::xotcl::Object-::FilterMix-calls-init-::xotcl::Object-::FilterCL-filterA-fclproc-::FilterCL-::FilterMix-calls-fclproc-::FilterCL" "Filter/Mixin Info Uplevel Test" } @ TestX nextTest { description {Regression test object testing the next primitive.} } TestX nextTest -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { global result infoNext set result "" set infoNext "" Class X X instproc n {} { append ::infoNext " [self]+[self class]->[self proc]*<[self next]>" next } Class Y -superclass X Y instproc m {} { append ::infoNext " [self]+[self class]->[self proc]*<[self next]>" next } Y instproc n {} { append ::infoNext " [self]+[self class]->[self proc]*<[self next]>" next } Y y y m y n y proc n {} { append ::infoNext " [self]+[self class]->[self proc]*<[self next]>" next } y n ::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::X instproc n> ::y+::X->n*<> ::y+->n*<::Y instproc n> ::y+::Y->n*<::X instproc n> ::y+::X->n*<>" \ "simple self next test" set infoNext "" set result "" Class A A instproc m arg { global result infoNext set result ${result}-[self]-$arg } Class B -superclass A B instproc m arg { global result infoNext set result ${result}-[self]-$arg append infoNext " 2[self]+[self class]->[self proc]*<[self next]>" next } B b0 -m 1 B b -m "" ::errorCheck $result "-::b0-1-::b0-1-::b--::b-" \ "Next Test A/B -- Wrong result" set result "" Class X X instproc init args { global result infoNext set result ${result}-[self]-$args append infoNext " 1[self]+[self class]->[self proc]*<[self next]>" next } X instproc test {} { global result set result ${result}-[self] } X x -test ::errorCheck $result "-::x-::x-" \ "Next Test X -- Wrong result" ::errorCheck $infoNext " 2::b0+::B->m*<::A instproc m> 2::b+::B->m*<::A instproc m> 1::x+::X->init*<::xotcl::Object instproc init>" \ "self next test 2" X destroy x destroy A destroy B destroy b0 destroy b destroy Class MIX MIX instproc mProc args { global result append result "[self]-[self class]-[self next]" next } Object o -mixin MIX o proc mProc args { global result append result "[self]-[self class]-[self next]" } set result "" o mProc ::errorCheck $result "::o-::MIX-::o proc mProc::o--" \ "Next Test Proc & Mixin" o destroy; MIX destroy } } @ TestX init_params { description { Regression test object testing the parameter instance method, the init dash '-' and constructor calling. } } TestX init_params -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { global dashResult set dashResult "" set dashResultEnd "" Class A A instproc t0 {} { global dashResult set dashResult ${dashResult}*[self proc] } A instproc t1 {a} { global dashResult set dashResult ${dashResult}*[self proc]-$a } A instproc t2 {a b} { global dashResult set dashResult ${dashResult}*[self proc]-${a}-$b } A instproc t3 {a b c} { global dashResult set dashResult ${dashResult}*[self proc]-${a}-${b}-$c } A a set dashResultEnd "[A a -t0] $dashResultEnd" A a set dashResultEnd "[A a -t1 1] $dashResultEnd" A a set dashResultEnd "[A a -t2 1 2] $dashResultEnd" A a set dashResultEnd "[A a -t3 1 2 3] $dashResultEnd" A a set dashResultEnd "[A a -t0 -t0 -t3 1 2 3 -t0 -t1 1 -t1 1 -t0] $dashResultEnd" catch {A a t} ::errorCheck $dashResult \ "*t0*t1-1*t2-1-2*t3-1-2-3*t0*t0*t3-1-2-3*t0*t1-1*t1-1*t0" \ "Init Dash Test fails" ::errorCheck $dashResultEnd \ "::a ::a ::a ::a ::a " \ "Init Dash Test fails -- result" Class Foo -parameter {{match -exact}} Foo ff ::errorCheck [ff match] "-exact" "default with dash" } # parameter/defaults test proc ::cmd {a b} { return in-cmd-${a}-${b} } global parameterResult global initResult for {set i 0} {$i < $n} {incr i} { Class O -parameter { {a -default 0} {b -default {[cmd 3 4]}} c d {e -default 3} {Self -default [self]} } O instproc init args { global initResult set initResult ${initResult}-[self]-[self class]-[self proc]--$args next } O instproc show {} { global parameterResult set parameterResult [self] foreach v [lsort [my info vars]] { set parameterResult ${parameterResult}-${v}=<[my set ${v}]> } } Class Meta -superclass Class Meta instproc create args {next; return Meta-create} Meta C -superclass O -parameter {a {b -default ""} {c -default 1}} Class D -parameter {a {c -default 1}} -superclass O # create on class should not be called D instproc create args {next; return D-create} D instproc init args { global initResult set initResult ${initResult}-[self]-[self class]-[self proc]--$args next } D instproc test i { ::errorCheck [my set c]-[my set a] "2-0" "Wrong order of init call" } set parameterResult "" set initResult "" C c0 -show ::errorCheck $parameterResult "::c0-Self=<::c0>-a=<0>-b=<>-c=<1>-e=<3>" \ "C c0 parameter Test failed" if {$i == 0} { ::errorCheck $initResult "-::c0-::O-init--" \ "C c0 parameter init Test failed" } else { ::errorCheck $initResult "-::c0-::O-init--" \ "C c0 parameter init Test failed (b)" } set parameterResult "" set initResult "" set r [C c1 -c 2 -init a b c -a 1 -show] ::errorCheck $parameterResult "::c1-Self=<::c1>-a=<1>-b=<>-c=<2>-e=<3>" \ "C c1 parameter Test failed (b)" ::errorCheck $initResult "-::c1-::O-init--a b c" \ "C c1 parameter init Test failed" set parameterResult "" set initResult "" set r $r-[D d1 -c 2 -init a b c -test $i -a 1 -show] ::errorCheck $parameterResult "::d1-Self=<::d1>-a=<1>-b=-c=<2>-e=<3>" \ "D d1 parameter Test failed" if {$i == 0} { ::errorCheck $initResult "-::d1-::D-init--a b c-::d1-::O-init--a b c" \ "D d1 parameter init Test failed" } else { ::errorCheck $initResult "-::d1-::D-init--a b c-::d1-::O-init--a b c" \ "D d1 parameter init Test failed (b)" } ::errorCheck $r "Meta-create-::d1" "User defined object creation failed" } } @ TestX mixinTest { description { Regression test object testing per-object mixins. } } TestX mixinTest -proc run {{n 10}} { global mixinResult set mixinResult "" Class Agent Agent instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Agent instproc otherProc {} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Class InteractiveAgent -superclass Agent InteractiveAgent instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Class InteractiveAgent2 -superclass Agent InteractiveAgent2 instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Class InteractiveAgent3 -superclass Agent InteractiveAgent3 instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } # Addition-Classes Class MovementLog MovementLog instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] my otherProc next } MovementLog instproc otherProc {} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Class MovementTest MovementTest instproc moveAgent {x y} { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } InteractiveAgent i1; InteractiveAgent i2 i1 mixin MovementLog i2 mixin MovementTest InteractiveAgent2 instmixin {MovementLog MovementTest} InteractiveAgent3 instmixin MovementTest InteractiveAgent2 i3; InteractiveAgent3 i4; ::errorCheck [InteractiveAgent2 info instmixin] "::MovementLog ::MovementTest" "Mixin: info instmixin" i2 moveAgent 1 2 ::errorCheck $mixinResult \ "-::i2-moveAgent-::MovementTest-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \ "Mixin: 'i2 moveAgent 1 2' failed" set mixinResult "" i1 moveAgent 3 4 ::errorCheck $mixinResult \ "-::i1-moveAgent-::MovementLog-::i1-otherProc-::MovementLog-::i1-otherProc-::Agent-::i1-moveAgent-::InteractiveAgent-::i1-moveAgent-::Agent" \ "Mixin: 'i1 moveAgent 3 4' failed" set mixinResult "" i3 moveAgent 3 4 ::errorCheck $mixinResult \ "-::i3-moveAgent-::MovementLog-::i3-otherProc-::MovementLog-::i3-otherProc-::Agent-::i3-moveAgent-::MovementTest-::i3-moveAgent-::InteractiveAgent2-::i3-moveAgent-::Agent" \ "Instmixin: 'i3 moveAgent 3 4' failed" set mixinResult "" i4 moveAgent 3 4 ::errorCheck $mixinResult \ "-::i4-moveAgent-::MovementTest-::i4-moveAgent-::InteractiveAgent3-::i4-moveAgent-::Agent" \ "Instmixin: 'i4 moveAgent 3 4' failed" i4 mixin {MovementTest MovementLog} i4 proc aaa args {puts TEST} ::errorCheck [i4 info precedence] "::MovementLog ::MovementTest ::InteractiveAgent3 ::Agent ::xotcl::Object" "precedence i4" ::errorCheck [i4 procsearch moveAgent]-[i4 procsearch aaa]-[i4 procsearch set] "::MovementLog instproc moveAgent-::i4 proc aaa-::xotcl::Object instcmd set" "procsearch" Class create A A instproc f1 {} {puts hu} A instforward f2 puts hu A instparametercmd f5 A create a0 a0 proc f3 {} {puts hu} a0 forward f4 puts hu a0 parametercmd f6 puts hu ::errorCheck [a0 procsearch f1] "::A instproc f1" procsearch-1 ::errorCheck [a0 procsearch f2] "::A instforward f2" procsearch-2 ::errorCheck [a0 procsearch f3] "::a0 proc f3" procsearch-3 ::errorCheck [a0 procsearch f4] "::a0 forward f4" procsearch-4 ::errorCheck [a0 procsearch f5] "::A instparametercmd f5" procsearch-4 ::errorCheck [a0 procsearch f6] "::a0 parametercmd f6" procsearch-6 ::errorCheck [a0 procsearch set] "::xotcl::Object instcmd set" procsearch-6 set mixinResult "" i4 moveAgent 5 6 ::errorCheck $mixinResult \ -::i4-moveAgent-::MovementLog-::i4-otherProc-::MovementLog-::i4-otherProc-::Agent-::i4-moveAgent-::MovementTest-::i4-moveAgent-::InteractiveAgent3-::i4-moveAgent-::Agent \ "Instmixin: 'i4 moveAgent 5 6' failed" Class A A instproc test {} { global mixinResult set mixinResult "test" i1 moveAgent 3 4 } A a a test ::errorCheck $mixinResult \ "test-::i1-moveAgent-::MovementLog-::i1-otherProc-::MovementLog-::i1-otherProc-::Agent-::i1-moveAgent-::InteractiveAgent-::i1-moveAgent-::Agent" \ "Mixin: 'a test' failed" i2 mixin {MovementLog MovementTest} set mixinResult "" i2 moveAgent a b ::errorCheck $mixinResult \ "-::i2-moveAgent-::MovementLog-::i2-otherProc-::MovementLog-::i2-otherProc-::Agent-::i2-moveAgent-::MovementTest-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \ "Mixin: 'i2 moveAgent a b' failed" ::errorCheck "[i2 info mixin]-[i1 info mixin]-[a info mixin]" \ "::MovementLog ::MovementTest-::MovementLog-" \ "Mixin: Info failed" ::errorCheck "[i2 ismixin MovementTest]-[i4 ismixin MovementTest]-[a ismixin MovementTest]-[i3 ismixin MovementTest]-[i4 ismixin MovementTest]-[i4 ismixin MovementLog]-[i3 ismixin YXZ]-[i3 ismixin InteractiveAgent]" \ "1-1-0-1-1-1-0-0" \ "'ismixin test' failed" ::errorCheck "[i2 hasclass MovementTest]-[i4 hasclass MovementTest]-[a hasclass MovementTest]-[i3 hasclass MovementTest]-[i4 hasclass MovementTest]-[i4 hasclass MovementLog]-[i3 hasclass YXZ]-[i3 hasclass InteractiveAgent]-[a hasclass A]-[i3 hasclass Agent]" \ "1-1-0-1-1-1-0-0-1-1" \ "'hasclass test' failed" set mixinResult "" i2 mixin "" i2 moveAgent a b ::errorCheck $mixinResult \ "-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \ "Mixin: remove failed" set mixinResult "" Class A A instproc destroy args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } A instproc y args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } Class B B instproc destroy args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] next } B instproc y args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] my mixin "" next } B instproc x args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] my destroy } A a -mixin B a destroy A a -mixin B a x A a -mixin B a y ::errorCheck $mixinResult \ "-::a-destroy-::B-::a-destroy-::A-::a-x-::B-::a-destroy-::B-::a-destroy-::A-::a-y-::B-::a-y-::A" \ "Mixin: destroy failed" A instmixin B set mixinResult "" A a2 a2 destroy A a2 a2 x A a2 a2 y ::errorCheck $mixinResult \ "-::a2-destroy-::B-::a2-destroy-::A-::a2-x-::B-::a2-destroy-::B-::a2-destroy-::A-::a2-y-::B-::a2-y-::A" \ "Instmixin: destroy failed" # mixin Test: calls the mixins and a proc of the object set ::mixinResult "" Class A Class B A instproc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc];next} B instproc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc]; next} A d -mixin B d proc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc]; next} d a ::errorCheck $::mixinResult \ "-::d-::B-a-::d--a-::d-::A-a" \ "Mixin: calling of object's proc" set mixinResult "" d mixin {} A instmixin B d a ::errorCheck $::mixinResult \ "-::d-::B-a-::d--a-::d-::A-a" \ "Instmixin: calling of object's proc" # # combining filters with mixins # set ::traceResults "" Class M1 M1 instproc test args { global traceResults lappend traceResults "[self] [self proc] [self class]" next } Class M2 M2 instproc test args { global traceResults lappend traceResults "[self] [self proc] [self class]" next } Class A A instproc test args { global traceResults lappend traceResults "[self] [self proc] [self class]" next } A instproc f1 args { global traceResults lappend traceResults "[self] [self proc] [self class]" next } A instproc f2 args { global traceResults lappend traceResults "[self] [self proc] [self class]" next } A a A instmixin {M1 M2} A instfilter {f1 f2} a test ::errorCheck $::traceResults \ "{::a f1 ::A} {::a f2 ::A} {::a test ::M1} {::a test ::M2} {::a test ::A}" \ "Combining mixins and filters" # mixin recursion test set mixinResult "" Class Computation Computation instproc compute args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] # abstract interface for computations } Class ComputationOutput -superclass Computation Computation instproc compute args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] return $args } Class RecFacultyMixin RecFacultyMixin instproc compute args { global mixinResult set mixinResult ${mixinResult}-[self]-[self proc]-[self class] set n [lindex $args 0] set callingClass - #puts stderr [self class]=[uplevel 1 self class]-[self callingclass] #catch {set callingClass [uplevel 1 self class]} set callingClass [self callingclass] if {$n == 0} { set result 1 } else { set f [my compute [expr {$n - 1}] x] set result [expr {$n * $f}] } if {$callingClass != [self class]} { next $result return $result } else { return $result } } ComputationOutput faculty faculty mixin RecFacultyMixin ::errorCheck [faculty compute 3] 6 \ "Mixin: faculty wrong result" ::errorCheck $mixinResult \ "-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::Computation" \ "Mixin: faculty failed" set mixinResult "" ComputationOutput faculty ComputationOutput instmixin RecFacultyMixin ::errorCheck [faculty compute 3] 6 "Mixin: faculty wrong result" ::errorCheck $mixinResult \ "-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::Computation" \ "Mixin: faculty failed" set ::mixinResult "" set ::calling "" Class GrObject GrObject instproc draw args { lappend ::mixinResult [list grObject [self] [self proc] [self class]] lappend ::calling [list grObject [self proc]: [self callingobject] [self callingclass] [self callingproc] [self next]] } Class Image -superclass GrObject Image instproc draw args { lappend ::mixinResult [list image [self] [self proc] [self class]] lappend ::calling [list image [self proc]: [self callingobject] [self callingclass] [self callingproc] [self next]] next } Class MenuDecorator MenuDecorator instproc draw args { lappend ::mixinResult [list m1 [self] [self proc] [self class]] lappend ::calling [list m1 [self proc]: [self callingobject] [self callingclass] [self callingproc] [self next]] next } Class ScrollBarDecorator ScrollBarDecorator instproc draw args { lappend ::mixinResult [list m2 [self] [self proc] [self class]] lappend ::calling [list m2 [self proc]: [self callingobject] [self callingclass] [self callingproc] [self next]] next } Image mainImage -mixin {MenuDecorator ScrollBarDecorator} Image zoom -mixin {ScrollBarDecorator} Object instproc f args { if {[self calledproc] ne "filter"} { lappend ::mixinResult [list filter [self] [self proc] [self class]] lappend ::calling [list filter [self proc]: [self callingobject] [self callingclass] [self callingproc] [self calledproc] [self next]] } return [next] } Object instfilter f mainImage draw zoom draw Object instfilter "" ::errorCheck $::calling \ "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}} {filter f: ::xotcl::Object ::xotcl::Class instfilter assign {::xotcl::InterceptorSlot instcmd assign}}" \ "Mixin: Calling-Obj/Cl/Proc failed" ::errorCheck $::mixinResult \ "{filter ::mainImage f ::xotcl::Object} {m1 ::mainImage draw ::MenuDecorator} {m2 ::mainImage draw ::ScrollBarDecorator} {image ::mainImage draw ::Image} {grObject ::mainImage draw ::GrObject} {filter ::zoom f ::xotcl::Object} {m2 ::zoom draw ::ScrollBarDecorator} {image ::zoom draw ::Image} {grObject ::zoom draw ::GrObject} {filter ::xotcl::Object f ::xotcl::Object} {filter ::xotcl::Class::slot::instfilter f ::xotcl::Object}" \ "Mixin: Filter failed" set ::mixinResult "" set ::calling "" Class InfoTrace2 InfoTrace2 instproc infoTraceFilter2 args { lappend ::calling \ self [self] \ "self proc" [self proc] \ "self class" [self class] \ "self calledproc" [self calledproc] \ "self callingproc" [self callingproc] \ "self callingobject" [self callingobject] \ "self callingclass" [self callingclass] \ "self filterreg" [self filterreg] \ "self next" [self next] next } Class CallingObjectsClass CallingObjectsClass create callingObject Class FilterRegClass -superclass InfoTrace2 Class FilteredObjectsClass -superclass FilterRegClass FilteredObjectsClass filteredObject CallingObjectsClass instproc callingProc args { filteredObject set someVar 0 } FilterRegClass instfilter infoTraceFilter2 callingObject callingProc ::errorCheck $::calling \ {self ::filteredObject {self proc} infoTraceFilter2 {self class} ::InfoTrace2 {self calledproc} set {self callingproc} callingProc {self callingobject} ::callingObject {self callingclass} ::CallingObjectsClass {self filterreg} {::FilterRegClass instfilter infoTraceFilter2} {self next} {::xotcl::Object instcmd set}} \ "call stack info" Class M1; Class M2; Class M3; Class M4 Class A; Class B -superclass A; B b A instmixin {M1 M2} B instmixin {M3 M1 M1 M4} b mixin {M1 M1 M4} ::errorCheck [b info mixin -order] "::M3 ::M4 ::M1 ::M2" "Mixin Info: -order option" ::errorCheck [B info instmixin]-[b info mixin] "::M3 ::M1 ::M4-::M1 ::M4" "Mixin Info: no duplicates" B instmixin {} ::errorCheck [b info mixin -order] "::M4 ::M1 ::M2" "Mixin Info: -order option" set ::r "" Class X11 -instproc test {args} { lappend ::r [self class] next } Class X12 -instproc test {args} { lappend ::r [self class] next } Class X -instmixin {X11 X12} -instproc test {args} { lappend ::r [self class] next } Class Y -instmixin X Y create y -test X create x -test ::errorCheck $::r [list ::X11 ::X12 ::X ::X11 ::X12 ::X] \ {transitive mixin} unset ::r # test for MixinRemoveFromMixinStack, MixinRemoveFromCmdPtr, # MixinRemoveOnObjFromCmdPtr Class A A instproc x {} {B destroy; next} Class B B instproc x {} {next} Class C C instproc x {} {next} Object o -mixin {A B C} o proc x {} {return x} ::errorCheck [o x] {x} {mixin destroy on stack} o destroy # testing transitive mixins; should be in both cases the same Class IM Class M Object o -mixin M M instmixin IM ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object} \ {trans. mixin precedence 1} Object o -mixin M ::errorCheck [o info precedence] {::IM ::M ::xotcl::Object} \ {trans. mixin precedence 2} o destroy } @ TestX procsearchTest { description { Regression test for procsearch } } TestX procsearchTest -proc run {{n 10}} { Class M -instproc foo args {puts m;next} Object o -mixin M -proc foo args {puts o;next} ::errorCheck [o procsearch foo] "::M instproc foo" "mixin before proc in procsearch" M destroy o destroy Class CC -instproc foo args {puts CC;next} CC create c -proc foo args {puts c;next} ::errorCheck [c procsearch foo] "::c proc foo" "proc before instproc in procsearch" CC destroy c destroy } @ TestX mixinInheritanceTest { description { Regression test object testing per-object mixin inheritance. } } TestX mixinInheritanceTest -proc run {{n 10}} { for {set i 0} {$i < $n} {incr i} { global mixinResult set mixinResult "" Class A Class B Class C -superclass {A B} Class GeneralMixin Class RefinedMixin1 -superclass GeneralMixin Class RefinedMixin2 -superclass GeneralMixin Class AppMixin1 -superclass {RefinedMixin1 RefinedMixin2} Class AppMixin2 -superclass {RefinedMixin2 RefinedMixin1} Class AppMixin3 -superclass {RefinedMixin1} A instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return $args } B instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return $args } C instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next "$args [self class]"] } GeneralMixin instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next "$args [self class]"] } RefinedMixin1 instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next "$args [self class]"] } RefinedMixin2 instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next "$args [self class]"] } AppMixin1 instproc aProc args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next "$args [self class]"] } AppMixin1 mixinInstance set r [mixinInstance aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin" \ "Mixin inheritance: mixinInstance aProc" set mixinResult "" AppMixin3 mixinInstance2 set r [mixinInstance2 aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::RefinedMixin1 ::GeneralMixin" \ "Mixin inheritance: mixinInstance2 aProc" set mixinResult "" A a a mixin AppMixin1 set r [a aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::A" \ "Mixin inheritance: a aProc" ::errorCheck $r \ "{{{{ARGS1 ARGS2 ::AppMixin1} ::RefinedMixin1} ::RefinedMixin2} ::GeneralMixin}" \ "Mixin inheritance result: a aProc" A a A instmixin AppMixin1 set mixinResult "" set r [a aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::A" \ "Instmixin inheritance: a aProc" ::errorCheck $r \ "{{{{ARGS1 ARGS2 ::AppMixin1} ::RefinedMixin1} ::RefinedMixin2} ::GeneralMixin}" \ "Instmixin inheritance: a aProc" set mixinResult "" C c c mixin {AppMixin3 AppMixin2} set r [c aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::C ::A" \ "Mixin/Instmixin inheritance: c aProc" set mixinResult "" A instmixin {} set r [c aProc ARGS1 ARGS2] ::errorCheck $mixinResult \ " ::RefinedMixin2 ::RefinedMixin1 ::GeneralMixin ::C ::A" \ "Mixin/Instmixin inheritance: c aProc" GeneralMixin instproc set args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next] } RefinedMixin1 instproc set args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next] } AppMixin1 instproc set args { global mixinResult; ::set mixinResult "$mixinResult [self class]" return [next] } global setFilterResult set setFilterResult "" Object instproc setFilter args { global setFilterResult ::append setFilterResult \ -[self]-[self calledproc]-[self calledclass] next } Object instfilter setFilter set mixinResult "" set r [c set setVar 111] ::errorCheck $mixinResult \ " ::RefinedMixin1 ::GeneralMixin" \ "Mixin inheritance: c set" # UNKNOWN PROBLEM 2 # ::errorCheck [c setsetVar] 111 "Mixin inheritance: c set - value" ::errorCheck [c set setVar] 111 "Mixin inheritance: c set - value" set mixinResult "" mixinInstance set setVar 222 ::errorCheck $mixinResult \ " ::AppMixin1 ::RefinedMixin1 ::GeneralMixin" \ "Mixin inheritance: mixinInstance set" ::errorCheck [mixinInstance set setVar] 222\ "Mixin inheritance: mixinInstance set - value" ::errorCheck $setFilterResult \ "-::c-set-::xotcl::Object-::c-set-::xotcl::Object-::mixinInstance-set-::AppMixin1-::mixinInstance-set-::AppMixin1" \ "Mixin inheritance: Wrong classes in mixin set test" Object instfilter "" } # Mixin init test global initResult set initResult "" Class A A instproc init args { my mixin B global initResult append initResult [self class]- next } Class C C instproc init args { global initResult append initResult [self class]- next } Class B -superclass C B instproc init args { global initResult append initResult [self class]- next } Class D D instproc init args { global initResult append initResult [self class]- next } A a ::errorCheck $initResult "::A-" "Mixin init 1 failed" set initResult "" # in A mixin changes to B - before D's constructor must # be called A b -mixin D ::errorCheck $initResult "::D-::A-" "Mixin init 2 failed" Class Mix Mix instproc init args { global initResult append initResult [self class]- next } Class Mix1 Mix1 instproc init args { global initResult append initResult [self class]- next } Class Mix2 Mix2 instproc init args { global initResult append initResult [self class]- next } Class A A instproc init args { global initResult append initResult [self class]- next } Class B B instproc init args { my mixin {Mix Mix1} global initResult append initResult [self class]- next } set initResult "" A a a mixin {Mix Mix1} ::errorCheck $initResult ::A- "Mixin init 3 failed" set initResult "" B b ::errorCheck $initResult ::B- "Mixin init 4 failed" set initResult "" B mixin add Mix2 ::errorCheck $initResult "" "Mixin init 5 failed" set initResult "" A mixin {}; A mixin {Mix Mix1} ::errorCheck $initResult "" "Mixin init 6 failed" set initResult "" A a -mixin {Mix} ::errorCheck $initResult "::Mix-::A-" "Mixin init 7 failed" Class Strategy Strategy instproc init args { global initResult append initResult [self class]- next } Class A A instproc strategy {n} { set a [my info mixin] my mixin [concat $n $a] } A instproc init args { global initResult append initResult [self class]- next } Class Mix1 Mix1 instproc init args { global initResult append initResult [self class]- my strategy Strategy next } set initResult "" A a -mixin Mix1 ::errorCheck $initResult ::Mix1-::A- "Mixin init 8 failed" set initResult "" Class X X instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } Class Y -superclass X Y instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } Class U -superclass X U instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } Class V V instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } Class A A instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } Class B -superclass A B instproc init args { append ::initResult " [self]: [self class]->[self proc]" next } A a a mixin X B b b mixin Y A a2 -mixin Y B b2 -mixin X A a3 -mixin {U V} B b3 b3 mixin {U V} A a3 A instmixin X A instmixin {} B instmixin Y B b3 b3 mixin Y ::errorCheck $initResult \ " ::a: ::A->init ::b: ::B->init ::b: ::A->init ::a2: ::Y->init ::a2: ::X->init ::a2: ::A->init ::b2: ::X->init ::b2: ::B->init ::b2: ::A->init ::a3: ::U->init ::a3: ::X->init ::a3: ::V->init ::a3: ::A->init ::b3: ::B->init ::b3: ::A->init ::a3: ::A->init ::b3: ::Y->init ::b3: ::X->init ::b3: ::B->init ::b3: ::A->init" \ "Mixin init 9 failed" } @ TestX copymove { description {Regression test for copy/move methods} } TestX copymove -proc run {{n 10}} { # Composite Class Composite -superclass Class Composite instproc addop {op} { my instvar ops set ops($op) $op } Composite instproc compositeFilter args { set m [self calledproc] set c [lindex [self filterreg] 0] set r [next] if {[$c exists ops($m)]} { foreach child [my info children] { eval [self]::$child $m $args } } return $r } Composite AbstractNode AbstractNode abstract instproc iterate v AbstractNode addop iterate for {set i 0} {$i < $n} {incr i} { # # class copy # Class X Class X::Y Class X::Y::Z -parameter { {param1 1} {param2 2} } #X::Y::Z metadata add {Version Author Nothing} #X::Y::Z metadata Version {0.0.9} #X::Y::Z metadata Author {Uwe} X::Y::Z instproc defaultValueIP {{a defA} {b defB} v} { return } X::Y::Z proc defaultValueP {{c defC} {d defD} v} { return } X::Y::Z instinvar {{7 > 6} { #a comment } } X::Y::Z instproc assProc {} {puts x} {{5 > 4} { #pre }} {{5 > 4} { #post } } X::Y::Z check {pre post instinvar} foreach C {X X::Y X::Y::Z} { $C instproc q {a b c} { return [self]--[self class]--[self proc]--[next]-- } } X::Y::Z z X::Y::Z copy V V v ::errorCheck "[z q 1 2 3]--[X::Y::Z info class]--[X::Y::Z info classparent]" \ "::z--::X::Y::Z--q------::xotcl::Class--::X::Y"\ "class copy z" ::errorCheck "[v q 1 2 3]--[V info class]--[V info classparent]" "::v--::V--q------::xotcl::Class--::"\ "class copy v" ::errorCheck "[::cutSpaces [V info parameter]--[v set param1]--[v set param2]]" \ " {param1 1} {param2 2} --1--2" \ "parameter test" ::errorCheck "[::cutSpaces [V info instinvar]--[V info instpre assProc]--[V info instpost assProc]]"\ "{7 > 6} { #a comment }--{5 > 4} { #pre }--{5 > 4} { #post }"\ "Copy Class Assertions" #::errorCheck "[V info metadata]--[V metadata Author]--[V metadata Version]--[V metadata Nothing]"\ "Version Author Nothing--Uwe--0.0.9--"\ "Copy Metadata" set df1 [V info default defaultValueP v dfv1] set df2 [V info default defaultValueP c dfv2] set df3 [V info instdefault defaultValueIP v dfv3] set df4 [V info instdefault defaultValueIP a dfv4] ::errorCheck "$df1 $dfv1 $df2 $dfv2 $df3 $dfv3 $df4 $dfv4"\ "0 1 defC 0 1 defA"\ "Copy Default Values" # class hierarchy copy Class O X copy O::X O::X x1; O::X::Y y1; O::X::Y::Z z1 ::errorCheck "[x1 q 1 2 3]--[y1 q 1 2 3]--[z1 q 1 2 3]" \ "::x1--::O::X--q------::y1--::O::X::Y--q------::z1--::O::X::Y::Z--q----"\ "class hierarchy copy" # # object copy # X x -set var1 12 -requireNamespace proc ::x::tclProc args {return tclProc} x proc q {a b c} {return [self]--[self class]--[self proc]--[next]--} x copy y ::errorCheck "[::y::tclProc]--[x q 1 2 3]--[y q 1 2 3]" \ "tclProc--::x----q--::x--::X--q--------::y----q--::y--::X--q------"\ "object copy" # object hierarchy copy x copy x::a x copy x::a::z ::errorCheck "[::x::a::tclProc]--[::x::a::z::a::tclProc]" \ "tclProc--tclProc"\ "object hierarchy copy" Class O O x x invar {{7 > 5} { #a comment }} x proc assProc {} {return} {{5 > 3} { #pre }} {{5 > 4} {#post }} x set var1 12 x proc p1 {} {return [self]-p1} x copy y ::errorCheck "[x p1]--[x set var1]--[::x info class]" "::x-p1--12--::O"\ "Simple Copy - Origin" ::errorCheck "[y p1]--[y set var1]--[::y info class]" "::y-p1--12--::O"\ "Simple Copy - Duplicate" ::errorCheck "[::cutSpaces [y info invar]--[y info pre assProc]--[y info post assProc]]"\ "{7 > 5} { #a comment }--{5 > 3} { #pre }--{5 > 4} {#post }"\ "Copy Obj Assertions" # # move test # V destroy X::Y::Z move V V v ::errorCheck "[v q 1 2 3]--[V info class]--[V info classparent]" "::v--::V--q------::xotcl::Class--::"\ "class move v" ::errorCheck "[::cutSpaces [V info parameter]--[v set param1]--[v set param2]]" \ " {param1 1} {param2 2} --1--2" \ "parameter move test" ::errorCheck "[::cutSpaces [V info instinvar]--[V info instpre assProc]--[V info instpost assProc]]"\ "{7 > 6} { #a comment }--{5 > 4} { #pre }--{5 > 4} { #post }"\ "Move Class Assertions" #::errorCheck "[V info metadata]--[V metadata Author]--[V metadata Version]--[V metadata Nothing]"\ "Version Author Nothing--Uwe--0.0.9--"\ "Move Metadata" set df1 [V info default defaultValueP v dfv1] set df2 [V info default defaultValueP c dfv2] set df3 [V info instdefault defaultValueIP v dfv3] set df4 [V info instdefault defaultValueIP a dfv4] ::errorCheck "$df1 $dfv1 $df2 $dfv2 $df3 $dfv3 $df4 $dfv4"\ "0 1 defC 0 1 defA"\ "Move Default Values" ::errorCheck [::info commands X::Y::Z] "" "Moved command still exists" # # copy with filters test # foreach filters {{} compositeFilter} { Composite instfilter $filters AbstractNode instfilter $filters Object commands Class Commands -superclass AbstractNode Class Command -superclass Commands Command instproc init args { my instvar label set label [self] next } Command instproc setlabel {{arg ""}} { my instvar label if {$arg eq ""} { set label } else { set label $arg } } Command instproc setproc {value} { my instvar src set src $value } # prototypes Command commands::cellcmd commands::cellcmd setlabel cell commands::cellcmd setproc {return "coucou" } commands::cellcmd proc x args {return xxx} commands::cellcmd copy toto ::errorCheck [::toto info class] ::Command "Copy with Filter: info class" ::errorCheck [toto set label] cell "Copy with Filter: set var" ::errorCheck [toto x] xxx "Copy with Filter: call proc" ::errorCheck [commands::cellcmd set label] cell \ "Copy with Filter: set var" } Class A Class V Class Z Class B -superclass A Class B1 -superclass {V A Z} A move X ::errorCheck [B info superclass]-[B1 info superclass]-[X info subclass] \ "::X-::V ::X ::Z-::B ::B1" \ "Move of subclass relationship" # # test nonpos args # Class X X proc do0 {arg1 arg2} {puts "$arg1 $arg2"} X proc do1 {-arg1 -arg2} {puts "$arg1 $arg2"} X proc do2 {-arg1 arg2} {puts "$arg1 $arg2"} X proc do3 {arg1 {arg2 d1}} {puts "$arg1 $arg2"} X proc do4 {-arg1 {-arg2 d2}} {puts "$arg1 $arg2"} X proc do5 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} X instproc do6 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} X copy Y foreach m [lsort [X info procs]] { foreach info {args nonposargs} { set x [X info $info $m] set y [Y info $info $m] ::errorCheck $x $y "copy nonposargs: $x ne $y" } foreach a [X info args $m] { set vx ""; set vy "" set dx [X info default $m $a vx] set dy [Y info default $m $a vy] ::errorCheck $dx $dy "copy nonposargs: hasdefault $dx ne $dy" if {[info exists dx] && [info exists dy]} { ::errorCheck $vx $vy "copy nonposargs: hasdefault value $vx ne $vy" } } } foreach m [lsort [X info instprocs]] { foreach info {instargs instnonposargs} { set x [X info $info $m] set y [Y info $info $m] ::errorCheck $x $y "copy inst nonposargs: $x ne $y" } foreach a [X info instargs $m] { set vx ""; set vy "" set dx [X info instdefault $m $a vx] set dy [Y info instdefault $m $a vy] ::errorCheck $dx $dy "copy inst nonposargs: hasdefault $dx ne $dy" if {[info exists dx] && [info exists dy]} { ::errorCheck $vx $vy "copy inst nonposargs: hasdefault value $vx ne $vy" } } } Object X X proc do0 {arg1 arg2} {puts "$arg1 $arg2"} X proc do1 {-arg1 -arg2} {puts "$arg1 $arg2"} X proc do2 {-arg1 arg2} {puts "$arg1 $arg2"} X proc do3 {arg1 {arg2 d1}} {puts "$arg1 $arg2"} X proc do4 {-arg1 {-arg2 d2}} {puts "$arg1 $arg2"} X proc do5 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} X copy Y foreach m [lsort [X info procs]] { foreach info {args nonposargs} { set x [X info $info $m] set y [Y info $info $m] ::errorCheck $x $y "copy nonposargs: $x ne $y" } foreach a [X info args $m] { set vx ""; set vy "" set dx [X info default $m $a vx] set dy [Y info default $m $a vy] ::errorCheck $dx $dy "copy nonposargs: hasdefault $dx ne $dy" if {[info exists dx] && [info exists dy]} { ::errorCheck $vx $vy "copy nonposargs: hasdefault value $vx ne $vy" } } } } } @ TestX recreation { description { Regression test for object recreation/cleanup. } } TestX recreation -proc run {{n 10}} { for {set i 0} {$i < $n} {incr i} { set ::recreateResult "" Class R R instproc recreate args { global recreateResult append recreateResult "*recreate [self] $args* " set r [next] append recreateResult "*recreate [self] <[lindex $args 0]> $r * " return $r } Object instmixin R catch { C destroy c1 destroy } Class C -parameter {a b} C instproc cProc {} {return cProc} C set r 4 C set v 5 C c1 -a 1 c1 proc x {} {return p} c1 set x 3 C c1 -b 2 append ::recreateResult "+[c1 info vars]," append ::recreateResult "[c1 info procs] +" Class C C set w 3 append ::recreateResult "+[C info vars]," append ::recreateResult "[C info instprocs] +" if {$i > 0} { errorCheck [set ::recreateResult] \ "*recreate ::xotcl::Class ::R* *recreate ::xotcl::Class <::R> ::R * *recreate ::C ::c1 -b 2* *recreate ::C <::c1> ::c1 * +b, +*recreate ::xotcl::Class ::C* *recreate ::xotcl::Class <::C> ::C * +w, +" \ "Var/proc recreate delete failed (n)" } else { errorCheck [set ::recreateResult] \ "*recreate ::C ::c1 -b 2* *recreate ::C <::c1> ::c1 * +b, +*recreate ::xotcl::Class ::C* *recreate ::xotcl::Class <::C> ::C * +w, +" \ "Var/proc recreate delete failed (0)" } global recreateMixinResult global recreateFilterResult set recreateMixinResult "" set recreateFilterResult "" Class RecreateObserve foreach ip {create destroy instdestroy init configure recreate cleanup alloc class} { RecreateObserve instproc $ip args { append ::recreateMixinResult " [self]+[self class]->[self proc]" next } } Class Recreated Recreated instproc recreationFilter args { append ::recreateFilterResult " [self]+[self calledclass]->[self calledproc]" next } Recreated instfilter recreationFilter Recreated mixin RecreateObserve Recreated instmixin RecreateObserve Recreated recreateObj Recreated recreateObj recreateObj destroy errorCheck [set ::recreateFilterResult] \ " ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->cleanup ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->destroy" \ "recreateObj - recreateFilterResult" if {$i == 0} { errorCheck [set ::recreateMixinResult] \ " ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->alloc ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->recreate ::recreateObj+::RecreateObserve->cleanup ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::recreateObj+::RecreateObserve->destroy ::Recreated+::RecreateObserve->instdestroy" \ "recreateObj - recreateMixinResult (0)" } else { errorCheck [set ::recreateMixinResult] \ " ::Recreated+::RecreateObserve->cleanup ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->alloc ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->recreate ::recreateObj+::RecreateObserve->cleanup ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::recreateObj+::RecreateObserve->destroy ::Recreated+::RecreateObserve->instdestroy" \ "recreateObj - recreateMixinResult (n)" } } set ::cleanupResult "" catch {a destroy} catch {A destroy} catch {X destroy} catch {META destroy} Class A A proc instdestroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} A proc recreate args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} A instproc destroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} A instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} A a A a::b errorCheck [set ::cleanupResult] "" "Cleanup Create Failed" A a errorCheck [a info children] "" "Cleanup Object Children Destroy Failed" A a::b errorCheck [set ::cleanupResult] \ " ::A+->recreate ::a+::A->cleanup ::a::b+::A->destroy ::A+->instdestroy" \ "Cleanup a/a::b Failed (n)" a destroy; set ::cleanupResult "" A instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"} A a A a::b errorCheck [set ::cleanupResult] "" "Cleanup Redefine Create Failed" A a errorCheck [a info children] ::a::b \ "Cleanup Redefine Object Children Survive Failed" A a::b errorCheck [set ::cleanupResult] \ " ::A+->recreate ::a+::A->cleanup ::A+->recreate ::a::b+::A->cleanup" \ "Cleanup Redefine a/a::b Failed" a destroy set ::cleanupResult "" Class META -superclass Class META proc instdestroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} META proc recreate args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} META instproc destroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} META instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"; next} META X META X::Y errorCheck [set ::cleanupResult] "" "Class Cleanup Create Failed" META X errorCheck [X info classchildren] "" "Class Cleanup Class Children Destroy Failed" META X::Y errorCheck [set ::cleanupResult] \ " ::META+->recreate ::X+::META->cleanup ::X::Y+::META->destroy ::META+->instdestroy" \ "Class Cleanup X/X::Y Failed" X destroy set ::cleanupResult "" META instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"} META X META X::Y errorCheck [set ::cleanupResult] "" "Class Cleanup Redefine Create Failed" META X errorCheck [X info classchildren] ::X::Y \ "Class Cleanup Redefine Class Children Survive Failed" META X::Y errorCheck [set ::cleanupResult] \ " ::META+->recreate ::X+::META->cleanup ::META+->recreate ::X::Y+::META->cleanup" \ "Class Cleanup Redefine X/X::Y Failed" X destroy A destroy META destroy unset ::cleanupResult Object instmixin "" # upgrading/downgrading Class B Class C -superclass B C c1 Object o1 -mixin B Object o2 -mixin C ::errorCheck [B info class] "::xotcl::Class" "up/down before 0" ::errorCheck [c1 istype B] 1 "up/down before 1" ::errorCheck [C info superclass] ::B "up/down before 2" ::errorCheck [B info subclass] ::C "up/down before 3" ::errorCheck [o1 info mixin] ::B "up/down before 4" ::errorCheck [o2 info mixin] ::C "up/down before 5" ::errorCheck [B info mixinof] ::o1 "up/down before 6" ::errorCheck [C info mixinof] ::o2 "up/down before 7" ::errorCheck [c1 info precedence] "::C ::B ::xotcl::Object" "up/down before 8" ::errorCheck [o1 info precedence] "::B ::xotcl::Object" "up/down before 9" ::errorCheck [o2 info precedence] "::C ::B ::xotcl::Object" "up/down before 10" ::errorCheck [catch {B class Object}] 1 "don't allow downgrading" Object B ::errorCheck [B info class] "::xotcl::Object" "up/down after 0" ::errorCheck [c1 istype B] 0 "up/down after 1" ::errorCheck [C info superclass] ::xotcl::Object "up/down after 2" ::errorCheck [catch {B info subclass}] 1 "up/down after 3" ::errorCheck [o1 info mixin] "" "up/down after 4" ::errorCheck [o2 info mixin] ::C "up/down after 5" ::errorCheck [catch {B info mixinof}] 1 "up/down after 6" ::errorCheck [C info mixinof] ::o2 "up/down after 7" ::errorCheck [c1 info precedence] "::C ::xotcl::Object" "up/down after 8" ::errorCheck [o1 info precedence] "::xotcl::Object" "up/down after 9" ::errorCheck [o2 info precedence] "::C ::xotcl::Object" "up/down after 10" ::errorCheck [B info class] "::xotcl::Object" "up/down after 0x" B class Object ::errorCheck [catch {B class Object}] 0 "don't complain when same level" ::errorCheck [catch {B class Class}] 1 "don't allow upgrading" } @ TestX smallScripts { description { Regression test object testing arbitrary features. } } TestX smallScripts proc ::up1 {} { return [uplevel 1 self] } proc ::up3 {} { return [uplevel 3 self] } proc ::up2 {} { return [up3] } smallScripts proc run {{n 20}} { catch {Object o; o r} errMsg ::errorCheck $errMsg "::o: unable to dispatch method 'r'" "Unknown Test" # uplevel test for {set i 0} {$i < $n} {incr i} { Object o o proc u2 {} {return [::up2]} o proc u1 {} {return [::up1]} Class SM SM instproc init args { ::errorCheck [o u1] "::o" "FAILED - UpLevel Test 1" ::errorCheck [o u2] "::s" "FAILED - UpLevel Test 2" } SM s } for {set i 1} {$i < $n} {incr i} { Class A A a set oname1 [Object autoname ooo] set oname2 [Object autoname -instance OOO] A autoname -reset AAA set names [A autoname AAA] a autoname -reset aaa lappend names [a autoname aaa] lappend names [a autoname aaa] ::errorCheck $names "AAA1 aaa1 aaa2" "Autoname creation" ::errorCheck $oname1 "ooo$i" "Autoname Object 1" ::errorCheck $oname2 "oOO$i" "Autoname Object 2" ::errorCheck [xotcl::Object set __autonames(ooo)] $i \ "Autoname Object Count" } Class P; P p P instproc x {} { my instvar "x(1) t" return $t } p set x(1) rrr ::errorCheck [p x] rrr "Array member alias, no ns" Object o o proc x {} { my instvar "x(1) t" return $t } o set x(1) rrr ::errorCheck [o x] rrr "Array member alias, with ns" Object o o proc x args {puts r} ::errorCheck [o info body x] "puts r" "Info Body" if {$::tcl_version < "8.6"} { ::errorCheck [info body o::x] "puts r" "Info Body" } Object o o proc a {} { my lappend table(i) xxx } ::errorCheck [o a]-[o set table(i)] "xxx-xxx" "Array instvar create" Class A A instproc myProc args {} Class Mix1 Mix1 instproc myProcMix1 args {} Class Mix2 Mix2 instproc myProcMix2 args {} Class B -superclass A -instmixin Mix1 B instproc myProc2 args {} B b -mixin Mix2 b proc objproc args {} ::errorCheck [b info procs] objproc "info procs" ::errorCheck [B info instprocs] myProc2 "info instprocs" ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objproc parametercmd proc procsearch requireNamespace self set setFilter signature subst trace unset uplevel upvar volatile vwait" "b info methods" ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move myProc myProc2 myProcMix1 myProcMix2 objproc self setFilter signature" "b info methods -nocmds" ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinguard noinit parametercmd proc procsearch requireNamespace set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move myProc myProc2 objproc self setFilter signature" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move parameter self setFilter signature uses" "B info methods -nocmds" namespace eval a { proc o args {return o} } namespace eval a::b { proc b args {return b} } Object a a requireNamespace set r [a::b::b] Object a::b a::b proc x args { return x } set r "$r-[a::b x]-[a o]" ::errorCheck $r b-x-o "Tcl Namespace should survive requireNamespace" xotcl::interp create in set ::r [in eval { namespace import -force xotcl::* Object o}] xotcl::interp delete in ::errorCheck $::r ::o "XOTcl slave interpreter " Object o -requireNamespace o set r 1 after 100 {o set r 3} o vwait r ::errorCheck [o set r] 3 "Vwait test" Class NS Class NS::Main NS::Main proc m1 {} { my m2 } NS::Main proc m2 {} { namespace eval :: Object toplevelObj } NS::Main m1 ::errorCheck [::toplevelObj set a 1] 1 "toplevel object allocated in ns" namespace eval foo { Class Foo Foo instproc blah {} {puts jou} Foo proc bar {} {puts bar} } namespace delete foo ::errorCheck [Object isobject ::foo::Foo] 0 "Namespace delete under object" # destroy test set x [Object create x] x destroy ::errorCheck [catch {$x set a 1}] 1 "Reference to destroyed object still valid" Object create x -volatile unset x ::errorCheck [catch {x destroy}] 1 "Object should not exist anymore" Object create x -volatile x destroy ::errorCheck [catch {unset x}] 1 "Variable should not exist anymore" } @ TestX objectReferences { description { Regression test for object and class references in tcl_objs } } TestX objectReferences -proc run {{n 20}} { my proc ok01 {} { Class AAA AAA destroy Class AAA } my proc ok02 {} { Class ::AAA AAA destroy Class AAA } my proc ok03 {} { Class ::AAA ::AAA destroy Class AAA } my proc ok04 {} { Class ::AAA ::AAA destroy Class ::AAA } my proc ok05 {} { set c [Class AAA] $c destroy Class AAA } my proc ok06 {} { set c [Class ::AAA] $c destroy Class AAA } my proc ok07 {} { set c [Class ::AAA] $c destroy Class ::AAA } my proc ok08 {} { set c [Class ::AAA] $c destroy Class $c } my proc ok09 {} { [Class AAA] destroy Class AAA } my proc ok10 {} { [Class ::AAA] destroy Class AAA } my proc ok11 {} { [Class ::AAA] destroy Class ::AAA } for {set i 1} {$i < 20} {incr i} { # "reference to xotcl object in instvar" Class LexxTreeMounter Class LexxTree LexxTreeMounter proc new {args} { if {[LexxTree exists LexxTreeMounter]} { set o [LexxTree set LexxTreeMounter] } else { set o [my create [my autoname [self]]] } $o incr C(refcnt) return $o } LexxTreeMounter instproc init {args} { my instvar C set C(refcnt) 0 if {[LexxTree exists LexxTreeMounter] == 0} { LexxTree set LexxTreeMounter [self] } next } set x [LexxTreeMounter new] set x [LexxTreeMounter new] ::errorCheck [llength [LexxTreeMounter info instances]] 1 singleton # "Global reference to xotcl object" set ::v [Object ::a] set ::w [Object ::b] set ::z(1) [Object ::c] unset ::v # "Class creation and Class destroys, after 2nd round procs contain xotcl-object references" foreach m [lsort [my info procs ok*]] {my $m} ::errorCheck [my isobject AAA] 1 classdestroys } catch {UnknownClass destroy} set ::utest "" Class proc __unknown args { lappend ::utest $args set x [Class $args] set r [$x] #puts r=$r return $r } Class O -superclass UnknownClass ::errorCheck $::utest ::UnknownClass "__unknown 1" Object o ::errorCheck [o mixin XX1] ::XX1 "__unknown XX1" namespace eval "" { Object o ::errorCheck [o mixin XX2] ::XX2 "__unknown XX2" } namespace eval "::" { Object o ::errorCheck [o mixin XX3] ::XX3 "__unknown XX3" } # this version of unknown creates global objects Class proc __unknown {name} { #puts "unknown called with $name" set name ::[namespace tail $name] set x [Class $name] set r [$x] #puts "... created $r" return $r } Object o ::errorCheck [o mixin XY1] ::XY1 " __unknown XY1" namespace eval "" { Object o ::errorCheck [o mixin XY2] ::XY2 " __unknown XY2" } namespace eval :: { Object o ::errorCheck [o mixin XY3] ::XY3 " __unknown XY3" } Class C namespace eval ::tmp { Object o -mixin C ::errorCheck [o mixin XY4] ::XY4 " __unknown XY4" } ::errorCheck [lsort [UnknownClass info info]] {args body children class classchildren classparent commands default filter filterguard forward heritage info instances instbody instcommands instdefault instfilter instfilterguard instforward instinvar instmixin instmixinof instpost instpre instprocs invar methods mixin mixinof parameter parent post pre precedence procs subclass superclass vars} "info info" # clear unknown handler to avoid strange results later Class proc __unknown "" "" ::errorCheck [Class info instances *Unk*] ::UnknownClass "match in info instances" ::errorCheck [Class info instances Unk*] "::UnknownClass" "no match in info instances" ::errorCheck [Class info instances Unk] "" "no match in info instances (no metachars)" ::errorCheck [Class info class] ::xotcl::Class "info class of Class" ::errorCheck [Class info precedence ::xotcl::Object] ::xotcl::Object "info class of Class Object" Class C Class D -superclass C Class E -superclass D -parameter {{x 1}} E instproc t {a b {c 1}} {return ok} E proc p {a b {c 1}} {return ok} E instproc q {} {return [self proc]} ::errorCheck [C info subclass D] ::D "transitive subclass 0" ::errorCheck [C info subclass E] "" "transitive subclass 0a" ::errorCheck [C info subclass -closure E] ::E "transitive subclass 1" ::errorCheck [Object info subclass -closure E] ::E "transitive subclass 2" ::errorCheck [D info subclass -closure C] "" "transitive subclass 3" ::errorCheck [E info heritage] "::D ::C ::xotcl::Object" "heritage" ::errorCheck [E info instargs t] "a b c" "instargs" ::errorCheck [E info instdefault t c x] 1 "instdefault" ::errorCheck [E info args p] "a b c" "args" ::errorCheck [E info default p c x] 1 "default" ::errorCheck [E configure [list -p -x -y]] 0 "list params 1" ::errorCheck [E e1 [list -t -1 -e -3]] ::e1 "list params 2" ::errorCheck [e1 x] 1 "instparameter cmd 1" ::errorCheck [e1 x 2] 2 "instparameter cmd 2" ::errorCheck [e1 x] 2 "instparameter cmd 3" ::errorCheck [e1 parametercmd y] "" "parametercmd 1" ::errorCheck [e1 y 3] 3 "parametercmd 2" ::errorCheck [e1 y] 3 "parametercmd 3" ::errorCheck [e1 forward regexp -objscope] "" "forward 1" ::errorCheck [e1 regexp (y) xyz _ X] "1" "forward 2" ::errorCheck [e1 exists X] "1" "forward 3" ::errorCheck [e1 q] q "self proc" ::errorCheck [E info commands] {p slot} "class commands" ::errorCheck [E info instcommands] "t x q" "class instcommands" ::errorCheck [E info instbody t] "return ok" "class info instbody" Object o Object o::abc Object o::bcd Object o::cde namespace eval ns1 {Class C; namespace export C} o eval {namespace import ::ns1::*} ::errorCheck [o info children] "::o::cde ::o::bcd ::o::abc" "info children 1" ::errorCheck [o info children *cd*] "::o::cde ::o::bcd" "info children 2" ::errorCheck [o info children ::o::cde] ::o::cde "info children 3" ::errorCheck [o info children ::o::def] "" "info children 4" Object new -childof o ::errorCheck [llength [o info children]] 4 "info children 5" ::errorCheck [Object isobject o] 1 "is object 1" ::errorCheck [Object isobject ox] 0 "is object 2" Class M -superclass Class ::errorCheck [Object ismetaclass M] 1 "is metaclass 1" ::errorCheck [Object ismetaclass C] 0 "is metaclass 0" Class X ::errorCheck [Object ismetaclass X] 0 "is metaclass 0" ::errorCheck [X isclass] 1 "is isclass 1" ::errorCheck [Class info instances X] ::X "is an instance of Class" ::errorCheck [catch {X class Object}] 1 "turn class into an object (error)" Class Y -superclass X Object o1 -mixin Y ::errorCheck [o1 info precedence] "::Y ::X ::xotcl::Object" "normal mixin precedence" Object X ;# turn class X into Object X (via destroy/create) ::errorCheck [o1 info precedence] "::Y ::xotcl::Object" "reduced mixin precedence" X destroy Y destroy o1 destroy Class M -superclass Class M create m1 ::errorCheck [Object ismetaclass M] 1 "is metaclass 1" ::errorCheck [M isclass] 1 "is isclass 1" ::errorCheck [Class info instances M] ::M "is an instance of Class" ::errorCheck [m1 info class] ::M "m1 is an instance of the meta-class" ::errorCheck [m1 isclass] 1 "m1 is isclass 1" ::errorCheck [m1 info class] ::M "m1 is of class ::M" Object M ;# make object from metaclass ::errorCheck [Object ismetaclass M] 0 "is metaclass 0" ::errorCheck [M isclass] 0 "is isclass 0" ::errorCheck [Class info instances M] "" "is not an instance of Class" ::errorCheck [m1 info class] ::xotcl::Class "m1 is now an instance of Class" ::errorCheck [m1 isclass] 1 "m1 is isclass 1" ::errorCheck [m1 info class] ::xotcl::Class "m1 is of class ::xotcl::Class" M destroy # to be completed XXX Class C -parameter {number name} C instproc test {} { my instvar {number x} name return [list $name $x] } C c -name koen -number 25 ::errorCheck [c test] "koen 25" "instvar with alias" # Class C Class D -superclass C Class D1 D instmixin D1 D d1 ::errorCheck [d1 info precedence] "::D1 ::D ::C ::xotcl::Object" "d1 info precedence" ::errorCheck [d1 info precedence *] "::D1 ::D ::C ::xotcl::Object" "d1 info precedence *" ::errorCheck [d1 info precedence ::D*] "::D1 ::D" "d1 info precedence pattern" ::errorCheck [d1 info precedence -intrinsic] "::D ::C ::xotcl::Object" "d1 info precedence -intrinsic" ::errorCheck [d1 info precedence -intrinsic *] "::D ::C ::xotcl::Object" "d1 info precedence -intrinsic *" ::errorCheck [d1 info precedence -intrinsic ::D*] "::D" "d1 info precedence -intrinsic pattern" d1 destroy D destroy D1 destroy } @ TestX condMixins { description { Regression test for conditional mixins } } TestX create condMixins -proc show {c obj} { set ::context $c set r [list] foreach x [list \ [list $obj info methods salary] \ [list $obj info methods -incontext salary] \ [list $obj info methods driv*] \ [list $obj info methods -incontext driv*] \ ] { lappend r "$::context: $x => [lsort [eval $x]]" } return $r } condMixins proc run {{n 20}} { Object instproc signature {} {return "[self] [my info class] ([my age] years)"} Class Person -parameter {id name age} Class Payroll-aspect -parameter salary Payroll-aspect instproc print {} {puts "[my signature]: [my salary]"} Class Driver-aspect -parameter driving-license Payroll-aspect instproc print {} {puts "[my signature]: [my driving-license]"} Person instmixin {{Payroll-aspect -guard {[string equal $::context "payrollApp"]}}} Person jim -mixin {{Driver-aspect -guard {[string equal $::context "shipmentApp"]}}} set ::context payrollApp ::errorCheck [lsort [jim info methods]] "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy driving-license eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit parametercmd print proc procsearch requireNamespace salary self set signature subst trace unset uplevel upvar volatile vwait" "condmixin all methods" ::errorCheck "[lsort [jim info methods -incontext]]" "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit parametercmd print proc procsearch requireNamespace salary self set signature subst trace unset uplevel upvar volatile vwait" "all methods in context" ::errorCheck [my show payrollApp jim] "{payrollApp: jim info methods salary => salary} {payrollApp: jim info methods -incontext salary => salary} {payrollApp: jim info methods driv* => driving-license} {payrollApp: jim info methods -incontext driv* => }" "payrollApp jim" ::errorCheck [my show shipmentApp jim] "{shipmentApp: jim info methods salary => salary} {shipmentApp: jim info methods -incontext salary => } {shipmentApp: jim info methods driv* => driving-license} {shipmentApp: jim info methods -incontext driv* => driving-license}" "shipmentApp jim" } @ TestX volatileObjects { description { Regression test for volatile objects } } TestX create volatileObjects volatileObjects proc inscope {} { set r 0 set y 0 set z 0 set c [C new -volatile] catch {incr r [$c test]} catch {set y [$c y]} catch {set z [$c z]} if {[catch {set u [$c u]} err]} {puts stderr $err} return $r-[llength [C info instances]]-$y-$z-$u } volatileObjects proc run {{n 20}} { Class create ::xotcl::_creator -instproc create {args} { set result [next] return $result } Class instproc f args { #puts stderr "*****F [self calledproc]" return [next] } Class C -parameter {{x 0}} C instproc f args { #puts stderr "*****C [self calledproc]" return [next] } C instproc test {} { my incr x } C instproc y {} { my instvar x; incr x } C instproc z {} { my set x 10 } C instproc u {} { upvar [self callinglevel] z b; info exists b } Class create ::xotcl::I -instproc instvar args { #puts [self proc] next } -instproc set args { #puts [self proc] next } -instproc u args { #puts [self proc] next } ::errorCheck [llength [C info instances]] 0 "foreign instances" ::errorCheck [my inscope] 1-1-2-10-1 "volatile objects in scope" ::errorCheck [llength [C info instances]] 0 "instances survived scope" Class instmixin ::xotcl::_creator ::errorCheck [my inscope] 1-1-2-10-1 "volatile objects in scope through mixin" ::errorCheck [llength [C info instances]] 0 \ "instances survived scope through mixin" Class instfilter f ::errorCheck [my inscope] 1-1-2-10-1 \ "volatile objects in scope through mixin + filter" ::errorCheck [llength [C info instances]] 0 \ "instances survived scope through mixin + filter" Class instmixin {} Class instfilter f ::errorCheck [my inscope] 1-1-2-10-1 \ "volatile objects in scope through filter" ::errorCheck [llength [C info instances]] 0 \ "instances survived scope through filter" Class instfilter {} C instmixin ::xotcl::I ::errorCheck [my inscope] 1-1-2-10-1 \ "instvar overload in scope through mixin" C instfilter f ::errorCheck [my inscope] 1-1-2-10-1 \ "instvar overload in scope through mixin and filter" C instfilter {} Class instproc f {} {} } TestX create uplevelCmds uplevelCmds proc upproc {} { lappend ::result [list \ self=[self] \ up1=[uplevel 1 self] \ up2=[uplevel 2 self] \ up3=[uplevel 3 self] ] } uplevelCmds proc run {{n 20}} { Object o1 -proc m {} { set ::result [list] lappend ::result [list \ self=[self] \ up1=[uplevel 1 self] \ up2=[uplevel 2 self] \ up3=[uplevel 3 self] ] uplevelCmds::upproc return $::result } Object o2 -proc m {} { o1 m } Object o3 -proc m {} { o2 m } Object o4 -proc m {} { o3 m } ::errorCheck [o4 m] \ "{self=::o1 up1=::o2 up2=::o3 up3=::o4} {self=::o1 up1=::o1 up2=::o2 up3=::o3}" \ "uplevel self" o4 m proc showstack {} { set l [info level] for {set i $l} {$i>0} {incr i -1} { set vars [uplevel \#$i info vars] upvar \#$i what w if {![info exists w]} {set w ""} puts "$i: $w[info level $i] vars=$vars" } } Class C C instproc u0 {} { upvar [self callinglevel] x y; incr y return [uplevel [self callinglevel] {incr x 1}] } C instproc u1 {} { upvar [self callinglevel] x y; incr y set r [uplevel [self callinglevel] {incr x 1}] set z [uplevel [self activelevel] incr z] return $z-$r } C instproc p0 {y} { set x $y set r [my u0] return $r-$x } C instproc p1 {y} { set z 0 set x $y set r [my u1] return $r-$x } Class D -superclass C D instproc u0 {} { upvar [self callinglevel] x y; incr y return [uplevel [self callinglevel] {incr x 1}] } D instproc u1 {} { set z [uplevel [self activelevel] incr z] set r [next] return $z-$r } Class M M instproc u1 {} { set z [uplevel [self activelevel] incr z] set r [next] return $z-$r } Object instproc f args { next } D create d1 errorCheck [d1 p0 1] 3-3 "simple uplevel" errorCheck [d1 p1 1] 2-2-3-3 "uplevel through next in class hierarchy + activelevel" D instmixin M errorCheck [d1 p1 1] 1-3-3-3-3 "uplevel through mixin and class hierarchy + activelevel" Object instfilter f errorCheck [d1 p1 1] 1-3-3-3-3 "uplevel through filter, mixin and class hierarchy + activelevel" Object instfilter "" D instmixin {} # now again the same tests with upvar and uplevel methods C instproc u0 {} { my upvar [self callinglevel] x y; incr y return [my uplevel {incr x 1}] } C instproc u1 {} { my upvar [self callinglevel] x y; incr y set r [my uplevel {incr x 1}] set z [my uplevel [self activelevel] incr z] return $z-$r } D instproc u0 {} { my upvar [self callinglevel] x y; incr y return [my uplevel {incr x 1}] } Class M M instproc u1 {} { set z [my uplevel [self activelevel] incr z] set r [next] return $z-$r } errorCheck [d1 p0 1] 3-3 "upvar method: simple uplevel" errorCheck [d1 p1 1] 2-2-3-3 \ "upvar method: uplevel through next in class hierarchy + activelevel" D instmixin M errorCheck [d1 p1 1] 1-3-3-3-3 \ "upvar method: uplevel through mixin and class hierarchy + activelevel" Object instfilter f errorCheck [d1 p1 1] 1-3-3-3-3 \ "upvar method: uplevel through filter, mixin and class hierarchy + activelevel" Object instfilter "" D instmixin {} # now again the same tests with upvar and uplevel methods with default levels C instproc u0 {} { my upvar x y; incr y return [my uplevel {incr x 1}] } C instproc u1 {} { my upvar x y; incr y set r [my uplevel {incr x 1}] set z [my uplevel [self activelevel] incr z] return $z-$r } D instproc u0 {} { my upvar x y; incr y return [my uplevel {incr x 1}] } Class M M instproc u1 {} { set z [my uplevel [self activelevel] incr z] set r [next] return $z-$r } errorCheck [d1 p0 1] 3-3 "upvar method: simple uplevel (dl)" errorCheck [d1 p1 1] 2-2-3-3 \ "upvar method: uplevel through next in class hierarchy + activelevel (dl)" D instmixin M errorCheck [d1 p1 1] 1-3-3-3-3 \ "upvar method: uplevel through mixin and class hierarchy + activelevel (dl)" Object instfilter f errorCheck [d1 p1 1] 1-3-3-3-3 \ "upvar method: uplevel through filter, mixin and class hierarchy + activelevel (dl)" Object instfilter "" D instmixin {} C instproc selftest args { return [self class]/[self isnextcall]-[next] } D instproc selftest args { return [self class]/[self isnextcall]-[next] } errorCheck [d1 selftest] "::D/0-::C/1-" \ "self isnextcall" Object instproc each {objName body} { #puts " *** level = [info level] self callinglevel = [self callinglevel]" uplevel [self callinglevel] [list foreach $objName [lsort [[self] info children]] $body] } Class TestB Class TestA TestA instproc init {args} { next TestB [self]::b1 TestB [self]::b2 TestB [self]::b3 } Class Test Test instproc init {args} { next TestA [self]::a1 TestA [self]::a2 TestA [self]::a3 } Test instproc loop1 {} { set i 0 [self] each a { incr i #puts "$a" } #puts "Total = $i" return $i } Test instproc loop2 {} { set i 0 [self] each a { incr i #puts "$a" $a each b { incr i #puts " $b" } } #puts "Total = $i" return $i } Object instproc f args {next} Test t errorCheck [t loop1] 3 "uplevel eval loop" errorCheck [t loop2] 12 "nested uplevel eval loop" t filter f errorCheck [t loop1] 3 "uplevel eval loop" errorCheck [t loop2] 12 "nested uplevel eval loop" t destroy } TestX create namespaceCommands -proc run {{n 20}} { errorCheck [catch { namespace eval foo { Class m Object o -mixin m } }] 0 "mixin resolved from namespace" Class create ::xotcl::_creator -instproc create {args} { set result [next] return $result } errorCheck [catch { namespace eval bar { Class A namespace export A } namespace eval foo { Class M -superclass Class namespace import ::bar::* Class B -superclass A -instmixin M Class instmixin ::xotcl::_creator Class C -superclass A -instmixin B Class instmixin "" } } error] 0 "mixin and Class resolve and import into namespace\n$error" } TestX create metaClassAsMixin -proc run {{n 20}} { Class create A -instmixin Class Class create B -superclass A B create b1 errorCheck [A ismetaclass]-[B ismetaclass]-[b1 ismetaclass]-[b1 isclass] \ "1-1-0-1" "metaclass through mixin" } TestX create nonposargs -proc run {{n 20}} { Object o o set result "" o proc test1 {-x:switch y} { my append result "x=$x y=$y, " } o test1 1 o test1 -x 1 o proc test2 {{-x:switch true} y} { my append result "x=$x y=$y, " } o test2 2 o test2 -x 2 o proc test3 {{-x:switch false} y} { my append result "x=$x y=$y, " } o test3 3 o test3 -x 3 errorCheck [o set result] \ "x=0 y=1, x=1 y=1, x=true y=2, x=0 y=2, x=false y=3, x=1 y=3, " \ "nonpos args switch" Object o o proc x {a b} { return "$a $b" } o proc x {} {a b} { return "$a $b" } o proc y {-x {-a {1 2 3}}} {a b} { return "$args" } o proc z1 {-x:required {-a {1 2 3}}} {a args} { return "$x -- $args" } o proc z2 {-x:required {-a {1 }} {-b {1 2}}} {args} {return "$x -- $args -- $a -- $b"} o proc z3 {-b:boolean} {arg} { return "$b $arg" } Object colorchecker colorchecker proc color {var value} { lappend ::r "color <$var> <$value>" } colorchecker proc reddish {var value} { lappend ::r "reddish <$var> <$value>" } o proc z4 {{{-b: required, checkobj colorchecker,color, reddish, checkobj xotcl::nonposArgs,required} red} {{-c: required }}} {arg} { lappend ::r "$b $arg" return "$b $arg" } o proc z5 {-pos args} { return [list $pos $args] } Class P P instproc x {a b} { return "$a $b" } P instproc z2 {-x:required {-a 1} {-b {1 2}}} {args} {return "$x -- $args -- $a -- $b"} P instproc z3 {-x:required {-a 1} {-b {1 2}}} {a b c} { return "$x -- $args -- $a -- $b" } P p errorCheck [o x 1 2] "1 2" "Ordinary Method" errorCheck [p x 3 4] "3 4" "Ordinary Method (2)" catch { o y 4 56 5 } m errorCheck $m {unknown argument '5' for method 'y': valid arguments -x {-a {1 2 3}} a b} "wrong \# check 1" catch { o y } m errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 2" catch { o y -x 1 } m errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 3" catch { o z1 a 1 2 3 } m errorCheck $m "required arg: 'x' missing" "required missing" errorCheck [o z1 -x 1 a 1 2 3] "1 -- 1 2 3" "invocation 1" errorCheck [o z2 -x 2 a 1 2 3] "2 -- a 1 2 3 -- 1 -- 1 2" "invocation 2" catch { o y -x 1 -a 2 2 3 } m errorCheck $m "can't read \"args\": no such variable" "args unset?" errorCheck [o z2 -a 2 -x 1 -b 3 a b c] \ "1 -- a b c -- 2 -- 3" "invocation 3" errorCheck [p z2 -x 1 -a 2 -b 3 a b c] \ "1 -- a b c -- 2 -- 3" "invocation 4" errorCheck [o z3 -b true -- -b] "true -b" "dash dash" errorCheck [o z5 -pos 1 a b] "1 {a b}" "nonpos with given args" errorCheck [o z5 -pos 1 a] "1 a" "nonpos with given args" errorCheck [o z5 -pos 1] "1 {}" "nonpos without given args" catch { o z3 -b abc -- -b } m errorCheck $m "non-positional argument: 'b' with value 'abc' is not of type boolean" "not boolean" set ::r "" o z4 -c 1 1 errorCheck $::r "{color } {reddish } {red 1}" \ "multiple check options + checkobject" errorCheck [o info body z2] {return "$x -- $args -- $a -- $b"} "info body 1" errorCheck [P info instbody z2] {return "$x -- $args -- $a -- $b"} "info instbody z2" errorCheck [o info args z4] {arg} "info args" errorCheck [o info nonposargs z4] "{{-b:required,checkobj colorchecker,color,reddish,checkobj xotcl::nonposArgs,required} red} -c:required" "info nonposargs 1" errorCheck [o info nonposargs x] {} "info nonposargs 2" errorCheck [P info instargs z3] {a b c} "info instargs" errorCheck [P info instnonposargs z3] {-x:required {-a 1} {-b {1 2}}} "info instnonposargs 1" errorCheck [P info instnonposargs x] {} "info instnonposargs 2" Object o o proc foo {{-a apple}} {{b banana}} { return [list [info locals] a: $a b: $b] } o proc foo2 {{-a apple}} {{b banana} {c apple}} { return [list [info locals] a: $a b: $b c: $c] } o proc foo3 {{-a apple}} {x y {b banana} {c apple}} { return [list [info locals] x: $x y: $y a: $a b: $b c: $c] } errorCheck [o foo] [list {a b} a: apple b: banana] \ "non pos + default values 1" errorCheck [o foo -a ack] [list {a b} a: ack b: banana] \ "non pos + default values 2" errorCheck [o foo bar] [list {a b} a: apple b: bar] \ "non pos + default values 3" errorCheck [o foo -a ack bar] [list {a b} a: ack b: bar] \ "non pos + default values 4" errorCheck [o foo2 -a ack] [list {a b c} a: ack b: banana c: apple] \ "non pos + default values 5" errorCheck [ o foo3 -a ack 1 2] [list {x y a b c} x: 1 y: 2 \ a: ack b: banana c: apple] \ "non pos + default values 6" Object o o proc foo {{-foo 1}} {} { #puts "foo: $foo" } o foo o foo -foo 0 catch {o foo -foo} msg errorCheck $msg "Non positional arg '-foo': value missing" "Empty non-pos arg" Object oa oa proc foo {{-a A}} {b} { #puts "$a $b" } oa foo "B" oa foo "-" oa foo "---" catch {oa foo "--"} msg errorCheck $msg "wrong # args for method 'foo': valid arguments {-a A} b" "Non-pos arg: double dash alone" Class C C create c1 C instproc m2 { {-flag:boolean false} } {x y {z 15}} { return $flag-$z } c1 proc m14 { {-flag:boolean false} } {x y {z 15}} { return $flag-$z } errorCheck [list [c1 m14 1 2 3] [c1 info args m14] \ [c1 info default m14 z e] [set e]] \ "false-3 {x y z} 1 15" \ "Defaults proc" errorCheck [list [c1 m2 1 2 3] [C info instargs m2]] \ "false-3 {x y z}" \ "info instargs" errorCheck [list [C info instdefault m2 x d] [C info instdefault m2 z d] [set d]] \ "0 1 15" \ "Defaults for instproc" catch {C info instdefault m2 xxx e} msg errorCheck $msg "method 'm2' doesn't have an argument 'xxx'" \ "Defaults instproc error" C instproc m3 { {-flag:boolean} } {x y z} { return hu3 } errorCheck [c1 m3 1 2 3] "hu3" "Defaults instproc no flag" Object o o proc f1 {{-x:boolean true} a } { if {![info exists a]} {error "pos arg a does not exist"} if {$x ne "true"} {error "x $x ne true"} if {$a ne "x"} {error "a $a ne x"} if {[info exists args]} {error "args still exists"} } o proc f2 {{-x:boolean true} {a x}} { if {![info exists a]} {error "pos arg a does not exist"} if {$x ne "false"} {error "x $x ne false"} if {$a ne "x"} {error "a $a ne x"} if {[info exists args]} {error "args still exists"} } o proc f3 {{-x:boolean true} } { if {$x ne "true"} {error "x $x ne true"} if {[info exists args]} {error "args still exists"} } o proc p0 {{-x 1} a} { #puts "--- [self proc] x=$x [info exists a]" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 1} {error "x $x != 1"} if {[info exists args]} {error "args still exists"} } o proc p1 {{-x 1} a args} { #puts "--- [self proc] x=$x [info exists a] args=$args" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 1} {error "x $x != 1"} if {$args ne ""} {error "args $args ne {}"} } o proc p2 {{-x 1} args} { if {$x != 1} {error "x $x != 1"} if {$args ne ""} {error "args $args ne {}"} } o proc p3 {{-x 1} args} { if {$x != 1} {error "x $x != 1"} if {$args ne "a b c"} {error "args $args ne {}"} } o proc p4 {{-x 1} args} { if {$x != 2} {error "x $x != 2"} if {$args ne "a b c"} {error "args $args ne {a b c}"} } o proc p5 {{-x 1} a args} { #puts "--- [self proc] x=$x [info exists a] args=$args" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 1} {error "x $x != 1"} if {$args ne "a b c"} {error "args $args ne {a b c}"} } o proc p6 {{-x 1} a args} { #puts "--- [self proc] x=$x [info exists a] args=$args" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 2} {error "x $x != 2"} if {$args ne "a b c"} {error "args $args ne {a b c}"} } o proc p7 {{-x 1} a args} { #puts "--- [self proc] x=$x [info exists a] args=$args" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 2} {error "x $x != 2"} if {$args ne ""} {error "args $args ne {}"} } o proc p8 {{-x 1} {a 1} args} { #puts "--- [self proc] x=$x [info exists a] args=$args" if {![info exists a]} {error "pos arg a does not exist"} if {$a != 1} {error "a $a != 1"} if {$x != 2} {error "x $x != 2"} if {$args ne ""} {error "args $args ne {}"} } errorCheck [catch {o f1 x}] 0 nonpos-1 errorCheck [catch {o f1 -y 1}] 1 nonpos-2 errorCheck [catch {o f1 -x false}] 1 nonpos-3 errorCheck [catch {o f2 -x false}] 0 nonpos-4 errorCheck [catch {o f3}] 0 nonpos-5 errorCheck [catch {o f3 -x true -y 1}] 1 nonpos-6 errorCheck [catch {o f3-y 1}] 1 nonpos-7 errorCheck [catch {o p0 1}] 0 nonpos-8 errorCheck [catch {o p1 1}] 0 nonpos-9 errorCheck [catch {o p1 }] 1 nonpos-10 errorCheck [catch {o p2 }] 0 nonpos-11 errorCheck [catch {o p3 a b c}] 0 nonpos-12 errorCheck [catch {o p4 -x 2 a b c}] 0 nonpos-13 errorCheck [catch {o p5 1 a b c}] 0 nonpos-14 errorCheck [catch {o p7 -x 2 1}] 0 nonpos-15 errorCheck [catch {o p7 -x 2 }] 1 nonpos-16 errorCheck [catch {o p8 -x 2 }] 0 nonpos-17 o destroy Class X X instproc ListOfStringsOption {{-default "murr6"} {-cb {}} name} { if {$cb eq {}} { set cb "::set ::$name " } ;# global variable eval $cb \$default } ::X create x1 ::x1 ListOfStringsOption uu errorCheck [set ::uu] murr6 murr6 ::x1 destroy X destroy } TestX copymove2 -proc run {{n 10}} { # Composite Class Composite -superclass Class Composite instproc addop {op} { my instvar ops set ops($op) $op } Composite instproc compositeFilter args { set m [self calledproc] set c [lindex [self filterreg] 0] set r [next] if {[$c exists ops($m)]} { foreach child [my info children] { eval [self]::$child $m $args } } return $r } Composite AbstractNode AbstractNode abstract instproc iterate v AbstractNode addop iterate for {set i 0} {$i < $n} {incr i} { # # class copy # foreach filters {{} compositeFilter} { Composite instfilter $filters AbstractNode instfilter $filters Object commands Class Commands -superclass AbstractNode Class Command -superclass Commands Command instproc init args { my instvar label set label [self] next } Command instproc setlabel {{arg ""}} { my instvar label if {$arg eq ""} { set label } else { set label $arg } } Command instproc setproc {value} { my instvar src set src $value } # prototypes Command commands::cellcmd commands::cellcmd copy toto } } } TestX proc run {} { foreach test [lsort [TestX info instances]] { puts stderr "$test: start" $test run } } puts "XOTcl - Test" puts "Time used: [time {TestX run} 1]" # toplevel tests ################################################# Class instmixin {} C instmixin {} set o [C new -volatile];errorCheck [Object isobject $o] 1 "topLevel, check object 1 - $o" Class instmixin ::xotcl::_creator set o [C new -volatile];errorCheck [Object isobject $o] 1 "topLevel, check object 2 - $o" C instmixin ::xotcl::I set o [C new -volatile];errorCheck [Object isobject $o] 1 "topLevel, check object 3 - $o" foreach i [C info instances] {$i destroy} proc x {} { Class instmixin {} C instmixin {} set c0 [llength [C info instances]] set o [C new -volatile]; errorCheck [Object isobject $o] 1 "x, check object" Class instmixin ::xotcl::_creator set o [C new -volatile]; errorCheck [Object isobject $o] 1 "x, check object" C instmixin ::xotcl::I set o [C new -volatile]; errorCheck [Object isobject $o] 1 "x, check object" set c1 [llength [C info instances]] errorCheck [expr {$c1 - $c0 != 3}] 0 "exit x, three more objects" } x errorCheck [expr {[llength [C info instances]] > 0}] 0 "top, all volatile object gone" proc x1 {} { set c0 [llength [C info instances]] set o [C new -volatile]; errorCheck [Object isobject $o] 1 "x1, check object" x set o [C new -volatile]; errorCheck [Object isobject $o] 1 "x1, check object" set c1 [llength [C info instances]] errorCheck [expr {$c1 - $c0 != 2}] 0 "exit x1, two more objects" } x1 errorCheck [expr {[llength [C info instances]] > 0}] 0 "top, volatile objects gone" Object o o proc test {} { x1; errorCheck [expr {[llength [C info instances]] > 0}] 0 "x1 from o" } o test puts "PASSED ::topLevelCommands"