Tcl Source Code

Changes On Branch tip-500
Login

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

Changes In Branch tip-500 Excluding Merge-Ins

This is equivalent to a diff from dade30b4a0 to 3419afb49d

2018-06-03
11:44
TIP 500: Private Methods and Variables in TclOO check-in: 86262924a2 user: dkf tags: core-8-branch
2018-06-02
14:19
merge core-8-branch Closed-Leaf check-in: 3419afb49d user: dkf tags: tip-500
2018-06-01
16:04
Rebase the sebres clock bounty work to the 8.7 branch. check-in: 3e943144b9 user: dgp tags: dgp-sebres-clock-review
2018-05-31
19:23
merge 8.7 check-in: 0a613bfb94 user: dgp tags: core_zip_vfs
07:21
Merge 8.7 check-in: 3fb815ef5f user: jan.nijtmans tags: initsubsystems
07:18
merge 8.7 check-in: 7173f591b6 user: jan.nijtmans tags: trunk
07:17
Neither use --disable-threads on MacOS builds, and don't mention it any more in the README check-in: dade30b4a0 user: jan.nijtmans tags: core-8-branch
2018-05-30
09:38
Tweaking the documentation check-in: d65f77c5b5 user: dkf tags: tip-500
07:15
No longer pass "--enable-threads" to battery-included sub-packages, since it's the default, even wh... check-in: 552b9e73d7 user: jan.nijtmans tags: core-8-branch

Changes to doc/Method.3.

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19


20
21
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
1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17


18
19
20
21


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











-
+





-
-
+
+


-
-
+
+














+


+
+
+
+







'\"
'\" Copyright (c) 2007 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
.SH SYNOPSIS
.nf
\fB#include <tclOO.h>\fR
.sp
Tcl_Method
\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic,
              methodTypePtr, clientData\fR)
\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr,
              clientData\fR)
.sp
Tcl_Method
\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic,
                      methodTypePtr, clientData\fR)
\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr,
                      clientData\fR)
.sp
\fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR)
.sp
\fBTcl_ClassSetDestructor\fR(\fIinterp, class, method\fR)
.sp
Tcl_Class
\fBTcl_MethodDeclarerClass\fR(\fImethod\fR)
.sp
Tcl_Object
\fBTcl_MethodDeclarerObject\fR(\fImethod\fR)
.sp
Tcl_Obj *
\fBTcl_MethodName\fR(\fImethod\fR)
.sp
.VS TIP500
int
\fBTcl_MethodIsPublic\fR(\fImethod\fR)
.VE TIP500
.sp
int
\fBTcl_MethodIsPrivate\fR(\fImethod\fR)
.sp
int
\fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR)
.sp
int
\fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR)
.sp
62
63
64
65
66
67
68
69
70
71
72









73
74
75
76
77
78
79
67
68
69
70
71
72
73




74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89







-
-
-
-
+
+
+
+
+
+
+
+
+







.AP Tcl_Object object in
The object to create the method in.
.AP Tcl_Class class in
The class to create the method in.
.AP Tcl_Obj *nameObj in
The name of the method to create. Should not be NULL unless creating
constructors or destructors.
.AP int isPublic in
A flag saying what the visibility of the method is. The only supported public
values of this flag are 0 for a non-exported method, and 1 for an exported
method.
.AP int flags in
A flag saying (currently) what the visibility of the method is. The supported
public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1
for backward compatibility) for an exported method,
\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward
compatibility) for a non-exported method,
.VS TIP500
and \fBTCL_OO_METHOD_PRIVATE\fR for a private method.
.VE TIP500
.AP Tcl_MethodType *methodTypePtr in
A description of the type of the method to create, or the type of method to
compare against.
.AP ClientData clientData in
A piece of data that is passed to the implementation of the method without
interpretation.
.AP ClientData *clientDataPtr out
101
102
103
104
105
106
107
108
109






110
111
112
113
114
115
116
117
118
119
120
121






122
123
124
125
126
127
128
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







-
-
+
+
+
+
+
+










-
-
+
+
+
+
+
+







that class.
.PP
Given a method, the entity that declared it can be found using
\fBTcl_MethodDeclarerClass\fR which returns the class that the method is
attached to (or NULL if the method is not attached to any class) and
\fBTcl_MethodDeclarerObject\fR which returns the object that the method is
attached to (or NULL if the method is not attached to an object). The name of
the method can be retrieved with \fBTcl_MethodName\fR and whether the method
is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method
the method can be retrieved with \fBTcl_MethodName\fR, whether the method
is exported is retrieved with \fBTcl_MethodIsPublic\fR,
.VS TIP500
and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR.
.VE TIP500
The type of the method
can also be introspected upon to a limited degree; the function
\fBTcl_MethodIsType\fR returns whether a method is of a particular type,
assigning the per-method \fIclientData\fR to the variable pointed to by
\fIclientDataPtr\fR if (that is non-NULL) if the type is matched.
.SS "METHOD CREATION"
.PP
Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR,
which
create a method attached to a class or an object respectively. In both cases,
the \fInameObj\fR argument gives the name of the method to create, the
\fIisPublic\fR argument states whether the method should be exported
initially, the \fImethodTypePtr\fR argument describes the implementation of
\fIflags\fR argument states whether the method should be exported
initially
.VS TIP500
or be marked as a private method,
.VE TIP500
the \fImethodTypePtr\fR argument describes the implementation of
the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR
argument gives some implementation-specific data that is passed on to the
implementation of the method when it is called.
.PP
When the \fInameObj\fR argument to \fBTcl_NewMethod\fR is NULL, an
unnamed method is created, which is used for constructors and destructors.
Constructors should be installed into their class using the

Changes to doc/define.n.

78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
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
78
79
80
81
82
83
84

85
86

87
88
89
90
91

92

93
94
95
96
97
98
99
100
101
102
103
104
105
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
159
160
161
162
163
164







-
+

-





-

-












+
+
+
+
+
+
+












+
+
+
+
+
+
+


-
+

-



-

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+







This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside an instance through the instance object's command) by the
class being defined. Note that the methods themselves may be actually defined
by a superclass; subclass exports override superclass visibility, and may in
turn be overridden by instances.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of method names that are used to guard whether
method call to instances of the class may be called and what the method's
results are. Each \fImethodName\fR names a single filtering method (which may
be exposed or not exposed); it is not an error for a non-existent method to be
named since they may be defined by subclasses.
.VS
By default, this slot works by appending.
.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded method called \fIname\fR. The method is
defined be forwarded to the command called \fIcmdName\fR, with additional
arguments, \fIarg\fR etc., added before those arguments specified by the
caller of the method. The \fIcmdName\fR will always be resolved using the
rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not
fully-qualified, the command will be searched for in each object's namespace,
using the instances' namespace's path, or by looking in the global namespace.
The method will be exported if \fIname\fR starts with a lower-case letter, and
non-exported otherwise.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
\fBmethod\fI name argList bodyScript\fR
.
This creates or updates a method that is implemented as a procedure-like
script. The name of the method is \fIname\fR, the formal arguments to the
method (defined using the same format as for the Tcl \fBproc\fR command) will
be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When
the body of the method is evaluated, the current namespace of the method will
be a namespace that is unique to the current object. The method will be
exported if \fIname\fR starts with a lower-case letter, and non-exported
otherwise; this behavior can be overridden via \fBexport\fR and
\fBunexport\fR.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private procedure-like methods.
.VE TIP500
.RE
.TP
\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of additional classes that are to be mixed into
all the instances of the class being defined. Each \fIclassName\fR argument
names a single class that is to be mixed in.
.VS
By default, this slot works by replacement.
.TP
\fBprivate \fIcmd arg...\fR
.TP
\fBprivate \fIscript\fR
.
.VS TIP500
This evaluates the \fIscript\fR (or the list of command and arguments given by
\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
current class will be private definitions.
.RS
.PP
The following class definition commands are affected by \fBprivate\fR:
\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting
\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost
definition context is just a private definition context. All other definition
commands have no difference in behavior when used in a private definition
context.
.RE
.VE
.VE TIP500
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
method must have previously existed in the class, and \fItoName\fR must not
previously refer to a method in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
155
156
157
158
159
160
161





162
163
164
165

166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

189
190
191
192
193

194

195
196
197
198











199


200
201
202
203
204
205
206
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

197
198

199
200
201
202
203
204

205

206
207
208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223

224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239

240
241
242
243
244
245
246
247
248







+
+
+
+
+



-
+

-






-

-











-
+





+
-
+




+
+
+
+
+
+
+
+
+
+
+
-
+
+







.QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
.RS
.PP
.VS TIP470
If no arguments at all are used, this gives the name of the class currently
being configured.
.VE TIP470
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), the definitions on the class object will also be made in a private
definition context.
.VE TIP500
.RE
.TP
\fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
allows the alteration of the superclasses of the class being defined.
Each \fIclassName\fR argument names one class that is to be a superclass of
the defined class. Note that objects must not be changed from being classes to
being non-classes or vice-versa, that an empty parent class is equivalent to
\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
\fBoo::class\fR may not be modified.
.VS
By default, this slot works by replacement.
.VE
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the instance through the instance object's command,
but instead just through the \fBmy\fR command visible in each object's
context) by the class being defined. Note that the methods themselves may be
actually defined by a superclass; subclass unexports override superclass
visibility, and may be overridden by instance unexports.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made
available in the methods, constructor and destructor declared by the class
being defined. Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
actually present in the namespace of the instance object on which the method
actually present in the instance object on which the method is executed. Note
is executed. Note
that the variable lists declared by a superclass or subclass are completely
disjoint, as are variable lists declared by instances; the list of variable
names is just for methods (and constructors and destructors) declared by this
class. By default, this slot works by appending.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this slot manipulates the list of private variable bindings for this
class. In a private variable binding, the name of the variable within the
instance object is different to the name given in the definition; the name
used in the definition is the name that you use to access the variable within
the methods of this class, and the name of the variable in the instance
namespace has a unique prefix that makes accidental use from other classes
extremely unlikely.
.VE
.VE TIP500
.RE
.SS "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
form:
.TP
\fBclass\fI className\fR
219
220
221
222
223
224
225
226

227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246







247
248
249
250
251
252
253
254
255
256







257
258
259

260
261
262
263
264
265
266
















267

268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292

293
294
295
296

297

298
299
300


























301
302
303
304
305
306
307
308
309
310
311

312
313
314
315
316

317
318
319
320
321

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

338
339
340
341
342
343
344

345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
261
262
263
264
265
266
267

268
269

270
271
272
273
274
275

276

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311

312
313

314
315
316

317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333

334
335
336
337
338
339
340
341
342
343
344

345
346
347
348
349
350
351
352
353
354
355
356
357

358
359
360
361
362
363

364
365
366
367
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
394
395
396
397
398
399
400

401
402

403
404

405
406

407
408

409
410

411
412
413
414
415
416
417
418
419
420
421
422
423

424
425

426
427
428
429

430
431

432
433
434
435
436
437
438
439
440
441
442

443
444
445
446
447
448
449







-
+

-






-

-









+
+
+
+
+
+
+










+
+
+
+
+
+
+


-
+

-



-

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+










-













-
+




+
-
+



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







-


-
+

-


-
+

-


-
+












-


-
+



-


-
+










-







