Tcl Source Code

Changes On Branch tip-558
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-558 Excluding Merge-Ins

This is equivalent to a diff from f5bc93143d to e92d3a4952

2020-02-26
16:56
merge core-8-branch Leaf check-in: e92d3a4952 user: dkf tags: tip-558
14:05
Merge 8.6 check-in: 0346bb5441 user: jan.nijtmans tags: core-8-branch
10:58
Merge 8.7 Closed-Leaf check-in: cfcbd55aba user: jan.nijtmans tags: cplusplus
08:32
merge core-8-branch Leaf check-in: 7859c7efe0 user: dkf tags: tip-567
08:14
Merge 8.7 check-in: 4dc9a5cea0 user: jan.nijtmans tags: trunk
08:04
Merge 8.6 check-in: f5bc93143d user: jan.nijtmans tags: core-8-branch
07:58
Make tclWinDde.c compilable with C++ compiler. dde -> 1.4.3 Make tclWinReg.c compilable with C++ com... check-in: cc5c355ced user: jan.nijtmans tags: core-8-6-branch
2020-02-24
12:18
Merge 8.6 check-in: 1d3f5159be user: jan.nijtmans tags: core-8-branch
2020-02-22
12:35
merge core-8-branch check-in: 199fa617ec user: dkf tags: tip-558

Added doc/configurable.n.




























































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
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
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
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
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
'\"
'\" Copyright (c) 2019 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 configurable n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties
.SH SYNOPSIS
.nf
package require TclOO

\fBoo::configurable create \fIclass\fR \fR?\fIdefinitionScript\fR?

\fBoo::define \fIclass\fB {\fR
    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR

\fBoo::objdefine \fIobject\fB {\fR
    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR

\fIobjectName \fBconfigure\fR
\fIobjectName \fBconfigure\fR \fI\-prop\fR
\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...\fR
.fi
.SH "CLASS HIERARCHY"
.nf
\fBoo::object\fR
   \(-> \fBoo::class\fR
       \(-> \fBoo::configurable\fR

\fBoo::object\fR
   \(-> \fBoo::class\fR
       \(-> \fBoo::configurablesupport::configurable\fR
.fi
.BE
.SH DESCRIPTION
.PP
Configurable objects are objects that support being configured with a
\fBconfigure\fR method. Each of the configurable entities of the object is
known as a property of the object. Properties may be defined on classes or
instances; when configuring an object, any of the properties defined by its
classes (direct or indirect) or by the instance itself may be configured.
.PP
The \fBoo::configurable\fR metaclass installs basic support for making
configurable objects into a class. This consists of making a \fBproperty\fR
definition command available in definition scripts for the class and instances
(e.g., from the class's constructor, within \fBoo::define\fR and within
\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the
instances.
.SS "CONFIGURE METHOD"
.PP
The behavior of the \fBconfigure\fR method is modelled after the
\fBfconfigure\fR/\fBchan configure\fR command.
.PP
If passed no additional arguments, the \fBconfigure\fR method returns an
alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR
properties and their current values.
.PP
If passed a single addiional argument, that argument to the \fBconfigure\fR
method must be the name of a property to read (or an unambiguous prefix
thereof); its value is returned.
.PP
Otherwise, if passed an even number of arguments then each pair of arguments
specifies a property name (or an unambiguous prefix thereof) and the value to
set it to. The properties will be set in the order specified, including
duplicates. If the setting of any property fails, the overall \fBconfigure\fR
method fails, the preceding pairs (if any) will continue to have been applied,
and the succeeding pairs (if any) will be not applied. On success, the result
of the \fBconfigure\fR method in this mode operation will be an empty string.
.SS "PROPERTY DEFINITIONS"
.PP
When a class has been manufactured by the \fBoo::configurable\fR metaclass (or
one of its subclasses), it gains an extra definition, \fBproperty\fR. The
\fBproperty\fR definition defines one or more properties that will be exposed
by the class's instances.
.PP
The \fBproperty\fR command takes the name of a property to define first,
\fIwithout a leading hyphen\fR, followed by a number of option-value pairs
that modify the basic behavior of the property. This can then be followed by
an arbitrary number of other property definitions. The supported options are:
.TP
\fB\-get \fIgetterScript\fR
.
This defines the implementation of how to read from the property; the
\fIgetterScript\fR will become the body of a method (taking no arguments)
defined on the class, if the kind of the property is such that the property
can be read from. The method will be named
\fB<ReadProp-\fIpropertyName\fB>\fR, and will default to being a simple read
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <ReadProp-xyz>
being created).
.TP
\fB\-kind \fIpropertyKind\fR
.
This defines what sort of property is being created. The \fIpropertyKind\fR
must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR
(which is the default) which will make the property read-only, write-only or
read-write, respectively.  Read-only properties can only ever be read from,
write-only properties can only ever be written to, and read-write properties
can be both read and written.
.RS
.PP
Note that write-only properties are not particularly discoverable as they are
never reported by the \fBconfigure\fR method other than by error messages when
attempting to write to a property that does not exist.
.RE
.TP
\fB\-set \fIsetterScript\fR
.
This defines the implementation of how to write to the property; the
\fIsetterScript\fR will become the body of a method taking a single argument,
\fIvalue\fR, defined on the class, if the kind of the property is such that
the property can be written to. The method will be named
\fB<WriteProp-\fIpropertyName\fB>\fR, and will default to being a simple write
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <WriteProp-xyz>
being created).
.PP
Instances of the class that was created by \fBoo::configurable\fR will also
support \fBproperty\fR definitions; the semantics will be exactly as above
except that the properties will be defined on the instance alone.
.PP
Note that the property implementation methods that \fBproperty\fR defines
should not be private, as this makes them inaccessible from the implementation
of \fBconfigure\fR (by design; the property configuration mechanism is
intended for use mainly from outside a class, whereas a class may access
variables directly). The variables accessed by the default implementations of
the properties \fImay\fR be private, if so declared.
.SH "ADVANCED USAGE"
.PP
The configurable class system is comprised of several pieces. The
\fBoo::configurable\fR metaclass works by mixing in a class and setting
definition namespaces during object creation that provide the other bits and
pieces of machinery. The key pieces of the implementation are enumerated here
so that they can be used by other code:
.TP
\fBoo::configuresupport::configurable\fR
.
This is a class that provids the implementation of the \fBconfigure\fR method
(described above in \fBCONFIGURE METHOD\fR).
.TP
\fBoo::configuresupport::configurableclass\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and
class constructors under normal circumstances), as described above in
\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR
command so that it may be used easily in user definition dialects.
.TP
.
\fBoo::configuresupport::configurableobject\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in instance objects (i.e., via
\fBoo::objdefine\fR, and the\fB self\R declaration in \fBoo::define), as
described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its
\fBproperty\fR command so that it may be used easily in user definition
dialects.
.PP
The underlying property discovery mechanism relies on four slots (see
\fBoo::define\fR for what that implies) that list the properties that can be
configured. These slots do not themselves impose any semantics on what the
slots mean other than that they have unique names, no important order, can be
inherited and discovered on classes and instances.
.PP
These slots, and their intended semantics, are:
.TP
\fBoo::configuresupport::readableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be read from when configuring an instance of the class. This slot can
also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::writableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be written to when configuring an instance of the class. This slot
can also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::objreadableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be read from when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.TP
\fBoo::configuresupport::objwritableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be written to when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.PP
Note that though these are slots, they are \fInot\fR in the standard
\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them
inside a definition script, they need to be referred to by full name. This is
because they are intended to be building bricks of configurable property
system, and not directly used by normal user code.
.SS "IMPLEMENTATION NOTE"
.PP
The implementation of the \fBconfigure\fR method uses
\fBinfo object properties\fR with the \fB\-all\fR option to discover what
properties it may manipulate.
.SH EXAMPLES
.PP
Here we create a simple configurable class and demonstrate how it can be
configured:
.PP
.CS
\fBoo::configurable\fR create Point {
    \fBproperty\fR x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
    variable x y
    method print {} {
        puts "x=$x, y=$y"
    }
}

set pt [Point new -x 27]
$pt print;   \fI# x=27, y=0\fR
$pt \fBconfigure\fR -y 42
$pt print;   \fI# x=27, y=42\fR
puts "distance from origin: [expr {
    hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y])
}]";         \fI# distance from origin: 49.92995093127971\fR
puts [$pt \fBconfigure\fR]
             \fI# -x 27 -y 42\fR
.CE
.PP
Such a configurable class can be extended by subclassing, though the subclass
needs to also be created by \fBoo::configurable\fR if it will use the
\fBproperty\fR definition:
.PP
.CS
\fBoo::configurable\fR create Point3D {
    superclass Point
    \fBproperty\fR z
    constructor args {
        next -z 0 {*}$args
    }
}

set pt2 [Point3D new -x 2 -y 3 -z 4]
puts [$pt2 \fBconfigure\fR]
             \fI# -x 2 -y 3 -z 4\fR
