TclOO Package

Changes On Branch development-rfe3485060
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch development-rfe3485060 Excluding Merge-Ins

This is equivalent to a diff from 0e25104bd8 to c4b509caa6

2012-03-27
07:00
Implementation of TIP #397 check-in: e0c1f21884 user: dkf tags: trunk
06:55
Fix uninit variable (thanks to dgp for reporting) check-in: 5d401a8455 user: dkf tags: trunk
2012-03-23
09:10
merge trunk Closed-Leaf check-in: c4b509caa6 user: dkf tags: development-rfe3485060
09:07
Implementation of TIP #380 check-in: 0e25104bd8 user: dkf tags: trunk
08:46
Tests of the system of slots. Closed-Leaf check-in: 14aad12d58 user: dkf tags: development-slots
2012-02-21
21:00
merge trunk check-in: 58ab0e3ddf user: dkf tags: development-rfe3485060
20:53
Don't use ranlib during installation process. It's already been done during build. check-in: 45f68ce75a user: dkf tags: trunk

Changes to ChangeLog.

            1  +2012-02-10  Donal K. Fellows  <[email protected]>
            2  +
            3  +	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
            4  +	target object name optional when copying classes. [RFE 3485060]: Add
            5  +	callback method ("<cloned>") so that scripted control over copying is
            6  +	easier.
            7  +
     1      8   2012-03-23  Donal K. Fellows  <[email protected]>
     2      9   
     3     10   	IMPLEMENTATION OF TIP#380.
     4     11   
     5     12   	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
     6     13   	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
     7     14   	* tests/oo.test: Switch definitions of lists of things in objects and