.
This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside the object through the object's command) by the object
being defined. Note that the methods themselves may be actually defined by a
class or superclass; object exports override class visibility.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of method names that are used to guard whether a
method call to the object may be called and what the method's results are.
Each \fImethodName\fR names a single filtering method (which may be exposed or
not exposed); it is not an error for a non-existent method to be named. Note
that the actual list of filters also depends on the filters set upon any
classes that the object is an instance of.
.VS
By default, this slot works by appending.
.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded object method called \fIname\fR. The
method is defined be forwarded to the command called \fIcmdName\fR, with
additional arguments, \fIarg\fR etc., added before those arguments specified
by the caller of the method. Forwarded methods should be deleted using the
\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
a lower-case letter, and non-exported otherwise.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
\fBmethod\fI name argList bodyScript\fR
.
This creates, updates or deletes an object method. The name of the method is
\fIname\fR, the formal arguments to the method (defined using the same format
as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
method will be \fIbodyScript\fR. When the body of the method is evaluated, the
current namespace of the method will be a namespace that is unique to the
object. The method will be exported if \fIname\fR starts with a lower-case
letter, and non-exported otherwise.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this command creates private procedure-like methods.
.VE TIP500
.RE
.TP
\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates a per-object list of additional classes that are to be
mixed into the object. Each argument, \fIclassName\fR, names a single class
that is to be mixed in.
.VS
By default, this slot works by replacement.
.TP
\fBprivate \fIcmd arg...\fR
.TP
\fBprivate \fIscript\fR
.VS TIP500
This evaluates the \fIscript\fR (or the list of command and arguments given by
\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
current object will be private definitions.
.RS
.PP
The following class definition commands are affected by \fBprivate\fR:
\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside
\fBprivate\fR has no cumulative effect; the innermost definition context is
just a private definition context. All other definition commands have no
difference in behavior when used in a private definition context.
.RE
.VE
.VE TIP500
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in an object to \fItoName\fR.
The method must have previously existed in the object, and \fItoName\fR must
not previously refer to a method in that object. Does not affect the classes
that the object is an instance of. Does not change the export status of the
method; if it was exported before, it will be afterwards.
.TP
\fBself \fR
.
.VS TIP470
This gives the name of the object currently being configured.
.VE TIP470
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the object through the object's command, but instead
just through the \fBmy\fR command visible in the object's context) by the
object being defined. Note that the methods themselves may be actually defined
by a class; instance unexports override class visibility.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
.VS
.
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made available in the methods declared by the
object being defined.  Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
actually present in the namespace of the object on which the method is
actually present in the object on which the method is executed. Note that the
executed. Note that the
variable lists declared by the classes and mixins of which the object is an
instance are completely disjoint; the list of variable names is just for
methods declared by this object. By default, this slot works by appending.
.RS
.PP
.VS TIP500
If in a private definition context (see the \fBprivate\fR definition command,
below), this slot manipulates the list of private variable bindings for this
object.  In a private variable binding, the name of the variable within the
instance object is different to the name given in the definition; the name
used in the definition is the name that you use to access the variable within
the methods of this instance object, and the name of the variable in the
instance namespace has a unique prefix that makes accidental use from
superclass methods extremely unlikely.
.VE TIP500
.RE
.SH "PRIVATE METHODS"
.VS TIP500
When a class or instance has a private method, that private method can only be
invoked from within methods of that class or instance. Other callers of the
object's methods \fIcannot\fR invoke private methods, it is as if the private
methods do not exist. However, a private method of a class \fIcan\fR be
invoked from the class's methods when those methods are being used on another
instance object; this means that a class can use them to coordinate behaviour
between several instances of itself without interfering with how other
classes (especially either subclasses or superclasses) interact. Private
methods precede all mixed in classes in the method call order (as reported by
\fBself call\fR).
.VE TIP500
.SH "SLOTTED DEFINITIONS"
Some of the configurable definitions of a class or object are \fIslotted
definitions\fR. This means that the configuration is implemented by a slot
object, that is an instance of the class \fBoo::Slot\fR, which manages a list
of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines three operations (as methods) that may be done on
the slot:
.VE
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.VS
.
This appends the given \fImember\fR elements to the slot definition.
.VE
.TP
\fIslot\fR \fB\-clear\fR
.VS
.
This sets the slot definition to the empty list.
.VE
.TP
\fIslot\fR \fB\-set\fR ?\fImember ...\fR?
.VS
.
This replaces the slot definition with the given \fImember\fR elements.
.PP
A consequence of this is that any use of a slot's default operation where the
first member argument begins with a hyphen will be an error. One of the above
operations should be used explicitly in those circumstances.
.SS "SLOT IMPLEMENTATION"
Internally, slot objects also define a method \fB\-\-default\-operation\fR
which is forwarded to the default operation of the slot (thus, for the class
.QW \fBvariable\fR
slot, this is forwarded to
.QW "\fBmy \-append\fR" ),
and these methods which provide the implementation interface:
.VE
.TP
\fIslot\fR \fBGet\fR
.VS
.
Returns a list that is the current contents of the slot. This method must
always be called from a stack frame created by a call to \fBoo::define\fR or
\fBoo::objdefine\fR.
.VE
.TP
\fIslot\fR \fBSet \fIelementList\fR
.VS
.
Sets the contents of the slot to the list \fIelementList\fR and returns the
empty string. This method must always be called from a stack frame created by
a call to \fBoo::define\fR or \fBoo::objdefine\fR.
.PP
The implementation of these methods is slot-dependent (and responsible for
accessing the correct part of the class or object definition). Slots also have
an unknown method handler to tie all these pieces together, and they hide
their \fBdestroy\fR method so that it is not invoked inadvertently. It is
\fIrecommended\fR that any user changes to the slot mechanism be restricted to
defining new operations whose names start with a hyphen.
.VE
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
\fBoo::objdefine\fR commands (they work in the same way), as well as
illustrating four of the subcommands of them.
.PP
.CS
oo::class create c

Changes to doc/info.n.

31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
31
32
33
34
35
36
37

38
39
40

41
42
43
44
45
46
47







-
+


-







.TP
\fBinfo body \fIprocname\fR
.
Returns the body of procedure \fIprocname\fR.  \fIProcname\fR must be
the name of a Tcl command procedure.
.TP
\fBinfo class\fI subcommand class\fR ?\fIarg ...\fR
.VS 8.6
.
Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are
described in \fBCLASS INTROSPECTION\fR below.
.VE 8.6
.TP
\fBinfo cmdcount\fR
.
Returns a count of the total number of commands that have been invoked
in this interpreter.
.TP
\fBinfo commands \fR?\fIpattern\fR?
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
73
74
75
76
77
78
79

80
81
82
83

84
85
86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101







-
+



-










-
+







If the command does not appear to be complete then 0 is returned.
This command is typically used in line-oriented input environments
to allow users to type in commands that span multiple lines;  if the
command is not complete, the script can delay evaluating it until additional
lines have been typed to complete the command.
.TP
\fBinfo coroutine\fR
.VS 8.6
.
Returns the name of the currently executing \fBcoroutine\fR, or the empty
string if either no coroutine is currently executing, or the current coroutine
has been deleted (but has not yet returned or yielded since deletion).
.VE 8.6
.TP
\fBinfo default \fIprocname arg varname\fR
.
\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR
must be the name of an argument to that procedure.  If \fIarg\fR
does not have a default value then the command returns \fB0\fR.
Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
into variable \fIvarname\fR.
.TP
\fBinfo errorstack \fR?\fIinterp\fR?
.VS 8.6
.
Returns, in a form that is programmatically easy to parse, the function names
and arguments at each level from the call stack of the last error in the given
\fIinterp\fR, or in the current one if not specified.
.RS
.PP
This form is an even-sized list alternating tokens and parameters. Tokens are
currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
112
113
114
115
116
117
118

119
120
121
122
123
124
125







-







granularity.
.PP
This information is also present in the \fB\-errorstack\fR entry of the
options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
is a convenient way of retrieving it for uncaught errors at top-level in an
interactive \fBtclsh\fR.
.RE
.VE 8.6
.TP
\fBinfo exists \fIvarName\fR
.
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.
.TP
325
326
327
328
329
330
331
332

333
334
335
336
337
338
339
340
341
342
322
323
324
325
326
327
328

329
330
331

332
333
334
335
336
337
338







-
+


-







\fBinfo nameofexecutable\fR
.
Returns the full path name of the binary file from which the application
was invoked.  If Tcl was unable to identify the file, then an empty
string is returned.
.TP
\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
.VS 8.6
.
Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are
described in \fBOBJECT INTROSPECTION\fR below.
.VE 8.6
.TP
\fBinfo patchlevel\fR
.
Returns the value of the global variable \fBtcl_patchLevel\fR, which holds
the exact version of the Tcl library by default.
.TP
\fBinfo procs \fR?\fIpattern\fR?
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415





416
417
418
419
420
421
422
423
424
425
426





427
428
429
430
431

432
433
434
435
436
437
438
439
440
441

442
443
444
445
446
447
448
449
450

451
452
453
454
455
456

457
458
459
460
461

462
463
464
465
466
467

468
469
470
471
472
473
474

475
476
477
478
479
480
481


482
483




484
485
486
487
488


489
490
491





492




















493
494


495
496
497

498
499
500
501
502
503
504
505
506

507
508
509
510
511
512

513
514
515
516
517
518
519
520

521
522
523
524
525

526

527
528
529




530
531
532
533
534
535
536

537
538
539
540
541





542
543
544
545
546
547
548
549
550
551
552
553





554
555
556
557
558

559
560
561











562

563
564
565

566
567
568
569
570
571
572
573
574

575
576
577
578
579

580
581
582
583
584
585

586
587
588
589
590
591
592
593

594
595
596
597
598
599

600
601
602
603
604
605

606
607
608
609
610

611
612
613
614
615

616
617
618
619
620
621
622
623

624
625
626
627
628
629
630


631
632




633
634
635
636
637


638
639
640





641




















642
643


644
645
646

647
648
649
650
651
652
653
654
655

656
657
658
659
660
661

662
663
664
665
666

667

668
669
670



671

672
673
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
391
392
393
394
395
396
397

398
399

400
401

402
403
404
405
406
407
408

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423

424
425
426
427
428
429

430
431

432
433
434
435
436
437
438

439
440

441
442
443
444
445
446

447
448

449
450
451

452
453

454
455

456
457

458
459
460

461
462

463
464
465
466

467
468

469
470
471
472
473

474
475
476
477


478
479
480
481
482
483

484
485
486
487



488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514

515
516
517
518

519
520
521
522
523
524

525
526

527
528
529

530
531

532
533
534
535
536

537
538

539
540
541

542

543

544
545
546
547
548
549
550
551
552
553
554

555
556

557
558
559
560
561

562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577

578
579
580
581
582
583

584
585

586
587
588
589
590
591
592
593
594
595
596
597
598
599
600

601
602
603

604
605
606
607
608
609

610
611

612
613

614
615

616
617
618

619
620

621
622
623
624

625
626
627

628
629
630

631
632

633
634
635

636
637

638
639

640
641

642
643

644
645

646
647
648
649
650

651
652

653
654
655
656
657

658
659
660
661


662
663
664
665
666
667

668
669
670
671



672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702

703
704
705
706
707
708

709
710

711
712
713

714
715

716
717
718

719

720

721
722
723
724
725
726
727

728
729
730

731
732
733
734
735
736
737
738
739

740
741
742
743
744
745
746







-


-


-
+






-
+
+
+
+
+










-
+
+
+
+
+

-


-
+






-


-
+





-


-
+


-


-
+

-


-
+


-


-
+



-


-
+




-


+
+
-
-
+
+
+
+


-


+
+
-
-
-
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+
+


-
+





-


-
+


-


-
+




-


-
+


-

-
+
-
+



+
+
+
+



-


-
+




-
+
+
+
+
+











-
+
+
+
+
+

-


-
+



+
+
+
+
+
+
+
+
+
+
+
-
+


-
+





-


-
+

-


-
+


-


-
+



-



-
+


-


-
+


-


-
+

-


-
+

-


-
+




-


-
+




-


+
+
-
-
+
+
+
+


-


+
+
-
-
-
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+
+


-
+





-


-
+


-


-
+


-

-
+
-
+



+
+
+
-
+


-
+








-







has each matching namespace variable qualified with the name
of its namespace.
Note that a currently-visible variable may not yet
.QW exist
if it has not
been set (e.g. a variable declared but not set by \fBvariable\fR).
.SS "CLASS INTROSPECTION"
.VS 8.6
.PP
The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
.VE 8.6
.TP
\fBinfo class call\fI class method\fR
.VS
.
Returns a description of the method implementations that are used to provide a
stereotypical instance of \fIclass\fR's implementation of \fImethod\fR
(stereotypical instances being objects instantiated by a class without having
any object-specific definitions added). This consists of a list of lists of
four elements, where each sublist consists of a word that describes the
general type of method implementation (being one of \fBmethod\fR for an
ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
ordinary method, \fBfilter\fR for an applied filter,
.VS TIP500
\fBprivate\fR for a private method,
.VE TIP500
and \fBunknown\fR for a
method that is invoked as part of unknown method handling), a word giving the
name of the particular method invoked (which is always the same as
\fImethod\fR for the \fBmethod\fR type, and
.QW \fBunknown\fR
for the \fBunknown\fR type), a word giving the fully qualified name of the
class that defined the method, and a word describing the type of method
implementation (see \fBinfo class methodtype\fR).
.RS
.PP
Note that there is no inspection of whether the method implementations
actually use \fBnext\fR to transfer control along the call chain.
actually use \fBnext\fR to transfer control along the call chain,
.VS TIP500
and the call chains that this command files do not actually contain private
methods.
.VE TIP500
.RE
.VE 8.6
.TP
\fBinfo class constructor\fI class\fR
.VS 8.6
.
This subcommand returns a description of the definition of the constructor of
class \fIclass\fR. The definition is described as a two element list; the first
element is the list of arguments to the constructor in a form suitable for
passing to another call to \fBproc\fR or a method definition, and the second
element is the body of the constructor. If no constructor is present, this
returns the empty list.
.VE 8.6
.TP
\fBinfo class definition\fI class method\fR
.VS 8.6
.
This subcommand returns a description of the definition of the method named
\fImethod\fR of class \fIclass\fR. The definition is described as a two element
list; the first element is the list of arguments to the method in a form
suitable for passing to another call to \fBproc\fR or a method definition, and
the second element is the body of the method.
.VE 8.6
.TP
\fBinfo class destructor\fI class\fR
.VS 8.6
.
This subcommand returns the body of the destructor of class \fIclass\fR. If no
destructor is present, this returns the empty string.
.VE 8.6
.TP
\fBinfo class filters\fI class\fR
.VS 8.6
.
This subcommand returns the list of filter methods set on the class.
.VE 8.6
.TP
\fBinfo class forward\fI class method\fR
.VS 8.6
.
This subcommand returns the argument list for the method forwarding called
\fImethod\fR that is set on the class called \fIclass\fR.
.VE 8.6
.TP
\fBinfo class instances\fI class\fR ?\fIpattern\fR?
.VS 8.6
.
This subcommand returns a list of instances of class \fIclass\fR. If the
optional \fIpattern\fR argument is present, it constrains the list of returned
instances to those that match it according to the rules of \fBstring match\fR.
.VE 8.6
.TP
\fBinfo class methods\fI class\fR ?\fIoptions...\fR?
.VS 8.6
.
This subcommand returns a list of all public (i.e. exported) methods of the
class called \fIclass\fR. Any of the following \fIoption\fRs may be
specified, controlling exactly which method names are returned:
.RS
.VE 8.6
.TP
\fB\-all\fR
.
If the \fB\-all\fR flag is given,
.VS 8.6
If the \fB\-all\fR flag is given, the list of methods will include those
.VS TIP500
and the \fB\-scope\fR flag is not given,
.VE TIP500
the list of methods will include those
methods defined not just by the class, but also by the class's superclasses
and mixins.
.VE 8.6
.TP
\fB\-private\fR
.
If the \fB\-private\fR flag is given,
.VS 8.6
If the \fB\-private\fR flag is given, the list of methods will also include
the private (i.e. non-exported) methods of the class (and superclasses and
.VS TIP500
and the \fB\-scope\fR flag is not given,
.VE TIP500
the list of methods will also include
the non-exported methods of the class (and superclasses and
mixins, if \fB\-all\fR is also given).
.VS TIP500
Note that this naming is an unfortunate clash with true private methods; this
option name is retained for backward compatibility.
.VE TIP500
.TP
\fB\-scope\fI scope\fR
.VS TIP500
Returns a list of all methods on \fIclass\fR that have the given visibility
\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
.RS
.IP \fBpublic\fR 3
Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance
of this class) are to be returned.
.IP \fBunexported\fR 3
Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
be returned.
.IP \fBprivate\fR 3
Only methods with \fIprivate\fR scope (i.e., only callable from within this class's
methods) are to be returned.
.RE
.VE 8.6
.VE TIP500
.RE
.TP
\fBinfo class methodtype\fI class method\fR
.VS 8.6
.
This subcommand returns a description of the type of implementation used for
the method named \fImethod\fR of class \fIclass\fR. When the result is
\fBmethod\fR, further information can be discovered with \fBinfo class
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo class forward\fR.
.VE 8.6
.TP
\fBinfo class mixins\fI class\fR
.VS 8.6
.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.
.VE 8.6
.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
.VS 8.6
.
This subcommand returns a list of direct subclasses of class \fIclass\fR. If
the optional \fIpattern\fR argument is present, it constrains the list of
returned classes to those that match it according to the rules of
\fBstring match\fR.
.VE 8.6
.TP
\fBinfo class superclasses\fI class\fR
.VS 8.6
.
This subcommand returns a list of direct superclasses of class \fIclass\fR in
inheritance precedence order.
.VE 8.6
.TP
\fBinfo class variables\fI class\fR
\fBinfo class variables\fI class\fR ?\fB\-private\fR?
.VS 8.6
.
This subcommand returns a list of all variables that have been declared for
the class named \fIclass\fR (i.e. that are automatically present in the
class's methods, constructor and destructor).
.VS TIP500
If the \fB\-private\fR option is specified, this lists the private variables
declared instead.
.VE TIP500
.SS "OBJECT INTROSPECTION"
.PP
The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
.VE 8.6
.TP
\fBinfo object call\fI object method\fR
.VS 8.6
.
Returns a description of the method implementations that are used to provide
\fIobject\fR's implementation of \fImethod\fR.  This consists of a list of
lists of four elements, where each sublist consists of a word that describes
the general type of method implementation (being one of \fBmethod\fR for an
ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
ordinary method, \fBfilter\fR for an applied filter,
.VS TIP500
\fBprivate\fR for a private method,
.VE TIP500
and \fBunknown\fR for a
method that is invoked as part of unknown method handling), a word giving the
name of the particular method invoked (which is always the same as
\fImethod\fR for the \fBmethod\fR type, and
.QW \fBunknown\fR
for the \fBunknown\fR type), a word giving what defined the method (the fully
qualified name of the class, or the literal string \fBobject\fR if the method
implementation is on an instance), and a word describing the type of method
implementation (see \fBinfo object methodtype\fR).
.RS
.PP
Note that there is no inspection of whether the method implementations
actually use \fBnext\fR to transfer control along the call chain.
actually use \fBnext\fR to transfer control along the call chain,
.VS TIP500
and the call chains that this command files do not actually contain private
methods.
.VE TIP500
.RE
.VE 8.6
.TP
\fBinfo object class\fI object\fR ?\fIclassName\fR?
.VS 8.6
.
If \fIclassName\fR is unspecified, this subcommand returns class of the
\fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a
boolean value indicating whether the \fIobject\fR is of that class.
.TP
\fBinfo object creationid\fI object\fR
.VS TIP500
Returns the unique creation identifier for the \fIobject\fR object. This
creation identifier is unique to the object (within a Tcl interpreter) and
cannot be controlled at object creation time or altered afterwards.
.RS
.PP
\fIImplementation note:\fR the creation identifier is used to generate unique
identifiers associated with the object, especially for private variables.
.RE
.VE 8.6
.VE TIP500
.TP
\fBinfo object definition\fI object method\fR
.VS 8.6
.
This subcommand returns a description of the definition of the method named
\fImethod\fR of object \fIobject\fR. The definition is described as a two
element list; the first element is the list of arguments to the method in a
form suitable for passing to another call to \fBproc\fR or a method definition,
and the second element is the body of the method.
.VE 8.6
.TP
\fBinfo object filters\fI object\fR
.VS 8.6
.
This subcommand returns the list of filter methods set on the object.
.VE 8.6
.TP
\fBinfo object forward\fI object method\fR
.VS 8.6
.
This subcommand returns the argument list for the method forwarding called
\fImethod\fR that is set on the object called \fIobject\fR.
.VE 8.6
.TP
\fBinfo object isa\fI category object\fR ?\fIarg\fR?
.VS 8.6
.
This subcommand tests whether an object belongs to a particular category,
returning a boolean value that indicates whether the \fIobject\fR argument
meets the criteria for the category. The supported categories are:
.VE 8.6
.RS
.TP
\fBinfo object isa class\fI object\fR
.VS 8.6
.
This returns whether \fIobject\fR is a class (i.e. an instance of
\fBoo::class\fR or one of its subclasses).
.VE 8.6
.TP
\fBinfo object isa metaclass\fI object\fR
.VS 8.6
.
This returns whether \fIobject\fR is a class that can manufacture classes
(i.e. is \fBoo::class\fR or a subclass of it).
.VE 8.6
.TP
\fBinfo object isa mixin\fI object class\fR
.VS 8.6
.
This returns whether \fIclass\fR is directly mixed into \fIobject\fR.
.VE 8.6
.TP
\fBinfo object isa object\fI object\fR
.VS 8.6
.
This returns whether \fIobject\fR really is an object.
.VE 8.6
.TP
\fBinfo object isa typeof\fI object class\fR
.VS 8.6
.
This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether
\fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether
direct or indirect).
.RE
.VE 8.6
.TP
\fBinfo object methods\fI object\fR ?\fIoption...\fR?
.VS 8.6
.
This subcommand returns a list of all public (i.e. exported) methods of the
object called \fIobject\fR. Any of the following \fIoption\fRs may be
specified, controlling exactly which method names are returned:
.RS
.VE 8.6
.TP
\fB\-all\fR
.
If the \fB\-all\fR flag is given,
.VS 8.6
If the \fB\-all\fR flag is given, the list of methods will include those
.VS TIP500
and the \fB\-scope\fR flag is not given,
.VE TIP500
the list of methods will include those
methods defined not just by the object, but also by the object's class and
mixins, plus the superclasses of those classes.
.VE 8.6
.TP
\fB\-private\fR
.
If the \fB\-private\fR flag is given,
.VS 8.6
If the \fB\-private\fR flag is given, the list of methods will also include
the private (i.e. non-exported) methods of the object (and classes, if
.VS TIP500
and the \fB\-scope\fR flag is not given,
.VE TIP500
the list of methods will also include
the non-exported methods of the object (and classes, if
\fB\-all\fR is also given).
.VS TIP500
Note that this naming is an unfortunate clash with true private methods; this
option name is retained for backward compatibility.
.VE TIP500
.TP
\fB\-scope\fI scope\fR
.VS TIP500
Returns a list of all methods on \fIobject\fR that have the given visibility
\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
.RS
.IP \fBpublic\fR 3
Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be
returned.
.IP \fBunexported\fR 3
Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
be returned.
.IP \fBprivate\fR 3
Only methods with \fIprivate\fR scope (i.e., only callable from within this object's
instance methods) are to be returned.
.RE
.VE 8.6
.VE TIP500
.RE
.TP
\fBinfo object methodtype\fI object method\fR
.VS 8.6
.
This subcommand returns a description of the type of implementation used for
the method named \fImethod\fR of object \fIobject\fR. When the result is
\fBmethod\fR, further information can be discovered with \fBinfo object
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo object forward\fR.
.VE 8.6
.TP
\fBinfo object mixins\fI object\fR
.VS 8.6
.
This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
.VE 8.6
.TP
\fBinfo object namespace\fI object\fR
.VS 8.6
.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
.VE 8.6
.TP
\fBinfo object variables\fI object\fR
\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
.VS 8.6
.
This subcommand returns a list of all variables that have been declared for
the object named \fIobject\fR (i.e. that are automatically present in the
object's methods).
.VS TIP500
If the \fB\-private\fR option is specified, this lists the private variables
declared instead.
.VE 8.6
.VE TIP500
.TP
\fBinfo object vars\fI object\fR ?\fIpattern\fR?
.VS 8.6
.
This subcommand returns a list of all variables in the private namespace of
the object named \fIobject\fR. If the optional \fIpattern\fR argument is
given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
that constrains the list of variables returned. Note that this is different
from the list returned by \fBinfo object variables\fR; that can include
variables that are currently unset, whereas this can include variables that
are not automatically included by any of \fIobject\fR's methods (or those of
its class, superclasses or mixins).
.VE 8.6
.SH EXAMPLES
.PP
This command prints out a procedure suitable for saving in a Tcl
script:
.PP
.CS
proc printProc {procName} {
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726

727
728

729
730
731
732
733
734
735
755
756
757
758
759
760
761

762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792







-




















+


+







            lappend formals [list $var]
        }
    }
    puts [lappend result $formals [\fBinfo body\fR $procName]]
}
.CE
.SS "EXAMPLES WITH OBJECTS"
.VS 8.6
.PP
Every object necessarily knows what its class is; this information is
trivially extractable through introspection:
.PP
.CS
oo::class create c
c create o
puts [\fBinfo object class\fR o]
                     \fI\(-> prints "::c"\fR
puts [\fBinfo object class\fR c]
                     \fI\(-> prints "::oo::class"\fR
.CE
.PP
The introspection capabilities can be used to discover what class implements a
method and get how it is defined. This procedure illustrates how:
.PP
.CS
proc getDef {obj method} {
    foreach inf [\fBinfo object call\fR $obj $method] {
        lassign $inf calltype name locus methodtype

        # Assume no forwards or filters, and hence no $calltype
        # or $methodtype checks...

        if {$locus eq "object"} {
            return [\fBinfo object definition\fR $obj $name]
        } else {
            return [\fBinfo class definition\fR $locus $name]
        }
    }
    error "no definition for $method"
744
745
746
747
748
749
750

751

752
753
754
755
756
757
758

759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774

775
776
777
778
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822

823

824

825
826
827




828
829
830
831
832







+

+







+




-

-

-



-
-
-
-
+




.PP
.CS
proc getDef {obj method} {
    if {$method in [\fBinfo object methods\fR $obj]} {
        # Assume no forwards
        return [\fBinfo object definition\fR $obj $method]
    }

    set cls [\fBinfo object class\fR $obj]

    while {$method ni [\fBinfo class methods\fR $cls]} {
        # Assume the simple case
        set cls [lindex [\fBinfo class superclass\fR $cls] 0]
        if {$cls eq ""} {
            error "no definition for $method"
        }
    }

    # Assume no forwards
    return [\fBinfo class definition\fR $cls $method]
}
.CE
.VE 8.6
.SH "SEE ALSO"
.VS 8.6
global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n),
.VE 8.6
tcl_library(n), tcl_patchLevel(n), tcl_version(n)
.SH KEYWORDS
command, information, interpreter, introspection, level, namespace,
.VS 8.6
object,
.VE 8.6
procedure, variable
object, procedure, variable
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:

Changes to doc/my.n.

15
16
17
18
19
20
21
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
54
55
56
15
16
17
18
19
20
21

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

80
81
82
83







-
+


-
-
+
+
+
+
+
+
-
-
+
+
+














+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+




-




package require TclOO

\fBmy\fI methodName\fR ?\fIarg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBmy\fR command is used to allow methods of objects to invoke any method
The \fBmy\fR command is used to allow methods of objects to invoke methods
of the object (or its class). In particular, the set of valid values for
\fImethodName\fR is the set of all methods supported by an object and its
superclasses, including those that are not exported. The object upon which the
method is invoked is always the one that is the current context of the method
superclasses, including those that are not exported
.VS TIP500
and private methods of the object or class when used within another method
defined by that object or class.
.VE TIP500
The object upon which the method is invoked is the one that owns the namespace
(i.e. the object that is returned by \fBself object\fR) from which the
\fBmy\fR command is invoked.
that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
remains if the command is renamed), which is the currently invoked object by
default.
.PP
Each object has its own \fBmy\fR command, contained in its instance namespace.
.SH EXAMPLES
.PP
This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
the \fBoo::object\fR class, which is not publicly visible by default:
.PP
.CS
oo::class create c {
    method count {} {
        \fBmy\fR variable counter
        puts [incr counter]
    }
}

c create o
o count              \fI\(-> prints "1"\fR
o count              \fI\(-> prints "2"\fR
o count              \fI\(-> prints "3"\fR
.CE
.PP
This example shows how you can use \fBmy\fR to make callbacks to private
methods from outside the object (from a \fBtrace\fR), using
\fBnamespace code\fR to enter the correct context:
.PP
.CS
oo::class create HasCallback {
    method makeCallback {} {
        return [namespace code {
            \fBmy\fR Callback
        }]
    }

    method Callback {args} {
        puts "callback: $args"
    }
}

set o [HasCallback new]
trace add variable xyz write [$o makeCallback]
set xyz "called"     \fI\(-> prints "callback: xyz {} write"\fR
.CE
.SH "SEE ALSO"
next(n), oo::object(n), self(n)
.SH KEYWORDS
method, method visibility, object, private method, public method

.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

Changes to doc/next.n.

108
109
110
111
112
113
114

115
116
117
118
119
120
121
122
123

124
125
126
127
128
129
130
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







+









+







.PP
.CS
oo::class create theSuperclass {
    method example {args} {
        puts "in the superclass, args = $args"
    }
}

oo::class create theSubclass {
    superclass theSuperclass
    method example {args} {
        puts "before chaining from subclass, args = $args"
        \fBnext\fR a {*}$args b
        \fBnext\fR pureSynthesis
        puts "after chaining from subclass"
    }
}

theSubclass create obj
oo::objdefine obj method example args {
    puts "per-object method, args = $args"
    \fBnext\fR x {*}$args y
    \fBnext\fR
}
obj example 1 2 3
163
164
165
166
167
168
169

170
171
172
173
174
175
176
177
178
179
180

181
182
183
184

185
186
187
188
189
190
191
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196







+











+




+







        if {[info exist ValueCache($key)]} {
            return $ValueCache($key)
        }

        \fI# Compute value, insert into cache, and return it\fR
        return [set ValueCache($key) [\fBnext\fR {*}$args]]
    }

    method flushCache {} {
        my variable ValueCache
        unset ValueCache
        \fI# Skip the caching\fR
        return -level 2 ""
    }
}

oo::object create demo
oo::objdefine demo {
    mixin cache

    method compute {a b c} {
        after 3000 \fI;# Simulate deep thought\fR
        return [expr {$a + $b * $c}]
    }

    method compute2 {a b c} {
        after 3000 \fI;# Simulate deep thought\fR
        return [expr {$a * $b + $c}]
    }
}

puts [demo compute  1 2 3]      \fI\(-> prints "7" after delay\fR

Changes to doc/self.n.

28
29
30
31
32
33
34





35

36
37
38
39
40
41
42
28
29
30
31
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46
47







+
+
+
+
+
-
+







\fBself call\fR
.
This returns a two-element list describing the method implementations used to
implement the current call chain. The first element is the same as would be
reported by \fBinfo object\fR \fBcall\fR for the current method (except that this
also reports useful values from within constructors and destructors, whose
names are reported as \fB<constructor>\fR and \fB<destructor>\fR
respectively,
.VS TIP500
and for private methods, which are described as being \fBprivate\fR instead of
being a \fBmethod\fR),
.VE TIP500
respectively), and the second element is an index into the first element's
and the second element is an index into the first element's
list that indicates which actual implementation is currently executing (the
first implementation to execute is always at index 0).
.TP
\fBself caller\fR
.
When the method was invoked from inside another object method, this subcommand
returns a three element list describing the containing object and method. The

Changes to generic/tclInt.h.

1162
1163
1164
1165
1166
1167
1168




1169
1170
1171
1172
1173
1174
1175
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179







+
+
+
+







				 * clientData field contains a CallContext
				 * reference. Part of TIP#257. */
#define FRAME_IS_OO_DEFINE 0x8	/* The frame is part of the inside workings of
				 * the [oo::define] command; the clientData
				 * field contains an Object reference that has
				 * been confirmed to refer to a class. Part of
				 * TIP#257. */
#define FRAME_IS_PRIVATE_DEFINE 0x10
				/* Marks this frame as being used for private
				 * declarations with [oo::define]. Usually
				 * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */

/*
 * TIP #280
 * The structure below defines a command frame. A command frame provides
 * location information for all commands executing a tcl script (source, eval,
 * uplevel, procedure bodies, ...). The runtime structure essentially contains
 * the stack trace as it would be if the currently executing command were to

Changes to generic/tclOO.c.

27
28
29
30
31
32
33

34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50
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







+










+







} defineCmds[] = {
    {"constructor", TclOODefineConstructorObjCmd, 0},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
    {"destructor", TclOODefineDestructorObjCmd, 0},
    {"export", TclOODefineExportObjCmd, 0},
    {"forward", TclOODefineForwardObjCmd, 0},
    {"method", TclOODefineMethodObjCmd, 0},
    {"private", TclOODefinePrivateObjCmd, 0},
    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
    {"self", TclOODefineSelfObjCmd, 0},
    {"unexport", TclOODefineUnexportObjCmd, 0},
    {NULL, NULL, 0}
}, objdefCmds[] = {
    {"class", TclOODefineClassObjCmd, 1},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
    {"export", TclOODefineExportObjCmd, 1},
    {"forward", TclOODefineForwardObjCmd, 1},
    {"method", TclOODefineMethodObjCmd, 1},
    {"private", TclOODefinePrivateObjCmd, 1},
    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
    {"self", TclOODefineObjSelfObjCmd, 0},
    {"unexport", TclOODefineUnexportObjCmd, 1},
    {NULL, NULL, 0}
};

/*
989
990
991
992
993
994
995

996
997
998
999
1000
1001
1002
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005







+







{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVariable;

    /*
     * Sanity check!
     */

    if (!Deleted(oPtr)) {
	if (IsRootClass(oPtr)) {
1094
1095
1096
1097
1098
1099
1100








1101
1102
1103
1104
1105
1106
1107
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118







+
+
+
+
+
+
+
+








    FOREACH(variableObj, clsPtr->variables) {
	TclDecrRefCount(variableObj);
    }
    if (i) {
	ckfree(clsPtr->variables.list);
    }

    FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
	TclDecrRefCount(privateVariable->variableObj);
	TclDecrRefCount(privateVariable->fullNameObj);
    }
    if (i) {
	ckfree(clsPtr->privateVariables.list);
    }

    if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
    }
}

/*
1124
1125
1126
1127
1128
1129
1130

1131
1132
1133
1134
1135
1136
1137
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149







+







{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Deleted(oPtr)) {
	/*
	 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
	 * guard could be removed.
1158
1159
1160
1161
1162
1163
1164
1165

1166
1167
1168
1169
1170
1171
1172
1170
1171
1172
1173
1174
1175
1176

1177
1178
1179
1180
1181
1182
1183
1184







-
+







     * interpreter is being deleted; their incestuous nature causes problems
     * in that case when the destructor is partially deleted before the uses
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;

	Tcl_InterpState state;
	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
1243
1244
1245
1246
1247
1248
1249








1250
1251
1252
1253
1254
1255
1256
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276







+
+
+
+
+
+
+
+








    FOREACH(variableObj, oPtr->variables) {
	TclDecrRefCount(variableObj);
    }
    if (i) {
	ckfree(oPtr->variables.list);
    }

    FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
	TclDecrRefCount(privateVariable->variableObj);
	TclDecrRefCount(privateVariable->fullNameObj);
    }
    if (i) {
	ckfree(oPtr->privateVariables.list);
    }

    if (oPtr->chainCache) {
	TclOODeleteChainCache(oPtr->chainCache);
    }

    SquelchCachedName(oPtr);

1627
1628
1629
1630
1631
1632
1633
1634

1635
1636
1637
1638
1639
1640
1641
1647
1648
1649
1650
1651
1652
1653

1654
1655
1656
1657
1658
1659
1660
1661







-
+







    /*
     * Run constructors, except when objc < 0, which is a special flag case
     * used for object cloning only.
     */

    if (objc >= 0) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);

	if (contextPtr != NULL) {
	    int isRoot, result;
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
1700
1701
1702
1703
1704
1705
1706
1707

1708
1709
1710
1711
1712
1713
1714
1720
1721
1722
1723
1724
1725
1726

1727
1728
1729
1730
1731
1732
1733
1734







-
+







     * object cloning only). If there aren't any constructors, we do nothing.
     */

    if (objc < 0) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }
    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
    if (contextPtr == NULL) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }

    state = Tcl_SaveInterpState(interp, TCL_OK);
    contextPtr->callPtr->flags |= CONSTRUCTOR;