.CE
.PP
Once you have a configurable class, you can also add instance properties to
it. (The backing variables for all properties start unset.) Note below that we
are using an unambiguous prefix of a property name when setting it; this is
supported for all properties though full names are normally recommended
because subclasses will not make an unambiguous prefix become ambiguous in
that case.
.PP
.CS
oo::objdefine $pt {
    \fBproperty\fR color
}
$pt \fBconfigure\fR -c bisque
puts [$pt \fBconfigure\fR]
             \fI# -color bisque -x 27 -y 42\fR
.CE
.PP
You can also do derived properties by making them read-only and supplying a
script that computes them.
.PP
.CS
\fBoo::configurable\fR create PointMk2 {
    \fBproperty\fR x y
    \fBproperty\fR distance -kind readable -get {
        return [expr {hypot($x, $y)}]
    }
    variable x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
}

set pt3 [PointMk2 new -x 3 -y 4]
puts [$pt3 \fBconfigure\fR -distance]
             \fI# 5.0\fR
$pt3 \fBconfigure\fR -distance 10
             \fI# ERROR: bad property "-distance": must be -x or -y\fR
.CE
.PP
Setters are used to validate the type of a property:
.PP
.CS
\fBoo::configurable\fR create PointMk3 {
    \fBproperty\fR x -set {
        if {![string is double -strict $value]} {
            error "-x property must be a number"
        }
        set x $value
    }
    \fBproperty\fR y -set {
        if {![string is double -strict $value]} {
            error "-y property must be a number"
        }
        set y $value
    }
    variable x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
}

set pt4 [PointMk3 new]
puts [$pt4 \fBconfigure\fR]
             \fI# -x 0 -y 0\fR
$pt4 \fBconfigure\fR -x 3 -y 4
puts [$pt4 \fBconfigure\fR]
             \fI# -x 3 -y 4\fR
$pt4 \fBconfigure\fR -x "obviously not a number"
             \fI# ERROR: -x property must be a number\fR
.CE
.SH "SEE ALSO"
info(n), oo::class(n), oo::define(n)
.SH KEYWORDS
class, object, properties, configuration
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

Changes to doc/define.n.

488
489
490
491
492
493
494






495
496
497
498
499
500
501
of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines five operations (as methods) that may be done on
the slot:
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.
This appends the given \fImember\fR elements to the slot definition.






.TP
\fIslot\fR \fB\-clear\fR
.
This sets the slot definition to the empty list.
.TP
\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
.VS TIP516






>
>
>
>
>
>







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines five operations (as methods) that may be done on
the slot:
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.
This appends the given \fImember\fR elements to the slot definition.
.TP
\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
.VS TIP558
This appends the given \fImember\fR elements to the slot definition if they
do not already exist.
.VE TIP558
.TP
\fIslot\fR \fB\-clear\fR
.
This sets the slot definition to the empty list.
.TP
\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
.VS TIP516

Changes to doc/info.n.

487
488
489
490
491
492
493























494
495
496
497
498
499
500
...
676
677
678
679
680
681
682
























683
684
685
686
687
688
689
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo class forward\fR.
.TP
\fBinfo class mixins\fI class\fR
.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.























.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
.
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.
................................................................................
This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
.TP
\fBinfo object namespace\fI object\fR
.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
























.TP
\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
.
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






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







 







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







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
...
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
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo class forward\fR.
.TP
\fBinfo class mixins\fI class\fR
.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.
.TP
\fBinfo class properties\fI class\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the class named
\fIclass\fR. The \fIoptions\fR define exactly which properties are returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the superclasses and mixins of the class
are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned.  Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
.
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.
................................................................................
This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
.TP
\fBinfo object namespace\fI object\fR
.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
.TP
\fBinfo object properties\fI object\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the object
named \fIobject\fR. The \fIoptions\fR define exactly which properties are
returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the class, superclasses and mixins of
the object are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned. Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
.
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

Changes to generic/tclOO.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
...
319
320
321
322
323
324
325

326
327
328
329
330
331
332
...
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
....
1009
1010
1011
1012
1013
1014
1015























1016
1017
1018
1019
1020
1021
1022
....
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
....
1263
1264
1265
1266
1267
1268
1269