Changes to doc/copy.n.

    22     22   The \fBoo::copy\fR command creates a copy of an object or class. It takes the
    23     23   name of the object or class to be copied, \fIsourceObject\fR, and optionally
    24     24   the name of the object or class to create, \fItargetObject\fR, which will be
    25     25   resolved relative to the current namespace if not an absolute qualified name.
    26     26   If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
    27     27   be of the same class as the source object, and will have all its per-object
    28     28   methods copied. If it is a class, it will also have all the class methods in
    29         -the class copied, but it will not have any of its instances copied. The
    30         -contents of the source object's private namespace \fIwill not\fR be copied; it
    31         -is up to the caller to do this. The result of this command will be the
    32         -fully-qualified name of the new object or class.
           29  +the class copied, but it will not have any of its instances copied.
           30  +.PP
           31  +After the \fItargetObject\fR has been created and all definitions of its
           32  +configuration (e.g., methods, filters, mixins) copied, the \fB<cloned>\fR
           33  +method of \fItargetObject\fR will be invoked, to allow for the customization
           34  +of the created object. The only argument given will be \fIsourceObject\fR. The
           35  +default implementation of this method (in \fBoo::object\fR) just copies the
           36  +procedures and variables in the namespace of \fIsourceObject\fR to the
           37  +namespace of \fItargetObject\fR. If this method call does not return a result
           38  +that is successful (i.e., an error or other kind of exception) then the
           39  +\fItargetObject\fR will be deleted and an error returned.
           40  +.PP
           41  +The result of this command will be the fully-qualified name of the new object
           42  +or class.
    33     43   .SH EXAMPLES
    34     44   This example creates an object, copies it, modifies the source object, and
    35     45   then demonstrates that the copied object is indeed a copy.
           46  +.PP
    36     47   .CS
    37     48   oo::object create src
    38     49   oo::objdefine src method msg {} {puts foo}
    39     50   \fBoo::copy\fR src dst
    40     51   oo::objdefine src method msg {} {puts bar}
    41     52   src msg              \fI\(-> prints "bar"\fR
    42     53   dst msg              \fI\(-> prints "foo"\fR

Changes to doc/object.n.

    86     86   is linked to the local variable in the procedure. Each \fIvarName\fR argument
    87     87   must not have any namespace separators in it. The result is the empty string.
    88     88   .TP
    89     89   \fIobj \fBvarname \fIvarName\fR
    90     90   .
    91     91   This method returns the globally qualified name of the variable \fIvarName\fR
    92     92   in the unique namespace for the object \fIobj\fR.
           93  +.TP
           94  +\fIobj \fB<cloned> \fIsourceObjectName\fR
           95  +.
           96  +This method is used by the \fBoo::object\fR command to copy the state of one
           97  +object to another. It is responsible for copying the procedures and variables
           98  +of the namespace of the source object (\fIsourceObjectName\fR) to the current
           99  +object. It does not copy any other types of commands or any traces on the
          100  +variables; that can be added if desired by overriding this method in a
          101  +subclass.
    93    102   .SH EXAMPLES
    94    103   This example demonstrates basic use of an object.
    95    104   .CS
    96    105   set obj [\fBoo::object\fR new]
    97    106   $obj foo             \fI\(-> error "unknown method foo"\fR
    98    107   oo::objdefine $obj method foo {} {
    99    108       my \fBvariable\fR count

Changes to generic/tclOO.c.

   106    106   }, clsMethods[] = {
   107    107       DCM("create", 1,	TclOO_Class_Create),
   108    108       DCM("new", 1,	TclOO_Class_New),
   109    109       DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
   110    110       {NULL}
   111    111   };
   112    112   
   113         -static char initScript[] =
   114         -    "namespace eval ::oo { variable version " TCLOO_VERSION " };"
   115         -    "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
   116         -/*     "tcl_findLibrary tcloo $oo::version $oo::version" */
   117         -/*     " tcloo.tcl OO_LIBRARY oo::library;"; */
          113  +/*
          114  + * Scripted parts of TclOO. Note that we embed the scripts for simpler
          115  + * deployment (i.e., no separate script to load).
          116  + */
          117  +
          118  +static const char *initScript =
          119  +"namespace eval ::oo { variable version " TCLOO_VERSION " };"
          120  +"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
          121  +/*"tcl_findLibrary tcloo $oo::version $oo::version" */
          122  +/*"     tcloo.tcl OO_LIBRARY oo::library;"; */
          123  +
          124  +static const char *classConstructorBody =
          125  +"lassign [::oo::UpCatch ::oo::define [self] $definitionScript] msg opts;"
          126  +"if {[dict get $opts -code] == 1} {dict set opts -errorline 0xDeadBeef};"
          127  +"return -options $opts $msg";
          128  +
          129  +static const char *clonedBody =
          130  +"foreach p [info procs [info object namespace $originObject]::*] {"
          131  +"    set args [info args $p];"
          132  +"    set idx -1;"
          133  +"    foreach a $args {"
          134  +"        lset args [incr idx] "
          135  +"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
          136  +"    };"
          137  +"    set b [info body $p];"
          138  +"    set p [namespace tail $p];"
          139  +"    proc $p $args $b;"
          140  +"};"
          141  +"foreach v [info vars [info object namespace $originObject]::*] {"
          142  +"    upvar 0 $v vOrigin;"
          143  +"    namespace upvar [namespace current] [namespace tail $v] vNew;"
          144  +"    if {[info exists vOrigin]} {"
          145  +"        if {[array exists vOrigin]} {"
          146  +"            array set vNew [array get vOrigin];"
          147  +"        } else {"
          148  +"            set vNew $vOrigin;"
          149  +"        }"
          150  +"    }"
          151  +"}";
   118    152   
   119    153   static const char *slotScript =
   120    154   "::oo::define ::oo::Slot {\n"
   121    155   "    method Get {} {error unimplemented}\n"
   122    156   "    method Set list {error unimplemented}\n"
   123    157   "    method -set args {\n"
   124    158   "        uplevel 1 [list [namespace which my] Set $args]\n"
................................................................................
   265    299       fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
   266    300   	    DeletedHelpersNamespace);
   267    301       fPtr->epoch = 0;
   268    302       fPtr->tsdPtr = tsdPtr;
   269    303       fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
   270    304       fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
   271    305       fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
          306  +    fPtr->clonedName = Tcl_NewStringObj("<cloned>", -1);
   272    307       Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
   273    308       Tcl_IncrRefCount(fPtr->constructorName);
   274    309       Tcl_IncrRefCount(fPtr->destructorName);
          310  +    Tcl_IncrRefCount(fPtr->clonedName);
   275    311       Tcl_CreateObjCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, NULL,NULL);
   276    312       Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
   277    313   	    TclOOUnknownDefinition, NULL, NULL);
   278    314       namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
   279    315       Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
   280    316       Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
   281    317   