1880
1881
1882
1883
1884
1885
1886

1887
1888
1889
1890
1891
1892
1893
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914







+







{
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    PrivateVariableMapping *privateVariable;
    int i, result;

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
1949
1950
1951
1952
1953
1954
1955
1956

1957
1958
1959
1960
1961
1962







1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976

1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997







-
+






+
+
+
+
+
+
+








    DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
    FOREACH(filterObj, o2Ptr->filters) {
	Tcl_IncrRefCount(filterObj);
    }

    /*
     * Copy the object's variable resolution list to the new object.
     * Copy the object's variable resolution lists to the new object.
     */

    DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
    FOREACH(variableObj, o2Ptr->variables) {
	Tcl_IncrRefCount(variableObj);
    }

    DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
	    PrivateVariableMapping);
    FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
	Tcl_IncrRefCount(privateVariable->variableObj);
	Tcl_IncrRefCount(privateVariable->fullNameObj);
    }

    /*
     * Copy the object's flags to the new object, clearing those that must be
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */
2045
2046
2047
2048
2049
2050
2051
2052

2053
2054
2055
2056
2057
2058







2059
2060
2061
2062
2063
2064
2065
2073
2074
2075
2076
2077
2078
2079

2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100







-
+






+
+
+
+
+
+
+








	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
	FOREACH(filterObj, cls2Ptr->filters) {
	    Tcl_IncrRefCount(filterObj);
	}

	/*
	 * Copy the source class's variable resolution list.
	 * Copy the source class's variable resolution lists.
	 */

	DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
	FOREACH(variableObj, cls2Ptr->variables) {
	    Tcl_IncrRefCount(variableObj);
	}

	DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
		PrivateVariableMapping);
	FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
	    Tcl_IncrRefCount(privateVariable->variableObj);
	    Tcl_IncrRefCount(privateVariable->fullNameObj);
	}

	/*
	 * Duplicate the source class's mixins (which cannot be circular
	 * references to the duplicate).
	 */

	if (cls2Ptr->mixins.num != 0) {
2125
2126
2127
2128
2129
2130
2131
2132


2133
2134
2135
2136
2137
2138
2139
2160
2161
2162
2163
2164
2165
2166

2167
2168
2169
2170
2171
2172
2173
2174
2175







-
+
+







			    duplicate);
		}
	    }
	}
    }

    TclResetRewriteEnsemble(interp, 1);
    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
	    NULL, NULL);
    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]);
2522
2523
2524
2525
2526
2527
2528



2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540


















2541
2542
2543
2544
2545
2546
2547
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604







+
+
+












+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    Class *startCls)		/* Where to start in the call chain, or NULL
				 * if we are to start at the front with
				 * filters and the object's methods (which is
				 * the normal case). */
{
    CallContext *contextPtr;
    Tcl_Obj *methodNamePtr;
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    Object *callerObjPtr = NULL;
    Class *callerClsPtr = NULL;
    int result;

    /*
     * If we've no method name, throw this directly into the unknown
     * processing.
     */

    if (objc < 2) {
	flags |= FORCE_UNKNOWN;
	methodNamePtr = NULL;
	goto noMapping;
    }

    /*
     * Determine if we're in a context that can see the extra, private methods
     * in this class.
     */

    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	CallContext *callerContextPtr = framePtr->clientData;
	Method *callerMethodPtr =
		callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;

	if (callerMethodPtr->declaringObjectPtr) {
	    callerObjPtr = callerMethodPtr->declaringObjectPtr;
	}
	if (callerMethodPtr->declaringClassPtr) {
	    callerClsPtr = callerMethodPtr->declaringClassPtr;
	}
    }

    /*
     * Give plugged in code a chance to remap the method name.
     */

    methodNamePtr = objv[1];
    if (oPtr->mapMethodNameProc != NULL) {
2562
2563
2564
2565
2566
2567
2568
2569


2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586


2587
2588
2589
2590
2591
2592
2593
2619
2620
2621
2622
2623
2624
2625

2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643

2644
2645
2646
2647
2648
2649
2650
2651
2652







-
+
+
















-
+
+








	/*
	 * Get the call chain for the remapped name.
	 */

	Tcl_IncrRefCount(mappedMethodName);
	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
		callerClsPtr, methodNamePtr);
	TclDecrRefCount(mappedMethodName);
	if (contextPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "impossible to invoke method \"%s\": no defined method or"
		    " unknown method", TclGetString(methodNamePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
		    TclGetString(methodNamePtr), NULL);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Get the call chain.
	 */

    noMapping:
	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
		flags | (oPtr->flags & FILTER_HANDLING), NULL);
		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
		callerClsPtr, NULL);
	if (contextPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "impossible to invoke method \"%s\": no defined method or"
		    " unknown method", TclGetString(methodNamePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), NULL);
	    return TCL_ERROR;

Changes to generic/tclOO.decls.

54
55
56
57
58
59
60
61

62
63
64
65
66

67
68
69
70
71
72
73
54
55
56
57
58
59
60

61
62
63
64
65

66
67
68
69
70
71
72
73







-
+