1270
1271
1272
1273
1274
1275
1276
/*
 * tclOO.c --
 *
 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright (c) 2005-2012 by Donal K. Fellows
 * Copyright (c) 2017 by Nathan Coulter
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
................................................................................
    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
	    DeletedDefineNamespace);
    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
	    DeletedObjdefNamespace);
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    DeletedHelpersNamespace);

    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
................................................................................
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVariable;

    /*
     * Sanity check!
     */

    if (!Destructing(oPtr)) {
................................................................................
	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree(clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }
























    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;
................................................................................
				 * being deleted. */
{
    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 (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
................................................................................
	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree(oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }
























    /*
     * Because an object can be a class that is an instance of itself, the
     * class object's class structure should only be cleaned after most of
     * the cleanup on the object is done.
     *
     * The class of objects needs some special care; if it is deleted (and




|







 







>







 







|







 







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







 







|







 







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







1
2
3
4
5
6
7
8
9
10
11
12
13
...
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
...
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
....
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
....
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
....
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
/*
 * tclOO.c --
 *
 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright (c) 2005-2019 by Donal K. Fellows
 * Copyright (c) 2017 by Nathan Coulter
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
................................................................................
    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
	    DeletedDefineNamespace);
    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
	    DeletedObjdefNamespace);
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    DeletedHelpersNamespace);
    Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
................................................................................
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj, *propertyObj;
    PrivateVariableMapping *privateVariable;

    /*
     * Sanity check!
     */

    if (!Destructing(oPtr)) {
................................................................................
	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree(clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }

    /*
     * Squelch the property lists.
     */

    if (clsPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
    }
    if (clsPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
    }
    if (clsPtr->properties.readable.num) {
	FOREACH(propertyObj, clsPtr->properties.readable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(clsPtr->properties.readable.list);
    }
    if (clsPtr->properties.writable.num) {
	FOREACH(propertyObj, clsPtr->properties.writable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(clsPtr->properties.writable.list);
    }

    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;
................................................................................
				 * being deleted. */
{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj, *propertyObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
................................................................................
	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree(oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    /*
     * Squelch the property lists.
     */

    if (oPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
    }
    if (oPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
    }
    if (oPtr->properties.readable.num) {
	FOREACH(propertyObj, oPtr->properties.readable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(oPtr->properties.readable.list);
    }
    if (oPtr->properties.writable.num) {
	FOREACH(propertyObj, oPtr->properties.writable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(oPtr->properties.writable.list);
    }

    /*
     * Because an object can be a class that is an instance of itself, the
     * class object's class structure should only be cleaned after most of
     * the cleanup on the object is done.
     *
     * The class of objects needs some special care; if it is deleted (and

Changes to generic/tclOOCall.c.

1
2
3
4
5

6
7
8
9
10
11
12
13
14
..
54
55
56
57
58
59
60

61
62
63
64
65
66
67
....
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
....
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
....
2097
2098
2099
2100
2101
2102
2103
2104





















2105














































































































































































2106
2107
2108
2109
2110
2111
/*
 * tclOOCall.c --
 *
 *	This file contains the method call chain management code for the
 *	object-system core.

 *
 * Copyright (c) 2005-2012 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
................................................................................
#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
#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.
................................................................................
				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;
    Tcl_Namespace *nsPtr = NULL;
    int i;

    define.list = staticSpace;
    define.num = 0;
    define.size = DEFINE_CHAIN_STATIC_SIZE;

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

    AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
    AddSimpleDefineNamespaces(oPtr, &define, forClass);

    /*
     * Go through the list until we find a namespace whose name we can
     * resolve.
     */

    FOREACH_STRUCT(entryPtr, define) {
................................................................................

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	AddSimpleClassDefineNamespaces(superPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
	AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
		definePtr, flags);
    } else {
	AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
		definePtr, flags);
    }

................................................................................
		    sizeof(DefineEntry) * definePtr->size);
	}
    }
    definePtr->list[i].definerCls = definerCls;
    definePtr->list[i].namespaceName = namespaceName;
    definePtr->num++;
}
 





















/*














































































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */



|
>

|







 







>







 







|










|
|







 







|







 








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
....
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
....
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
....
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
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
/*
 * tclOOCall.c --
 *
 *	This file contains the method call chain management code for the
 *	object-system core. It also contains everything else that does
 *	inheritance hierarchy traversal.
 *
 * Copyright (c) 2005-2019 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
................................................................................
#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
#define BUILDING_MIXINS	   0x400000
#define TRAVERSED_MIXIN	   0x800000
#define OBJECT_MIXIN	   0x1000000
#define DEFINE_FOR_CLASS   0x2000000
#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.
................................................................................
				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;
    Tcl_Namespace *nsPtr = NULL;
    int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);

    define.list = staticSpace;
    define.num = 0;
    define.size = DEFINE_CHAIN_STATIC_SIZE;

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

    AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
    AddSimpleDefineNamespaces(oPtr, &define, flags);

    /*
     * Go through the list until we find a namespace whose name we can
     * resolve.
     */

    FOREACH_STRUCT(entryPtr, define) {
................................................................................

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	AddSimpleClassDefineNamespaces(superPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    if (flags & DEFINE_FOR_CLASS) {
	AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
		definePtr, flags);
    } else {
	AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
		definePtr, flags);
    }

................................................................................
		    sizeof(DefineEntry) * definePtr->size);
	}
    }
    definePtr->list[i].definerCls = definerCls;
    definePtr->list[i].namespaceName = namespaceName;
    definePtr->num++;
}
 
static void
FindClassProps(
    Class *clsPtr,
    int writable,
    Tcl_HashTable *accumulator)
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin, *sup;

  tailRecurse:
    if (writable) {
	FOREACH(propName, clsPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, clsPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
	/*
	 * We do *not* traverse upwards from the root!
	 */
	return;
    }
    FOREACH(mixin, clsPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    if (clsPtr->superclasses.num == 1) {
	clsPtr = clsPtr->superclasses.list[0];
	goto tailRecurse;
    }
    FOREACH(sup, clsPtr->superclasses) {
	FindClassProps(sup, writable, accumulator);
    }
}

static void
FindObjectProps(
    Object *oPtr,
    int writable,
    Tcl_HashTable *accumulator)
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin;

    if (writable) {
	FOREACH(propName, oPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, oPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    FOREACH(mixin, oPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    FindClassProps(oPtr->selfCls, writable, accumulator);
}

Tcl_Obj *
TclOOGetAllClassProperties(
    Class *clsPtr,
    int writable,
    int *allocated)
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = 0;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {
		*allocated = 0;
		return clsPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindClassProps(clsPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information. Also purges the cache.
     */

    if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
	if (clsPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
	    clsPtr->properties.allWritableCache = NULL;
	}
	if (clsPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
	    clsPtr->properties.allReadableCache = NULL;
	}
    }
    clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
    if (writable) {
	clsPtr->properties.allWritableCache = result;
    } else {
	clsPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,
    int writable,
    int *allocated)
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
	if (writable) {
	    if (oPtr->properties.allWritableCache) {
		*allocated = 0;
		return oPtr->properties.allWritableCache;
	    }
	} else {
	    if (oPtr->properties.allReadableCache) {
		*allocated = 0;
		return oPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindObjectProps(oPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information.
     */

    if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
	if (oPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	    oPtr->properties.allWritableCache = NULL;
	}
	if (oPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	    oPtr->properties.allReadableCache = NULL;
	}
    }
    oPtr->properties.epoch = oPtr->fPtr->epoch;
    if (writable) {
	oPtr->properties.allWritableCache = result;
    } else {
	oPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOODefineCmds.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
..
56
57
58
59
60
61
62

63
64
65
66
67
68
69
..
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138








139
140
141
142
143
144
145
...
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
...
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
...
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
...
478
479
480
481
482
483
484

485
486
487
488
489
490
491
....
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
....
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
....
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
....
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
....
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
....
3073
3074
3075
3076
3077
3078
3079
3080
3081








































































































































































































































































































































































































3082
3083
3084
3085
3086
3087
/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo::define command,
 *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006-2013 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
................................................................................
#define PUBLIC_PATTERN		"[a-z]*"

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);

static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static inline void	GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline int	MagicDefinitionInvoke(Tcl_Interp *interp,
			    Tcl_Namespace *nsPtr, int cmdIndex,
			    int objc, Tcl_Obj *const *objv);
................................................................................
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
static int		ClassFilterGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ResolveClass(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),








    {NULL, {0, 0, 0, 0, 0}, {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().
 */
................................................................................
	 * invalidate any call chains. Note that we still bump our object's
	 * epoch if it has any mixins; the relation between a class and its
	 * representative object is special. But it won't hurt.
	 */

	if (classPtr->thisPtr->mixins.num > 0) {
	    classPtr->thisPtr->epoch++;













	}
	return;
    }

    /*
     * Either there's no class (?!) or we're reconfiguring something that is
     * in use. Force regeneration of call chains.
     */

    TclOOGetFoundation(interp)->epoch++;
}



























 
/*
 * ----------------------------------------------------------------------
 *
 * RecomputeClassCacheFlag --
 *
 *	Determine whether the object is prototypical of its class, and hence
................................................................................
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
    oPtr->epoch++;		/* Only this object can be affected. */
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetFilters --
 *
................................................................................
		 * For the new copy created by memcpy().
		 */

		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetMixins --
 *
................................................................................
 *
 * 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;
................................................................................
	} else if (!wasClass && willBeClass) {
	    TclOOAllocClass(interp, oPtr);
	}

	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	}
    }
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    if (isInstanceDeleteMethod) {
	oPtr->epoch++;
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}
 
/*
................................................................................

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceExport) {
	    oPtr->epoch++;
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}
 
................................................................................

    if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
	    objv[1], objv[2]) != TCL_OK) {
	return TCL_ERROR;
    }

    if (isInstanceRenameMethod) {
	oPtr->epoch++;
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}
 
/*
................................................................................

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceUnexport) {
	    oPtr->epoch++;
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}
 
................................................................................
	Tcl_SetObjResult(interp, objv[idx]);
    } else {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
    }

    return TCL_OK;
}
 
/*








































































































































































































































































































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */





|







 







>







 







|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<













>
>
>
>
>
>
>
>







 







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






|




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







 







|







 







|







 







>







 







|







 







|







 







|







 







|







 







|







 









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






1
2
3
4
5
6
7
8
9
10
11
12
13
14
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
..
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
...
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
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
...
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
...
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
....
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
....
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
....
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
....
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
....
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
....
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo::define command,
 *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006-2019 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
................................................................................
#define PUBLIC_PATTERN		"[a-z]*"

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static inline void	BumpInstanceEpoch(Object *oPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static inline void	GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline int	MagicDefinitionInvoke(Tcl_Interp *interp,
			    Tcl_Namespace *nsPtr, int cmdIndex,
			    int objc, Tcl_Obj *const *objv);
................................................................................
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet;
static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet;
static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet;
static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet;
static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet;
static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet;
static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet;
static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
static Tcl_MethodCallProc ResolveClass;


































/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),
    SLOT("configuresupport::readableproperties",
	    ClassRPropsGet, ClassRPropsSet, NULL),
    SLOT("configuresupport::writableproperties",
	    ClassWPropsGet, ClassWPropsSet, NULL),
    SLOT("configuresupport::objreadableproperties",
	    ObjRPropsGet, ObjRPropsSet, NULL),
    SLOT("configuresupport::objwritableproperties",
	    ObjWPropsGet, ObjWPropsSet, NULL),
    {NULL, {0, 0, 0, 0, 0}, {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().
 */
................................................................................
	 * invalidate any call chains. Note that we still bump our object's
	 * epoch if it has any mixins; the relation between a class and its
	 * representative object is special. But it won't hurt.
	 */

	if (classPtr->thisPtr->mixins.num > 0) {
	    classPtr->thisPtr->epoch++;

	    /*
	     * Invalidate the property caches directly.
	     */

	    if (classPtr->properties.allReadableCache) {
		Tcl_DecrRefCount(classPtr->properties.allReadableCache);
		classPtr->properties.allReadableCache = NULL;
	    }
	    if (classPtr->properties.allWritableCache) {
		Tcl_DecrRefCount(classPtr->properties.allWritableCache);
		classPtr->properties.allWritableCache = NULL;
	    }
	}
	return;
    }

    /*
     * Either there's no class (?!) or we're reconfiguring something that is
     * in use. Force regeneration of call chains and properties.
     */

    TclOOGetFoundation(interp)->epoch++;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * BumpInstanceEpoch --
 *
 *	Advances the epoch and clears the property cache of an object. The
 *	equivalent for classes is BumpGlobalEpoch(), as classes have a more
 *	complex set of relationships to other entities.
 *
 * ----------------------------------------------------------------------
 */

static inline void
BumpInstanceEpoch(
    Object *oPtr)
{
    oPtr->epoch++;
    if (oPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	oPtr->properties.allReadableCache = NULL;
    }
    if (oPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	oPtr->properties.allWritableCache = NULL;
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * RecomputeClassCacheFlag --
 *
 *	Determine whether the object is prototypical of its class, and hence
................................................................................
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
    BumpInstanceEpoch(oPtr);	/* Only this object can be affected. */
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetFilters --
 *
................................................................................
		 * For the new copy created by memcpy().
		 */

		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    BumpInstanceEpoch(oPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetMixins --
 *
................................................................................
 *
 * 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;
................................................................................
	} else if (!wasClass && willBeClass) {
	    TclOOAllocClass(interp, oPtr);
	}

	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    BumpInstanceEpoch(oPtr);
	}
    }
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    if (isInstanceDeleteMethod) {
	BumpInstanceEpoch(oPtr);
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}
 
/*
................................................................................

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceExport) {
	    BumpInstanceEpoch(oPtr);
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}
 
................................................................................

    if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
	    objv[1], objv[2]) != TCL_OK) {
	return TCL_ERROR;
    }

    if (isInstanceRenameMethod) {
	BumpInstanceEpoch(oPtr);
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}
 
/*
................................................................................

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceUnexport) {
	    BumpInstanceEpoch(oPtr);
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}
 
................................................................................
	Tcl_SetObjResult(interp, objv[idx]);
    } else {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
    }

    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
 *
 *	Implementations of the "readableproperties" slot accessors for classes
 *	and instances.
 *
 * ----------------------------------------------------------------------
 */

static void
InstallReadableProps(
    PropertyStorage *props,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *propObj;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    if (props->allReadableCache) {
	Tcl_DecrRefCount(props->allReadableCache);
	props->allReadableCache = NULL;
    }

    for (i=0 ; i<objc ; i++) {
	Tcl_IncrRefCount(objv[i]);
    }
    FOREACH(propObj, props->readable) {
	Tcl_DecrRefCount(propObj);
    }
    if (i != objc) {
	if (objc == 0) {
	    ckfree(props->readable.list);
	} else if (i) {
	    props->readable.list = ckrealloc(props->readable.list,
		    sizeof(Tcl_Obj *) * objc);
	} else {
	    props->readable.list = ckalloc(sizeof(Tcl_Obj *) * objc);
	}
    }
    props->readable.num = 0;
    if (objc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<objc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
	    if (created) {
		props->readable.list[n++] = objv[i];
	    } else {
		Tcl_DecrRefCount(objv[i]);
	    }
	}
	props->readable.num = n;

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

	if (n != objc) {
	    props->readable.list = ckrealloc(props->readable.list,
		    sizeof(Tcl_Obj *) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static int
ClassRPropsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    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();
    FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

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

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    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;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

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

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

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->properties.readable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

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

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallReadableProps(&oPtr->properties, varc, varv);
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
 *
 *	Implementations of the "writableproperties" slot accessors for classes
 *	and instances.
 *
 * ----------------------------------------------------------------------
 */

static void
InstallWritableProps(
    PropertyStorage *props,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *propObj;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    if (props->allWritableCache) {
	Tcl_DecrRefCount(props->allWritableCache);
	props->allWritableCache = NULL;
    }

    for (i=0 ; i<objc ; i++) {
	Tcl_IncrRefCount(objv[i]);
    }
    FOREACH(propObj, props->writable) {
	Tcl_DecrRefCount(propObj);
    }
    if (i != objc) {
	if (objc == 0) {
	    ckfree(props->writable.list);
	} else if (i) {
	    props->writable.list = ckrealloc(props->writable.list,
		    sizeof(Tcl_Obj *) * objc);
	} else {
	    props->writable.list = ckalloc(sizeof(Tcl_Obj *) * objc);
	}
    }
    props->writable.num = 0;
    if (objc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<objc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
	    if (created) {
		props->writable.list[n++] = objv[i];
	    } else {
		Tcl_DecrRefCount(objv[i]);
	    }
	}
	props->writable.num = n;

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

	if (n != objc) {
	    props->writable.list = ckrealloc(props->writable.list,
		    sizeof(Tcl_Obj *) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static int
ClassWPropsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    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();
    FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

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

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"propertyList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    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;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

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

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

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->properties.writable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

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

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"propertyList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallWritableProps(&oPtr->properties, varc, varv);
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOOInfo.c.

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
..
57
58
59
60
61
62
63

64
65
66
67
68
69
70
..
78
79
80
81
82
83
84

85
86
87
88
89
90
91
....
1708
1709
1710
1711
1712
1713
1714
1715
1716


















































































































































































1717
1718
1719
1720
1721
1722
/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo-related [info]
 *	subcommands.
 *
 * Copyright (c) 2006-2011 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

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

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;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;

static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;

/*
 * List of commands that are used to implement the [info object] subcommands.
 */
................................................................................
    {"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,  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.
................................................................................
    {"destructor",   InfoClassDestrCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"filters",	     InfoClassFiltersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"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,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};
 
/*
................................................................................
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}
 
/*


















































































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */





|












>











>













>







 







>







 







>







 









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






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
52
53
..
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
....
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
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo-related [info]
 *	subcommands.
 *
 * Copyright (c) 2006-2019 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

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

static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		SortPropList(Tcl_Obj *list);
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 InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;

/*
 * List of commands that are used to implement the [info object] subcommands.
 */
................................................................................
    {"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},
    {"properties", InfoObjectPropCmd,	    TclCompileBasicMin1ArgCmd, 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.
................................................................................
    {"destructor",   InfoClassDestrCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"filters",	     InfoClassFiltersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"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},
    {"properties",   InfoClassPropCmd,		TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};
 
/*
................................................................................
		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * InfoClassPropCmd, InfoObjectPropCmd --
 *
 *	Implements [info class properties $clsName ?$option...?] and
 *	[info object properties $objName ?$option...?]
 *
 * ----------------------------------------------------------------------
 */

enum PropOpt {
    PROP_ALL, PROP_READABLE, PROP_WRITABLE
};
static const char *const propOptNames[] = {
    "-all", "-readable", "-writable",
    NULL
};

static int
InfoClassPropCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    int i, idx, all = 0, writable = 0, allocated = 0;
    Tcl_Obj *result, *propObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	}
    }

    /*
     * Get the properties.
     */

    if (all) {
	result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
	if (allocated) {
	    SortPropList(result);
	}
    } else {
	result = Tcl_NewObj();
	if (writable) {
	    FOREACH(propObj, clsPtr->properties.writable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	} else {
	    FOREACH(propObj, clsPtr->properties.readable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	}
	SortPropList(result);
    }
    Tcl_SetObjResult(interp, result);
    return TCL_OK;
}

static int
InfoObjectPropCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    int i, idx, all = 0, writable = 0, allocated = 0;
    Tcl_Obj *result, *propObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	}
    }

    /*
     * Get the properties.
     */

    if (all) {
	result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
	if (allocated) {
	    SortPropList(result);
	}
    } else {
	result = Tcl_NewObj();
	if (writable) {
	    FOREACH(propObj, oPtr->properties.writable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	} else {
	    FOREACH(propObj, oPtr->properties.readable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	}
	SortPropList(result);
    }
    Tcl_SetObjResult(interp, result);
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * SortPropList --
 *	Sort a list of names of properties. Simple support function. Assumes
 *	that the list Tcl_Obj is unshared and doesn't have a string
 *	representation.
 *
 * ----------------------------------------------------------------------
 */

static int
PropNameCompare(
    const void *a,
    const void *b)
{
    Tcl_Obj *first = *(Tcl_Obj **) a;
    Tcl_Obj *second = *(Tcl_Obj **) b;

    return strcmp(Tcl_GetString(first), Tcl_GetString(second));
}

static void
SortPropList(
    Tcl_Obj *list)
{
    int ec;
    Tcl_Obj **ev;

    Tcl_ListObjGetElements(NULL, list, &ec, &ev);
    qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOOInt.h.

156
157
158
159
160
161
162




















163
164
165
166
167
168
169
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
...
207
208
209
210
211
212
213



214
215
216
217
218
219
220
221
222
223
224
225
226
...
315
316
317
318
319
320
321



322
323
324
325
326
327
328
...
564
565
566
567
568
569
570




571
572
573
574
575
576
577
/*
 * 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
................................................................................
    Tcl_HashTable *methodsPtr;	/* Object-local Tcl_Obj (method name) to
				 * Method* mapping. */
    LIST_STATIC(struct Class *) mixins;
				/* Classes mixed into this object. */
    LIST_STATIC(Tcl_Obj *) filters;
				/* List of filter names. */
    struct Class *classPtr;	/* This is non-NULL for all classes, and NULL
				 *  for everything else. It points to the class
				 *  structure. */
    int refCount;		/* Number of strong references to this object.
				 * Note that there may be many more weak
				 * references; this mechanism exists to
				 * avoid Tcl_Preserve. */
    int flags;
    int creationEpoch;		/* Unique value to make comparisons of objects
				 * easier. */
................................................................................
				 * names. For itcl-ng. */
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */



} Object;

#define OBJECT_DESTRUCTING	1	/* Indicates that an object is being or has
								 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor script for the
							   object has began */
#define OO_UNUSED_4	4	/* No longer used.  */
#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty
................................................................................
				 * class in when those instances are defined
				 * as instances. If NULL, use the value from
				 * the class hierarchy. It's an error at
				 * [oo::objdefine]/[self] call time if this
				 * namespace is defined but doesn't exist; we
				 * also check at setting time but don't check
				 * between times. */



} 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.
................................................................................
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	TclOODeleteDescendants(Tcl_Interp *interp,
			    Object *oPtr);
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 Tcl_Namespace *TclOOGetDefineContextNamespace(
			    Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,






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







 







|
|







 







>
>
>


|
|
|
|







 







>
>
>







 







>
>
>
>







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
...
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
...
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
...
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
...
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
/*
 * These types are needed in function arguments.
 */

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

/*
 * This type is used in various places.
 */

typedef struct {
    LIST_STATIC(Tcl_Obj *) readable;
				/* The readable properties slot. */
    LIST_STATIC(Tcl_Obj *) writable;
				/* The writable properties slot. */
    Tcl_Obj *allReadableCache;	/* The cache of all readable properties
				 * exposed by this object or class (in its
				 * stereotypical instancs). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Obj *allWritableCache;	/* The cache of all writable properties
				 * exposed by this object or class (in its
				 * stereotypical instances). Contains a sorted
				 * unique list if not NULL. */
    int epoch;			/* The epoch that the caches are valid for. */
} PropertyStorage;

/*
 * 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
................................................................................
    Tcl_HashTable *methodsPtr;	/* Object-local Tcl_Obj (method name) to
				 * Method* mapping. */
    LIST_STATIC(struct Class *) mixins;
				/* Classes mixed into this object. */
    LIST_STATIC(Tcl_Obj *) filters;
				/* List of filter names. */
    struct Class *classPtr;	/* This is non-NULL for all classes, and NULL
				 * for everything else. It points to the class
				 * structure. */
    int refCount;		/* Number of strong references to this object.
				 * Note that there may be many more weak
				 * references; this mechanism exists to
				 * avoid Tcl_Preserve. */
    int flags;
    int creationEpoch;		/* Unique value to make comparisons of objects
				 * easier. */
................................................................................
				 * names. For itcl-ng. */
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this object *claims* to
				 * support. */
} Object;

#define OBJECT_DESTRUCTING 1	/* Indicates that an object is being or has
				 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor
				 * script for the object has began */
#define OO_UNUSED_4	4	/* No longer used.  */
#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty
................................................................................
				 * class in when those instances are defined
				 * as instances. If NULL, use the value from
				 * the class hierarchy. It's an error at
				 * [oo::objdefine]/[self] call time if this
				 * namespace is defined but doesn't exist; we
				 * also check at setting time but don't check
				 * between times. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this class *claims* to
				 * support. */
} 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.
................................................................................
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	TclOODeleteDescendants(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllClassProperties(Class *clsPtr,
			    int writable, int *allocated);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
			    int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Object *contextObjPtr, Class *contextClsPtr,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
			    Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,

Changes to generic/tclOOScript.h.

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
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
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
...
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
...
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
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\t::namespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
"\t\tnamespace export callback\n"
"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
"\t\tnamespace export -clear\n"
"\t\trename tmp::callback mymethod\n"
................................................................................
"\t\t\treturn\n"
"\t\t}\n"
"\t\tforeach c [info class superclass $class] {\n"
"\t\t\tset d [DelegateName $c]\n"
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
................................................................................
"\t\t::namespace export initialise\n"
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"










"\t\tmethod -clear {} {tailcall my Set {}}\n"
"\t\tmethod -prepend args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [lmap val $current {\n"
"\t\t\t\tif {$val in $args} continue else {set val}\n"
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\t\tmethod unknown {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
"\t\t\t\ttailcall my $def {*}$args\n"
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"
"\t\texport -set -append -clear -prepend -remove\n"
"\t\tunexport unknown destroy\n"
"\t}\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
"\t\t\t\t} else {\n"
................................................................................
"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
"\tclass create singleton {\n"
"\t\tsuperclass class\n"
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
................................................................................
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t}\n"
"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"




























































































































































































































"}\n"
/* !END!: Do not edit above this line. */
;
 
#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






|







 







|

|







 







|


|


|


|




|





>
>
>
>
>
>
>
>
>
>
|
|





|








|








<
|




|







 







|







 







|












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













25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
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
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
207
208
209
210
211
...
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
...
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
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
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\tnamespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
"\t\tnamespace export callback\n"
"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
"\t\tnamespace export -clear\n"
"\t\trename tmp::callback mymethod\n"
................................................................................
"\t\t\treturn\n"
"\t\t}\n"
"\t\tforeach c [info class superclass $class] {\n"
"\t\t\tset d [DelegateName $c]\n"
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
................................................................................
"\t\t::namespace export initialise\n"
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -appendifnew -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\tset args [lmap a $args {\n"
"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
"\t\t\t\tif {$a in $current} continue\n"
"\t\t\t\tset a\n"
"\t\t\t}]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [lmap val $current {\n"
"\t\t\t\tif {$val in $args} continue else {set val}\n"
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\t\tmethod unknown -unexport {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
"\t\t\t\ttailcall my $def {*}$args\n"
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"

"\t\tunexport destroy\n"
"\t}\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
"\t\t\t\t} else {\n"
................................................................................
"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
"\tclass create singleton {\n"
"\t\tsuperclass class\n"
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
................................................................................
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t}\n"
"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
"\t::namespace eval configuresupport {\n"
"\t\tnamespace path ::tcl\n"
"\t\tproc PropertyImpl {readslot writeslot args} {\n"
"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
"\t\t\t\tset prop [lindex $args $i]\n"
"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {$prop ne [list $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
"\t\t\t\t}\n"
"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
"\t\t\t\tset kind readwrite\n"
"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
"\t\t\t\t\t\t-get {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset getter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-set {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset setter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-kind {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
"\t\t\t\t\t\t\t\treadable readwrite writable\n"
"\t\t\t\t\t\t\t} $arg]\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t\tset reader <ReadProp$realprop>\n"
"\t\t\t\tset writer <WriteProp$realprop>\n"
"\t\t\t\tswitch $kind {\n"
"\t\t\t\t\treadable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\twritable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treadwrite {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t\tnamespace eval configurableclass {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tnamespace eval configurableobject {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tproc ReadAll {object my} {\n"
"\t\t\tset result {}\n"
"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $result\n"
"\t\t}\n"
"\t\tproc ReadOne {object my propertyName} {\n"
"\t\t\tset props [info object properties $object -all -readable]\n"
"\t\t\ttry {\n"
"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
"\t\t\t} on error {msg} {\n"
"\t\t\t\tcatch {\n"
"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
"\t\t\t\t}\n"
"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
"\t\t\t}\n"
"\t\t\ttry {\n"
"\t\t\t\tset value [$my <ReadProp$prop>]\n"
"\t\t\t} on error {msg opt} {\n"
"\t\t\t\tdict set opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on return {msg opt} {\n"
"\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on break {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t} on continue {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t}\n"
"\t\t\treturn $value\n"
"\t\t}\n"
"\t\tproc WriteMany {object my setterMap} {\n"
"\t\t\tset props [info object properties $object -all -writable]\n"
"\t\t\tforeach {prop value} $setterMap {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
"\t\t\t\t} on error {msg} {\n"
"\t\t\t\t\tcatch {\n"
"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
"\t\t\t\t}\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\t$my <WriteProp$prop> $value\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\t::oo::class create configurable {\n"
"\t\t\tprivate variable my\n"
"\t\t\tmethod configure -export args {\n"
"\t\t\t\t::if {![::info exists my]} {\n"
"\t\t\t\t\t::set my [::namespace which my]\n"
"\t\t\t\t}\n"
"\t\t\t\t::if {[::llength $args] == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
"\t\t\t\t\t\t[::lindex $args 0]\n"
"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class configurableclass\n"
"\t\t}\n"
"\t}\n"
"\tclass create configurable {\n"
"\t\tsuperclass class\n"
"\t\tconstructor {{definitionScript \"\"}} {\n"
"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
"\t\t\tnext $definitionScript\n"
"\t\t}\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;
 
#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to tests/oo.test.

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
....
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
....
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
....
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
....
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
	foreach initial $initials {
	    lappend x [info object class $initial]
	}
	return $x
    }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require TclOO
................................................................................
    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, 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] \
................................................................................
} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]
................................................................................
    set s [SampleSlot new]
}] -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result \
    {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {
    oo::define oo::object {
	::lappend ::result [::info object class filter]
................................................................................
    }
    return $result
} -cleanup {
    $obj destroy
} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
test oo-34.2 {TIP 380: slots - presence} {
    lsort [info class instances oo::Slot]
} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
    list [lsort [info object methods $obj -all]] \
	[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
    getMethods oo::define::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
    getMethods oo::define::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
    getMethods oo::define::superclass
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
    getMethods oo::define::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
    getMethods oo::objdefine::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
    getMethods oo::objdefine::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
    getMethods oo::objdefine::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
    oo::class create parent
    set result {}
    oo::class create 516a { superclass parent }
    oo::class create 516b { superclass parent }
    oo::class create 516c { superclass parent }
    namespace eval 516test {






|







 







|







 







|







 







|







 







|






|


|


|


|


|


|


|







372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
....
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
....
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
....
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
....
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
	foreach initial $initials {
	    lappend x [info object class $initial]
	}
	return $x
    }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require TclOO
................................................................................
    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, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, 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] \
................................................................................
} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]
................................................................................
    set s [SampleSlot new]
}] -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result \
    {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {
    oo::define oo::object {
	::lappend ::result [::info object class filter]
................................................................................
    }
    return $result
} -cleanup {
    $obj destroy
} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
test oo-34.2 {TIP 380: slots - presence} {
    lsort [info class instances oo::Slot]
} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
    list [lsort [info object methods $obj -all]] \
	[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
    getMethods oo::define::filter
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
    getMethods oo::define::mixin
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
    getMethods oo::define::superclass
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
    getMethods oo::define::variable
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
    getMethods oo::objdefine::filter
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
    getMethods oo::objdefine::mixin
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
    getMethods oo::objdefine::variable
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
    oo::class create parent
    set result {}
    oo::class create 516a { superclass parent }
    oo::class create 516b { superclass parent }
    oo::class create 516c { superclass parent }
    namespace eval 516test {

Added tests/ooProp.test.










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
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
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
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
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
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
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
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
# This file contains a collection of tests for Tcl's built-in object system,
# specifically the parts that support configurable properties on objects.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2019-2020 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}
 
test ooProp-1.1 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set a a a
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties c] [info class properties c -writable]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
test ooProp-1.2 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a a a
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties c -all] [info class properties c -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
test ooProp-1.3 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set a a a
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties c] [info class properties c -writable]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
test ooProp-1.4 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a a a
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties c -all] [info class properties c -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
test ooProp-1.5 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    oo::define d ::oo::configuresupport::readableproperties -set x y z
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    oo::define d ::oo::configuresupport::readableproperties -set r p q
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a a h
    oo::define d ::oo::configuresupport::readableproperties -set g h g
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define d ::oo::configuresupport::readableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}}
test ooProp-1.6 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    oo::define d ::oo::configuresupport::writableproperties -set x y z
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    oo::define d ::oo::configuresupport::writableproperties -set r p q
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a a h
    oo::define d ::oo::configuresupport::writableproperties -set g h g
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define d ::oo::configuresupport::writableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}}
test ooProp-1.7 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    c create o
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set
    lappend result [info object properties o] [info object properties o -writable]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}}
test ooProp-1.8 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    c create o
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set
    lappend result [info object properties o] [info object properties o -writable]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}}
