From 56f89b98500c1b7f96c8c5eca2a349a77a3ffa65 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Oct 2018 12:48:53 +0000 Subject: Test cases (and some fixes) --- generic/tclOO.c | 11 +- generic/tclOOInfo.c | 4 +- generic/tclOOScript.h | 4 +- generic/tclOOScript.tcl | 6 +- tests/oo.test | 259 +++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 268 insertions(+), 16 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0cbddcd..f68e4f3 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -446,6 +446,7 @@ InitClassSystemRoots( { Class fakeCls; Object fakeObject; + Tcl_Obj *defNsName; /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; @@ -473,8 +474,9 @@ InitClassSystemRoots( fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; - TclNewLiteralStringObj(fPtr->objectCls->objDefinitionNs, "::oo::objdefine"); - Tcl_IncrRefCount(fPtr->objectCls->objDefinitionNs); + TclNewLiteralStringObj(defNsName, "::oo::objdefine"); + fPtr->objectCls->objDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); @@ -503,8 +505,9 @@ InitClassSystemRoots( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; - TclNewLiteralStringObj(fPtr->objectCls->clsDefinitionNs, "::oo::define"); - Tcl_IncrRefCount(fPtr->objectCls->clsDefinitionNs); + TclNewLiteralStringObj(defNsName, "::oo::define"); + fPtr->classCls->clsDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index abae835..8c45e1b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1072,9 +1072,9 @@ InfoClassDefnNsCmd( } if (kind) { - nsNamePtr = clsPtr->clsDefinitionNs; - } else { nsNamePtr = clsPtr->objDefinitionNs; + } else { + nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { Tcl_SetObjResult(interp, nsNamePtr); diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 2213ce3..ab637dd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -98,9 +98,9 @@ static const char *tclOOSetupScript = "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" -"\t\t\tdefine $delegate superclass -append $d\n" +"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" "\t\t}\n" -"\t\tobjdefine $class mixin -append $delegate\n" +"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index a48eab5..5e0145f 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -153,9 +153,9 @@ if {![info object isa class $d]} { continue } - define $delegate superclass -append $d + define $delegate ::oo::define::superclass -append $d } - objdefine $class mixin -append $delegate + objdefine $class ::oo::objdefine::mixin -append $delegate } # ---------------------------------------------------------------------- @@ -176,7 +176,7 @@ && ![info object isa class $targetDelegate] } then { copy $originDelegate $targetDelegate - objdefine $targetObject mixin -set \ + objdefine $targetObject ::oo::objdefine::mixin -set \ {*}[lmap c [info object mixin $targetObject] { if {$c eq $originDelegate} {set targetDelegate} {set c} }] diff --git a/tests/oo.test b/tests/oo.test index 2a266a7..459db8e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -329,16 +329,17 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { + set initials {::oo::object ::oo::class ::oo::Slot} foreach cmd {instances subclasses mixins superclass} { - foreach initial {object class Slot} { - lappend x [info class $cmd ::oo::$initial] + foreach initial $initials { + lappend x [info class $cmd $initial] } } - foreach initial {object class Slot} { - lappend x [info object class ::oo::$initial] + foreach initial $initials { + lappend x [info object class $initial] } return $x - }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} + }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh } -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} @@ -5076,6 +5077,254 @@ test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -s } -cleanup { parent destroy } -result {1 {this is ::cls1}} + +test oo-42.1 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object +} {} +test oo-42.2 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -class +} {} +test oo-42.3 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -instance +} ::oo::objdefine +test oo-42.4 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -gorp +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-42.5 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -class x +} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} +test oo-42.6 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class +} ::oo::define +test oo-42.7 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -class +} ::oo::define +test oo-42.8 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -instance +} {} + +test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + oo::class create foo { + superclass parent + self class foocls + } + oo::define foo { + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -class foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -instance foodef + } + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + namespace delete foodef +} -result {invalid command name "sparkle"} +test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + namespace delete foodef + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {invalid command name "sparkle"} +test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain result +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace delete foodef + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + lappend result [catch {oo::define foo sparkle} msg] $msg +} -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {0 ok 1 {invalid command name "sparkle"} 0 ok} +test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {x} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + } + oo::define foo spar gorp +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foo { + superclass parent + definitionnamespace -instance foodef + } + oo::objdefine [foo new] { + method x y z + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.9 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -gorp foodef + } +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-43.10 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -class foodef x + } +} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} +test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { + catch {namespace delete ::no_such_ns} +} -body { + oo::class create foo { + definitionnamespace -class ::no_such_ns + } +} -returnCodes error -result {namespace "::no_such_ns" not found} +test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass oo::class parent + } + list [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace foodef] \ + [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace {}] \ + [info class definitionnamespace foo] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} +test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass parent + } + list [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance foodef] \ + [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance {}] \ + [info class definitionnamespace foo -instance] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} cleanupTests return -- cgit v0.12