-
+







	    ClientData *clientDataPtr)
}
declare 10 {
    Tcl_Obj *Tcl_MethodName(Tcl_Method method)
}
declare 11 {
    Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
	    ClientData clientData)
}
declare 12 {
    Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
	    ClientData clientData)
}
declare 13 {
    Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
	    const char *nameStr, const char *nsNameStr, int objc,
	    Tcl_Obj *const *objv, int skip)
}
122
123
124
125
126
127
128



129
130
131
132
133
134
135
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138







+
+
+







declare 27 {
    void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz,
	    Tcl_Method method)
}
declare 28 {
    Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
}
declare 29 {
    int Tcl_MethodIsPrivate(Tcl_Method method)
}

######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
# TclOO; not intended for general use and does not have any commitment to
# long-term support.
#

Changes to generic/tclOO.h.

95
96
97
98
99
100
101









102
103
104
105
106
107
108
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117







+
+
+
+
+
+
+
+
+







/*
 * The correct value for the version field of the Tcl_MethodType structure.
 * This allows new versions of the structure to be introduced without breaking
 * binary compatability.
 */

#define TCL_OO_METHOD_VERSION_CURRENT 1

/*
 * Visibility constants for the flags parameter to Tcl_NewMethod and
 * Tcl_NewInstanceMethod.
 */

#define TCL_OO_METHOD_PUBLIC		1
#define TCL_OO_METHOD_UNEXPORTED	0
#define TCL_OO_METHOD_PRIVATE		0x20

/*
 * The type of some object (or class) metadata. This describes how to delete
 * the metadata (when the object or class is deleted) and how to create a
 * clone of it (when the object or class is copied).
 */

Changes to generic/tclOOBasic.c.

343
344
345
346
347
348
349
350


351
352
353
354
355
356
357
343
344
345
346
347
348
349

350
351
352
353
354
355
356
357
358







-
+
+







    if (objc != Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
	oPtr->flags |= DESTRUCTOR_CALLED;
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
		NULL);
	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
		    NULL, NULL, NULL);
	    TclPushTailcallPoint(interp);
	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
495
496
497
498
499
500
501


502
503
504

505
506
507
508
509
510
511
512
513
514
515
516





















517
518
519
520
521
522

523
524
525
526
527
528
529
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546

547
548
549
550
551
552
553
554







+
+



+












+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
+







    Tcl_Interp *interp,		/* Interpreter in which to create the object;
				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    CallContext *contextPtr = (CallContext *) context;
    Object *callerObj = NULL;
    Class *callerCls = NULL;
    Object *oPtr = contextPtr->oPtr;
    const char **methodNames;
    int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    Tcl_Obj *errorMsg;

    /*
     * If no method name, generate an error asking for a method name. (Only by
     * overriding *this* method can an object handle the absence of a method
     * name without an error).
     */

    if (objc < skip+1) {
	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Determine if the calling context should know about extra private
     * methods, and if so, which.
     */

    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	CallContext *callerContext = framePtr->clientData;
	Method *mPtr = callerContext->callPtr->chain[
		    callerContext->index].mPtr;

	if (mPtr->declaringObjectPtr) {
	    if (oPtr == mPtr->declaringObjectPtr) {
		callerObj = mPtr->declaringObjectPtr;
	    }
	} else {
	    if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
		callerCls = mPtr->declaringClassPtr;
	    }
	}
    }

    /*
     * Get the list of methods that we want to know about.
     */

    numMethodNames = TclOOGetSortedMethodList(oPtr,
    numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
	    contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);

    /*
     * Special message when there are no visible methods at all.
     */

    if (numMethodNames == 0) {
680
681
682
683
684
685
686

687
688
689
690
691
692
693
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719







+







				 * also used for error reporting. */
    Tcl_ObjectContext context,	/* The object/call context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    Var *varPtr, *aryVar;
    Tcl_Obj *varNamePtr, *argPtr;
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    const char *arg;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }
704
705
706
707
708
709
710




















































711
712
713
714
715
716
717
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







     */

    if (arg[0] == ':' && arg[1] == ':') {
	varNamePtr = argPtr;
    } else {
	Tcl_Namespace *namespacePtr =
		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));

	/*
	 * Private method handling. [TIP 500]
	 *
	 * If we're in a context that can see some private methods of an
	 * object, we may need to precede a variable name with its prefix.
	 * This is a little tricky as we need to check through the inheritance
	 * hierarchy when the method was declared by a class to see if the
	 * current object is an instance of that class.
	 */

	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
	    CallContext *callerContext = framePtr->clientData;
	    Method *mPtr = callerContext->callPtr->chain[
		    callerContext->index].mPtr;
	    PrivateVariableMapping *pvPtr;
	    int i;

	    if (mPtr->declaringObjectPtr == oPtr) {
		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
		    if (!strcmp(Tcl_GetString(pvPtr->variableObj),
			    Tcl_GetString(argPtr))) {
			argPtr = pvPtr->fullNameObj;
			break;
		    }
		}
	    } else if (mPtr->declaringClassPtr &&
		    mPtr->declaringClassPtr->privateVariables.num) {
		Class *clsPtr = mPtr->declaringClassPtr;
		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
		Class *mixinCls;

		if (!isInstance) {
		    FOREACH(mixinCls, oPtr->mixins) {
			if (TclOOIsReachable(clsPtr, mixinCls)) {
			    isInstance = 1;
			    break;
			}
		    }
		}
		if (isInstance) {
		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
			if (!strcmp(Tcl_GetString(pvPtr->variableObj),
				Tcl_GetString(argPtr))) {
			    argPtr = pvPtr->fullNameObj;
			    break;
			}
		    }
		}
	    }
	}

	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
	Tcl_AppendToObj(varNamePtr, "::", 2);
	Tcl_AppendObjToObj(varNamePtr, argPtr);
    }
    Tcl_IncrRefCount(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747




748
749
750
751
752
753
754
755
756
757
758
803
804
805
806
807
808
809



810
811
812
813
814
815







816
817
818
819




820
821
822
823
824
825
826







-
-
-






-
-
-
-
-
-
-
+
+
+
+
-
-
-
-







    /*
     * Now that we've pinned down what variable we're really talking about
     * (including traversing variable links), convert back to a name.
     */

    varNamePtr = Tcl_NewObj();
    if (aryVar != NULL) {
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch search;

	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);

	/*
	 * WARNING! This code pokes inside the implementation of hash tables!
	 */

	hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
		&search);
	while (hPtr != NULL) {
	    if (varPtr == Tcl_GetHashValue(hPtr)) {
		Tcl_AppendToObj(varNamePtr, "(", -1);
		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
		Tcl_AppendToObj(varNamePtr, ")", -1);
	Tcl_AppendToObj(varNamePtr, "(", -1);
	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
		varPtr)->entry.key.objPtr);
	Tcl_AppendToObj(varNamePtr, ")", -1);
		break;
	    }
	    hPtr = Tcl_NextHashEntry(&search);
	}
    } else {
	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}


Changes to generic/tclOOCall.c.

41
42
43
44
45
46
47






















48
49
50
51
52
53
54
55
56
57
58
59
60
61







62








63
64
65
66
67

68
69
70
71
72
73
74
75
76
77
78
79


80
81
82
83
84
85
86
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102

103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+














+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+




-
+












+
+







#define BUILDING_MIXINS	   0x400000
#define TRAVERSED_MIXIN	   0x800000
#define OBJECT_MIXIN	   0x1000000
#define MIXIN_CONSISTENT(flags) \
    (((flags) & OBJECT_MIXIN) ||					\
	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))

/*
 * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
 * Itcl's special type of private.
 */

#define IS_PUBLIC(mPtr)				\
    (((mPtr)->flags & PUBLIC_METHOD) != 0)
#define IS_UNEXPORTED(mPtr)			\
    (((mPtr)->flags & SCOPE_FLAGS) == 0)
#define IS_ITCLPRIVATE(mPtr)				\
    (((mPtr)->flags & PRIVATE_METHOD) != 0)
#define IS_PRIVATE(mPtr)			\
    (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
#define WANT_PUBLIC(flags)			\
    (((flags) & PUBLIC_METHOD) != 0)
#define WANT_UNEXPORTED(flags)			\
    (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
#define WANT_ITCLPRIVATE(flags)			\
    (((flags) & PRIVATE_METHOD) != 0)
#define WANT_PRIVATE(flags)			\
    (((flags) & TRUE_PRIVATE_METHOD) != 0)

/*
 * Function declarations for things defined in this file.
 */

static void		AddClassFiltersToCallContext(Object *const oPtr,
			    Class *clsPtr, struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags);
static void		AddClassMethodNames(Class *clsPtr, const int flags,
			    Tcl_HashTable *const namesPtr,
			    Tcl_HashTable *const examinedClassesPtr);
static inline void	AddMethodToCallChain(Method *const mPtr,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters,
			    Class *const filterDecl, int flags);
static inline int	AddInstancePrivateToCallContext(Object *const oPtr,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr, int flags);
static inline void	AddStandardMethodName(int flags, Tcl_Obj *namePtr,
			    Method *mPtr, Tcl_HashTable *namesPtr);
static inline void	AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
			    Tcl_HashTable *namesPtr);
static inline void	AddSimpleChainToCallContext(Object *const oPtr,
static inline int	AddSimpleChainToCallContext(Object *const oPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		AddPrivatesFromClassChainToCallContext(Class *classPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static void		AddSimpleClassChainToCallContext(Class *classPtr,
static int		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc	FinalizeMethodRefs;
static void		FreeMethodNameRep(Tcl_Obj *objPtr);
static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
			    int flags, int reuseMask);
static Tcl_NRPostProc	ResetFilterFlags;
static Tcl_NRPostProc	SetFilterFlags;
static int		SortMethodNames(Tcl_HashTable *namesPtr, int flags,
			    const char ***stringsPtr);
static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);

/*
 * Object type used to manage type caches attached to method names.
 */

static const Tcl_ObjType methodNameType = {
362
363
364
365
366
367
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
394
395
396
397
398
399
400
401
402

403
404
405



406
407
408

409
410
411
412
413
414
415
416
417
418
419
420
421
422

423
424
425
426



427
428
429
430
431
432

433
434
435
436
437
438
439
440
441
442












443
444
445
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460
461
462

463
464
465
466

467
468
469
470
471

472
473
474
475
476
477
478
479
480
481
482

483
484
485
486
487

488
489
490
491
492
493
494
495
496
497
498
499

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518
519
520
521
522
523
524
525
526
527
528
529
530


















































531
532
533
534
535
536
537
538
539
540
541
542
543
544










545
546
547
548
549
550
551
552
553
554









555
556
557
558
559





560
561
562
563
564
565
566
567
568









569
570
571
572
573
574
575

576
577
578
579
580
581
582
583
584

585
586
587
588
589
590
591
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426

427
428
429
430


431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447



448
449
450
451
452

453






454
455
456
457
458
459
460

461
462



463
464
465






466










467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487

488
489
490
491


492




493




494





495
496










497





498










499

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516


517


518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583









584
585
586
587
588
589
590
591
592
593
594









595
596
597
598
599
600
601
602
603
604




605
606
607
608
609
610








611
612
613
614
615
616
617
618
619



620
621
622

623
624
625
626
627
628
629
630
631

632
633
634
635
636
637
638
639







+
+
+
+
+
+
+
+












-
+



-
-
















+
-
-
-
+
+
+


-
+
-
-
-
-
-
-







-
+

-
-
-
+
+
+
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+









-
+



-
-

-
-
-
-
+
-
-
-
-
+
-
-
-
-
-
+

-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-

-
+
















-
-
+
-
-











+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+

-
-
-
-
+
+
+
+
+

-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-



-
+








-
+







 *
 * ----------------------------------------------------------------------
 */

int
TclOOGetSortedMethodList(
    Object *oPtr,		/* The object to get the method names for. */
    Object *contextObj,		/* From what context object we are inquiring.
				 * NULL when the context shouldn't see
				 * object-level private methods. Note that
				 * flags can override this. */
    Class *contextCls,		/* From what context class we are inquiring.
				 * NULL when the context shouldn't see
				 * class-level private methods. Note that
				 * flags can override this. */
    int flags,			/* Whether we just want the public method
				 * names. */
    const char ***stringsPtr)	/* Where to write a pointer to the array of
				 * strings to. */
{
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* Used to track what classes have been looked
				 * at. Is set-like in nature and keyed by
				 * pointer to class. */
    FOREACH_HASH_DECLS;
    int i;
    int i, numStrings;
    Class *mixinPtr;
    Tcl_Obj *namePtr;
    Method *mPtr;
    int isWantedIn;
    void *isWanted;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

    /*
     * Name the bits used in the names table values.
     */
#define IN_LIST 1
#define NO_IMPLEMENTATION 2

    /*
     * Process method names due to the object.
     */

    if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (IS_PRIVATE(mPtr)) {
	    int isNew;

	    if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
		continue;
	    }
	    if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
		continue;
	    }
	    hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
	    AddStandardMethodName(flags, namePtr, mPtr, &names);
	    if (isNew) {
		isWantedIn = ((!(flags & PUBLIC_METHOD)
			|| mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
		isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
		Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
	    }
	}
    }

    /*
     * Process method names due to private methods on the object's class.
     */

    if (flags & PRIVATE_METHOD) {
    if (WANT_UNEXPORTED(flags)) {
	FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
	    if (mPtr->flags & PRIVATE_METHOD) {
		int isNew;

	    if (IS_UNEXPORTED(mPtr)) {
		AddStandardMethodName(flags, namePtr, mPtr, &names);
	    }
		hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
		if (isNew) {
		    isWantedIn = IN_LIST;
		    if (mPtr->typePtr == NULL) {
			isWantedIn |= NO_IMPLEMENTATION;
		    }
	}
		    Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
		} else if (mPtr->typePtr != NULL) {
		    isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
		    if (isWantedIn & NO_IMPLEMENTATION) {
			isWantedIn &= ~NO_IMPLEMENTATION;
			Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
		    }
		}
	    }
	}
    }

    /*
     * Process method names due to private methods on the context's object or
     * class. Which must be correct if either are not NULL.
     */

    if (contextObj && contextObj->methodsPtr) {
	AddPrivateMethodNames(contextObj->methodsPtr, &names);
    }
    if (contextCls) {
	AddPrivateMethodNames(&contextCls->classMethods, &names);
    }

    /*
     * Process (normal) method names from the class hierarchy and the mixin
     * hierarchy.
     */

    AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses);
    FOREACH(mixinPtr, oPtr->mixins) {
	AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names,
	AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names,
		&examinedClasses);
    }

    Tcl_DeleteHashTable(&examinedClasses);

    /*
     * See how many (visible) method names there are. If none, we do not (and
     * should not) try to sort the list of them.
     */

     * Tidy up, sort the names and resolve finally whether we really want
    i = 0;
    if (names.numEntries != 0) {
	const char **strings;

     * them (processing export layering).
	/*
	 * We need to build the list of methods to sort. We will be using
	 * qsort() for this, because it is very unlikely that the list will be
	 * heavily sorted when it is long enough to matter.
	 */
     */

	strings = ckalloc(sizeof(char *) * names.numEntries);
	FOREACH_HASH(namePtr, isWanted, &names) {
	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
		    continue;
		}
		strings[i++] = TclGetString(namePtr);
	    }
	}

    Tcl_DeleteHashTable(&examinedClasses);
	/*
	 * Note that 'i' may well be less than names.numEntries when we are
	 * dealing with public method names.
	 */

    numStrings = SortMethodNames(&names, flags, stringsPtr);
	if (i > 0) {
	    if (i > 1) {
		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
	    }
	    *stringsPtr = strings;
	} else {
	    ckfree(strings);
	}
    }

    Tcl_DeleteHashTable(&names);
    return i;
    return numStrings;
}

int
TclOOGetSortedClassMethodList(
    Class *clsPtr,		/* The class to get the method names for. */
    int flags,			/* Whether we just want the public method
				 * names. */
    const char ***stringsPtr)	/* Where to write a pointer to the array of
				 * strings to. */
{
    Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
				 * mapping. */
    Tcl_HashTable examinedClasses;
				/* Used to track what classes have been looked
				 * at. Is set-like in nature and keyed by
				 * pointer to class. */
    FOREACH_HASH_DECLS;
    int i;
    int numStrings;
    Tcl_Obj *namePtr;
    void *isWanted;

    Tcl_InitObjHashTable(&names);
    Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);

    /*
     * Process method names from the class hierarchy and the mixin hierarchy.
     */

    AddClassMethodNames(clsPtr, flags, &names, &examinedClasses);
    Tcl_DeleteHashTable(&examinedClasses);

    /*
     * Process private method names if we should. [TIP 500]
     */

    if (WANT_PRIVATE(flags)) {
	AddPrivateMethodNames(&clsPtr->classMethods, &names);
	flags &= ~TRUE_PRIVATE_METHOD;
    }

    /*
     * Tidy up, sort the names and resolve finally whether we really want
     * them (processing export layering).
     */

    numStrings = SortMethodNames(&names, flags, stringsPtr);
    Tcl_DeleteHashTable(&names);
    return numStrings;
}

/*
 * ----------------------------------------------------------------------
 *
 * SortMethodNames --
 *
 *	Shared helper for TclOOGetSortedMethodList etc. that knows the method
 *	sorting rules.
 *
 * Returns:
 *	The length of the sorted list.
 *
 * ----------------------------------------------------------------------
 */

