Attachment "3485060.patch" to
ticket [3485060fff]
added by
dkf
2012-02-13 07:18:16.
Index: ChangeLog
===================================================================
--- ChangeLog
+++ ChangeLog
@@ -1,5 +1,12 @@
+2012-02-10 Donal K. Fellows <[email protected]>
+
+ * 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.
+
2012-01-25 Donal K. Fellows <[email protected]>
* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: When
copying an object, make sure that the configuration of the variable
resolver is also duplicated.
Index: doc/copy.n
===================================================================
--- doc/copy.n
+++ doc/copy.n
@@ -24,17 +24,28 @@
the name of the object or class to create, \fItargetObject\fR, which will be
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
+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 the customization
+of the created object. 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.
+.PP
+The result of this command will be the fully-qualified name of the new object
+or class.
.SH EXAMPLES
This example creates an object, copies it, modifies the source object, and
then demonstrates that the copied object is indeed a copy.
+.PP
.CS
oo::object create src
oo::objdefine src method msg {} {puts foo}
\fBoo::copy\fR src dst
oo::objdefine src method msg {} {puts bar}
Index: doc/object.n
===================================================================
--- doc/object.n
+++ doc/object.n
@@ -83,10 +83,19 @@
.TP
\fIobj \fBvarname \fIvarName\fR
.
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
+.
+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.
.SH EXAMPLES
This example demonstrates basic use of an object.
.CS
set obj [\fBoo::object\fR new]
$obj foo \fI\(-> error "unknown method foo"\fR
Index: generic/tclOO.c
===================================================================
--- generic/tclOO.c
+++ generic/tclOO.c
@@ -115,15 +115,49 @@
DCM("new", 1, TclOO_Class_New),
DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
{NULL}
};
-static char initScript[] =
- "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. Note that we embed the scripts for simpler
+ * deployment (i.e., no separate script to load).
+ */
+
+static const char *initScript =
+"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;"; */
+
+static const char *classConstructorBody =
+"lassign [::oo::UpCatch ::oo::define [self] $definitionScript] msg opts;"
+"if {[dict get $opts -code] == 1} {dict set opts -errorline 0xDeadBeef};"
+"return -options $opts $msg";
+
+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;"
+" }"
+" }"
+"}";
extern const TclStubs *const tclOOConstStubsPtr;
/*
* Key into the interpreter assocData table for the foundation structure ref.
@@ -243,13 +277,15 @@
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+ fPtr->clonedName = Tcl_NewStringObj("<cloned>", -1);
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_IncrRefCount(fPtr->clonedName);
Tcl_CreateObjCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, NULL,NULL);
Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
TclOOUnknownDefinition, NULL, NULL);
namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
@@ -311,10 +347,22 @@
for (i=0 ; clsMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
}
/*
+ * Create the default <cloned> method implementation, used when 'oo::copy'
+ * is called to finish the copying of one object to another.
+ */
+
+ argsPtr = Tcl_NewStringObj("originObject", -1);
+ 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.
*
* The 0xDeadBeef is a special signal to the errorInfo logger that is used
@@ -326,16 +374,11 @@
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(
- "lassign [::oo::UpCatch ::oo::define [self] $definitionScript] 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);
/*
@@ -422,10 +465,11 @@
DelRef(fPtr->objectCls->thisPtr);
DelRef(fPtr->objectCls);
Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
Tcl_DecrRefCount(fPtr->constructorName);
Tcl_DecrRefCount(fPtr->destructorName);
+ Tcl_DecrRefCount(fPtr->clonedName);
ckfree((char *) fPtr);
}
/*
* ----------------------------------------------------------------------
@@ -1470,22 +1514,18 @@
{
Object *oPtr = (Object *) sourceObject, *o2Ptr;
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);
- return NULL;
- }
if (oPtr->flags & ROOT_CLASS) {
Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
return NULL;
}
@@ -1702,10 +1742,29 @@
if (duplicate != NULL) {
Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
duplicate);
}
}
+ }
+ }
+
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0);
+ 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 = TclOOInvokeContext(interp, contextPtr, 3, args);
+ Tcl_DecrRefCount(args[0]);
+ Tcl_DecrRefCount(args[1]);
+ Tcl_DecrRefCount(args[2]);
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
}
}
return (Tcl_Object) o2Ptr;
}
Index: generic/tclOOInt.h
===================================================================
--- generic/tclOOInt.h
+++ generic/tclOOInt.h
@@ -316,10 +316,12 @@
* unknown method handler method. */
Tcl_Obj *constructorName; /* Shared object containing the "name" of a
* 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;
/*
* A call context structure is built when a method is called. They contain the
* chain of method implementations that are to be invoked by a particular
Index: tests/oo.test
===================================================================
--- tests/oo.test
+++ tests/oo.test
@@ -1601,10 +1601,25 @@
oo::copy Foo Bar
info class variable Bar
} -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-16.1 {OO: object introspection} -body {
info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
test oo-16.2 {OO: object introspection} -body {
@@ -1696,14 +1711,14 @@
oo::class create foo
foo create bar
} -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 {
rename foo {}
} -body {
@@ -1780,15 +1795,15 @@
self {
method bad {} {...}
}
}
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 {
rename foo {}
} -body {
