TclOO Package

Check-in [9331a9eb28]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Implementation of TIP 473 went into 8.6 series Tcl.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1: 9331a9eb28da2cc6edb0d1fd6cad2ead989334c5
User & Date: dkf 2017-10-19 11:06:25
Context
2017-10-19
11:06
Implementation of TIP 473 went into 8.6 series Tcl. Leaf check-in: 9331a9eb28 user: dkf tags: trunk
11:05
[tcl:1a56550e96] Ensure that method list introspection finds methods from mixins in all cases. check-in: 0274fdbceb user: dkf tags: trunk
2017-06-18
07:36
Implement TIP 473: Allow a Defined Target Namespace in oo::copy Closed-Leaf check-in: cc799c22cc user: dkf tags: tip-473
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to doc/copy.n.

    10     10   '\" Note:  do not modify the .SH NAME line immediately below!
    11     11   .SH NAME
    12     12   oo::copy \- create copies of objects and classes
    13     13   .SH SYNOPSIS
    14     14   .nf
    15     15   package require TclOO
    16     16   
    17         -\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR?
           17  +\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR?
    18     18   .fi
    19     19   .BE
    20     20   
    21     21   .SH DESCRIPTION
    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         -resolved relative to the current namespace if not an absolute qualified name.
    26         -If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
    27         -be of the same class as the source object, and will have all its per-object
    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.
           25  +resolved relative to the current namespace if not an absolute qualified name
           26  +and
           27  +.VS TIP473
           28  +\fItargetNamespace\fR which is the name of the namespace where the object is
           29  +going to be created in.
           30  +If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given
           31  +as the empty string, a new name is chosen. Names, unless specified, are
           32  +chosen with the same algorithm used by the \fBnew\fR method of
           33  +\fBoo::class\fR.
           34  +.VE TIP473
           35  +The copied object will be of the same class as the source object, and will have 
           36  +all its per-object methods copied. If it is a class, it will also have all the 
           37  +class methods in the class copied, but it will not have any of its instances 
           38  +copied.
    30     39   .PP
    31     40   After the \fItargetObject\fR has been created and all definitions of its
    32     41   configuration (e.g., methods, filters, mixins) copied, the \fB<cloned>\fR
    33     42   method of \fItargetObject\fR will be invoked, to allow for the customization
    34     43   of the created object. The only argument given will be \fIsourceObject\fR. The
    35     44   default implementation of this method (in \fBoo::object\fR) just copies the
    36     45   procedures and variables in the namespace of \fIsourceObject\fR to the