static int
SortMethodNames(
    Tcl_HashTable *namesPtr,	/* The table of names; unsorted, but contains
				 * whether the names are wanted and under what
				 * circumstances. */
    int flags,			/* Whether we are looking for unexported
				 * methods. Full private methods are handled
				 * on insertion to the table. */
    const char ***stringsPtr)	/* Where to store the sorted list of strings
				 * that we produce. ckalloced() */
{
    const char **strings;
    FOREACH_HASH_DECLS;
    Tcl_Obj *namePtr;
    void *isWanted;
    int i = 0;

    /*
     * See how many (visible) method names there are. If none, we do not (and
     * should not) try to sort the list of them.
     */

    i = 0;
    if (names.numEntries != 0) {
	const char **strings;

	/*
	 * We need to build the list of methods to sort. We will be using
	 * qsort() for this, because it is very unlikely that the list will be
	 * heavily sorted when it is long enough to matter.
	 */
    if (namesPtr->numEntries == 0) {
	*stringsPtr = NULL;
	return 0;
    }

    /*
     * We need to build the list of methods to sort. We will be using qsort()
     * for this, because it is very unlikely that the list will be heavily
     * sorted when it is long enough to matter.
     */

	strings = ckalloc(sizeof(char *) * names.numEntries);
	FOREACH_HASH(namePtr, isWanted, &names) {
	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
		    continue;
		}
		strings[i++] = TclGetString(namePtr);
	    }
	}
    strings = ckalloc(sizeof(char *) * namesPtr->numEntries);
    FOREACH_HASH(namePtr, isWanted, namesPtr) {
	if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
	    if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
		continue;
	    }
	    strings[i++] = TclGetString(namePtr);
	}
    }

	/*
	 * Note that 'i' may well be less than names.numEntries when we are
	 * dealing with public method names.
	 */
    /*
     * Note that 'i' may well be less than names.numEntries when we are
     * dealing with public method names. We don't sort unless there's at least
     * two method names.
     */

	if (i > 0) {
	    if (i > 1) {
		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
	    }
	    *stringsPtr = strings;
	} else {
	    ckfree(strings);
	}
    if (i > 0) {
	if (i > 1) {
	    qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
	}
	*stringsPtr = strings;
    } else {
	ckfree(strings);
	*stringsPtr = NULL;
    }
    }

    Tcl_DeleteHashTable(&names);
    return i;
}

/* Comparator for GetSortedMethodList */
/* Comparator for SortMethodNames */
static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;

    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1);
}

/*
 * ----------------------------------------------------------------------
 *
 * AddClassMethodNames --
 *
610
611
612
613
614
615
616


617
618
619
620
621
622
623
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673







+
+







				 * semantics are handled correctly. */
    Tcl_HashTable *const examinedClassesPtr)
				/* Hash table that tracks what classes have
				 * already been looked at. The keys are the
				 * pointers to the classes, and the values are
				 * immaterial. */
{
    int i;

    /*
     * If we've already started looking at this class, stop working on it now
     * to prevent repeated work.
     */

    if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) {
	return;
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662

663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692



































































































693
694
695
696
697
698

699
700
701
702
703

704
705



706
707
708
709
710
711
712
713
714
715
716
717
718
719



720
721
722

723
724
725
726
727
728
729




730
731
732
733
734
735







736
737
738
739
740
741
742
743

744
745
746
747









748
749
750
751





752
753
754






755
756




757
758
759
760
761
762
763
690
691
692
693
694
695
696

697
698
699
700
701
702
703
704
705
706





707









708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831

832
833
834
835
836

837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855

856
857
858
859
860

861

862
863




864
865
866
867






868
869
870
871
872
873
874
875
876
877
878

879
880
881
882




883
884
885
886
887
888
889
890
891
892
893


894
895
896
897
898
899
900
901
902
903
904
905
906
907


908
909
910
911
912
913
914
915
916
917
918







-










-
-
-
-
-
+
-
-
-
-
-
-
-
-
-









-











+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
+




-
+


+
+
+













-
+
+
+


-
+
-


-
-
-
-
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+




-



+
-
-
-
-
+
+
+
+
+
+
+
+
+


-
-
+
+
+
+
+



+
+
+
+
+
+
-
-
+
+
+
+







		&isNew);
	if (!isNew) {
	    break;
	}

	if (clsPtr->mixins.num != 0) {
	    Class *mixinPtr;
	    int i;

	    FOREACH(mixinPtr, clsPtr->mixins) {
		if (mixinPtr != clsPtr) {
		    AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN,
			    namesPtr, examinedClassesPtr);
		}
	    }
	}

	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
	    if (isNew) {
		int isWanted = (!(flags & PUBLIC_METHOD)
			|| (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;

	    AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
		isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	    } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
		    && mPtr->typePtr != NULL) {
		int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));

		isWanted &= ~NO_IMPLEMENTATION;
		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	    }
	}

	if (clsPtr->superclasses.num != 1) {
	    break;
	}
	clsPtr = clsPtr->superclasses.list[0];
    }
    if (clsPtr->superclasses.num != 0) {
	Class *superPtr;
	int i;

	FOREACH(superPtr, clsPtr->superclasses) {
	    AddClassMethodNames(superPtr, flags, namesPtr,
		    examinedClassesPtr);
	}
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddPrivateMethodNames, AddStandardMethodName --
 *
 *	Factored-out helpers for the sorted name list production functions.
 *
 * ----------------------------------------------------------------------
 */

static inline void
AddPrivateMethodNames(
    Tcl_HashTable *methodsTablePtr,
    Tcl_HashTable *namesPtr)
{
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Tcl_Obj *namePtr;

    FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
	if (IS_PRIVATE(mPtr)) {
	    int isNew;

	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
	    Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST));
	}
    }
}

static inline void
AddStandardMethodName(
    int flags,
    Tcl_Obj *namePtr,
    Method *mPtr,
    Tcl_HashTable *namesPtr)
{
    if (!IS_PRIVATE(mPtr)) {
	int isNew;
	Tcl_HashEntry *hPtr =
		Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);

	if (isNew) {
	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
		    ? IN_LIST : 0;

	    isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
		&& mPtr->typePtr != NULL) {
	    int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));

	    isWanted &= ~NO_IMPLEMENTATION;
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	}
    }
}

#undef IN_LIST
#undef NO_IMPLEMENTATION

/*
 * ----------------------------------------------------------------------
 *
 * AddInstancePrivateToCallContext --
 *
 *	Add private methods from the instance. Called when the calling Tcl
 *	context is a TclOO method declared by an object that is the same as
 *	the current object. Returns true iff a private method was actually
 *	found and added to the call chain (as this suppresses caching).
 *
 * ----------------------------------------------------------------------
 */

static inline int
AddInstancePrivateToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */
    struct ChainBuilder *const cbPtr,
				/* Where to add the call chain entries. */
    int flags)			/* What sort of call chain are we building. */
{
    Tcl_HashEntry *hPtr;
    Method *mPtr;
    int donePrivate = 0;

    if (oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
	if (hPtr != NULL) {
	    mPtr = Tcl_GetHashValue(hPtr);
	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
		donePrivate = 1;
	    }
	}
    }
    return donePrivate;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleChainToCallContext --
 *
 *	The core of the call-chain construction engine, this handles calling a
 *	particular method on a particular object. Note that filters and
 *	unknown handling are already handled by the logic that uses this
 *	function.
 *	function. Returns true if a private method was one of those found.
 *
 * ----------------------------------------------------------------------
 */

static inline void
static inline int
AddSimpleChainToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. [TIP 500] */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    struct ChainBuilder *const cbPtr,
				/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    int i;
    int i, foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
		(char *) methodNameObj);

	if (hPtr != NULL) {
	    Method *mPtr = Tcl_GetHashValue(hPtr);

	    if (flags & PUBLIC_METHOD) {
		if (!(mPtr->flags & PUBLIC_METHOD)) {
	    mPtr = Tcl_GetHashValue(hPtr);
	    if (!IS_PRIVATE(mPtr)) {
		if (WANT_PUBLIC(flags)) {
		    if (!IS_PUBLIC(mPtr)) {
		    return;
		} else {
		    flags |= DEFINITE_PUBLIC;
		}
	    } else {
		flags |= DEFINITE_PROTECTED;
			blockedUnexported = 1;
		    } else {
			flags |= DEFINITE_PUBLIC;
		    }
		} else {
		    flags |= DEFINITE_PROTECTED;
		}
	    }
	}
    }
    if (!(flags & SPECIAL)) {
	Tcl_HashEntry *hPtr;
	Class *mixinPtr;

	FOREACH(mixinPtr, oPtr->mixins) {
	    if (contextCls) {
	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
		    doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
	}
	if (oPtr->methodsPtr) {
		foundPrivate |= AddPrivatesFromClassChainToCallContext(
			mixinPtr, contextCls, methodNameObj, cbPtr,
			doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
	    }
	    foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
		    methodNameObj, cbPtr, doneFilters,
		    flags | TRAVERSED_MIXIN, filterDecl);
	}
	if (oPtr->methodsPtr && !blockedUnexported) {
	    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
	    if (hPtr != NULL) {
		AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
			doneFilters, filterDecl, flags);
		mPtr = Tcl_GetHashValue(hPtr);
		if (!IS_PRIVATE(mPtr)) {
		    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			    flags);
		}
	    }
	}
    }
    if (contextCls) {
	foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
		contextCls, methodNameObj, cbPtr, doneFilters, flags,
		filterDecl);
    }
    if (!blockedUnexported) {
    AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
	    doneFilters, flags, filterDecl);
	foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls,
		methodNameObj, cbPtr, doneFilters, flags, filterDecl);
    }
    return foundPrivate;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddMethodToCallChain --
 *
812
813
814
815
816
817
818
819
820


821
822
823
824
825
826
827
967
968
969
970
971
972
973


974
975
976
977
978
979
980
981
982







-
-
+
+







     *  3) this is a class method, AND
     *  4) this method was not declared by the class of the current object.
     *
     * This does mean that only classes really handle private methods. This
     * should be sufficient for [incr Tcl] support though.
     */

    if (!(callPtr->flags & PRIVATE_METHOD)
	    && (mPtr->flags & PRIVATE_METHOD)
    if (!WANT_UNEXPORTED(callPtr->flags)
	    && IS_UNEXPORTED(mPtr)
	    && (mPtr->declaringClassPtr != NULL)
	    && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
	return;
    }

    /*
     * First test whether the method is already in the call chain. Skip over
854
855
856
857
858
859
860
861

862
863
864
865
866
867
868
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023







-
+







     * Need to really add the method. This is made a bit more complex by the
     * fact that we are using some "static" space initially, and only start
     * realloc-ing if the chain gets long.
     */

    if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
	callPtr->chain =
		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1));
		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
	memcpy(callPtr->chain, callPtr->staticChain,
		sizeof(struct MInvoke) * callPtr->numChain);
    } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
	callPtr->chain = ckrealloc(callPtr->chain,
		sizeof(struct MInvoke) * (callPtr->numChain + 1));
    }
    callPtr->chain[i].mPtr = mPtr;
953
954
955
956
957
958
959






960
961
962
963
964
965
966
967

968
969
970
971
972
973
974
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127

1128
1129
1130
1131
1132
1133
1134
1135







+
+
+
+
+
+







-
+







    Tcl_Obj *methodNameObj,	/* The name of the method to get the context
				 * for. NULL when getting a constructor or
				 * destructor chain. */
    int flags,			/* What sort of context are we looking for.
				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
				 * PRIVATE_METHOD, DESTRUCTOR and
				 * FILTER_HANDLING are useful. */
    Object *contextObj,		/* Context object; when equal to oPtr, it
				 * means that private methods may also be
				 * added. [TIP 500] */
    Class *contextCls,		/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. [TIP 500] */
    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
				 * to be in the same object as the
				 * methodNameObj. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    struct ChainBuilder cb;
    int i, count, doFilters;
    int i, count, doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }
    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
1000
1001
1002
1003
1004
1005
1006
1007

1008
1009
1010
1011
1012
1013
1014
1161
1162
1163
1164
1165
1166
1167

1168
1169
1170
1171
1172
1173
1174
1175







-
+







	/*
	 * Check if we can get the chain out of the Tcl_Obj method name or out
	 * of the cache. This is made a bit more complex by the fact that
	 * there are multiple different layers of cache (in the Tcl_Obj, in
	 * the object, and in the class).
	 */

	const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
	const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);

	if (cacheInThisObj->typePtr == &methodNameType) {
	    callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
		callPtr->refCount++;
		goto returnContext;
	    }
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062





1063
1064
1065
1066
1067
1068
1069
1213
1214
1215
1216
1217
1218
1219




1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231







-
-
-
-
+
+
+
+
+







    cb.oPtr = oPtr;

    /*
     * If we're working with a forced use of unknown, do that now.
     */

    if (flags & FORCE_UNKNOWN) {
	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
		&cb, NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
		&cb, NULL, 0, NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
		NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = -1;
	if (callPtr->numChain == 0) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
	goto returnContext;
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094




1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108





1109
1110
1111




1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132





1133
1134
1135
1136
1137
1138
1139

1140
1141
1142
1143
1144
1145
1146
1246
1247
1248
1249
1250
1251
1252




1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275



1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296




1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307

1308
1309
1310
1311
1312
1313
1314
1315







-
-
-
-
+
+
+
+














+
+
+
+
+
-
-
-
+
+
+
+

















-
-
-
-
+
+
+
+
+






-
+







	FOREACH(mixinPtr, oPtr->mixins) {
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN);
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    OBJECT_MIXIN);
	}
	FOREACH(filterObj, oPtr->filters) {
	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
		    BUILDING_MIXINS, NULL);
	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
		    NULL);
	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
		    filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
		    filterObj, &cb, &doneFilters, 0, NULL);
	}
	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
		BUILDING_MIXINS);
	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
		0);
	Tcl_DeleteHashTable(&doneFilters);
    }
    count = cb.filterLength = callPtr->numChain;

    /*
     * Add the actual method implementations. We have to do this twice to
     * handle class mixins right.
     */

    if (oPtr == contextObj) {
	donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj,
		&cb, flags);
	donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS);
    }
    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
	    flags|BUILDING_MIXINS, NULL);
    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
	    methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL);
    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
	    methodNameObj, &cb, NULL, flags, NULL);

    /*
     * Check to see if the method has no implementation. If so, we probably
     * need to add in a call to the unknown method. Otherwise, set up the
     * cacheing of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	/*
	 * Method does not actually exist. If we're dealing with constructors
	 * or destructors, this isn't a problem.
	 */

	if (flags & SPECIAL) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
		&cb, NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
		&cb, NULL, 0, NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
		NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = -1;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
    } else if (doFilters) {
    } else if (doFilters && !donePrivate) {
	if (hPtr == NULL) {
	    if (oPtr->flags & USE_CLASS_CACHE) {
		if (oPtr->selfCls->classChainCache == NULL) {
		    oPtr->selfCls->classChainCache =
			    ckalloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
1238
1239
1240
1241
1242
1243
1244
1245

1246
1247
1248
1249
1250
1251
1252
1253
1407
1408
1409
1410
1411
1412
1413

1414

1415
1416
1417
1418
1419
1420
1421







-
+
-







     * in the class).
     */

    if (clsPtr->classChainCache != NULL) {
	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
		(char *) methodNameObj);
	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
	    const int reuseMask =
	    const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
		    ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);

	    callPtr = Tcl_GetHashValue(hPtr);
	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
		callPtr->refCount++;
		return callPtr;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
1283
1284
1285
1286
1287
1288
1289
1290

1291
1292


1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304




1305
1306
1307
1308
1309
1310
1311
1451
1452
1453
1454
1455
1456
1457

1458
1459

1460
1461
1462
1463
1464
1465
1466
1467
1468
1469




1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480







-
+

-
+
+








-
-
-
-
+
+
+
+







    Tcl_DeleteHashTable(&doneFilters);
    count = cb.filterLength = callPtr->numChain;

    /*
     * Add the actual method implementations.
     */

    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
	    flags|BUILDING_MIXINS, NULL);
    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags,
	    NULL);

    /*
     * Check to see if the method has no implementation. If so, we probably
     * need to add in a call to the unknown method. Otherwise, set up the
     * cacheing of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, 0, NULL);
	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
		&cb, NULL, BUILDING_MIXINS, NULL);
	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
		&cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = -1;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
    } else {
1377
1378
1379
1380
1381
1382
1383
1384

1385
1386

1387
1388
1389
1390
1391
1392
1393
1546
1547
1548
1549
1550
1551
1552

1553
1554

1555
1556
1557
1558
1559
1560
1561
1562







-
+

-
+







    if (MIXIN_CONSISTENT(flags)) {
	FOREACH(filterObj, clsPtr->filters) {
	    int isNew;

	    (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
		    &isNew);
	    if (isNew) {
		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
			doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
			doneFilters, clearedFlags, clsPtr);
	    }
	}
    }

    /*
     * Now process the recursive case. Notice the tail-call optimization.
1406
1407
1408
1409
1410
1411
1412
1413

1414
1415



1416
1417
1418
1419
1420
1421


1422
1423
1424




1425
1426
1427
1428
1429
1430
1431
1575
1576
1577
1578
1579
1580
1581

1582
1583

1584
1585
1586
1587
1588
1589
1590


1591
1592
1593


1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604







-
+

-
+
+
+




-
-
+
+

-
-
+
+
+
+







	return;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassChainToCallContext --
 * AddPrivatesFromClassChainToCallContext --
 *
 *	Construct a call-chain from a class hierarchy.
 *	Helper for AddSimpleChainToCallContext that is used to find private
 *	methds and add them to the call chain. Returns true when a private
 *	method is found and added. [TIP 500]
 *
 * ----------------------------------------------------------------------
 */

