TclOO Package

Check-in [e0c1f21884]
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 #397
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e0c1f2188474d9aeac64b67ad74abbeda704c273
User & Date: dkf 2012-03-27 07:00:28
Context
2012-04-04
21:07
Fix [Bug 3514761] and related ensemble/construction problems. check-in: 3d75ad8d85 user: dkf tags: trunk
2012-03-28
08:04
merge trunk check-in: 33d4e0b690 user: dkf tags: development-submethods
08:00
merge trunk check-in: db8ae3ab09 user: dkf tags: development-gc
07:58
merge trunk check-in: 6d0dd79102 user: dkf tags: development-friends
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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








1
2
3
4
5
6
7






2012-03-23  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#380.

	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
	* tests/oo.test: Switch definitions of lists of things in objects and
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
2012-02-10  Donal K. Fellows  <[email protected]>

	* 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-03-23  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#380.

	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
	* tests/oo.test: Switch definitions of lists of things in objects and

Changes to doc/copy.n.

22
23
24
25
26
27
28
29
30

31









32

33
34
35

36
37
38
39
40
41
42
The \fBoo::copy\fR command creates a copy of an object or class. It takes the
name of the object or class to be copied, \fIsourceObject\fR, and optionally
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.

.SH EXAMPLES
This example creates an object, copies it, modifies the source object, and
then demonstrates that the copied object is indeed a copy.

.CS
oo::object create src
oo::objdefine src method msg {} {puts foo}
\fBoo::copy\fR src dst
oo::objdefine src method msg {} {puts bar}
src msg              \fI\(-> prints "bar"\fR
dst msg              \fI\(-> prints "foo"\fR






|
<
>
|
>
>
>
>
>
>
>
>
>
|
>



>







22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
The \fBoo::copy\fR command creates a copy of an object or class. It takes the
name of the object or class to be copied, \fIsourceObject\fR, and optionally
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.

.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}
src msg              \fI\(-> prints "bar"\fR
dst msg              \fI\(-> prints "foo"\fR

Changes to doc/object.n.

86
87
88
89
90
91
92









93
94
95
96
97
98
99
is linked to the local variable in the procedure. Each \fIvarName\fR argument
must not have any namespace separators in it. The result is the empty string.
.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.









.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
oo::objdefine $obj method foo {} {
    my \fBvariable\fR count






>
>
>
>
>
>
>
>
>







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
is linked to the local variable in the procedure. Each \fIvarName\fR argument
must not have any namespace separators in it. The result is the empty string.
.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
oo::objdefine $obj method foo {} {
    my \fBvariable\fR count

Changes to generic/tclOO.c.

106
107
108
109
110
111
112
113






114
115
116
117





























118
119
120
121
122
123
124
...
265
266
267
268
269
270
271

272
273
274

275
276
277
278
279
280
281
...
332
333
334
335
336
337
338












339
340
341
342
343
344
345
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
...
453
454
455
456
457
458
459

460
461
462
463
464
465
466
....
1507
1508
1509
1510
1511
1512
1513

1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
....
1741
1742
1743
1744
1745
1746
1747



















1748
1749
1750
1751
1752
1753
1754
}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    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;"; */






























static const char *slotScript =
"::oo::define ::oo::Slot {\n"
"    method Get {} {error unimplemented}\n"
"    method Set list {error unimplemented}\n"
"    method -set args {\n"
"        uplevel 1 [list [namespace which my] Set $args]\n"
................................................................................
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    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);

    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
    Tcl_IncrRefCount(fPtr->constructorName);
    Tcl_IncrRefCount(fPtr->destructorName);

    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);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

................................................................................
    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }













    /*
     * 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
     * by constructors that stops it from generating extra error information
................................................................................

    namePtr = Tcl_NewStringObj("new", -1);
    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);
    fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
................................................................................
    }

    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->objectCls);
    Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
    Tcl_DecrRefCount(fPtr->constructorName);
    Tcl_DecrRefCount(fPtr->destructorName);

    ckfree((char *) fPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --
................................................................................
    const char *targetName,
    const char *targetNamespaceName)
{
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;

    Tcl_Obj *keyPtr, *filterObj, *variableObj;
    int i;

    /*
     * Sanity checks.
     */

    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;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
................................................................................
		if (duplicate != NULL) {
		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
			    duplicate);
		}
	    }
	}
    }




















    return (Tcl_Object) o2Ptr;
}
 
