diff options
| -rw-r--r-- | generic/tclOOBasic.c | 14 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 35 | ||||
| -rw-r--r-- | tests/oo.test | 139 |
3 files changed, 178 insertions, 10 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 54115e0..13c98f4 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -122,7 +122,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, NULL, NULL, NULL); + invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -139,16 +139,26 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Object *oPtr = data[1]; Tcl_InterpState saved; + int code; TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[1] = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); saved = Tcl_SaveInterpState(interp, result); - Tcl_EvalObjv(interp, 2, invoke, 0); + code = Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); ckfree(invoke); + if (code != TCL_OK) { + Tcl_DiscardInterpState(saved); + return code; + } return Tcl_RestoreInterpState(interp, saved); } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 102f2a2..73c3383 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -73,10 +73,21 @@ static const char *tclOOSetupScript = "}\n" "proc ::oo::MixinClassDelegates {class} {\n" -" ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n" +" if {![info object isa class $class]} {\n" +" return\n" +" }\n" +" set delegate [::oo::DelegateName $class]\n" +" if {![info object isa class $delegate]} {\n" +" return\n" +" }\n" +" foreach c [info class superclass $class] {" " set d [::oo::DelegateName $c]\n" -" if {![info object isa class $d]} continue; set d\n" -" }]\n" +" if {![info object isa class $d]} {\n" +" continue\n" +" }\n" +" ::oo::define $delegate superclass -append $d\n" +" }\n" +" ::oo::objdefine $class mixin -append $delegate\n" "}\n" "::proc ::oo::define::initialise {body} {\n" @@ -114,6 +125,19 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" +"::oo::define ::oo::class method <cloned> {originObject} {\n" +" next $originObject\n" +" # Rebuild the class inheritance delegation class\n" +" set originDelegate [::oo::DelegateName $originObject]\n" +" set targetDelegate [::oo::DelegateName [self]]\n" +" if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n" +" ::oo::copy $originDelegate $targetDelegate\n" +" ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n" +" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" +" }]\n" +" }\n" +"}\n" + "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" @@ -137,6 +161,7 @@ static const char *tclOOSetupScript = */ static const char *clonedBody = +"# Copy over the procedures from the original namespace\n" "foreach p [info procs [info object namespace $originObject]::*] {\n" " set args [info args $p]\n" " set idx -1\n" @@ -148,6 +173,7 @@ static const char *clonedBody = " set p [namespace tail $p]\n" " proc $p $args $b\n" "}\n" +"# Copy over the variables from the original namespace\n" "foreach v [info vars [info object namespace $originObject]::*] {\n" " upvar 0 $v vOrigin\n" " namespace upvar [namespace current] [namespace tail $v] vNew\n" @@ -158,7 +184,8 @@ static const char *clonedBody = " set vNew $vOrigin\n" " }\n" " }\n" -"}\n"; +"}\n" +; #endif /* TCL_OO_SCRIPT_H */ diff --git a/tests/oo.test b/tests/oo.test index 87f0567..9aafe2e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4851,7 +4851,9 @@ test oo-41.1 {TIP 478: classmethod} -setup { } -body { oo::class create ActiveRecord { superclass parent - classmethod find args { puts "[self] called with arguments: $args" } + classmethod find args { + return "[self] called with arguments: $args" + } } oo::class create Table { superclass ActiveRecord @@ -4859,13 +4861,15 @@ test oo-41.1 {TIP 478: classmethod} -setup { Table find foo bar } -cleanup { parent destroy -} -output "::Table called with arguments: foo bar\n" +} -result {::Table called with arguments: foo bar} test oo-41.2 {TIP 478: classmethod in namespace} -setup { namespace eval ::testns {} } -body { namespace eval ::testns { oo::class create ActiveRecord { - classmethod find args { puts "[self] called with arguments: $args" } + classmethod find args { + return "[self] called with arguments: $args" + } } oo::class create Table { superclass ActiveRecord @@ -4874,7 +4878,7 @@ test oo-41.2 {TIP 478: classmethod in namespace} -setup { testns::Table find foo bar } -cleanup { namespace delete ::testns -} -output "::testns::Table called with arguments: foo bar\n" +} -result {::testns::Table called with arguments: foo bar} test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { oo::class create parent } -body { @@ -4888,6 +4892,133 @@ test oo-41.3 {TIP 478: classmethod must not interfere with constructor signature } -cleanup { parent destroy } -result {::okay} +test oo-41.4 {TIP 478: classmethod with three levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} + +test oo-42.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test oo-42.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test oo-42.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test oo-42.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test oo-42.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test oo-42.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 cleanupTests return |