static void
AddSimpleClassChainToCallContext(
static int
AddPrivatesFromClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */
    struct ChainBuilder *const cbPtr,
				/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
1442
1443
1444
1445
1446
1447
1448

















































1449
1450































1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463



1464
1465
1466

1467
1468


1469
1470

1471
1472
1473
1474
1475
1476
1477
1478










1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489


1490
1491
1492

1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
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
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551








1552
1553

1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570

1571
1572
1573
1574
1575
1576
1577
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670


1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721


1722
1723


1724








1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743


1744
1745
1746
1747

1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767

1768
1769
1770
1771
1772
1773
1774
1775
1776

1777
1778

1779
1780

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
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+













+
+
+



+
-
-
+
+
-
-
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+









-
-
+
+


-
+



















-
+








-
+

-
+

-
+

+
+

















-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
+

















+







     *
     * Note that mixins must be processed before the main class hierarchy.
     * [Bug 1998221]
     */

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
		filterDecl)) {
	    return 1;
	}
    }

    if (classPtr == contextCls) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		(char *) methodName);

	if (hPtr != NULL) {
	    register Method *mPtr = Tcl_GetHashValue(hPtr);

	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
		return 1;
	    }
	}
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		    methodName, cbPtr, doneFilters, flags, filterDecl)) {
		return 1;
	    }
	}
    case 0:
	return 0;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassChainToCallContext --
 *
 *	Construct a call-chain from a class hierarchy.
 *
 * ----------------------------------------------------------------------
 */

static int
	AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
		doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
AddSimpleClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    struct ChainBuilder *const cbPtr,
				/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    int i, privateDanger = 0;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.
     * [Bug 1998221]
     */

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	privateDanger |= AddSimpleClassChainToCallContext(superPtr,
		methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
		filterDecl);
    }

    if (flags & CONSTRUCTOR) {
	AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
		filterDecl, flags);

    } else if (flags & DESTRUCTOR) {
	AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
		filterDecl, flags);
    } else {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		(char *) methodNameObj);

	if (classPtr->flags & HAS_PRIVATE_METHODS) {
	    privateDanger |= 1;
	}
	if (hPtr != NULL) {
	    register Method *mPtr = Tcl_GetHashValue(hPtr);

	    if (!IS_PRIVATE(mPtr)) {
	    if (!(flags & KNOWN_STATE)) {
		if (flags & PUBLIC_METHOD) {
		if (!(flags & KNOWN_STATE)) {
		    if (flags & PUBLIC_METHOD) {
		    if (mPtr->flags & PUBLIC_METHOD) {
			flags |= DEFINITE_PUBLIC;
			if (!IS_PUBLIC(mPtr)) {
		    } else {
			return;
		    }
		} else {
		    flags |= DEFINITE_PROTECTED;
		}
	    }
	    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags);
			    return privateDanger;
			}
			flags |= DEFINITE_PUBLIC;
		    } else {
			flags |= DEFINITE_PROTECTED;
		    }
		}
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
	    }
	}
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
		    doneFilters, flags, filterDecl);
	    privateDanger |= AddSimpleClassChainToCallContext(superPtr,
		    methodNameObj, cbPtr, doneFilters, flags, filterDecl);
	}
    case 0:
	return;
	return privateDanger;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOORenderCallChain --
 *
 *	Create a description of a call chain. Used in [info object call],
 *	[info class call], and [self call].
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOORenderCallChain(
    Tcl_Interp *interp,
    CallChain *callPtr)
{
    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
    Tcl_Obj *resultObj, *descObjs[4], **objv;
    Foundation *fPtr = TclOOGetFoundation(interp);
    int i;

    /*
     * Allocate the literals (potentially) used in our description.
     */

    filterLiteral = Tcl_NewStringObj("filter", -1);
    TclNewLiteralStringObj(filterLiteral, "filter");
    Tcl_IncrRefCount(filterLiteral);
    methodLiteral = Tcl_NewStringObj("method", -1);
    TclNewLiteralStringObj(methodLiteral, "method");
    Tcl_IncrRefCount(methodLiteral);
    objectLiteral = Tcl_NewStringObj("object", -1);
    TclNewLiteralStringObj(objectLiteral, "object");
    Tcl_IncrRefCount(objectLiteral);
    TclNewLiteralStringObj(privateLiteral, "private");
    Tcl_IncrRefCount(privateLiteral);

    /*
     * Do the actual construction of the descriptions. They consist of a list
     * of triples that describe the details of how a method is understood. For
     * each triple, the first word is the type of invocation ("method" is
     * normal, "unknown" is special because it adds the method name as an
     * extra argument when handled by some method types, and "filter" is
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i=0 ; i<callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] = miPtr->isFilter
		? filterLiteral
		: callPtr->flags & OO_UNKNOWN_METHOD
			? fPtr->unknownMethodNameObj
			: methodLiteral;
	descObjs[1] = callPtr->flags & CONSTRUCTOR
		? fPtr->constructorName
		: callPtr->flags & DESTRUCTOR
	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;
	descObjs[1] =
	    callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
	    callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
			? fPtr->destructorName
			: miPtr->mPtr->namePtr;
		    miPtr->mPtr->namePtr;
	descObjs[2] = miPtr->mPtr->declaringClassPtr
		? Tcl_GetObjectName(interp,
			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
		: objectLiteral;
	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);

	objv[i] = Tcl_NewListObj(4, descObjs);
    }

    /*
     * Drop the local references to the literals; if they're actually used,
     * they'll live on the description itself.
     */

    Tcl_DecrRefCount(filterLiteral);
    Tcl_DecrRefCount(methodLiteral);
    Tcl_DecrRefCount(objectLiteral);
    Tcl_DecrRefCount(privateLiteral);

    /*
     * Finish building the description and return it.
     */

    resultObj = Tcl_NewListObj(callPtr->numChain, objv);
    TclStackFree(interp, objv);

Changes to generic/tclOODecls.h.

55
56
57
58
59
60
61
62

63
64
65
66

67
68
69
70
71
72
73
55
56
57
58
59
60
61

62
63
64
65

66
67
68
69
70
71
72
73







-
+



-
+







				const Tcl_MethodType *typePtr,
				ClientData *clientDataPtr);
/* 10 */
TCLAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
/* 11 */
TCLAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
				Tcl_Object object, Tcl_Obj *nameObj,
				int isPublic, const Tcl_MethodType *typePtr,
				int flags, const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 12 */
TCLAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
				Tcl_Obj *nameObj, int isPublic,
				Tcl_Obj *nameObj, int flags,
				const Tcl_MethodType *typePtr,
				ClientData clientData);
/* 13 */
TCLAPI Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
				Tcl_Class cls, const char *nameStr,
				const char *nsNameStr, int objc,
				Tcl_Obj *const *objv, int skip);
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
159
160
161
162
163
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
159
160
161
162
163
164
165
166







+
+




















-
-
+
+
















+







				Tcl_Class clazz, Tcl_Method method);
/* 27 */
TCLAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
				Tcl_Class clazz, Tcl_Method method);
/* 28 */
TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
				Tcl_Object object);
/* 29 */
TCLAPI int		Tcl_MethodIsPrivate(Tcl_Method method);

typedef struct {
    const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;

typedef struct TclOOStubs {
    int magic;
    const TclOOStubHooks *hooks;

    Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */
    Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */
    Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
    Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
    Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
    Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
    Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
    Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
    int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
    int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */
    Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
    Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
    int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
    int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
    Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
    Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
    int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
    ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */
    void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */
    ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */
    void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */
    int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */
    Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
    void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */
    void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
    void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
    Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
    int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
} TclOOStubs;

extern const TclOOStubs *tclOOStubsPtr;

#ifdef __cplusplus
}
#endif
222
223
224
225
226
227
228


229
230
231
232
233
234
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239







+
+






	(tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */
#define Tcl_ClassSetConstructor \
	(tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */
#define Tcl_ClassSetDestructor \
	(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
#define Tcl_GetObjectName \
	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
#define Tcl_MethodIsPrivate \
	(tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */

#endif /* defined(USE_TCLOO_STUBS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLOODECLS */

Changes to generic/tclOODefineCmds.c.

12
13
14
15
16
17
18






19
20
21
22
23
24
25
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31







+
+
+
+
+
+








#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

/*
 * The actual value used to mark private declaration frames.
 */

#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)

/*
 * The maximum length of fully-qualified object name to use in an errorinfo
 * message. Longer than this will be curtailed.
 */

#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30

114
115
116
117
118
119
120





























121
122
123
124
125
126
127
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
159
160
161
162







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};

/*
 * How to build the in-namespace name of a private variable. This is a pattern
 * used with Tcl_ObjPrintf().
 */

#define PRIVATE_VARIABLE_PATTERN "%d : %s"

/*
 * ----------------------------------------------------------------------
 *
 * IsPrivateDefine --
 *
 *	Extracts whether the current context is handling private definitions.
 *
 * ----------------------------------------------------------------------
 */

static inline int
IsPrivateDefine(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;

    if (!iPtr->varFramePtr) {
	return 0;
    }
    return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
}

/*
 * ----------------------------------------------------------------------
 *
 * BumpGlobalEpoch --
 *
 *	Utility that ensures that call chains that are invalid will get thrown
415
416
417
418
419
420
421





















































































































422
423
424
425
426
427
428
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    }
    BumpGlobalEpoch(interp, classPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * InstallStandardVariableMapping, InstallPrivateVariableMapping --
 *
 *	Helpers for installing standard and private variable maps.
 *
 * ----------------------------------------------------------------------
 */
static inline void
InstallStandardVariableMapping(
    VariableNameList *vnlPtr,
    int varc,
    Tcl_Obj *const *varv)
{
    Tcl_Obj *variableObj;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH(variableObj, *vnlPtr) {
	Tcl_DecrRefCount(variableObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree(vnlPtr->list);
	} else if (i) {
	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
	} else {
	    vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc);
	}
    }
    vnlPtr->num = 0;
    if (varc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<varc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
	    if (created) {
		vnlPtr->list[n++] = varv[i];
	    } else {
		Tcl_DecrRefCount(varv[i]);
	    }
	}
	vnlPtr->num = n;

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	if (n != varc) {
	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static inline void
InstallPrivateVariableMapping(
    PrivateVariableList *pvlPtr,
    int varc,
    Tcl_Obj *const *varv,
    int creationEpoch)
{
    PrivateVariableMapping *privatePtr;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH_STRUCT(privatePtr, *pvlPtr) {
	Tcl_DecrRefCount(privatePtr->variableObj);
	Tcl_DecrRefCount(privatePtr->fullNameObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree(pvlPtr->list);
	} else if (i) {
	    pvlPtr->list = ckrealloc(pvlPtr->list,
		    sizeof(PrivateVariableMapping) * varc);
	} else {
	    pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc);
	}
    }

    pvlPtr->num = 0;
    if (varc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<varc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
	    if (created) {
		privatePtr = &(pvlPtr->list[n++]);
		privatePtr->variableObj = varv[i];
		privatePtr->fullNameObj = Tcl_ObjPrintf(
			PRIVATE_VARIABLE_PATTERN,
			creationEpoch, Tcl_GetString(varv[i]));
		Tcl_IncrRefCount(privatePtr->fullNameObj);
	    } else {
		Tcl_DecrRefCount(varv[i]);
	    }
	}
	pvlPtr->num = n;

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	if (n != varc) {
	    pvlPtr->list = ckrealloc(pvlPtr->list,
		    sizeof(PrivateVariableMapping) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * RenameDeleteMethod --
 *
 *	Core of the code to rename and delete methods.
 *
 * ----------------------------------------------------------------------
 */

704
705
706
707
708
709
710
711


712
713
714
715
716
717
718
856
857
858
859
860
861
862

863
864
865
866
867
868
869
870
871







-
+
+







TclOOGetDefineCmdContext(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object;

    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command may only be called from within the context of"
		" an ::oo::define or ::oo::objdefine command", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    object = iPtr->varFramePtr->clientData;
745
746
747
748
749
750
751
752


753
754
755
756
757
758
759
898
899
900
901
902
903
904

905
906
907
908
909
910
911
912
913







-
+
+







    Tcl_Obj *className,
    const char *errMsg)
{
    Interp *iPtr = (Interp *) interp;
    Object *oPtr;
    CallFrame *savedFramePtr = iPtr->varFramePtr;

    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
	    || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
	if (iPtr->varFramePtr->callerVarPtr == NULL) {
	    Tcl_Panic("getting outer context when already in global context");
	}
	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
    iPtr->varFramePtr = savedFramePtr;
1034
1035
1036
1037
1038
1039
1040
1041

1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052


1053
1054
1055
1056
1057
1058
1059
1060



1061
1062
1063
1064
1065
1066
1067
1068

1069
1070
1071
1072
1073
1074
1075
1188
1189
1190
1191
1192
1193
1194

1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226

1227
1228
1229
1230
1231
1232
1233
1234







-
+











+
+








+
+
+







-
+







    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Foundation *fPtr = TclOOGetFoundation(interp);
    Object *oPtr;
    int result;
    int result, private;

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    if (objc < 2) {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
	return TCL_OK;
    }

    private = IsPrivateDefine(interp);

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }
    if (private) {
	((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
    }

    AddRef(oPtr);
    if (objc == 2) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	Tcl_IncrRefCount(objNameObj);
	result = TclEvalObjEx(interp, objv[1], 0,
		((Interp *)interp)->cmdFramePtr, 2);
		((Interp *)interp)->cmdFramePtr, 1);
	if (result == TCL_ERROR) {
	    GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
	}
	TclDecrRefCount(objNameObj);
    } else {
	result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
    }
1112
1113
1114
1115
1116
1117
1118









































































1119
1120
1121
1122
1123
1124
1125
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefinePrivateObjCmd --
 *
 *	Implementation of the "private" subcommand of the "oo::define"
 *	and "oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefinePrivateObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstancePrivate = (clientData != NULL);
				/* Just so that we can generate the correct
				 * error message depending on the context of
				 * usage of this function. */
    Interp *iPtr = (Interp *) interp;
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int saved;			/* The saved flag. We restore it on exit so
				 * that [private private ...] doesn't make
				 * things go weird. */
    int result;

    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
	return TCL_OK;
    }

    /*
     * Change the frame type flag while evaluating the body.
     */

    saved = iPtr->varFramePtr->isProcCallFrame;
    iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;

    /*
     * Evaluate the body; standard pattern.
     */

    AddRef(oPtr);
    if (objc == 2) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	Tcl_IncrRefCount(objNameObj);
	result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
	if (result == TCL_ERROR) {
	    GenerateErrorInfo(interp, oPtr, objNameObj,
		    isInstancePrivate ? "object" : "class");
	}
	TclDecrRefCount(objNameObj);
    } else {
	result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
		1, objc, objv);
    }
    TclOODecrRefCount(oPtr);

    /*
     * Restore the frame type flag to what it was previously.
     */

    iPtr->varFramePtr->isProcCallFrame = saved;
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineClassObjCmd --
 *
 *	Implementation of the "class" subcommand of the "oo::objdefine"
1456
1457
1458
1459
1460
1461
1462
1463

1464

1465
1466
1467
1468
1469
1470
1471
1688
1689
1690
1691
1692
1693
1694

1695
1696
1697
1698
1699
1700
1701
1702
1703
1704







-
+

+







	    mPtr->refCount = 1;
	    mPtr->namePtr = objv[i];
	    Tcl_IncrRefCount(objv[i]);
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = Tcl_GetHashValue(hPtr);
	}
	if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
	    mPtr->flags |= PUBLIC_METHOD;
	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
	    changed = 1;
	}
    }

    /*
     * Bump the right epoch if we actually changed anything.
     */
1517
1518
1519
1520
1521
1522
1523



1524
1525
1526
1527
1528
1529
1530
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766







+
+
+







	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method structure.
     */

    prefixObj = Tcl_NewListObj(objc-2, objv+2);
    if (isInstanceForward) {
1576
1577
1578
1579
1580
1581
1582



1583
1584
1585
1586
1587
1588
1589
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828







+
+
+







	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method by using the right back-end API.
     */

    if (isInstanceMethod) {
	if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
1791
1792
1793
1794
1795
1796
1797
1798
1799


1800
1801
1802
1803
1804
1805
1806
2030
2031
2032
2033
2034
2035
2036


2037
2038
2039
2040
2041
2042
2043
2044
2045







-
-
+
+







	    mPtr->refCount = 1;
	    mPtr->namePtr = objv[i];
	    Tcl_IncrRefCount(objv[i]);
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = Tcl_GetHashValue(hPtr);
	}
	if (isNew || mPtr->flags & PUBLIC_METHOD) {
	    mPtr->flags &= ~PUBLIC_METHOD;
	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
	    changed = 1;
	}
    }

    /*
     * Bump the right epoch if we actually changed anything.
     */
2284
2285
2286
2287
2288
2289
2290
2291

2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308









2309
2310



2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326

2327
2328
2329
2330
2331
2332
2333
2523
2524
2525
2526
2527
2528
2529

2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556


2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574

2575
2576
2577
2578
2579
2580
2581
2582







-
+

















+
+
+
+
+
+
+
+
+
-
-
+
+
+