test ooProp-1.9 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    d create o
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b
    oo::define d ::oo::configuresupport::readableproperties -set c d
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e
    lappend result [info object properties o -all] [info object properties o -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c d e f} {} {a b c d e f} {}}
test ooProp-1.10 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    d create o
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b
    oo::define d ::oo::configuresupport::writableproperties -set c d
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e
    lappend result [info object properties o -all] [info object properties o -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c d e f} {} {a b c d e f}}
test ooProp-1.11 {TIP 558: properties: core support cache} -setup {
    oo::class create parent
    unset -nocomplain result
} -body {
    oo::class create m {
	superclass parent
	::oo::configuresupport::readableproperties -set a
	::oo::configuresupport::writableproperties -set c
    }
    oo::class create c {
	superclass parent
	::oo::configuresupport::readableproperties -set b
	::oo::configuresupport::writableproperties -set d
    }
    c create o
    lappend result [info object properties o -all -readable] \
	[info object properties o -all -writable]
    oo::objdefine o mixin m
    lappend result [info object properties o -all -readable] \
	[info object properties o -all -writable]
} -cleanup {
    parent destroy
} -result {b d {a b} {c d}}

test ooProp-2.1 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
        variable x y
        method report {} {
            lappend ::result "x=$x, y=$y"
        }
    }
    set pt [Point new -x 3]
    $pt report
    $pt configure -y 4
    $pt report
    lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
} -cleanup {
    parent destroy
} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    oo::configurable create 3DPoint {
	superclass Point
	property z
	constructor args {
	    next -z 0 {*}$args
	}
    }
    set pt [3DPoint new -x 3 -y 4 -z 5]
    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
	[$pt configure]
} -cleanup {
    parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    set pt [Point new -x 3 -y 4]
    oo::objdefine $pt property z
    $pt configure -z 5
    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
	[$pt configure]
} -cleanup {
    parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    [Point new] configure gorp
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property "gorp": must be -x or -y}
test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    oo::configurable create 3DPoint {
	superclass Point
	property z
	constructor args {
	    next -z 0 {*}$args
	}
    }
    [3DPoint new] configure gorp
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property "gorp": must be -x, -y, or -z}
test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    [Point create p] configure -x 1 -y
} -returnCodes error -cleanup {
    parent destroy
} -result {wrong # args: should be "::p configure ?-option value ...?"}
test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	property x y -kind writable
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    Point create p
    list [p configure -y ok] [catch {p configure -y} msg] $msg
} -cleanup {
    parent destroy
} -result {{} 1 {property "-y" is write only}}
test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	property x y -kind readable
        constructor args {
            my configure -x 0 {*}$args
	    variable y 123
        }
    }
    Point create p
    list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
} -cleanup {
    parent destroy
} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}

