Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,12 @@ +2012-02-10 Donal K. Fellows + + * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the + target object name optional when copying classes. [RFE 3485060]: Add + callback method ("") so that scripted control over copying is + easier. + 2012-03-23 Donal K. Fellows IMPLEMENTATION OF TIP#380. * doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c: 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\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 @@ -88,10 +88,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 \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 @@ -108,15 +108,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;" +" }" +" }" +"}"; static const char *slotScript = "::oo::define ::oo::Slot {\n" " method Get {} {error unimplemented}\n" " method Set list {error unimplemented}\n" @@ -267,13 +301,15 @@ fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); fPtr->constructorName = Tcl_NewStringObj("", -1); fPtr->destructorName = Tcl_NewStringObj("", -1); + fPtr->clonedName = Tcl_NewStringObj("", -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); @@ -334,10 +370,22 @@ } for (i=0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } + /* + * Create the default 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. * @@ -350,16 +398,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); /* @@ -455,10 +498,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); } /* * ---------------------------------------------------------------------- @@ -1509,22 +1553,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; } @@ -1743,10 +1783,29 @@ 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 @@ -318,10 +318,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 + * "" 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 @@ -1608,10 +1608,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 { @@ -1703,14 +1718,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} { boo destroy eval spong unknown variable varname}} test oo-16.12 {OO: object introspection} -setup { oo::object create foo } -cleanup { rename foo {} } -body { @@ -1787,15 +1802,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} { bar boo destroy eval unknown variable varname}} test oo-17.10 {OO: class introspection} -setup { oo::class create foo } -cleanup { rename foo {} } -body {