-
+







    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    Tcl_Obj *resultObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;

	FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
	}
    } else {
	Tcl_Obj *variableObj;

    FOREACH(variableObj, oPtr->classPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	FOREACH(variableObj, oPtr->classPtr->variables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassVarsSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv, *variableObj;
    Tcl_Obj **varv;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386


2387
2388
2389
2390

2391
2392
2393
2394
2395
2396

2397
2398
2399
2400

2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2609
2610
2611
2612
2613
2614
2615




















2616
2617




2618






2619




2620









2621
2622
2623
2624
2625
2626
2627







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
+
-
-
-
-
-
-
-
-
-







		    "invalid declared variable name \"%s\": must not %s",
		    varName, "refer to an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
    }

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH(variableObj, oPtr->classPtr->variables) {
	Tcl_DecrRefCount(variableObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree(oPtr->classPtr->variables.list);
	} else if (i) {
	    oPtr->classPtr->variables.list = (Tcl_Obj **)
		    ckrealloc((char *) oPtr->classPtr->variables.list,
		    sizeof(Tcl_Obj *) * varc);
	} else {
	    oPtr->classPtr->variables.list = (Tcl_Obj **)
		    ckalloc(sizeof(Tcl_Obj *) * varc);
	}
    }

    oPtr->classPtr->variables.num = 0;
    if (IsPrivateDefine(interp)) {
	InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
    if (varc > 0) {
	int created, n;
	Tcl_HashTable uniqueTable;

		varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<varc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
	    if (created) {
		oPtr->classPtr->variables.list[n++] = varv[i];
	    } else {
    } else {
		Tcl_DecrRefCount(varv[i]);
	    }
	}
	oPtr->classPtr->variables.num = n;
	InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	oPtr->classPtr->variables.list = (Tcl_Obj **)
		ckrealloc((char *) oPtr->classPtr->variables.list,
		sizeof(Tcl_Obj *) * n);
	Tcl_DeleteHashTable(&uniqueTable);
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
2581
2582
2583
2584
2585
2586
2587
2588

2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599









2600
2601



2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617

2618
2619
2620
2621
2622
2623
2624
2792
2793
2794
2795
2796
2797
2798

2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819


2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837

2838
2839
2840
2841
2842
2843
2844
2845







-
+











+
+
+
+
+
+
+
+
+
-
-
+
+
+















-
+







    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    Tcl_Obj *resultObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;

	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
	}
    } else {
	Tcl_Obj *variableObj;

    FOREACH(variableObj, oPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	FOREACH(variableObj, oPtr->variables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjVarsSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv, *variableObj;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653


2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673

2674
2675
2676
2677

2678
2679

2680
2681
2682
2683

2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2864
2865
2866
2867
2868
2869
2870




2871
2872




















2873




2874


2875




2876









2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887







-
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
+
-
-
+
-
-
-
-
+
-
-
-
-
-
-
-
-
-











	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "refer to an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
    }
    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }


    if (IsPrivateDefine(interp)) {
    FOREACH(variableObj, oPtr->variables) {
	Tcl_DecrRefCount(variableObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree(oPtr->variables.list);
	} else if (i) {
	    oPtr->variables.list = (Tcl_Obj **)
		    ckrealloc((char *) oPtr->variables.list,
		    sizeof(Tcl_Obj *) * varc);
	} else {
	    oPtr->variables.list = (Tcl_Obj **)
		    ckalloc(sizeof(Tcl_Obj *) * varc);
	}
    }
    oPtr->variables.num = 0;
    if (varc > 0) {
	int created, n;
	Tcl_HashTable uniqueTable;

	InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<varc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
	    if (created) {
		oPtr->creationEpoch);
		oPtr->variables.list[n++] = varv[i];
	    } else {
    } else {
		Tcl_DecrRefCount(varv[i]);
	    }
	}
	oPtr->variables.num = n;
	InstallStandardVariableMapping(&oPtr->variables, varc, varv);

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	oPtr->variables.list = (Tcl_Obj **)
		ckrealloc((char *) oPtr->variables.list,
		sizeof(Tcl_Obj *) * n);
	Tcl_DeleteHashTable(&uniqueTable);
    }
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOOInfo.c.

18
19
20
21
22
23
24

25
26
27
28
29
30
31
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32







+








static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
static Tcl_ObjCmdProc InfoObjectIdCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70







+








-
+







/*
 * List of commands that are used to implement the [info object] subcommands.
 */

static const EnsembleImplMap infoObjectCmds[] = {
    {"call",	   InfoObjectCallCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
    {"creationid", InfoObjectIdCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"definition", InfoObjectDefnCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
    {"methods",	   InfoObjectMethodsCmd,    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*
 * List of commands that are used to implement the [info class] subcommands.
 */
76
77
78
79
80
81
82
83

84
85
86
87
88
89
90
78
79
80
81
82
83
84

85
86
87
88
89
90
91
92







-
+







    {"forward",	     InfoClassForwardCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"instances",    InfoClassInstancesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"methods",	     InfoClassMethodsCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"methodtype",   InfoClassMethodTypeCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*
 * ----------------------------------------------------------------------
 *
 * TclOOInitInfo --
513
514
515
516
517
518
519
520

521
522
523
524
525

526
527
528








529
530
531
532
533
534
535
515
516
517
518
519
520
521

522
523
524
525
526

527
528
529

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544







-
+




-
+


-
+
+
+
+
+
+
+
+







InfoObjectMethodsCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    int flag = PUBLIC_METHOD, recurse = 0;
    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
    FOREACH_HASH_DECLS;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;
    static const char *const options[] = {
	"-all", "-localprivate", "-private", NULL
	"-all", "-localprivate", "-private", "-scope", NULL
    };
    enum Options {
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
    };
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_LOCALPRIVATE
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
549
550
551
552
553
554
555
556







557
558

























559
560
561
562
563
564


565
566
567
568
569
570
571
572
573
574
575

576
577
578
579
580
581
582
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572


573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602

603
604
605
606
607
608
609
610
611
612
613
614

615
616
617
618
619
620
621
622








+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
+
+










-
+







		recurse = 1;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;
	    case OPT_SCOPE:
		if (++i >= objc) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "missing option for -scope"));
		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
			    NULL);
		    return TCL_ERROR;
	    }
	}
		}
		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
			&scope) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    }
	}
    }
    if (scope != -1) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;
	case SCOPE_LOCALPRIVATE:
	    flag = PRIVATE_METHOD;
	    break;
	case SCOPE_UNEXPORTED:
	    flag = 0;
	    break;
	}
    }

    resultObj = Tcl_NewObj();
    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
		&names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    ckfree(names);
	}
    } else if (oPtr->methodsPtr) {
	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
	    }
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
680
681
682
683
684
685
686
































687
688
689
690
691
692
693
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectIdCmd --
 *
 *	Implements [info object creationid $objName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectIdCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectNsCmd --
 *
 *	Implements [info object namespace $objName]
 *
 * ----------------------------------------------------------------------
 */

715
716
717
718
719
720
721
722

723
724
725
726
727
728
729
730
731
732
733
734
735
736


737
738
739


740






741
742
743
744
745
746
747









748
749



750
751
752
753
754
755
756
787
788
789
790
791
792
793

794
795
796
797
798
799
800
801
802
803
804
805
806


807
808
809


810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834


835
836
837
838
839
840
841
842
843
844







-
+












-
-
+
+

-
-
+
+

+
+
+
+
+
+







+
+
+
+
+
+
+
+
+
-
-
+
+
+







}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectVariablesCmd --
 *
 *	Implements [info object variables $objName]
 *	Implements [info object variables $objName ?-private?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectVariablesCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *variableObj, *resultObj;
    int i;
    Tcl_Obj *resultObj;
    int i, private = 0;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
	    return TCL_ERROR;
	}
	private = 1;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    if (private) {
	PrivateVariableMapping *privatePtr;

	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
	}
    } else {
	Tcl_Obj *variableObj;

    FOREACH(variableObj, oPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	FOREACH(variableObj, oPtr->variables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
1124
1125
1126
1127
1128
1129
1130
1131

1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143

1144
1145
1146
1147
1148

1149
1150
1151







1152
1153
1154
1155
1156
1157
1158
1212
1213
1214
1215
1216
1217
1218

1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230

1231
1232
1233
1234
1235

1236
1237
1238

1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252







-
+











-
+




-
+


-
+
+
+
+
+
+
+







}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassMethodsCmd --
 *
 *	Implements [info class methods $clsName ?-private?]
 *	Implements [info class methods $clsName ?options...?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassMethodsCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int flag = PUBLIC_METHOD, recurse = 0;
    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;
    Class *clsPtr;
    static const char *const options[] = {
	"-all", "-localprivate", "-private", NULL
	"-all", "-localprivate", "-private", "-scope", NULL
    };
    enum Options {
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
    };
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
1172
1173
1174
1175
1176
1177
1178
1179







1180
1181






















1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200

1201
1202
1203
1204
1205
1206
1207
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280


1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320

1321
1322
1323
1324
1325
1326
1327
1328








+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


















-
+







		recurse = 1;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;
	    case OPT_SCOPE:
		if (++i >= objc) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "missing option for -scope"));
		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
			    NULL);
		    return TCL_ERROR;
	    }
	}
		}
		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
			&scope) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    }
	}
    }
    if (scope != -1) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;
	case SCOPE_UNEXPORTED:
	    flag = 0;
	    break;
	}
    }

    resultObj = Tcl_NewObj();
    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], -1));
	}
	if (numNames > 0) {
	    ckfree(names);
	}
    } else {
	FOREACH_HASH_DECLS;

	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
	    }
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
1395
1396
1397
1398
1399
1400
1401
1402

1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416


1417
1418
1419


1420






1421
1422
1423
1424
1425
1426
1427









1428
1429



1430
1431
1432
1433
1434
1435
1436
1516
1517
1518
1519
1520
1521
1522

1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535


1536
1537
1538


1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563


1564
1565
1566
1567
1568
1569
1570
1571
1572
1573







-
+












-
-
+
+

-
-
+
+

+
+
+
+
+
+







+
+
+
+
+
+
+
+
+
-
-
+
+
+







}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassVariablesCmd --
 *
 *	Implements [info class variables $clsName]
 *	Implements [info class variables $clsName ?-private?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassVariablesCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *variableObj, *resultObj;
    int i;
    Tcl_Obj *resultObj;
    int i, private = 0;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
	    return TCL_ERROR;
	}
	private = 1;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    if (private) {
	PrivateVariableMapping *privatePtr;

	FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
	}
    } else {
	Tcl_Obj *variableObj;

    FOREACH(variableObj, clsPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	FOREACH(variableObj, clsPtr->variables) {
	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
	}
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
1461
1462
1463
1464
1465
1466
1467
1468


1469
1470
1471
1472
1473
1474
1475
1598
1599
1600
1601
1602
1603
1604

1605
1606
1607
1608
1609
1610
1611
1612
1613







-
+
+







	return TCL_ERROR;
    }

    /*
     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
	    NULL);
    if (contextPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));

Changes to generic/tclOOInt.h.

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
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
159
160
161
162
163
164
165
166
167
168
169







+
+
+
+
+
+
+
+
+
+
+
+

















+
+
+
+
+
+
+








typedef struct ForwardMethod {
    Tcl_Obj *prefixObj;		/* The list of values to use to replace the
				 * object and method name with. Will be a
				 * non-empty list. */
} ForwardMethod;

/*
 * Structure used in private variable mappings. Describes the mapping of a
 * single variable from the user's local name to the system's storage name.
 * [TIP #500]
 */

typedef struct {
    Tcl_Obj *variableObj;	/* Name used within methods. This is the part
				 * that is properly under user control. */
    Tcl_Obj *fullNameObj;	/* Name used at the instance namespace level. */
} PrivateVariableMapping;

/*
 * Helper definitions that declare a "list" array. The two varieties are
 * either optimized for simplicity (in the case that the whole array is
 * typically assigned at once) or efficiency (in the case that the array is
 * expected to be expanded over time). These lists are designed to be iterated
 * over with the help of the FOREACH macro (see later in this file).
 *
 * The "num" field always counts the number of listType_t elements used in the
 * "list" field. When a "size" field exists, it describes how many elements
 * are present in the list; when absent, exactly "num" elements are present.
 */

#define LIST_STATIC(listType_t) \
    struct { int num; listType_t *list; }
#define LIST_DYNAMIC(listType_t) \
    struct { int num, size; listType_t *list; }

/*
 * These types are needed in function arguments.
 */

typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;

/*
 * Now, the definition of what an object actually is.
 */

typedef struct Object {
    struct Foundation *fPtr;	/* The basis for the object system. Putting
				 * this here allows the avoidance of quite a
182
183
184
185
186
187
188
189




190
191
192
193
194
195
196
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218







-
+
+
+
+







				 * allocated if metadata is attached. */
    Tcl_Obj *cachedNameObj;	/* Cache of the name of the object. */
    Tcl_HashTable *chainCache;	/* Place to keep unused contexts. This table
				 * is indexed by method name as Tcl_Obj. */
    Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
				/* Function to allow remapping of method
				 * names. For itcl-ng. */
    LIST_STATIC(Tcl_Obj *) variables;
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */
#define CLASS_GONE	4	/* Obsolete. Indicates that the class of this
210
211
212
213
214
215
216




217
218
219
220
221
222
223
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249







+
+
+
+







				 * no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
				 * class of classes, and should be treated
				 * specially during teardown (and in a few
				 * other spots). */
#define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
				 * unknown method handler at that point. */
#define HAS_PRIVATE_METHODS 0x20000
				/* Object/class has (or had) private methods,
				 * and so shouldn't be cached so
				 * aggressively. */

/*
 * And the definition of a class. Note that every class also has an associated
 * object, through which it is manipulated.
 */

typedef struct Class {
264
265
266
267
268
269
270
271




272
273
274
275
276
277
278
290
291
292
293
294
295
296

297
298
299
300
301
302
303
304
305
306
307







-
+
+
+
+







				/* Places where call chains are stored. For
				 * constructors, the class chain is always
				 * used. For destructors and ordinary methods,
				 * the class chain is only used when the
				 * object doesn't override with its own mixins
				 * (and filters and method implementations for
				 * when getting method chains). */
    LIST_STATIC(Tcl_Obj *) variables;
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
} Class;

/*
 * The foundation of the object system within an interpreter contains
 * references to the key classes and namespaces, together with a few other
 * useful bits and pieces. Probably ought to eventually go in the Interp
 * structure itself.
366
367
368
369
370
371
372
373

374
375
376





377
378
379
380
381
382
383
395
396
397
398
399
400
401

402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417







-
+



+
+
+
+
+








/*
 * Bits for the 'flags' field of the call chain.
 */

#define PUBLIC_METHOD     0x01	/* This is a public (exported) method. */
#define PRIVATE_METHOD    0x02	/* This is a private (class's direct instances
				 * only) method. */
				 * only) method. Supports itcl. */
#define OO_UNKNOWN_METHOD 0x04	/* This is an unknown method. */
#define CONSTRUCTOR	  0x08	/* This is a constructor. */
#define DESTRUCTOR	  0x10	/* This is a destructor. */
#define TRUE_PRIVATE_METHOD 0x20
				/* This is a private method only accessible
				 * from other methods defined on this class
				 * or instance. [TIP #500] */
#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)

/*
 * Structure containing definition information about basic class methods.
 */

typedef struct {
    const char *name;		/* Name of the method in question. */
426
427
428
429
430
431
432



433
434
435
436
437
438
439
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476







+
+
+







			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineObjSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefinePrivateObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
500
501
502
503
504
505
506

507
508
509
510
511
512
513
514
515
516


517
518
519
520
521
522
523
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553

554
555
556
557
558
559
560
561
562







+









-
+
+







MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Object *contextObjPtr, Class *contextClsPtr,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
			    Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
			    int flags, const char ***stringsPtr);
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr,
			    Object *contextObj, Class *contextCls, int flags,
			    const char ***stringsPtr);
MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
556
557
558
559
560
561
562










563
564
565
566
567

568
569
570
571
572
573
574
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624







+
+
+
+
+
+
+
+
+
+





+







 */

#define FOREACH(var,ary) \
    for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
	continue; \
    } else if (var = (ary).list[i], 1) 

/*
 * A variation where the array is an array of structs. There's no issue with
 * possible NULLs; every element of the array will be iterated over and the
 * varable set to a pointer to each of those elements in turn.
 * REQUIRES DECLARATION: int i;
 */

#define FOREACH_STRUCT(var,ary) \
    for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)

/*
 * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
 * sets up the declarations needed for the main macro, FOREACH_HASH, which
 * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
 * only iterates over values.
 * REQUIRES DECLARATION: FOREACH_HASH_DECLS;
 */

#define FOREACH_HASH_DECLS \
    Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
    for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
	    ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\

Changes to generic/tclOOMethod.c.

182
183
184
185
186
187
188
189





190
191
192
193
194
195
196
182
183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199
200







-
+
+
+
+
+







  populate:
    mPtr->typePtr = typePtr;
    mPtr->clientData = clientData;
    mPtr->flags = 0;
    mPtr->declaringObjectPtr = oPtr;
    mPtr->declaringClassPtr = NULL;
    if (flags) {
	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
	mPtr->flags |= flags &
		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
	if (flags & TRUE_PRIVATE_METHOD) {
	    oPtr->flags |= HAS_PRIVATE_METHODS;
	}
    }
    oPtr->epoch++;
    return (Tcl_Method) mPtr;
}

/*
 * ----------------------------------------------------------------------
246
247
248
249
250
251
252
253





254
255
256
257
258
259
260
250
251
252
253
254
255
256

257
258
259
260
261
262
263
264
265
266
267
268







-
+
+
+
+
+







    clsPtr->thisPtr->fPtr->epoch++;
    mPtr->typePtr = typePtr;
    mPtr->clientData = clientData;
    mPtr->flags = 0;
    mPtr->declaringObjectPtr = NULL;
    mPtr->declaringClassPtr = clsPtr;
    if (flags) {
	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
	mPtr->flags |= flags &
		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
	if (flags & TRUE_PRIVATE_METHOD) {
	    clsPtr->flags |= HAS_PRIVATE_METHODS;
	}
    }

    return (Tcl_Method) mPtr;
}

/*
 * ----------------------------------------------------------------------
924
925
926
927
928
929
930
931

932
933
934
935
936
937
938
932
933
934
935
936
937
938

939
940
941
942
943
944
945
946







-
+







 *
 * TclOOSetupVariableResolver, etc. --
 *
 *	Variable resolution engine used to connect declared variables to local
 *	variables used in methods. The compiled variable resolver is more
 *	important, but both are needed as it is possible to have a variable
 *	that is only referred to in ways that aren't compilable and we can't
 *	force LVT presence. [TIP #320]
 *	force LVT presence. [TIP #320, #500]
 *
 * ----------------------------------------------------------------------
 */

void
TclOOSetupVariableResolver(
    Tcl_Namespace *nsPtr)