test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property x -get {
	    global result
	    lappend result "get"
	    return [lrepeat 3 $xyz]
	} -set {
	    global result
	    lappend result [list set $value]
	    set xyz [expr {$value * 3}]
	}
    }
    Point create pt
    pt configure -x 5
    lappend result >[pt configure -x]<
} -cleanup {
    parent destroy
} -result {{set 5} get {>15 15 15<}}
test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property x -get {
	    global result
	    lappend result "get"
	    return [lrepeat 3 $xyz]
	} -set {
	    global result
	    lappend result [list set $value]
	    set xyz [expr {$value * 3}]
	} y -kind readable -get {return $xyz}
    }
    Point create pt
    pt configure -x 5
    lappend result >[pt configure -x]< [pt configure -y]
} -cleanup {
    parent destroy
} -result {{set 5} get {>15 15 15<} 15}
test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property -x -get {return $xyz}
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "-x": must not begin with -}
test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property "x y"
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x y": must be a simple word}
test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property ::x
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "::x": must not contain namespace separators}
test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x(
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x(": must not contain parentheses}
test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x)
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x)": must not contain parentheses}
test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -get
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -get option}
test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -set
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -set option}
test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -kind
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing kind value to go with -kind option}
test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -get {} -set
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -set option}
test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {} -get {return ok}
    }
    [Point new] configure -x
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -kind gorp
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad kind "gorp": must be readable, readwrite, or writable}
test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -k reada -g {return ok}
    }
    [Point new] configure -x
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property {*}{
	    x -kind writable
	    y -get {return ok}
	}
    }
    [Point new] configure -y
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	variable xy
	property x -kind readable -get {return $xy}
	property x -kind writable -set {set xy $value}
    }
    Point create pt
    list [catch {
	pt configure -x ok
    } msg] $msg [catch {
	pt configure -x
    } msg] $msg [catch {
	pt configure -y 1
    } msg] $msg
} -cleanup {
    parent destroy
} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}}
test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code break}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a break}
test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code break}
    }
    while 1 {
	[Point new] configure
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a break}
test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {error "boo"}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {error "boo"}
    }
    while 1 {
	[Point new] configure
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code continue}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a continue}
test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure -x
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -code break}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property setter for -x did a break}
test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -code continue}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property setter for -x did a continue}
test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {error "boo"}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure -x gorp
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	private property var
    }
    Point create pt
    pt configure -var ok
    pt configure -var
} -cleanup {
    parent destroy
} -result ok

