diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | doc/copy.n | 21 | ||||
| -rw-r--r-- | doc/object.n | 10 | ||||
| -rw-r--r-- | generic/tclOO.c | 150 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 2 | ||||
| -rw-r--r-- | tests/oo.test | 57 |
6 files changed, 209 insertions, 44 deletions
@@ -1,3 +1,16 @@ +2012-02-10 Donal K. Fellows <dkf@users.sf.net> + + IMPLEMENTATION OF TIP#397. + + * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the + target object name optional when copying classes. [RFE 3485060]: Add + callback method ("<cloned>") so that scripted control over copying is + easier. + ***POTENTIAL INCOMPATIBILITY*** + If you'd previously been using the "<cloned>" method name, this now + has a standard semantics and call interface. Only a problem if you are + also using [oo::copy]. + 2012-03-26 Donal K. Fellows <dkf@users.sf.net> IMPLEMENTATION OF TIP#380. @@ -26,10 +26,23 @@ resolved relative to the current namespace if not an absolute qualified name. If \fItargetObject\fR is omitted, a new name is chosen. The copied object will be of the same class as the source object, and will have all its per-object methods copied. If it is a class, it will also have all the class methods in -the class copied, but it will not have any of its instances copied. The -contents of the source object's private namespace \fIwill not\fR be copied; it -is up to the caller to do this. The result of this command will be the -fully-qualified name of the new object or class. +the class copied, but it will not have any of its instances copied. +.PP +.VS +After the \fItargetObject\fR has been created and all definitions of its +configuration (e.g., methods, filters, mixins) copied, the \fB<cloned>\fR +method of \fItargetObject\fR will be invoked, to allow for customization of +the created object such as installing related variable traces. The only +argument given will be \fIsourceObject\fR. The default implementation of this +method (in \fBoo::object\fR) just copies the procedures and variables in the +namespace of \fIsourceObject\fR to the namespace of \fItargetObject\fR. If +this method call does not return a result that is successful (i.e., an error +or other kind of exception) then the \fItargetObject\fR will be deleted and an +error returned. +.VE +.PP +The result of the \fBoo::copy\fR command will be the fully-qualified name of +the new object or class. .SH EXAMPLES .PP This example creates an object, copies it, modifies the source object, and diff --git a/doc/object.n b/doc/object.n index 3a948a4..6737e7e 100644 --- a/doc/object.n +++ b/doc/object.n @@ -91,6 +91,16 @@ must not have any namespace separators in it. The result is the empty string. . This method returns the globally qualified name of the variable \fIvarName\fR in the unique namespace for the object \fIobj\fR. +.TP +\fIobj \fB<cloned> \fIsourceObjectName\fR +.VS +This method is used by the \fBoo::object\fR command to copy the state of one +object to another. It is responsible for copying the procedures and variables +of the namespace of the source object (\fIsourceObjectName\fR) to the current +object. It does not copy any other types of commands or any traces on the +variables; that can be added if desired by overriding this method in a +subclass. +.VE .SH EXAMPLES .PP This example demonstrates basic use of an object. diff --git a/generic/tclOO.c b/generic/tclOO.c index 6300d80..22a4d57 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -122,12 +122,33 @@ static const DeclaredClassMethod objMethods[] = { {NULL, 0, {0, NULL, NULL, NULL, NULL}} }; -static char initScript[] = - "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" - "namespace eval ::oo { variable version " TCLOO_VERSION " };" - "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; -/* "tcl_findLibrary tcloo $oo::version $oo::version" */ -/* " tcloo.tcl OO_LIBRARY oo::library;"; */ +/* + * Scripted parts of TclOO. First, the master script (cannot be outside this + * file). + */ + +static const char *initScript = +"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +"namespace eval ::oo { variable version " TCLOO_VERSION " };" +"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +/* "tcl_findLibrary tcloo $oo::version $oo::version" */ +/* " tcloo.tcl OO_LIBRARY oo::library;"; */ + +/* + * The body of the constructor for oo::class. + */ + +static const char *classConstructorBody = +"set script [list ::oo::define [self] $definitionScript];" +"lassign [::oo::UpCatch $script] msg opts;" +"if {[dict get $opts -code] == 1} {" +" dict set opts -errorline 0xDeadBeef" +"};" +"return -options $opts $msg;"; + +/* + * The scripted part of the definitions of slots. + */ static const char *slotScript = "::oo::define ::oo::Slot {\n" @@ -158,6 +179,38 @@ static const char *slotScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; +/* + * The body of the <cloned> method of oo::object. + */ + +static const char *clonedBody = +"foreach p [info procs [info object namespace $originObject]::*] {" +" set args [info args $p];" +" set idx -1;" +" foreach a $args {" +" lset args [incr idx] " +" [if {[info default $p $a d]} {list $a $d} {list $a}]" +" };" +" set b [info body $p];" +" set p [namespace tail $p];" +" proc $p $args $b;" +"};" +"foreach v [info vars [info object namespace $originObject]::*] {" +" upvar 0 $v vOrigin;" +" namespace upvar [namespace current] [namespace tail $v] vNew;" +" if {[info exists vOrigin]} {" +" if {[array exists vOrigin]} {" +" array set vNew [array get vOrigin];" +" } else {" +" set vNew $vOrigin;" +" }" +" }" +"}"; + +/* + * The actual definition of the variable holding the TclOO stub table. + */ + MODULE_SCOPE const TclOOStubs tclOOStubs; /* @@ -168,15 +221,18 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; ((Foundation *)((Interp *)(interp))->objectFoundation) /* - * Macros to make inspecting into the guts of an object cleaner. Note that the - * roots oo::object and oo::class have _both_ their object and class flags - * tagged with ROOT_OBJECT and ROOT_CLASS respectively. + * Macros to make inspecting into the guts of an object cleaner. + * + * The ocPtr parameter (only in these macros) is assumed to work fine with + * either an oPtr or a classPtr. Note that the roots oo::object and oo::class + * have _both_ their object and class flags tagged with ROOT_OBJECT and + * ROOT_CLASS respectively. */ -#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) -#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) -#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) -#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) +#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) +#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) +#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) /* * ---------------------------------------------------------------------- @@ -280,17 +336,19 @@ InitFoundation( DeletedHelpersNamespace); fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; - fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); - fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1); - fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1); + TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); + TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); + TclNewLiteralStringObj(fPtr->destructorName, "<destructor>"); + TclNewLiteralStringObj(fPtr->clonedName, "<cloned>"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); + Tcl_IncrRefCount(fPtr->clonedName); Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, TclOONRUpcatch, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", TclOOUnknownDefinition, NULL, NULL); - namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1); + TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); @@ -351,6 +409,18 @@ InitFoundation( } /* + * Create the default <cloned> method implementation, used when 'oo::copy' + * is called to finish the copying of one object to another. + */ + + TclNewLiteralStringObj(argsPtr, "originObject"); + Tcl_IncrRefCount(argsPtr); + bodyPtr = Tcl_NewStringObj(clonedBody, -1); + TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, + bodyPtr, NULL); + Tcl_DecrRefCount(argsPtr); + + /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. @@ -360,19 +430,13 @@ InitFoundation( * that is confusing. */ - namePtr = Tcl_NewStringObj("new", -1); + TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); - argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1); + TclNewLiteralStringObj(argsPtr, "{definitionScript {}}"); Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj( - "set script [list ::oo::define [self] $definitionScript];" - "lassign [::oo::UpCatch $script] msg opts\n" - "if {[dict get $opts -code] == 1} {" - " dict set opts -errorline 0xDeadBeef\n" - "}\n" - "return -options $opts $msg", -1); + bodyPtr = Tcl_NewStringObj(classConstructorBody, -1); fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); Tcl_DecrRefCount(argsPtr); @@ -468,6 +532,7 @@ KillFoundation( Tcl_DecrRefCount(fPtr->unknownMethodNameObj); Tcl_DecrRefCount(fPtr->constructorName); Tcl_DecrRefCount(fPtr->destructorName); + Tcl_DecrRefCount(fPtr->clonedName); ckfree(fPtr); } @@ -1755,19 +1820,14 @@ Tcl_CopyObjectInstance( FOREACH_HASH_DECLS; Method *mPtr; Class *mixinPtr; - Tcl_Obj *keyPtr, *filterObj, *variableObj; - int i; + CallContext *contextPtr; + Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + int i, result; /* - * Sanity checks. + * Sanity check. */ - if (targetName == NULL && oPtr->classPtr != NULL) { - Tcl_AppendResult(interp, "must supply a name when copying a class", - NULL); - Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL); - return NULL; - } if (IsRootClass(oPtr)) { Tcl_AppendResult(interp, "may not clone the class of classes", NULL); Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); @@ -1991,6 +2051,26 @@ Tcl_CopyObjectInstance( } } + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + if (contextPtr) { + args[0] = TclOOObjectName(interp, o2Ptr); + args[1] = oPtr->fPtr->clonedName; + args[2] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(args[0]); + Tcl_IncrRefCount(args[1]); + Tcl_IncrRefCount(args[2]); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, + args); + TclDecrRefCount(args[0]); + TclDecrRefCount(args[1]); + TclDecrRefCount(args[2]); + TclOODeleteContext(contextPtr); + if (result != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + return (Tcl_Object) o2Ptr; } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index b9745ca..2d6f324 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -320,6 +320,8 @@ typedef struct Foundation { * constructor. */ Tcl_Obj *destructorName; /* Shared object containing the "name" of a * destructor. */ + Tcl_Obj *clonedName; /* Shared object containing the name of a + * "<cloned>" pseudo-constructor. */ } Foundation; /* diff --git a/tests/oo.test b/tests/oo.test index a5c4cb0..150bc97 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1679,6 +1679,53 @@ test oo-15.5 {OO: class cloning - Bug 3474460} -setup { } -cleanup { ArbitraryClass destroy } -result {a b c} +test oo-15.6 {OO: object cloning copies namespace contents} -setup { + oo::class create ArbitraryClass {export eval} +} -body { + ArbitraryClass create a + a eval {proc foo x { + variable y + return [string repeat $x [incr y]] + }} + set result [list [a eval {foo 2}] [a eval {foo 3}]] + oo::copy a b + a eval {rename foo bar} + lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}] +} -cleanup { + ArbitraryClass destroy +} -result {2 33 222 3333 444} +test oo-15.7 {OO: classes can be cloned anonymously} -setup { + oo::class create ArbitraryClassA + oo::class create ArbitraryClassB {superclass ArbitraryClassA} +} -body { + info object isa class [oo::copy ArbitraryClassB] +} -cleanup { + ArbitraryClassA destroy +} -result 1 +test oo-15.8 {OO: intercept object cloning} -setup { + oo::class create Foo + set result {} +} -body { + oo::define Foo { + constructor {msg} { + variable v $msg + } + method <cloned> {from} { + next $from + lappend ::result cloned $from [self] + } + method check {} { + variable v + lappend ::result check [self] $v + } + } + Foo create foo ok + oo::copy foo bar + foo check + bar check +} -cleanup { + Foo destroy +} -result {cloned ::foo ::bar check ::foo ok check ::bar ok} test oo-16.1 {OO: object introspection} -body { info object @@ -1774,10 +1821,10 @@ test oo-16.11 {OO: object introspection} -setup { } -body { oo::define foo method spong {} {...} oo::objdefine bar method boo {a {b c} args} {the body} - list [info object methods bar -all] [info object methods bar -all -private] + list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]] } -cleanup { foo destroy -} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}} +} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}} test oo-16.12 {OO: object introspection} -setup { oo::object create foo } -cleanup { @@ -1858,11 +1905,11 @@ test oo-17.9 {OO: class introspection} -setup { } } oo::define subfoo method boo {a {b c} args} {the body} - list [info class methods subfoo -all] \ - [info class methods subfoo -all -private] + list [lsort [info class methods subfoo -all]] \ + [lsort [info class methods subfoo -all -private]] } -cleanup { foo destroy -} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}} +} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}} test oo-17.10 {OO: class introspection} -setup { oo::class create foo } -cleanup { |