diff options
| -rw-r--r-- | generic/tclOOBasic.c | 22 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 56 | ||||
| -rw-r--r-- | tests/oo.test | 45 |
3 files changed, 81 insertions, 42 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 763f0ad..54115e0 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -83,7 +83,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke; + Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -94,6 +94,17 @@ TclOO_Class_Constructor( } /* + * Make the class definition delegate. This is special; it doesn't reenter + * here (and the class definition delegate doesn't run any constructors). + */ + + nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); + Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, + TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_DecrRefCount(nameObj); + + /* * Delegate to [oo::define] to do the work. */ @@ -128,12 +139,17 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Tcl_InterpState saved; TclDecrRefCount(invoke[0]); - TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + Tcl_IncrRefCount(invoke[0]); + saved = Tcl_SaveInterpState(interp, result); + Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[1]); ckfree(invoke); - return result; + return Tcl_RestoreInterpState(interp, saved); } /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4ca286c..102f2a2 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -5,7 +5,9 @@ * that the code can be definitely run even in safe interpreters; TclOO's * core setup is safe. * - * Copyright (c) 2012-2018 by Donal K. Fellows + * Copyright (c) 2012-2018 Donal K. Fellows + * Copyright (c) 2013 Andreas Kupries + * Copyright (c) 2017 Gerald Lester * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -51,6 +53,10 @@ static const char *tclOOSetupScript = " return\n" "}\n" +"proc ::oo::DelegateName {class} {\n" +" string cat [info object namespace $class] {:: oo ::delegate}\n" +"}\n" + "proc ::oo::define::classmethod {name {args {}} {body {}}} {\n" " # Create the method on the class if the caller gave arguments and body\n" " set argc [llength [info level 0]]\n" @@ -59,46 +65,24 @@ static const char *tclOOSetupScript = " [lindex [info level 0] 0] { name ?args body?\"}]\n" " }\n" " set cls [uplevel 1 self]\n" -/* -" set d $cls.Delegate\n" -" if {[info object isa object $d] && [info object isa class $d]} {\n" -" set cls $d\n" -" }\n" -*/ " if {$argc == 4} {\n" -" ::oo::define $cls method $name $args $body\n" +" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" " }\n" " # Make the connection by forwarding\n" " tailcall forward $name [info object namespace $cls]::my $name\n" "}\n" -/* -"# Build this *almost* like a class method, but with extra care to avoid\n" -"# nuking the existing method.\n" -"::oo::class create ::oo::class.Delegate {\n" -" method create {name args} {\n" -" if {![string match ::* $name]} {\n" -" set ns [uplevel 1 {namespace current}]\n" -" if {$ns eq {::}} {set ns {}}\n" -" set name ${ns}::${name}\n" -" }\n" -" if {[string match *.Delegate $name]} {\n" -" return [next $name {*}$args]\n" -" }\n" -" set delegate [oo::class create $name.Delegate]\n" -" set cls [next $name {*}$args]\n" -" set superdelegates [list $delegate]\n" -" foreach c [info class superclass $cls] {\n" -" set d $c.Delegate\n" -" if {[info object isa object $d] && [info object isa class $d]} {\n" -" lappend superdelegates $d\n" -" }\n" -" }\n" -" oo::objdefine $cls mixin {*}$superdelegates\n" -" return $cls\n" -" }\n" +"proc ::oo::MixinClassDelegates {class} {\n" +" ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n" +" set d [::oo::DelegateName $c]\n" +" if {![info object isa class $d]} continue; set d\n" +" }]\n" +"}\n" + +"::proc ::oo::define::initialise {body} {\n" +" set clsns [info object namespace [uplevel 1 self]]\n" +" tailcall apply [list {} $body $clsns]\n" "}\n" -*/ "::oo::define ::oo::Slot {\n" " method Get {} {return -code error unimplemented}\n" @@ -130,10 +114,6 @@ 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 self mixin ::oo::class.Delegate\n" -*/ - "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" diff --git a/tests/oo.test b/tests/oo.test index 25ef5e2..87f0567 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -340,7 +340,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { lappend x [info object class ::oo::$initial] } return $x - }] {lsort $x} + }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} } -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} @@ -4845,6 +4845,49 @@ test oo-40.3 {TIP 500: private and unexport} -setup { } -cleanup { cls destroy } -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { puts "[self] called with arguments: $args" } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -output "::Table called with arguments: foo bar\n" +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" } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -output "::testns::Table called with arguments: foo bar\n" +test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} cleanupTests return |