test ooProp-4.1 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property -x}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property name "-x": must not begin with -
    while executing
"property -x"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}}
test ooProp-4.2 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -get}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing body to go with -get option
    while executing
"property x -get"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -get}"} {TCL WRONGARGS}}
test ooProp-4.3 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -set}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing body to go with -set option
    while executing
"property x -set"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -set}"} {TCL WRONGARGS}}
test ooProp-4.4 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -kind}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing kind value to go with -kind option
    while executing
"property x -kind"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -kind}"} {TCL WRONGARGS}}
test ooProp-4.5 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -kind gorp}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad kind "gorp": must be readable, readwrite, or writable
    while executing
"property x -kind gorp"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}}
test ooProp-4.6 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -gorp}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad option "-gorp": must be -get, -kind, or -set
    while executing
"property x -gorp"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}}
test ooProp-4.7 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {
	superclass parent
	property x
    }
    Point create pt
    list [catch {pt configure -gorp} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property "-gorp": must be -x
    while executing
"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}}
test ooProp-4.8 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {
	superclass parent
	property x
    }
    Point create pt
    list [catch {pt configure -gorp blarg} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property "-gorp": must be -x
    while executing
"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}
 
cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tools/tclOOScript.tcl.

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
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
...
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
...
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
...
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
...
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
...
443
444
445
446
447
448
449
450

451











































































































































































































































































































































452
453
454
455
456
# tclOOScript.h --
#
# 	This file contains support scripts for TclOO. They are defined here so
# 	that the code can be definitely run even in safe interpreters; TclOO's
# 	core setup is safe.
#
# Copyright (c) 2012-2018 Donal K. Fellows
# Copyright (c) 2013 Andreas Kupries
# Copyright (c) 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
::namespace eval ::oo {
    ::namespace path {}

    #
    # Commands that are made available to objects by default.
    #
    namespace eval Helpers {
	::namespace path {}

	# ------------------------------------------------------------------
	#
	# callback, mymethod --
	#
	#	Create a script prefix that calls a method on the current
	#	object. Same operation, two names.
................................................................................
	    return
	}
	foreach c [info class superclass $class] {
	    set d [DelegateName $c]
	    if {![info object isa class $d]} {
		continue
	    }
	    define $delegate ::oo::define::superclass -append $d
	}
	objdefine $class ::oo::objdefine::mixin -append $delegate
    }

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a
................................................................................
	#
	#	Basic slot getter. Retrieves the contents of the slot.
	#	Particular slots must provide concrete non-erroring
	#	implementation.
	#
	# ------------------------------------------------------------------

	method Get {} {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Set --
	#
	#	Basic slot setter. Sets the contents of the slot.  Particular
	#	slots must provide concrete non-erroring implementation.
	#
	# ------------------------------------------------------------------

	method Set list {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Resolve --
	#
	#	Helper that lets a slot convert a list of arguments of a
	#	particular type to their canonical forms. Defaults to doing
	#	nothing (suitable for simple strings).
	#
	# ------------------------------------------------------------------

	method Resolve list {
	    return $list
	}

	# ------------------------------------------------------------------
	#
	# Slot -set, -append, -clear, --default-operation --
	#
	#	Standard public slot operations. If a slot can't figure out
	#	what method to call directly, it uses --default-operation.
	#
	# ------------------------------------------------------------------

	method -set args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    tailcall my Set $args
	}
	method -append args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$current {*}$args]
	}











	method -clear {} {tailcall my Set {}}
	method -prepend args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$args {*}$current]
	}
	method -remove args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [lmap val $current {
		if {$val in $args} continue else {set val}
	    }]
	}

	# Default handling
	forward --default-operation my -append
	method unknown {args} {
	    set def --default-operation
	    if {[llength $args] == 0} {
		tailcall my $def
	    } elseif {![string match -* [lindex $args 0]]} {
		tailcall my $def {*}$args
	    }
	    next {*}$args
	}

	# Set up what is exported and what isn't
	export -set -append -clear -prepend -remove
	unexport unknown destroy
    }

    # Set the default operation differently for these slots
    objdefine define::superclass forward --default-operation my -set
    objdefine define::mixin forward --default-operation my -set
    objdefine objdefine::mixin forward --default-operation my -set