................................................................................
   332    368       for (i=0 ; objMethods[i].name ; i++) {
   333    369   	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
   334    370       }
   335    371       for (i=0 ; clsMethods[i].name ; i++) {
   336    372   	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
   337    373       }
   338    374   
          375  +    /*
          376  +     * Create the default <cloned> method implementation, used when 'oo::copy'
          377  +     * is called to finish the copying of one object to another.
          378  +     */
          379  +
          380  +    argsPtr = Tcl_NewStringObj("originObject", -1);
          381  +    Tcl_IncrRefCount(argsPtr);
          382  +    bodyPtr = Tcl_NewStringObj(clonedBody, -1);
          383  +    TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
          384  +	    bodyPtr, NULL);
          385  +    Tcl_DecrRefCount(argsPtr);
          386  +
   339    387       /*
   340    388        * Finish setting up the class of classes by marking the 'new' method as
   341    389        * private; classes, unlike general objects, must have explicit names. We
   342    390        * also need to create the constructor for classes.
   343    391        *
   344    392        * The 0xDeadBeef is a special signal to the errorInfo logger that is used
   345    393        * by constructors that stops it from generating extra error information
................................................................................
   348    396   
   349    397       namePtr = Tcl_NewStringObj("new", -1);
   350    398       Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
   351    399   	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
   352    400   
   353    401       argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
   354    402       Tcl_IncrRefCount(argsPtr);
   355         -    bodyPtr = Tcl_NewStringObj(
   356         -	    "lassign [::oo::UpCatch ::oo::define [self] $definitionScript] msg opts\n"
   357         -	    "if {[dict get $opts -code] == 1} {"
   358         -	    "    dict set opts -errorline 0xDeadBeef\n"
   359         -	    "}\n"
   360         -	    "return -options $opts $msg", -1);
          403  +    bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
   361    404       fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
   362    405   	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
   363    406       Tcl_DecrRefCount(argsPtr);
   364    407   
   365    408       /*
   366    409        * Create non-object commands and plug ourselves into the Tcl [info]
   367    410        * ensemble.
................................................................................
   453    496       }
   454    497   
   455    498       DelRef(fPtr->objectCls->thisPtr);
   456    499       DelRef(fPtr->objectCls);
   457    500       Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
   458    501       Tcl_DecrRefCount(fPtr->constructorName);
   459    502       Tcl_DecrRefCount(fPtr->destructorName);
          503  +    Tcl_DecrRefCount(fPtr->clonedName);
   460    504       ckfree((char *) fPtr);
   461    505   }
   462    506   
   463    507   /*
   464    508    * ----------------------------------------------------------------------
   465    509    *
   466    510    * AllocObject --
................................................................................
  1507   1551       const char *targetName,
  1508   1552       const char *targetNamespaceName)
  1509   1553   {
  1510   1554       Object *oPtr = (Object *) sourceObject, *o2Ptr;
  1511   1555       FOREACH_HASH_DECLS;
  1512   1556       Method *mPtr;
  1513   1557       Class *mixinPtr;
  1514         -    Tcl_Obj *keyPtr, *filterObj, *variableObj;
  1515         -    int i;
         1558  +    CallContext *contextPtr;
         1559  +    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
         1560  +    int i, result;
  1516   1561   
  1517   1562       /*
  1518         -     * Sanity checks.
         1563  +     * Sanity check.
  1519   1564        */
  1520   1565   
  1521         -    if (targetName == NULL && oPtr->classPtr != NULL) {
  1522         -	Tcl_AppendResult(interp, "must supply a name when copying a class",
  1523         -		NULL);
  1524         -	return NULL;
  1525         -    }
  1526   1566       if (oPtr->flags & ROOT_CLASS) {
  1527   1567   	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
  1528   1568   	return NULL;
  1529   1569       }
  1530   1570   
  1531   1571       /*
  1532   1572        * Build the instance. Note that this does not run any constructors.
................................................................................
  1741   1781   		if (duplicate != NULL) {
  1742   1782   		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
  1743   1783   			    duplicate);
  1744   1784   		}
  1745   1785   	    }
  1746   1786   	}
  1747   1787       }
         1788  +
         1789  +    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0);
         1790  +    if (contextPtr) {
         1791  +	args[0] = TclOOObjectName(interp, o2Ptr);
         1792  +	args[1] = oPtr->fPtr->clonedName;
         1793  +	args[2] = TclOOObjectName(interp, oPtr);
         1794  +	Tcl_IncrRefCount(args[0]);
         1795  +	Tcl_IncrRefCount(args[1]);
         1796  +	Tcl_IncrRefCount(args[2]);
         1797  +	result = TclOOInvokeContext(interp, contextPtr, 3, args);
         1798  +	Tcl_DecrRefCount(args[0]);
         1799  +	Tcl_DecrRefCount(args[1]);
         1800  +	Tcl_DecrRefCount(args[2]);
         1801  +	TclOODeleteContext(contextPtr);
         1802  +	if (result != TCL_OK) {
         1803  +	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
         1804  +	    return NULL;
         1805  +	}
         1806  +    }
  1748   1807   
  1749   1808       return (Tcl_Object) o2Ptr;
  1750   1809   }
  1751   1810   
  1752   1811   /*
  1753   1812    * ----------------------------------------------------------------------
  1754   1813    *

Changes to generic/tclOOInt.h.

   316    316       Tcl_Obj *unknownMethodNameObj;
   317    317   				/* Shared object containing the name of the
   318    318   				 * unknown method handler method. */
   319    319       Tcl_Obj *constructorName;	/* Shared object containing the "name" of a
   320    320   				 * constructor. */
   321    321       Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
   322    322   				 * destructor. */
          323  +    Tcl_Obj *clonedName;	/* Shared object containing the name of a
          324  +				 * "<cloned>" pseudo-constructor. */
   323    325   } Foundation;
   324    326   
   325    327   /*
   326    328    * A call context structure is built when a method is called. They contain the
   327    329    * chain of method implementations that are to be invoked by a particular
   328    330    * call, and the process of calling walks the chain, with the [next] command
   329    331    * proceeding to the next entry in the chain.

Changes to tests/oo.test.

  1606   1606   	variable a b c
  1607   1607       }
  1608   1608       oo::copy Foo Bar
  1609   1609       info class variable Bar
  1610   1610   } -cleanup {
  1611   1611       ArbitraryClass destroy
  1612   1612   } -result {a b c}
         1613  +test oo-15.6 {OO: object cloning copies namespace contents} -setup {
         1614  +    oo::class create ArbitraryClass {export eval}
         1615  +} -body {
         1616  +    ArbitraryClass create a
         1617  +    a eval {proc foo x {
         1618  +	variable y
         1619  +	return [string repeat $x [incr y]]
         1620  +    }}
         1621  +    set result [list [a eval {foo 2}] [a eval {foo 3}]]
         1622  +    oo::copy a b
         1623  +    a eval {rename foo bar}
         1624  +    lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
         1625  +} -cleanup {
         1626  +    ArbitraryClass destroy
         1627  +} -result {2 33 222 3333 444}
  1613   1628   
  1614   1629   test oo-16.1 {OO: object introspection} -body {
  1615   1630       info object
  1616   1631   } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
  1617   1632   test oo-16.2 {OO: object introspection} -body {
  1618   1633       info object class NOTANOBJECT
  1619   1634   } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
................................................................................
  1701   1716   } -result {a b c}
  1702   1717   test oo-16.11 {OO: object introspection} -setup {
  1703   1718       oo::class create foo
  1704   1719       foo create bar
  1705   1720   } -body {
  1706   1721       oo::define foo method spong {} {...}
  1707   1722       oo::objdefine bar method boo {a {b c} args} {the body}
  1708         -    list [info object methods bar -all] [info object methods bar -all -private]
         1723  +    list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
  1709   1724   } -cleanup {
  1710   1725       foo destroy
  1711         -} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
         1726  +} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
  1712   1727   test oo-16.12 {OO: object introspection} -setup {
  1713   1728       oo::object create foo
  1714   1729   } -cleanup {
  1715   1730       rename foo {}
  1716   1731   } -body {
  1717   1732       oo::objdefine foo unexport {*}[info object methods foo -all]
  1718   1733       info object methods foo -all
................................................................................
  1785   1800       oo::define foo {
  1786   1801   	method bar {a {b c} args} {the body}
  1787   1802   	self {
  1788   1803   	    method bad {} {...}
  1789   1804   	}
  1790   1805       }
  1791   1806       oo::define subfoo method boo {a {b c} args} {the body}
  1792         -    list [info class methods subfoo -all] \
  1793         -	[info class methods subfoo -all -private]
         1807  +    list [lsort [info class methods subfoo -all]] \
         1808  +	[lsort [info class methods subfoo -all -private]]
  1794   1809   } -cleanup {
  1795   1810       foo destroy
  1796         -} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
         1811  +} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
  1797   1812   test oo-17.10 {OO: class introspection} -setup {
  1798   1813       oo::class create foo
  1799   1814   } -cleanup {
  1800   1815       rename foo {}
  1801   1816   } -body {
  1802   1817       oo::define foo unexport {*}[info class methods foo -all]
  1803   1818       info class methods foo -all