/*
 * ----------------------------------------------------------------------
 *






<
>
>
>
>
>
>
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>



>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







|
<
<
<
<
<







 







>







 







>
|
|


|


<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







106
107
108
109
110
111
112

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
...
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
...
396
397
398
399
400
401
402
403





404
405
406
407
408
409
410
...
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
....
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565





1566
1567
1568
1569
1570
1571
1572
....
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    DCM("new", 1,	TclOO_Class_New),
    DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
    {NULL}
};


/*
 * 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"
"    method -set args {\n"
"        uplevel 1 [list [namespace which my] Set $args]\n"
................................................................................
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    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);
    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);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

................................................................................
    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    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
     * by constructors that stops it from generating extra error information
................................................................................

    namePtr = Tcl_NewStringObj("new", -1);
    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(classConstructorBody, -1);





    fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
................................................................................
    }

    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);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --
................................................................................
    const char *targetName,
    const char *targetNamespaceName)
{
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    int i, result;

    /*
     * Sanity check.
     */






    if (oPtr->flags & ROOT_CLASS) {
	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
................................................................................
		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;
}
 
/*
 * ----------------------------------------------------------------------
 *

Changes to generic/tclOOInt.h.

316
317
318
319
320
321
322


323
324
325
326
327
328
329
    Tcl_Obj *unknownMethodNameObj;
				/* Shared object containing the name of the
				 * 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. */


} 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
 * call, and the process of calling walks the chain, with the [next] command
 * proceeding to the next entry in the chain.






>
>







316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
    Tcl_Obj *unknownMethodNameObj;
				/* Shared object containing the name of the
				 * 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
 * call, and the process of calling walks the chain, with the [next] command
 * proceeding to the next entry in the chain.

Changes to tests/oo.test.

1606
1607
1608
1609
1610
1611
1612















1613
1614
1615
1616
1617
1618
1619
....
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
....
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
	variable a b c
    }
    oo::copy Foo Bar
    info class variable Bar
} -cleanup {
    ArbitraryClass destroy
} -result {a b c}
















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 {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
................................................................................
} -result {a b c}
test oo-16.11 {OO: object introspection} -setup {
    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]
} -cleanup {
    foo destroy
} -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 {
    oo::objdefine foo unexport {*}[info object methods foo -all]
    info object methods foo -all
................................................................................
    oo::define foo {
	method bar {a {b c} args} {the body}
	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]
} -cleanup {
    foo destroy
} -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 {
    oo::define foo unexport {*}[info class methods foo -all]
    info class methods foo -all






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|


|







 







|
|


|







1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
....
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
....
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
	variable a b c
    }
    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 {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
................................................................................
} -result {a b c}
test oo-16.11 {OO: object introspection} -setup {
    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 [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
} -cleanup {
    foo destroy
} -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 {
    oo::objdefine foo unexport {*}[info object methods foo -all]
    info object methods foo -all
................................................................................
    oo::define foo {
	method bar {a {b c} args} {the body}
	self {
	    method bad {} {...}
	}
    }
    oo::define subfoo method boo {a {b c} args} {the body}
    list [lsort [info class methods subfoo -all]] \
	[lsort [info class methods subfoo -all -private]]
} -cleanup {
    foo destroy
} -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 {
    oo::define foo unexport {*}[info class methods foo -all]
    info class methods foo -all