982
983
984
985
986
987
988

989
990
991
992
993
994
995
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004







+







    Tcl_ResolvedVarInfo *rPtr)
{
    OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVar;
    Tcl_HashEntry *hPtr;
    int i, isNew, cacheIt, varLen, len;
    const char *match, *varName;

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
1015
1016
1017
1018
1019
1020
1021









1022
1023
1024
1025
1026
1027
1028
1029
1030








1031
1032
1033
1034
1035
1036
1037
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063







+
+
+
+
+
+
+
+
+









+
+
+
+
+
+
+
+







     * is in the list provided by the user). If not, we mustn't do anything
     * either.
     */

    varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
    if (contextPtr->callPtr->chain[contextPtr->index]
	    .mPtr->declaringClassPtr != NULL) {
	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->privateVariables) {
	    match = TclGetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = 0;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->variables) {
	    match = TclGetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = 0;
		goto gotMatch;
	    }
	}
    } else {
	FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
	    match = TclGetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = 1;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->oPtr->variables) {
	    match = TclGetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = 1;
		goto gotMatch;
	    }
	}
1669
1670
1671
1672
1673
1674
1675







1676
1677
1678
1679
1680
1681
1682
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715







+
+
+
+
+
+
+








int
Tcl_MethodIsPublic(
    Tcl_Method method)
{
    return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
}

int
Tcl_MethodIsPrivate(
    Tcl_Method method)
{
    return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
}

/*
 * Extended method construction for itcl-ng.
 */

Tcl_Method
TclOONewProcInstanceMethodEx(

Changes to generic/tclOOStubInit.c.

69
70
71
72
73
74
75

76
77
78
69
70
71
72
73
74
75
76
77
78
79







+



    Tcl_ObjectSetMetadata, /* 22 */
    Tcl_ObjectContextInvokeNext, /* 23 */
    Tcl_ObjectGetMethodNameMapper, /* 24 */
    Tcl_ObjectSetMethodNameMapper, /* 25 */
    Tcl_ClassSetConstructor, /* 26 */
    Tcl_ClassSetDestructor, /* 27 */
    Tcl_GetObjectName, /* 28 */
    Tcl_MethodIsPrivate, /* 29 */
};

/* !END!: Do not edit above this line. */

Changes to generic/tclVar.c.

6319
6320
6321
6322
6323
6324
6325

6326

6327

6328
6329


6330





















6331
6332
6333
6334
6335
6336
6337
6338
6339



6340
6341
6342




6343
6344
6345
6346
6347
6348
6349
6319
6320
6321
6322
6323
6324
6325
6326

6327

6328
6329
6330
6331
6332

6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359



6360
6361
6362
6363


6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374







+
-
+
-
+


+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+






-
-
-
+
+
+

-
-
+
+
+
+








  objectVars:
    if (!includeLinks) {
	return;
    }

    if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
	Method *mPtr = (Method *)
	CallContext *contextPtr = iPtr->varFramePtr->clientData;
		Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData);
	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
	PrivateVariableMapping *privatePtr;

	if (mPtr->declaringObjectPtr) {
	    Object *oPtr = mPtr->declaringObjectPtr;

	    FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
	    FOREACH(objNamePtr, oPtr->variables) {
		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
		if (added && (!pattern ||
			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
		}
	    }
	    FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
			&added);
		if (added && (!pattern ||
			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
				pattern))) {
		    Tcl_ListObjAppendElement(interp, listPtr,
			    privatePtr->variableObj);
		}
	    }
	} else {
	    Class *clsPtr = mPtr->declaringClassPtr;

	    FOREACH(objNamePtr, clsPtr->variables) {
		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
		if (added && (!pattern ||
			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
		}
	    }
	} else {
	    FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
	    FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
			&added);
		if (added && (!pattern ||
			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
				pattern))) {
		    Tcl_ListObjAppendElement(interp, listPtr,
			    privatePtr->variableObj);
		}
	    }
	}
    }
    Tcl_DeleteHashTable(&addedTable);
}


Changes to tests/oo.test.

2198
2199
2200
2201
2202
2203
2204
2205

2206
2207
2208
2209
2210
2211
2212
2198
2199
2200
2201
2202
2203
2204

2205
2206
2207
2208
2209
2210
2211
2212







-
+







    while executing
\"info object\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \
2328
2329
2330
2331
2332
2333
2334



































































2335
2336
2337
2338
2339
2340
2341
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







		 [info object isa mixin list NOTANOBJECT] \
		 [info object isa mixin NOTANOBJECT list] \
		 [info object isa mixin oo::object list] \
		 [info object isa mixin list oo::object]]
} -cleanup {
    meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
test oo-16.15 {OO: object introspection: creationid #500} -setup {
    oo::class create cls
} -body {
    info object creationid [cls new]
} -cleanup {
    cls destroy
} -result {^\d+$} -match regexp
test oo-16.16 {OO: object introspection: creationid #500} -setup {
    oo::class create cls
} -body {
    set obj [cls new]
    set id [info object creationid $obj]
    rename $obj gorp
    set id2 [info object creationid gorp]
    list $id $id2
} -cleanup {
    cls destroy
} -result {^(\d+) \1$} -match regexp
test oo-16.17 {OO: object introspection: creationid #500} -body {
    info object creationid nosuchobject
} -returnCodes error -result {nosuchobject does not refer to an object}
test oo-16.18 {OO: object introspection: creationid #500} -body {
    info object creationid
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.18 {OO: object introspection: creationid #500} -body {
    info object creationid oo::object gorp
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.19 {OO: object introspection: creationid #500} -setup {
    oo::class create cls
} -body {
    set id1 [info object creationid [set o1 [cls new]]]
    set id2 [info object creationid [set o2 [cls new]]]
    if {$id1 == $id2} {
	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
    } else {
	string cat not-equal
    }
} -cleanup {
    cls destroy
} -result not-equal
test oo-16.20 {OO: object introspection: creationid #500} -setup {
    oo::class create cls
} -body {
    set id1 [info object creationid [set o1 [cls new]]]
    $o1 destroy
    set id2 [info object creationid [set o2 [cls new]]]
    if {$id1 == $id2} {
	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
    } else {
	string cat not-equal
    }
} -cleanup {
    cls destroy
} -result not-equal
test oo-16.21 {OO: object introspection: creationid #500} -setup {
    oo::class create cls
} -body {
    set id1 [info object creationid [set o1 [cls new]]]
    set id2 [info object creationid [set o2 [oo::copy $o1]]]
    if {$id1 == $id2} {
	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
    } else {
	string cat not-equal
    }
} -cleanup {
    cls destroy
} -result not-equal

test oo-17.1 {OO: class introspection} -body {
    info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
test oo-17.1.1 {OO: class introspection} -body {
    catch {info class} m o
    dict get $o -errorinfo
4098
4099
4100
4101
4102
4103
4104




































































































































































































































































































































































































































































































































































































































































































4105
4106
4107
4108
4109
4110
4111
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    }
    Cls create obj
    list [oo::objdefine obj testself] $result
} -cleanup {
    Cls destroy
    catch {rename oo::objdefine::testself {}}
} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}

test oo-37.1 {TIP 500: private command propagates errors} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	private ::error "this is an error"
    }
} -cleanup {
    cls destroy
} -returnCodes error -result {this is an error}
test oo-37.2 {TIP 500: private command propagates errors} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	private {
	    ::error "this is an error"
	}
    }
} -cleanup {
    cls destroy
} -returnCodes error -result {this is an error}
test oo-37.3 {TIP 500: private command propagates errors} -setup {
    oo::object create obj
} -body {
    oo::objdefine obj {
	private ::error "this is an error"
    }
} -cleanup {
    obj destroy
} -returnCodes error -result {this is an error}
test oo-37.4 {TIP 500: private command propagates errors} -setup {
    oo::object create obj
} -body {
    oo::objdefine obj {
	private {
	    ::error "this is an error"
	}
    }
} -cleanup {
    obj destroy
} -returnCodes error -result {this is an error}
test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
    oo::define::private error "xyz"
} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
    oo::objdefine::private error "xyz"
} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}

test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	private variable x
	constructor {} {
	    set x 1
	}
	method getA {} {
	    return $x
	}
    }
    oo::class create clsB {
	superclass clsA
	private {
	    variable x
	}
	constructor {} {
	    set x 2
	    next
	}
	method getB {} {
	    return $x
	}
    }
    oo::class create clsC {
	superclass clsB
	variable x
	constructor {} {
	    set x 3
	    next
	}
	method getC {} {
	    return $x
	}
    }
    clsC create obj
    oo::objdefine obj {
	private {
	    variable x
	}
	method setup {} {
	    set x 4
	}
	method getO {} {
	    return $x
	}
    }
    obj setup
    list [obj getA] [obj getB] [obj getC] [obj getO] \
	[lsort [string map [list [info object creationid clsA] CLASS-A \
				[info object creationid clsB] CLASS-B \
				[info object creationid obj] OBJ] \
		    [info object vars obj]]]
} -cleanup {
    parent destroy
} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
test oo-38.2 {TIP 500: private variables introspection} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	private {
	    variable x1
	    variable x2
	}
	variable y1 y2
    }
    cls create obj
    oo::objdefine obj {
	private variable a1 a2
	variable b1 b2
    }
    list [lsort [info class variables cls]] \
	[lsort [info class variables cls -private]] \
	[lsort [info object variables obj]] \
	[lsort [info object variables obj -private]]
} -cleanup {
    parent destroy
} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	private {
	    variable x
	}
	method getx {} {
	    set x 1
	    my varname x
	}
	method readx {} {
	    return $x
	}
    }
    oo::class create clsB {
	superclass clsA
	variable x
	method gety {} {
	    set x 1
	    my varname x
	}
	method ready {} {
	    return $x
	}
    }
    clsB create obj
    set [obj getx] 2
    set [obj gety] 3
    list [obj readx] [obj ready]
} -cleanup {
    parent destroy
} -result {2 3}
test oo-38.4 {TIP 500: private variables introspection} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	private {
	    variable x1 x2
	}
	variable y1 y2
	constructor {} {
	    variable z boo
	    set x1 a
	    set y1 c
	}
	method list {} {
	    variable z
	    set ok 1
	    list [info locals] [lsort [info vars]] [info exist x2]
	}
    }
    cls create obj
    oo::objdefine obj {
	private variable a1 a2
	variable b1 b2
	method init {} {
	    # Because we don't have a constructor to do this setup for us
	    set a1 p
	    set b1 r
	}
	method list {} {
	    variable z
	    set yes 1
	    list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
	}
    }
    obj init
    obj list
} -cleanup {
    parent destroy
} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
    oo::class create parent
} -body {
    oo::class create cls1 {
	superclass parent
	private variable x
	method abc val {
	    my variable x
	    set x $val
	}
	method def val {
	    my variable y
	    set y $val
	}
	method get1 {} {
	    my variable x y
	    return [list $x $y]
	}
    }
    oo::class create cls2 {
	superclass cls1
	private variable x
	method x-exists {} {
	    return [info exists x],[uplevel 1 {info exists x}]
	}
	method ghi x {
	    # Additional instrumentation to show that we're not using the
	    # resolved variable until we ask for it; the argument nixed that
	    # happening by default.
	    set val $x
	    set before [my x-exists]
	    unset x
	    set x $val
	    set mid [my x-exists]
	    unset x
	    set mid2 [my x-exists]
	    my variable x
	    set x $val
	    set after [my x-exists]
	    return "$before;$mid;$mid2;$after"
	}
	method jkl val {
	    my variable y
	    set y $val
	}
	method get2 {} {
	    my variable x y
	    return [list $x $y]
	}
    }
    cls2 create a
    a abc 123
    a def 234
    set tmp [a ghi 345]
    a jkl 456
    list $tmp [a get1] [a get2]
} -cleanup {
    parent destroy
} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}

test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	variable x
	constructor {} {
	    set x 1
	}
	method act {} {
	    my step
	    my step
	    my step
	    return
	}
	private {
	    method step {} {
		incr x 2
	    }
	}
	method x {} {
	    return $x
	}
    }
    clsA create obj
    obj act
    list [obj x] [catch {obj step} msg] $msg
} -cleanup {
    parent destroy
} -result {7 1 {unknown method "step": must be act, destroy or x}}
test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	variable x
	constructor {} {
	    set x 1
	}
	method act {} {
	    my step
	    my step
	    my step
	    return
	}
	private {
	    method step {} {
		incr x 2
	    }
	}
	method x {} {
	    return $x
	}
    }
    oo::class create clsB {
	superclass clsA
	variable x
	method step {} {
	    incr x 5
	}
    }
    clsB create obj
    obj act
    list [obj x] [obj step]
} -cleanup {
    parent destroy
} -result {7 12}
test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	variable x
	constructor {} {
	    set x 1
	}
	method act {} {
	    my Step
	    my Step
	    my Step
	    return
	}
	method x {} {
	    return $x
	}
    }
    oo::class create clsB {
	superclass clsA
	variable x
	method Step {} {
	    incr x 5
	}
    }
    clsB create obj
    obj act
    set result [obj x]
    oo::define clsA {
	private {
	    method Step {} {
		incr x 2
	    }
	}
    }
    obj act
    lappend result [obj x]
} -cleanup {
    parent destroy
} -result {16 22}
test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
    oo::class create parent
} -body {
    oo::class create clsA {
	superclass parent
	variable x
	constructor {} {
	    set x 1
	}
	method act {} {
	    my step
	    return
	}
	method step {} {
	    incr x
	}
	method x {} {
	    return $x
	}
    }
    clsA create obj
    obj act
    set result [obj x]
    oo::objdefine obj {
	variable x
	private {
	    method step {} {
		incr x 2
	    }
	}
    }
    obj act
    lappend result [obj x]
    oo::objdefine obj {
	method act {} {
	    my step
	    next
	}
    }
    obj act
    lappend result [obj x]
} -cleanup {
    parent destroy
} -result {2 3 6}
test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
	method equal {other} {
	    expr {$x == [$other x]}
	}
    }
    cls create a 1
    cls create b 2
    cls create c 1
    list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
} -cleanup {
    parent destroy
} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
	method equal {other} {
	    expr {$x == [$other y]}
	}
    }
    cls create a 1
    cls create b 2
    a equal b
} -returnCodes error -cleanup {
    parent destroy
} -result {unknown method "y": must be destroy, equal or x}
test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
	method equal {other} {
	    expr {[[self] y] == [$other x]}
	}
    }
    cls create a 1
    cls create b 2
    a equal b
} -returnCodes error -cleanup {
    parent destroy
} -result {unknown method "y": must be destroy, equal or x}
test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
	method equal {other} {
	    expr {[my y] == [$other x]}
	}
    }
    cls create a 1
    cls create b 2
    a equal b
} -returnCodes error -cleanup {
    parent destroy
} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
    }
    oo::class create cls2 {
	superclass cls
	method equal {other} {
	    expr {[my y] == [$other x]}
	}
    }
    cls2 create a 1
    cls2 create b 2
    a equal b
} -returnCodes error -cleanup {
    parent destroy
} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	variable x
	constructor {val} {
	    set x $val
	}
	private method x {} {
	    return $x
	}
    }
    oo::class create cls2 {
	superclass cls
	method equal {other} {
	    expr {[my x] == [$other x]}
	}
    }
    cls2 create a 1
    cls2 create b 2
    a equal b
} -returnCodes error -cleanup {
    parent destroy
} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	method chain {} {
	    return [self call]
	}
    }
    oo::class create cls2 {
	superclass cls
	private method chain {} {
	    next
	}
	method chain2 {} {
	    my chain
	}
	method chain3 {} {
	    [self] chain
	}
    }
    cls create a
    cls2 create b
    list [a chain] [b chain] [b chain2] [b chain3]
} -cleanup {
    parent destroy
} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
test oo-39.12 {TIP 500: private methods; introspection} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	method chain {} {
	    return [self call]
	}
	private method abc {} {}
    }
    oo::class create cls2 {
	superclass cls
	method chain2 {} {
	    my chain
	}
	method chain3 {} {
	    [self] chain
	}
	private method def {} {}
	unexport chain3
    }
    cls create a
    cls2 create b
    oo::objdefine b {
	private method ghi {} {}
	method ABC {} {}
	method foo {} {}
    }
    set scopes {public unexported private}
    list a: [lmap s $scopes {info object methods a -scope $s}] \
	b: [lmap s $scopes {info object methods b -scope $s}] \
	cls: [lmap s $scopes {info class methods cls -scope $s}] \
	cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
} -cleanup {
    parent destroy
} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}

test oo-40.1 {TIP 500: private and self} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	self {
	    private {
		variable a
	    }
	    variable b
	}
	private {
	    self {
		variable c
	    }
	    variable d
	}
	variable e
    }
    list \
	[lsort [info class variables cls]] \
	[lsort [info class variables cls -private]] \
	[lsort [info object variables cls]] \
	[lsort [info object variables cls -private]]
} -cleanup {
    cls destroy
} -result {e d b {a c}}
test oo-40.2 {TIP 500: private and export} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	private method foo {} {}
    }
    set result [lmap s {public unexported private} {
	info class methods cls -scope $s}]
    oo::define cls {
	export foo
    }
    lappend result {*}[lmap s {public unexported private} {
	info class methods cls -scope $s}]
} -cleanup {
    cls destroy
} -result {{} {} foo foo {} {}}
test oo-40.3 {TIP 500: private and unexport} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	private method foo {} {}
    }
    set result [lmap s {public unexported private} {
	info class methods cls -scope $s}]
    oo::define cls {
	unexport foo
    }
    lappend result {*}[lmap s {public unexported private} {
	info class methods cls -scope $s}]
} -cleanup {
    cls destroy
} -result {{} {} foo {} foo {}}

cleanupTests
return

# Local Variables:
# mode: tcl
# End: