Implementation of TIP #397

6 files changed, 209 insertions, 44 deletions

diff --git a/ChangeLog b/ChangeLog
index 792af60..6fb55c5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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.
diff --git a/doc/copy.n b/doc/copy.n
index 51ec844..f5002f8 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -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 {