Index: ChangeLog
===================================================================
--- ChangeLog
+++ ChangeLog
@@ -1,5 +1,12 @@
+2012-02-10  Donal K. Fellows  <dkf@users.sf.net>
+
+	* 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  <dkf@users.sf.net>
 
 	* 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 {