Changes to generic/tclOOBasic.c.

  1092   1092       ClientData clientData,
  1093   1093       Tcl_Interp *interp,
  1094   1094       int objc,
  1095   1095       Tcl_Obj *const *objv)
  1096   1096   {
  1097   1097       Tcl_Object oPtr, o2Ptr;
  1098   1098   
  1099         -    if (objc < 2 || objc > 3) {
  1100         -	Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
         1099  +    if (objc < 2 || objc > 4) {
         1100  +	Tcl_WrongNumArgs(interp, 1, objv,
         1101  +		"sourceName ?targetName? ?targetNamespace?");
  1101   1102   	return TCL_ERROR;
  1102   1103       }
  1103   1104   
  1104   1105       oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
  1105   1106       if (oPtr == NULL) {
  1106   1107   	return TCL_ERROR;
  1107   1108       }
................................................................................
  1113   1114        * but rather in the context of the namespace of the caller of the overall
  1114   1115        * [oo::define] command.
  1115   1116        */
  1116   1117   
  1117   1118       if (objc == 2) {
  1118   1119   	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
  1119   1120       } else {
  1120         -	char *name;
         1121  +	char *name, *namespaceName;
  1121   1122   	Tcl_DString buffer;
  1122   1123   
  1123   1124   	name = TclGetString(objv[2]);
  1124   1125   	Tcl_DStringInit(&buffer);
  1125         -	if (name[0]!=':' || name[1]!=':') {
         1126  +	if (name[0] == '\0') {
         1127  +	    name = NULL;
         1128  +	} else if (name[0]!=':' || name[1]!=':') {
  1126   1129   	    Interp *iPtr = (Interp *) interp;
  1127   1130   
  1128   1131   	    if (iPtr->varFramePtr != NULL) {
  1129   1132   		Tcl_DStringAppend(&buffer,
  1130   1133   			iPtr->varFramePtr->nsPtr->fullName, -1);
  1131   1134   	    }
  1132   1135   	    Tcl_DStringAppend(&buffer, "::", 2);
  1133   1136   	    Tcl_DStringAppend(&buffer, name, -1);
  1134   1137   	    name = Tcl_DStringValue(&buffer);
  1135   1138   	}
  1136         -	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
         1139  +
         1140  +	/*
         1141  +	 * Choose a unique namespace name if the user didn't supply one.
         1142  +	 */
         1143  +
         1144  +	namespaceName = NULL;
         1145  +	if (objc == 4) {
         1146  +	    namespaceName = TclGetString(objv[3]);
         1147  +
         1148  +	    if (namespaceName[0] == '\0') {
         1149  +		namespaceName = NULL;
         1150  +	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
         1151  +		    0) != NULL) {
         1152  +		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
         1153  +			"%s refers to an existing namespace", namespaceName));
         1154  +		return TCL_ERROR;
         1155  +	    }
         1156  +	}
         1157  +
         1158  +	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
  1137   1159   	Tcl_DStringFree(&buffer);
  1138   1160       }
  1139   1161   
  1140   1162       if (o2Ptr == NULL) {
  1141   1163   	return TCL_ERROR;
  1142   1164       }
  1143   1165   

Changes to tests/oo.test.

  1927   1927   	method <cloned> {a b} {}
  1928   1928       }
  1929   1929       interp alias {} Bar {} oo::copy [Foo create foo]
  1930   1930       Bar bar
  1931   1931   } -returnCodes error -cleanup {
  1932   1932       Foo destroy
  1933   1933   } -result {wrong # args: should be "::bar <cloned> a b"}
         1934  +test oo-15.11 {OO: object cloning} -returnCodes error -body {
         1935  +    oo::copy
         1936  +} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"}
         1937  +test oo-15.12 {OO: object cloning with target NS} -setup {
         1938  +    oo::class create Super
         1939  +    oo::class create Cls {superclass Super}
         1940  +} -body {
         1941  +    namespace eval ::existing {}
         1942  +    oo::copy Cls {} ::existing
         1943  +} -returnCodes error -cleanup {
         1944  +    Super destroy
         1945  +    catch {namespace delete ::existing}
         1946  +} -result {::existing refers to an existing namespace}
         1947  +test oo-15.13 {OO: object cloning with target NS} -setup {
         1948  +    oo::class create Super
         1949  +    oo::class create Cls {superclass Super}
         1950  +} -body {
         1951  +    list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
         1952  +} -cleanup {
         1953  +    Super destroy
         1954  +} -result {0 ::Cls2 1}
         1955  +test oo-15.14 {OO: object cloning with target NS} -setup {
         1956  +    oo::class create Cls {export eval}
         1957  +    set result {}
         1958  +} -body {
         1959  +    Cls create obj
         1960  +    obj eval {
         1961  +	proc test-15.14 {} {}
         1962  +    }
         1963  +    lappend result [info commands ::dupens::t*]
         1964  +    oo::copy obj obj2 ::dupens
         1965  +    lappend result [info commands ::dupens::t*]
         1966  +} -cleanup {
         1967  +    Cls destroy
         1968  +} -result {{} ::dupens::test-15.14}
  1934   1969   
  1935   1970   test oo-16.1 {OO: object introspection} -body {
  1936   1971       info object
  1937   1972   } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
  1938   1973   test oo-16.2 {OO: object introspection} -body {
  1939   1974       info object class NOTANOBJECT
  1940   1975   } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}