................................................................................
    #
    #	Handler for cloning objects that clones basic bits (only!) of the
    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
    #	more complex (and class-specific) handling.
    #
    # ----------------------------------------------------------------------

    define object method <cloned> {originObject} {
	# Copy over the procedures from the original namespace
	foreach p [info procs [info object namespace $originObject]::*] {
	    set args [info args $p]
	    set idx -1
	    foreach a $args {
		if {[info default $p $a d]} {
		    lset args [incr idx] [list $a $d]
................................................................................
    #
    # oo::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> {originObject} {
	next $originObject
	# Rebuild the class inheritance delegation class
	::oo::UpdateClassDelegatesAfterClone $originObject [self]
    }

    # ----------------------------------------------------------------------
    #
................................................................................
	    if {![info exists object] || ![info object isa object $object]} {
		set object [next {*}$args]
		::oo::objdefine $object {
		    method destroy {} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not destroy a singleton object"
		    }
		    method <cloned> {originObject} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not clone a singleton object"
		    }
		}
	    }
	    return $object
	}
................................................................................
    #
    # ----------------------------------------------------------------------

    class create abstract {
	superclass class
	unexport create createWithNamespace new
    }
}

 











































































































































































































































































































































# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:





|













|







 







|

|







 







|












|













|












|




|





>
>
>
>
>
>
>
>
>
>
>
|
|





|










|









|
<
|







 







|







 







|







 







|







 







|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





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
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
...
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
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
...
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
...
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
...
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
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
# tclOOScript.h --
#
# 	This file contains support scripts for TclOO. They are defined here so
# 	that the code can be definitely run even in safe interpreters; TclOO's
# 	core setup is safe.
#
# Copyright (c) 2012-2019 Donal K. Fellows
# Copyright (c) 2013 Andreas Kupries
# Copyright (c) 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
::namespace eval ::oo {
    ::namespace path {}

    #
    # Commands that are made available to objects by default.
    #
    namespace eval Helpers {
	namespace path {}

	# ------------------------------------------------------------------
	#
	# callback, mymethod --
	#
	#	Create a script prefix that calls a method on the current
	#	object. Same operation, two names.
................................................................................
	    return
	}
	foreach c [info class superclass $class] {
	    set d [DelegateName $c]
	    if {![info object isa class $d]} {
		continue
	    }
	    define $delegate ::oo::define::superclass -appendifnew $d
	}
	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
    }

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a
................................................................................
	#
	#	Basic slot getter. Retrieves the contents of the slot.
	#	Particular slots must provide concrete non-erroring
	#	implementation.
	#
	# ------------------------------------------------------------------

	method Get -unexport {} {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Set --
	#
	#	Basic slot setter. Sets the contents of the slot.  Particular
	#	slots must provide concrete non-erroring implementation.
	#
	# ------------------------------------------------------------------

	method Set -unexport list {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Resolve --
	#
	#	Helper that lets a slot convert a list of arguments of a
	#	particular type to their canonical forms. Defaults to doing
	#	nothing (suitable for simple strings).
	#
	# ------------------------------------------------------------------

	method Resolve -unexport list {
	    return $list
	}

	# ------------------------------------------------------------------
	#
	# Slot -set, -append, -clear, --default-operation --
	#
	#	Standard public slot operations. If a slot can't figure out
	#	what method to call directly, it uses --default-operation.
	#
	# ------------------------------------------------------------------

	method -set -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    tailcall my Set $args
	}
	method -append -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$current {*}$args]
	}
	method -appendifnew -export args {
	    set my [namespace which my]
	    set current [uplevel 1 [list $my Get]]
	    foreach a $args {
		set a [uplevel 1 [list $my Resolve $a]]
		if {$a ni $current} {
		    lappend current $a
		}
	    }
	    tailcall my Set $current
	}
	method -clear -export {} {tailcall my Set {}}
	method -prepend -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$args {*}$current]
	}
	method -remove -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [lmap val $current {
		if {$val in $args} continue else {set val}
	    }]
	}

	# Default handling
	forward --default-operation my -append
	method unknown -unexport {args} {
	    set def --default-operation
	    if {[llength $args] == 0} {
		tailcall my $def
	    } elseif {![string match -* [lindex $args 0]]} {
		tailcall my $def {*}$args
	    }
	    next {*}$args
	}

	# Hide destroy

	unexport destroy
    }

    # Set the default operation differently for these slots
    objdefine define::superclass forward --default-operation my -set
    objdefine define::mixin forward --default-operation my -set
    objdefine objdefine::mixin forward --default-operation my -set

................................................................................
    #
    #	Handler for cloning objects that clones basic bits (only!) of the
    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
    #	more complex (and class-specific) handling.
    #
    # ----------------------------------------------------------------------

    define object method <cloned> -unexport {originObject} {
	# Copy over the procedures from the original namespace
	foreach p [info procs [info object namespace $originObject]::*] {
	    set args [info args $p]
	    set idx -1
	    foreach a $args {
		if {[info default $p $a d]} {
		    lset args [incr idx] [list $a $d]
................................................................................
    #
    # oo::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> -unexport {originObject} {
	next $originObject
	# Rebuild the class inheritance delegation class
	::oo::UpdateClassDelegatesAfterClone $originObject [self]
    }

    # ----------------------------------------------------------------------
    #
................................................................................
	    if {![info exists object] || ![info object isa object $object]} {
		set object [next {*}$args]
		::oo::objdefine $object {
		    method destroy {} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not destroy a singleton object"
		    }
		    method <cloned> -unexport {originObject} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not clone a singleton object"
		    }
		}
	    }
	    return $object
	}
................................................................................
    #
    # ----------------------------------------------------------------------

    class create abstract {
	superclass class
	unexport create createWithNamespace new
    }

    # ----------------------------------------------------------------------
    #
    # oo::configuresupport --
    #
    #	Namespace that holds all the implementation details of TIP #558.
    #	Also includes the commands:
    #
    #	 * readableproperties
    #	 * writableproperties
    #	 * objreadableproperties
    #	 * objwritableproperties
    #
    #	Those are all slot implementations that provide access to the C layer
    #	of property support (i.e., very fast cached lookup of property names).
    #
    # ----------------------------------------------------------------------

    ::namespace eval configuresupport {
	namespace path ::tcl

	# ------------------------------------------------------------------
	#
	# oo::configuresupport --
	#
	#	A metaclass that is used to make classes that can be configured.
	#
	# ------------------------------------------------------------------

	proc PropertyImpl {readslot writeslot args} {
	    for {set i 0} {$i < [llength $args]} {incr i} {
		# Parse the property name
		set prop [lindex $args $i]
		if {[string match "-*" $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not begin with -"
		}
		if {$prop ne [list $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must be a simple word"
		}
		if {[string first "::" $prop] != -1} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not contain namespace separators"
		}
		if {[string match {*[()]*} $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not contain parentheses"
		}
		set realprop [string cat "-" $prop]
		set getter [format {::set [my varname %s]} $prop]
		set setter [format {::set [my varname %s] $value} $prop]
		set kind readwrite

		# Parse the extra options
		while {[set next [lindex $args [expr {$i + 1}]]
			string match "-*" $next]} {
		    set arg [lindex $args [incr i 2]]
		    switch [prefix match -error [list -level 2 -errorcode \
			    [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {
			-get {
			    if {$i >= [llength $args]} {
				return -code error -level 2 \
				    -errorcode {TCL WRONGARGS} \
				    "missing body to go with -get option"
			    }
			    set getter $arg
			}
			-set {
			    if {$i >= [llength $args]} {
				return -code error -level 2 \
				    -errorcode {TCL WRONGARGS} \
				    "missing body to go with -set option"
			    }
			    set setter $arg
			}
			-kind {
			    if {$i >= [llength $args]} {
				return -code error -level 2\
				    -errorcode {TCL WRONGARGS} \
				    "missing kind value to go with -kind option"
			    }
			    set kind [prefix match -message "kind" -error [list \
				    -level 2 \
				    -errorcode [list TCL LOOKUP INDEX kind $arg]] {
				readable readwrite writable
			    } $arg]
			}
		    }
		}

		# Install the option
		set reader <ReadProp$realprop>
		set writer <WriteProp$realprop>
		switch $kind {
		    readable {
			uplevel 2 [list $readslot -append $realprop]
			uplevel 2 [list $writeslot -remove $realprop]
			uplevel 2 [list method $reader -unexport {} $getter]
		    }
		    writable {
			uplevel 2 [list $readslot -remove $realprop]
			uplevel 2 [list $writeslot -append $realprop]
			uplevel 2 [list method $writer -unexport {value} $setter]
		    }
		    readwrite {
			uplevel 2 [list $readslot -append $realprop]
			uplevel 2 [list $writeslot -append $realprop]
			uplevel 2 [list method $reader -unexport {} $getter]
			uplevel 2 [list method $writer -unexport {value} $setter]
		    }
		}
	    }
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::configurableclass,
	# oo::configuresupport::configurableobject --
	#
	#	Namespaces used as implementation vectors for oo::define and
	#	oo::objdefine when the class/instance is configurable.
	# 
	# ------------------------------------------------------------------

	namespace eval configurableclass {
	    ::proc property args {
		::oo::configuresupport::PropertyImpl \
		    ::oo::configuresupport::readableproperties \
		    ::oo::configuresupport::writableproperties {*}$args
	    }
	    # Plural alias just in case; deliberately NOT documented!
	    ::proc properties args {::tailcall property {*}$args}
	    ::namespace path ::oo::define
	    ::namespace export property
	}

	namespace eval configurableobject {
	    ::proc property args {
		::oo::configuresupport::PropertyImpl \
		    ::oo::configuresupport::objreadableproperties \
		    ::oo::configuresupport::objwritableproperties {*}$args
	    }
	    # Plural alias just in case; deliberately NOT documented!
	    ::proc properties args {::tailcall property {*}$args}
	    ::namespace path ::oo::objdefine
	    ::namespace export property
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::ReadAll --
	#
	#	The implementation of [$o configure] with no extra arguments.
	#
	# ------------------------------------------------------------------

	proc ReadAll {object my} {
	    set result {}
	    foreach prop [info object properties $object -all -readable] {
		try {
		    dict set result $prop [$my <ReadProp$prop>]
		} on error {msg opt} {
		    dict set opt -level 2
		    return -options $opt $msg
		} on return {msg opt} {
		    dict incr opt -level 2
		    return -options $opt $msg
		} on break {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property getter for $prop did a break"
		} on continue {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property getter for $prop did a continue"
		}
	    }
	    return $result
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::ReadOne --
	#
	#	The implementation of [$o configure -prop] with that single
	#	extra argument.
	#
	# ------------------------------------------------------------------

	proc ReadOne {object my propertyName} {
	    set props [info object properties $object -all -readable]
	    try {
		set prop [prefix match -message "property" $props $propertyName]
	    } on error {msg} {
		catch {
		    set wps [info object properties $object -all -writable]
		    set wprop [prefix match $wps $propertyName]
		    set msg "property \"$wprop\" is write only"
		}
		return -code error -level 2 -errorcode [list \
			TCL LOOKUP INDEX property $propertyName] $msg
	    }
	    try {
		set value [$my <ReadProp$prop>]
	    } on error {msg opt} {
		dict set opt -level 2
		return -options $opt $msg
	    } on return {msg opt} {
		dict incr opt -level 2
		return -options $opt $msg
	    } on break {} {
		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
		    "property getter for $prop did a break"
	    } on continue {} {
		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
		    "property getter for $prop did a continue"
	    }
	    return $value
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::WriteMany --
	#
	#	The implementation of [$o configure -prop val ?-prop val...?].
	#
	# ------------------------------------------------------------------

	proc WriteMany {object my setterMap} {
	    set props [info object properties $object -all -writable]
	    foreach {prop value} $setterMap {
		try {
		    set prop [prefix match -message "property" $props $prop]
		} on error {msg} {
		    catch {
			set rps [info object properties $object -all -readable]
			set rprop [prefix match $rps $prop]
			set msg "property \"$rprop\" is read only"
		    }
		    return -code error -level 2 -errorcode [list \
			    TCL LOOKUP INDEX property $prop] $msg
		}
		try {
		    $my <WriteProp$prop> $value
		} on error {msg opt} {
		    dict set opt -level 2
		    return -options $opt $msg
		} on return {msg opt} {
		    dict incr opt -level 2
		    return -options $opt $msg
		} on break {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property setter for $prop did a break"
		} on continue {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property setter for $prop did a continue"
		}
	    }
	    return
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::configurable --
	#
	#	The class that contains the implementation of the actual
	#	'configure' method (mixed into actually configurable classes).
	#	Great care needs to be taken in these methods as they are
	#	potentially used in classes where the current namespace is set
	#	up very strangely.
	#
	# ------------------------------------------------------------------

	::oo::class create configurable {
	    private variable my
	    #
	    # configure --
	    #	Method for providing client access to the property mechanism.
	    #	Has a user-facing API similar to that of [chan configure].
	    # 
	    method configure -export args {
		::if {![::info exists my]} {
		    ::set my [::namespace which my]
		}
		::if {[::llength $args] == 0} {
		    # Read all properties
		    ::oo::configuresupport::ReadAll [self] $my
		} elseif {[::llength $args] == 1} {
		    # Read a single property
		    ::oo::configuresupport::ReadOne [self] $my \
			[::lindex $args 0]
		} elseif {[::llength $args] % 2 == 0} {
		    # Set properties, one or several
		    ::oo::configuresupport::WriteMany [self] $my $args
		} else {
		    # Invalid call
		    ::return -code error -errorcode {TCL WRONGARGS} \
			[::format {wrong # args: should be "%s"} \
			    "[self] configure ?-option value ...?"]
		}
	    }

	    definitionnamespace -instance configurableobject
	    definitionnamespace -class configurableclass
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::configurable --
    #
    #	A metaclass that is used to make classes that can be configured in
    #	their creation phase (and later too). All the metaclass itself does is
    #	arrange for the class created to have a 'configure' method and for
    #	oo::define and oo::objdefine (on the class and its instances) to have
    #	a property definition for setting things up for 'configure'.
    #
    # ----------------------------------------------------------------------

    class create configurable {
	superclass class

	constructor {{definitionScript ""}} {
	    next {mixin ::oo::configuresupport::configurable}
	    next $definitionScript
	}

	definitionnamespace -class configuresupport::configurableclass
    }
}
 
# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End: