1 /*
2 * tclOO.c --
3 *
4 * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
5 *
6 * Copyright (c) 2005-2012 by Donal K. Fellows
7 * Copyright (c) 2017 by Nathan Coulter
8 *
9 * See the file "license.terms" for information on usage and redistribution of
10 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 */
12
13 #ifdef HAVE_CONFIG_H
14 #include "config.h"
15 #endif
16 #include "tclInt.h"
17 #include "tclOOInt.h"
18
19 /*
20 * Commands in oo::define.
21 */
22
23 static const struct {
24 const char *name;
25 Tcl_ObjCmdProc *objProc;
26 int flag;
27 } defineCmds[] = {
28 {"constructor", TclOODefineConstructorObjCmd, 0},
29 {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
30 {"destructor", TclOODefineDestructorObjCmd, 0},
31 {"export", TclOODefineExportObjCmd, 0},
32 {"forward", TclOODefineForwardObjCmd, 0},
33 {"method", TclOODefineMethodObjCmd, 0},
34 {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
35 {"self", TclOODefineSelfObjCmd, 0},
36 {"unexport", TclOODefineUnexportObjCmd, 0},
37 {NULL, NULL, 0}
38 }, objdefCmds[] = {
39 {"class", TclOODefineClassObjCmd, 1},
40 {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
41 {"export", TclOODefineExportObjCmd, 1},
42 {"forward", TclOODefineForwardObjCmd, 1},
43 {"method", TclOODefineMethodObjCmd, 1},
44 {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
45 {"unexport", TclOODefineUnexportObjCmd, 1},
46 {NULL, NULL, 0}
47 };
48
49 /*
50 * What sort of size of things we like to allocate.
51 */
52
53 #define ALLOC_CHUNK 8
54
55 /*
56 * Function declarations for things defined in this file.
57 */
58
59 static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
60 Namespace *nsPtr, const char *nsNameStr);
61 static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
62 Method *mPtr, Tcl_Obj *namePtr,
63 Method **newMPtrPtr);
64 static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
65 Method *mPtr, Tcl_Obj *namePtr);
66 static void DeletedDefineNamespace(ClientData clientData);
67 static void DeletedObjdefNamespace(ClientData clientData);
68 static void DeletedHelpersNamespace(ClientData clientData);
69 static Tcl_NRPostProc FinalizeAlloc;
70 static Tcl_NRPostProc FinalizeNext;
71 static Tcl_NRPostProc FinalizeObjectCall;
72 static void initClassPath(Tcl_Interp * interp, Class *clsPtr);
73 static int InitFoundation(Tcl_Interp *interp);
74 static void KillFoundation(ClientData clientData,
75 Tcl_Interp *interp);
76 static void MyDeleted(ClientData clientData);
77 static void ObjectNamespaceDeleted(ClientData clientData);
78 static void ObjectRenamedTrace(ClientData clientData,
79 Tcl_Interp *interp, const char *oldName,
80 const char *newName, int flags);
81 static inline void SquelchCachedName(Object *oPtr);
82
83 static int PublicObjectCmd(ClientData clientData,
84 Tcl_Interp *interp, int objc,
85 Tcl_Obj *const *objv);
86 static int PublicNRObjectCmd(ClientData clientData,
87 Tcl_Interp *interp, int objc,
88 Tcl_Obj *const *objv);
89 static int PrivateObjectCmd(ClientData clientData,
90 Tcl_Interp *interp, int objc,
91 Tcl_Obj *const *objv);
92 static int PrivateNRObjectCmd(ClientData clientData,
93 Tcl_Interp *interp, int objc,
94 Tcl_Obj *const *objv);
95 static void RemoveClass(Class ** list, int num, int idx);
96 static void RemoveObject(Object ** list, int num, int idx);
97
98 /*
99 * Methods in the oo::object and oo::class classes. First, we define a helper
100 * macro that makes building the method type declaration structure a lot
101 * easier. No point in making life harder than it has to be!
102 *
103 * Note that the core methods don't need clone or free proc callbacks.
104 */
105
106 #define DCM(name,visibility,proc) \
107 {name,visibility,\
108 {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}
109
110 static const DeclaredClassMethod objMethods[] = {
111 DCM("destroy", 1, TclOO_Object_Destroy),
112 DCM("eval", 0, TclOO_Object_Eval),
113 DCM("unknown", 0, TclOO_Object_Unknown),
114 DCM("variable", 0, TclOO_Object_LinkVar),
115 DCM("varname", 0, TclOO_Object_VarName),
116 {NULL, 0, {0, NULL, NULL, NULL, NULL}}
117 }, clsMethods[] = {
118 DCM("create", 1, TclOO_Class_Create),
119 DCM("new", 1, TclOO_Class_New),
120 DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
121 {NULL, 0, {0, NULL, NULL, NULL, NULL}}
122 };
123
124 /*
125 * And for the oo::class constructor...
126 */
127
128 static const Tcl_MethodType classConstructor = {
129 TCL_OO_METHOD_VERSION_CURRENT,
130 "oo::class constructor",
131 TclOO_Class_Constructor, NULL, NULL
132 };
133
134 /*
135 * Scripted parts of TclOO. First, the main script (cannot be outside this
136 * file).
137 */
138
139 static const char *initScript =
140 "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
141 "namespace eval ::oo { variable version " TCLOO_VERSION " };"
142 "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
143 /* "tcl_findLibrary tcloo $oo::version $oo::version" */
144 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
145
146 /*
147 * The scripted part of the definitions of slots.
148 */
149
150 static const char *slotScript =
151 "::oo::define ::oo::Slot {\n"
152 " method Get {} {error unimplemented}\n"
153 " method Set list {error unimplemented}\n"
154 " method -set args {\n"
155 " uplevel 1 [list [namespace which my] Set $args]\n"
156 " }\n"
157 " method -append args {\n"
158 " uplevel 1 [list [namespace which my] Set [list"
159 " {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
160 " }\n"
161 " method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
162 " forward --default-operation my -append\n"
163 " method unknown {args} {\n"
164 " set def --default-operation\n"
165 " if {[llength $args] == 0} {\n"
166 " return [uplevel 1 [list [namespace which my] $def]]\n"
167 " } elseif {![string match -* [lindex $args 0]]} {\n"
168 " return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
169 " }\n"
170 " next {*}$args\n"
171 " }\n"
172 " export -set -append -clear\n"
173 " unexport unknown destroy\n"
174 "}\n"
175 "::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
176 "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
177 "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
178
179 /*
180 * The body of the <cloned> method of oo::object.
181 */
182
183 static const char *clonedBody =
184 "foreach p [info procs [info object namespace $originObject]::*] {"
185 " set args [info args $p];"
186 " set idx -1;"
187 " foreach a $args {"
188 " lset args [incr idx] "
189 " [if {[info default $p $a d]} {list $a $d} {list $a}]"
190 " };"
191 " set b [info body $p];"
192 " set p [namespace tail $p];"
193 " proc $p $args $b;"
194 "};"
195 "foreach v [info vars [info object namespace $originObject]::*] {"
196 " upvar 0 $v vOrigin;"
197 " namespace upvar [namespace current] [namespace tail $v] vNew;"
198 " if {[info exists vOrigin]} {"
199 " if {[array exists vOrigin]} {"
200 " array set vNew [array get vOrigin];"
201 " } else {"
202 " set vNew $vOrigin;"
203 " }"
204 " }"
205 "}";
206
207 /*
208 * The actual definition of the variable holding the TclOO stub table.
209 */
210
211 MODULE_SCOPE const TclOOStubs tclOOStubs;
212
213 /*
214 * Convenience macro for getting the foundation from an interpreter.
215 */
216
217 #define GetFoundation(interp) \
218 ((Foundation *)((Interp *)(interp))->objectFoundation)
219
220 /*
221 * Macros to make inspecting into the guts of an object cleaner.
222 *
223 * The ocPtr parameter (only in these macros) is assumed to work fine with
224 * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
225 * have _both_ their object and class flags tagged with ROOT_OBJECT and
226 * ROOT_CLASS respectively.
227 */
228
229 #define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING)
230 #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
231 #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
232 #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
233
234 #define RemoveItem(type, lst, i) \
235 do { \
236 Remove ## type ((lst).list, (lst).num, i); \
237 (lst).num--; \
238 } while (0)
239
240 /*
241 * ----------------------------------------------------------------------
242 *
243 * TclOOInit --
244 *
245 * Called to initialise the OO system within an interpreter.
246 *
247 * Result:
248 * TCL_OK if the setup succeeded. Currently assumed to always work.
249 *
250 * Side effects:
251 * Creates namespaces, commands, several classes and a number of
252 * callbacks. Upon return, the OO system is ready for use.
253 *
254 * ----------------------------------------------------------------------
255 */
256
257 int
TclOOInit(Tcl_Interp * interp)258 TclOOInit(
259 Tcl_Interp *interp) /* The interpreter to install into. */
260 {
261 /*
262 * Build the core of the OO system.
263 */
264
265 if (InitFoundation(interp) != TCL_OK) {
266 return TCL_ERROR;
267 }
268
269 /*
270 * Run our initialization script and, if that works, declare the package
271 * to be fully provided.
272 */
273
274 if (Tcl_Eval(interp, initScript) != TCL_OK) {
275 return TCL_ERROR;
276 }
277
278 return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
279 (ClientData) &tclOOStubs);
280 }
281
282 /*
283 * ----------------------------------------------------------------------
284 *
285 * TclOOGetFoundation --
286 *
287 * Get a reference to the OO core class system.
288 *
289 * ----------------------------------------------------------------------
290 */
291
292 Foundation *
TclOOGetFoundation(Tcl_Interp * interp)293 TclOOGetFoundation(
294 Tcl_Interp *interp)
295 {
296 return GetFoundation(interp);
297 }
298
299 /*
300 * ----------------------------------------------------------------------
301 *
302 * InitFoundation --
303 *
304 * Set up the core of the OO core class system. This is a structure
305 * holding references to the magical bits that need to be known about in
306 * other places, plus the oo::object and oo::class classes.
307 *
308 * ----------------------------------------------------------------------
309 */
310
311 static int
InitFoundation(Tcl_Interp * interp)312 InitFoundation(
313 Tcl_Interp *interp)
314 {
315 static Tcl_ThreadDataKey tsdKey;
316 ThreadLocalData *tsdPtr =
317 Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
318 Foundation *fPtr = ckalloc(sizeof(Foundation));
319 Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
320
321 Class fakeCls;
322 Object fakeObject;
323
324 Tcl_DString buffer;
325 Command *cmdPtr;
326 int i;
327
328 /*
329 * Initialize the structure that holds the OO system core. This is
330 * attached to the interpreter via an assocData entry; not very efficient,
331 * but the best we can do without hacking the core more.
332 */
333
334 memset(fPtr, 0, sizeof(Foundation));
335 ((Interp *) interp)->objectFoundation = fPtr;
336 fPtr->interp = interp;
337 fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
338 Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
339 fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
340 DeletedDefineNamespace);
341 fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
342 DeletedObjdefNamespace);
343 fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
344 DeletedHelpersNamespace);
345 fPtr->epoch = 0;
346 fPtr->tsdPtr = tsdPtr;
347 TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
348 TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
349 TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
350 TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
351 TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
352 Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
353 Tcl_IncrRefCount(fPtr->constructorName);
354 Tcl_IncrRefCount(fPtr->destructorName);
355 Tcl_IncrRefCount(fPtr->clonedName);
356 Tcl_IncrRefCount(fPtr->defineName);
357 Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
358 TclOOUnknownDefinition, NULL, NULL);
359 TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
360 Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
361 Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
362
363 /*
364 * Create the subcommands in the oo::define and oo::objdefine spaces.
365 */
366
367 Tcl_DStringInit(&buffer);
368 for (i = 0 ; defineCmds[i].name ; i++) {
369 TclDStringAppendLiteral(&buffer, "::oo::define::");
370 Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
371 Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
372 defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
373 Tcl_DStringFree(&buffer);
374 }
375 for (i = 0 ; objdefCmds[i].name ; i++) {
376 TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
377 Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
378 Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
379 objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
380 Tcl_DStringFree(&buffer);
381 }
382
383 Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
384
385 /*
386 * Create the objects at the core of the object system. These need to be
387 * spliced manually.
388 */
389
390 /*
391 * Stand up a phony class for bootstrapping.
392 */
393
394 fPtr->objectCls = &fakeCls;
395
396 /*
397 * Referenced in TclOOAllocClass to increment the refCount.
398 */
399
400 fakeCls.thisPtr = &fakeObject;
401
402 fPtr->objectCls = TclOOAllocClass(interp,
403 AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
404 /*
405 * Corresponding TclOODecrRefCount in KillFoudation.
406 */
407
408 AddRef(fPtr->objectCls->thisPtr);
409
410 /*
411 * This is why it is unnecessary in this routine to replace the
412 * incremented reference count of fPtr->objectCls that was swallowed by
413 * fakeObject.
414 */
415
416 fPtr->objectCls->superclasses.num = 0;
417 ckfree(fPtr->objectCls->superclasses.list);
418 fPtr->objectCls->superclasses.list = NULL;
419
420 /*
421 * Special initialization for the primordial objects.
422 */
423
424 fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
425 fPtr->objectCls->flags |= ROOT_OBJECT;
426
427 fPtr->classCls = TclOOAllocClass(interp,
428 AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
429
430 /*
431 * Corresponding TclOODecrRefCount in KillFoudation.
432 */
433
434 AddRef(fPtr->classCls->thisPtr);
435
436 /*
437 * Increment reference counts for each reference because these
438 * relationships can be dynamically changed.
439 *
440 * Corresponding TclOODecrRefCount for all incremented refcounts is in
441 * KillFoundation.
442 */
443
444 /*
445 * Rewire bootstrapped objects.
446 */
447
448 fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
449 AddRef(fPtr->classCls->thisPtr);
450 TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
451
452 fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
453 AddRef(fPtr->classCls->thisPtr);
454 TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
455
456 fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
457 fPtr->classCls->flags |= ROOT_CLASS;
458
459 /*
460 * Standard initialization for new Objects.
461 */
462
463 TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
464
465 /*
466 * Basic method declarations for the core classes.
467 */
468
469 for (i = 0 ; objMethods[i].name ; i++) {
470 TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
471 }
472 for (i = 0 ; clsMethods[i].name ; i++) {
473 TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
474 }
475
476 /*
477 * Create the default <cloned> method implementation, used when 'oo::copy'
478 * is called to finish the copying of one object to another.
479 */
480
481 TclNewLiteralStringObj(argsPtr, "originObject");
482 Tcl_IncrRefCount(argsPtr);
483 bodyPtr = Tcl_NewStringObj(clonedBody, -1);
484 TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
485 bodyPtr, NULL);
486 TclDecrRefCount(argsPtr);
487
488 /*
489 * Finish setting up the class of classes by marking the 'new' method as
490 * private; classes, unlike general objects, must have explicit names. We
491 * also need to create the constructor for classes.
492 */
493
494 TclNewLiteralStringObj(namePtr, "new");
495 Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
496 namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
497 fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
498 (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
499
500 /*
501 * Create non-object commands and plug ourselves into the Tcl [info]
502 * ensemble.
503 */
504
505 cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
506 NULL, TclOONextObjCmd, NULL, NULL);
507 cmdPtr->compileProc = TclCompileObjectNextCmd;
508 cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
509 NULL, TclOONextToObjCmd, NULL, NULL);
510 cmdPtr->compileProc = TclCompileObjectNextToCmd;
511 cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
512 TclOOSelfObjCmd, NULL, NULL);
513 cmdPtr->compileProc = TclCompileObjectSelfCmd;
514 Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
515 NULL);
516 Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
517 NULL);
518 Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
519 TclOOInitInfo(interp);
520
521 /*
522 * Now make the class of slots.
523 */
524
525 if (TclOODefineSlots(fPtr) != TCL_OK) {
526 return TCL_ERROR;
527 }
528 return Tcl_Eval(interp, slotScript);
529 }
530
531 /*
532 * ----------------------------------------------------------------------
533 *
534 * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
535 *
536 * Simple helpers used to clear fields of the foundation when they no
537 * longer hold useful information.
538 *
539 * ----------------------------------------------------------------------
540 */
541
542 static void
DeletedDefineNamespace(ClientData clientData)543 DeletedDefineNamespace(
544 ClientData clientData)
545 {
546 Foundation *fPtr = clientData;
547
548 fPtr->defineNs = NULL;
549 }
550
551 static void
DeletedObjdefNamespace(ClientData clientData)552 DeletedObjdefNamespace(
553 ClientData clientData)
554 {
555 Foundation *fPtr = clientData;
556
557 fPtr->objdefNs = NULL;
558 }
559
560 static void
DeletedHelpersNamespace(ClientData clientData)561 DeletedHelpersNamespace(
562 ClientData clientData)
563 {
564 Foundation *fPtr = clientData;
565
566 fPtr->helpersNs = NULL;
567 }
568
569 /*
570 * ----------------------------------------------------------------------
571 *
572 * KillFoundation --
573 *
574 * Delete those parts of the OO core that are not deleted automatically
575 * when the objects and classes themselves are destroyed.
576 *
577 * ----------------------------------------------------------------------
578 */
579
580 static void
KillFoundation(ClientData clientData,Tcl_Interp * interp)581 KillFoundation(
582 ClientData clientData, /* Pointer to the OO system foundation
583 * structure. */
584 Tcl_Interp *interp) /* The interpreter containing the OO system
585 * foundation. */
586 {
587 Foundation *fPtr = GetFoundation(interp);
588
589 TclDecrRefCount(fPtr->unknownMethodNameObj);
590 TclDecrRefCount(fPtr->constructorName);
591 TclDecrRefCount(fPtr->destructorName);
592 TclDecrRefCount(fPtr->clonedName);
593 TclDecrRefCount(fPtr->defineName);
594 TclOODecrRefCount(fPtr->objectCls->thisPtr);
595 TclOODecrRefCount(fPtr->classCls->thisPtr);
596
597 ckfree(fPtr);
598 }
599
600 /*
601 * ----------------------------------------------------------------------
602 *
603 * AllocObject --
604 *
605 * Allocate an object of basic type. Does not splice the object into its
606 * class's instance list. The caller must set the classPtr on the object
607 * to either a class or NULL, call TclOOAddToInstances to add the object
608 * to the class's instance list, and if the object itself is a class, use
609 * call TclOOAddToSubclasses() to add it to the right class's list of
610 * subclasses.
611 *
612 * ----------------------------------------------------------------------
613 */
614
615 static Object *
AllocObject(Tcl_Interp * interp,const char * nameStr,Namespace * nsPtr,const char * nsNameStr)616 AllocObject(
617 Tcl_Interp *interp, /* Interpreter within which to create the
618 * object. */
619 const char *nameStr, /* The name of the object to create, or NULL
620 * if the OO system should pick the object
621 * name itself (equal to the namespace
622 * name). */
623 Namespace *nsPtr, /* The namespace to create the object in,
624 or NULL if *nameStr is NULL */
625 const char *nsNameStr) /* The name of the namespace to create, or
626 * NULL if the OO system should pick a unique
627 * name itself. If this is non-NULL but names
628 * a namespace that already exists, the effect
629 * will be the same as if this was NULL. */
630 {
631 Foundation *fPtr = GetFoundation(interp);
632 Object *oPtr;
633 Command *cmdPtr;
634 CommandTrace *tracePtr;
635 int creationEpoch;
636
637 oPtr = ckalloc(sizeof(Object));
638 memset(oPtr, 0, sizeof(Object));
639
640 /*
641 * Every object has a namespace; make one. Note that this also normally
642 * computes the creation epoch value for the object, a sequence number
643 * that is unique to the object (and which allows us to manage method
644 * caching without comparing pointers).
645 *
646 * When creating a namespace, we first check to see if the caller
647 * specified the name for the namespace. If not, we generate namespace
648 * names using the epoch until such time as a new namespace is actually
649 * created.
650 */
651
652 if (nsNameStr != NULL) {
653 oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
654 if (oPtr->namespacePtr != NULL) {
655 creationEpoch = ++fPtr->tsdPtr->nsCount;
656 goto configNamespace;
657 }
658 Tcl_ResetResult(interp);
659 }
660
661 while (1) {
662 char objName[10 + TCL_INTEGER_SPACE];
663
664 sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount);
665 oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
666 if (oPtr->namespacePtr != NULL) {
667 creationEpoch = fPtr->tsdPtr->nsCount;
668 break;
669 }
670
671 /*
672 * Could not make that namespace, so we make another. But first we
673 * have to get rid of the error message from Tcl_CreateNamespace,
674 * since that's something that should not be exposed to the user.
675 */
676
677 Tcl_ResetResult(interp);
678 }
679
680 configNamespace:
681 ((Namespace *) oPtr->namespacePtr)->refCount++;
682
683 /*
684 * Make the namespace know about the helper commands. This grants access
685 * to the [self] and [next] commands.
686 */
687
688 if (fPtr->helpersNs != NULL) {
689 TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
690 }
691 TclOOSetupVariableResolver(oPtr->namespacePtr);
692
693 /*
694 * Suppress use of compiled versions of the commands in this object's
695 * namespace and its children; causes wrong behaviour without expensive
696 * recompilation. [Bug 2037727]
697 */
698
699 ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
700
701 /*
702 * Set up a callback to get notification of the deletion of a namespace
703 * when enough of the namespace still remains to execute commands and
704 * access variables in it. [Bug 2950259]
705 */
706
707 ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted;
708
709 /*
710 * Fill in the rest of the non-zero/NULL parts of the structure.
711 */
712
713 oPtr->fPtr = fPtr;
714 oPtr->creationEpoch = creationEpoch;
715
716 /*
717 * An object starts life with a refCount of 2 to mark the two stages of
718 * destruction it occur: A call to ObjectRenamedTrace(), and a call to
719 * ObjectNamespaceDeleted().
720 */
721 oPtr->refCount = 2;
722
723 oPtr->flags = USE_CLASS_CACHE;
724
725 /*
726 * Finally, create the object commands and initialize the trace on the
727 * public command (so that the object structures are deleted when the
728 * command is deleted).
729 */
730
731 if (!nameStr) {
732 nameStr = oPtr->namespacePtr->name;
733 nsPtr = (Namespace *)oPtr->namespacePtr;
734 if (nsPtr->parentPtr != NULL) {
735 nsPtr = nsPtr->parentPtr;
736 }
737
738 }
739 oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
740 (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
741
742 /*
743 * Add the NRE command and trace directly. While this breaks a number of
744 * abstractions, it is faster and we're inside Tcl here so we're allowed.
745 */
746
747 cmdPtr = (Command *) oPtr->command;
748 cmdPtr->nreProc = PublicNRObjectCmd;
749 cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
750 tracePtr->traceProc = ObjectRenamedTrace;
751 tracePtr->clientData = oPtr;
752 tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
753 tracePtr->nextPtr = NULL;
754 tracePtr->refCount = 1;
755
756 oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
757 PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
758 return oPtr;
759 }
760
761 /*
762 * ----------------------------------------------------------------------
763 *
764 * SquelchCachedName --
765 *
766 * Encapsulates how to throw away a cached object name. Called from
767 * object rename traces and at object destruction.
768 *
769 * ----------------------------------------------------------------------
770 */
771
772 static inline void
SquelchCachedName(Object * oPtr)773 SquelchCachedName(
774 Object *oPtr)
775 {
776 if (oPtr->cachedNameObj) {
777 Tcl_DecrRefCount(oPtr->cachedNameObj);
778 oPtr->cachedNameObj = NULL;
779 }
780 }
781
782 /*
783 * ----------------------------------------------------------------------
784 *
785 * MyDeleted --
786 *
787 * This callback is triggered when the object's [my] command is deleted
788 * by any mechanism. It just marks the object as not having a [my]
789 * command, and so prevents cleanup of that when the object itself is
790 * deleted.
791 *
792 * ----------------------------------------------------------------------
793 */
794
795 static void
MyDeleted(ClientData clientData)796 MyDeleted(
797 ClientData clientData) /* Reference to the object whose [my] has been
798 * squelched. */
799 {
800 Object *oPtr = clientData;
801
802 oPtr->myCommand = NULL;
803 }
804
805 /*
806 * ----------------------------------------------------------------------
807 *
808 * ObjectRenamedTrace --
809 *
810 * This callback is triggered when the object is deleted by any
811 * mechanism. It runs the destructors and arranges for the actual cleanup
812 * of the object's namespace, which in turn triggers cleansing of the
813 * object data structures.
814 *
815 * ----------------------------------------------------------------------
816 */
817
818 static void
ObjectRenamedTrace(ClientData clientData,Tcl_Interp * interp,const char * oldName,const char * newName,int flags)819 ObjectRenamedTrace(
820 ClientData clientData, /* The object being deleted. */
821 Tcl_Interp *interp, /* The interpreter containing the object. */
822 const char *oldName, /* What the object was (last) called. */
823 const char *newName, /* What it's getting renamed to. (unused) */
824 int flags) /* Why was the object deleted? */
825 {
826 Object *oPtr = clientData;
827 /*
828 * If this is a rename and not a delete of the object, we just flush the
829 * cache of the object name.
830 */
831
832 if (flags & TCL_TRACE_RENAME) {
833 SquelchCachedName(oPtr);
834 return;
835 }
836
837 /*
838 * The namespace is only deleted if it hasn't already been deleted. [Bug
839 * 2950259].
840 */
841
842 if (!Destructing(oPtr)) {
843 Tcl_DeleteNamespace(oPtr->namespacePtr);
844 }
845 oPtr->command = NULL;
846 TclOODecrRefCount(oPtr);
847 return;
848 }
849
850 /*
851 * ----------------------------------------------------------------------
852 *
853 * TclOODeleteDescendants --
854 *
855 * Delete all descendants of a particular class.
856 *
857 * ----------------------------------------------------------------------
858 */
859
860 void
TclOODeleteDescendants(Tcl_Interp * interp,Object * oPtr)861 TclOODeleteDescendants(
862 Tcl_Interp *interp, /* The interpreter containing the class. */
863 Object *oPtr) /* The object representing the class. */
864 {
865 Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
866 Object *instancePtr;
867
868 /*
869 * Squelch classes that this class has been mixed into.
870 */
871
872 if (clsPtr->mixinSubs.num > 0) {
873 while (clsPtr->mixinSubs.num > 0) {
874 mixinSubclassPtr =
875 clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
876
877 /*
878 * This condition also covers the case where mixinSubclassPtr ==
879 * clsPtr
880 */
881
882 if (!Destructing(mixinSubclassPtr->thisPtr)
883 && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
884 Tcl_DeleteCommandFromToken(interp,
885 mixinSubclassPtr->thisPtr->command);
886 }
887 TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
888 }
889 }
890 if (clsPtr->mixinSubs.size > 0) {
891 ckfree(clsPtr->mixinSubs.list);
892 clsPtr->mixinSubs.size = 0;
893 }
894 /*
895 * Squelch subclasses of this class.
896 */
897
898 if (clsPtr->subclasses.num > 0) {
899 while (clsPtr->subclasses.num > 0) {
900 subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
901 if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
902 && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
903 Tcl_DeleteCommandFromToken(interp,
904 subclassPtr->thisPtr->command);
905 }
906 TclOORemoveFromSubclasses(subclassPtr, clsPtr);
907 }
908 }
909 if (clsPtr->subclasses.size > 0) {
910 ckfree(clsPtr->subclasses.list);
911 clsPtr->subclasses.list = NULL;
912 clsPtr->subclasses.size = 0;
913 }
914
915 /*
916 * Squelch instances of this class (includes objects we're mixed into).
917 */
918
919 if (clsPtr->instances.num > 0) {
920 while (clsPtr->instances.num > 0) {
921 instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
922
923 /*
924 * This condition also covers the case where instancePtr == oPtr
925 */
926
927 if (!Destructing(instancePtr) && !IsRoot(instancePtr) &&
928 !(instancePtr->flags & DONT_DELETE)) {
929 Tcl_DeleteCommandFromToken(interp, instancePtr->command);
930 }
931 TclOORemoveFromInstances(instancePtr, clsPtr);
932 }
933 }
934 if (clsPtr->instances.size > 0) {
935 ckfree(clsPtr->instances.list);
936 clsPtr->instances.list = NULL;
937 clsPtr->instances.size = 0;
938 }
939 }
940
941 /*
942 * ----------------------------------------------------------------------
943 *
944 * TclOOReleaseClassContents --
945 *
946 * Tear down the special class data structure, including deleting all
947 * dependent classes and objects.
948 *
949 * ----------------------------------------------------------------------
950 */
951
952 void
TclOOReleaseClassContents(Tcl_Interp * interp,Object * oPtr)953 TclOOReleaseClassContents(
954 Tcl_Interp *interp, /* The interpreter containing the class. */
955 Object *oPtr) /* The object representing the class. */
956 {
957 FOREACH_HASH_DECLS;
958 int i;
959 Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
960 Method *mPtr;
961 Foundation *fPtr = oPtr->fPtr;
962 Tcl_Obj *variableObj;
963
964 /*
965 * Sanity check!
966 */
967
968 if (!Destructing(oPtr)) {
969 if (IsRootClass(oPtr)) {
970 Tcl_Panic("deleting class structure for non-deleted %s",
971 "::oo::class");
972 } else if (IsRootObject(oPtr)) {
973 Tcl_Panic("deleting class structure for non-deleted %s",
974 "::oo::object");
975 }
976 }
977
978 /*
979 * Squelch method implementation chain caches.
980 */
981
982 if (clsPtr->constructorChainPtr) {
983 TclOODeleteChain(clsPtr->constructorChainPtr);
984 clsPtr->constructorChainPtr = NULL;
985 }
986 if (clsPtr->destructorChainPtr) {
987 TclOODeleteChain(clsPtr->destructorChainPtr);
988 clsPtr->destructorChainPtr = NULL;
989 }
990 if (clsPtr->classChainCache) {
991 CallChain *callPtr;
992
993 FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
994 TclOODeleteChain(callPtr);
995 }
996 Tcl_DeleteHashTable(clsPtr->classChainCache);
997 ckfree(clsPtr->classChainCache);
998 clsPtr->classChainCache = NULL;
999 }
1000
1001 /*
1002 * Squelch our filter list.
1003 */
1004
1005 if (clsPtr->filters.num) {
1006 Tcl_Obj *filterObj;
1007
1008 FOREACH(filterObj, clsPtr->filters) {
1009 TclDecrRefCount(filterObj);
1010 }
1011 ckfree(clsPtr->filters.list);
1012 clsPtr->filters.list = NULL;
1013 clsPtr->filters.num = 0;
1014 }
1015
1016 /*
1017 * Squelch our metadata.
1018 */
1019
1020 if (clsPtr->metadataPtr != NULL) {
1021 Tcl_ObjectMetadataType *metadataTypePtr;
1022 ClientData value;
1023
1024 FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
1025 metadataTypePtr->deleteProc(value);
1026 }
1027 Tcl_DeleteHashTable(clsPtr->metadataPtr);
1028 ckfree(clsPtr->metadataPtr);
1029 clsPtr->metadataPtr = NULL;
1030 }
1031
1032 if (clsPtr->mixins.num) {
1033 FOREACH(tmpClsPtr, clsPtr->mixins) {
1034 TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
1035 TclOODecrRefCount(tmpClsPtr->thisPtr);
1036 }
1037 ckfree(clsPtr->mixins.list);
1038 clsPtr->mixins.list = NULL;
1039 clsPtr->mixins.num = 0;
1040 }
1041
1042 if (clsPtr->superclasses.num > 0) {
1043 FOREACH(tmpClsPtr, clsPtr->superclasses) {
1044 TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
1045 TclOODecrRefCount(tmpClsPtr->thisPtr);
1046 }
1047 ckfree(clsPtr->superclasses.list);
1048 clsPtr->superclasses.num = 0;
1049 clsPtr->superclasses.list = NULL;
1050 }
1051
1052 FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
1053 TclOODelMethodRef(mPtr);
1054 }
1055 Tcl_DeleteHashTable(&clsPtr->classMethods);
1056 TclOODelMethodRef(clsPtr->constructorPtr);
1057 TclOODelMethodRef(clsPtr->destructorPtr);
1058
1059 FOREACH(variableObj, clsPtr->variables) {
1060 TclDecrRefCount(variableObj);
1061 }
1062 if (i) {
1063 ckfree(clsPtr->variables.list);
1064 }
1065
1066 if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
1067 Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
1068 }
1069 }
1070
1071 /*
1072 * ----------------------------------------------------------------------
1073 *
1074 * ObjectNamespaceDeleted --
1075 *
1076 * Callback when the object's namespace is deleted. Used to clean up the
1077 * data structures associated with the object. The complicated bit is
1078 * that this can sometimes happen before the object's command is deleted
1079 * (interpreter teardown is complex!)
1080 *
1081 * ----------------------------------------------------------------------
1082 */
1083
1084 static void
ObjectNamespaceDeleted(ClientData clientData)1085 ObjectNamespaceDeleted(
1086 ClientData clientData) /* Pointer to the class whose namespace is
1087 * being deleted. */
1088 {
1089 Object *oPtr = clientData;
1090 Foundation *fPtr = oPtr->fPtr;
1091 FOREACH_HASH_DECLS;
1092 Class *mixinPtr;
1093 Method *mPtr;
1094 Tcl_Obj *filterObj, *variableObj;
1095 Tcl_Interp *interp = oPtr->fPtr->interp;
1096 int i;
1097
1098 if (Destructing(oPtr)) {
1099 /*
1100 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
1101 * this guard could be removed.
1102 */
1103 return;
1104 }
1105
1106 /*
1107 * One rule for the teardown routines is that if an object is in the
1108 * process of being deleted, nothing else may modify its bookeeping
1109 * records. This is the flag that
1110 */
1111 oPtr->flags |= OBJECT_DESTRUCTING;
1112
1113 /*
1114 * Let the dominoes fall!
1115 */
1116
1117 if (oPtr->classPtr) {
1118 TclOODeleteDescendants(interp, oPtr);
1119 }
1120
1121 /*
1122 * We do not run destructors on the core class objects when the
1123 * interpreter is being deleted; their incestuous nature causes problems
1124 * in that case when the destructor is partially deleted before the uses
1125 * of it have gone. [Bug 2949397]
1126 */
1127
1128 if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
1129 CallContext *contextPtr =
1130 TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
1131 int result;
1132 Tcl_InterpState state;
1133
1134 oPtr->flags |= DESTRUCTOR_CALLED;
1135
1136 if (contextPtr != NULL) {
1137 contextPtr->callPtr->flags |= DESTRUCTOR;
1138 contextPtr->skip = 0;
1139 state = Tcl_SaveInterpState(interp, TCL_OK);
1140 result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
1141 contextPtr, 0, NULL);
1142 if (result != TCL_OK) {
1143 Tcl_BackgroundException(interp, result);
1144 }
1145 Tcl_RestoreInterpState(interp, state);
1146 TclOODeleteContext(contextPtr);
1147 }
1148 }
1149
1150 /*
1151 * Instruct everyone to no longer use any allocated fields of the object.
1152 * Also delete the command that refers to the object at this point (if it
1153 * still exists) because otherwise its pointer to the object points into
1154 * freed memory.
1155 */
1156
1157 if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
1158 /*
1159 * Something has already started the command deletion process. We can
1160 * go ahead and clean up the the namespace,
1161 */
1162 } else {
1163 /*
1164 * The namespace must have been deleted directly. Delete the command
1165 * as well.
1166 */
1167
1168 Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
1169 }
1170
1171 if (oPtr->myCommand) {
1172 Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
1173 }
1174
1175 /*
1176 * Splice the object out of its context. After this, we must *not* call
1177 * methods on the object.
1178 */
1179
1180 /* TODO: Should this be protected with a !IsRoot() condition? */
1181 TclOORemoveFromInstances(oPtr, oPtr->selfCls);
1182
1183 if (oPtr->mixins.num > 0) {
1184 FOREACH(mixinPtr, oPtr->mixins) {
1185 TclOORemoveFromInstances(oPtr, mixinPtr);
1186 TclOODecrRefCount(mixinPtr->thisPtr);
1187 }
1188 if (oPtr->mixins.list != NULL) {
1189 ckfree(oPtr->mixins.list);
1190 }
1191 }
1192
1193 FOREACH(filterObj, oPtr->filters) {
1194 TclDecrRefCount(filterObj);
1195 }
1196 if (i) {
1197 ckfree(oPtr->filters.list);
1198 }
1199
1200 if (oPtr->methodsPtr) {
1201 FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
1202 TclOODelMethodRef(mPtr);
1203 }
1204 Tcl_DeleteHashTable(oPtr->methodsPtr);
1205 ckfree(oPtr->methodsPtr);
1206 }
1207
1208 FOREACH(variableObj, oPtr->variables) {
1209 TclDecrRefCount(variableObj);
1210 }
1211 if (i) {
1212 ckfree(oPtr->variables.list);
1213 }
1214
1215 if (oPtr->chainCache) {
1216 TclOODeleteChainCache(oPtr->chainCache);
1217 }
1218
1219 SquelchCachedName(oPtr);
1220
1221 if (oPtr->metadataPtr != NULL) {
1222 Tcl_ObjectMetadataType *metadataTypePtr;
1223 ClientData value;
1224
1225 FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
1226 metadataTypePtr->deleteProc(value);
1227 }
1228 Tcl_DeleteHashTable(oPtr->metadataPtr);
1229 ckfree(oPtr->metadataPtr);
1230 oPtr->metadataPtr = NULL;
1231 }
1232
1233 /*
1234 * Because an object can be a class that is an instance of itself, the
1235 * class object's class structure should only be cleaned after most of
1236 * the cleanup on the object is done.
1237 *
1238 * The class of objects needs some special care; if it is deleted (and
1239 * we're not killing the whole interpreter) we force the delete of the
1240 * class of classes now as well. Due to the incestuous nature of those two
1241 * classes, if one goes the other must too and yet the tangle can
1242 * sometimes not go away automatically; we force it here. [Bug 2962664]
1243 */
1244
1245 if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
1246 && !Tcl_InterpDeleted(interp)) {
1247
1248 Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
1249 }
1250
1251 if (oPtr->classPtr != NULL) {
1252 TclOOReleaseClassContents(interp, oPtr);
1253 }
1254
1255 /*
1256 * Delete the object structure itself.
1257 */
1258
1259 TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
1260 oPtr->namespacePtr = NULL;
1261 TclOODecrRefCount(oPtr->selfCls->thisPtr);
1262 oPtr->selfCls = NULL;
1263 TclOODecrRefCount(oPtr);
1264 return;
1265 }
1266
1267 /*
1268 * ----------------------------------------------------------------------
1269 *
1270 * TclOODecrRef --
1271 *
1272 * Decrement the refcount of an object and deallocate storage then object
1273 * is no longer referenced. Returns 1 if storage was deallocated, and 0
1274 * otherwise.
1275 *
1276 * ----------------------------------------------------------------------
1277 */
TclOODecrRefCount(Object * oPtr)1278 int TclOODecrRefCount(Object *oPtr) {
1279 if (oPtr->refCount-- <= 1) {
1280 if (oPtr->classPtr != NULL) {
1281 ckfree(oPtr->classPtr);
1282 }
1283 ckfree(oPtr);
1284 return 1;
1285 }
1286 return 0;
1287 }
1288
1289 /*
1290 * ----------------------------------------------------------------------
1291 *
1292 * TclOOObjectDestroyed --
1293 *
1294 * Returns TCL_OK if an object is entirely deleted, i.e. the destruction
1295 * sequence has completed.
1296 *
1297 * ----------------------------------------------------------------------
1298 */
TclOOObjectDestroyed(Object * oPtr)1299 int TclOOObjectDestroyed(Object *oPtr) {
1300 return (oPtr->namespacePtr == NULL);
1301 }
1302
1303 /*
1304 * Setting the "empty" location to NULL makes debugging a little easier.
1305 */
1306
1307 #define REMOVEBODY { \
1308 for (; idx < num - 1; idx++) { \
1309 list[idx] = list[idx + 1]; \
1310 } \
1311 list[idx] = NULL; \
1312 return; \
1313 }
RemoveClass(Class ** list,int num,int idx)1314 void RemoveClass(Class **list, int num, int idx) REMOVEBODY
1315
1316 void RemoveObject(Object **list, int num, int idx) REMOVEBODY
1317
1318 /*
1319 * ----------------------------------------------------------------------
1320 *
1321 * TclOORemoveFromInstances --
1322 *
1323 * Utility function to remove an object from the list of instances within
1324 * a class.
1325 *
1326 * ----------------------------------------------------------------------
1327 */
1328
1329 int
1330 TclOORemoveFromInstances(
1331 Object *oPtr, /* The instance to remove. */
1332 Class *clsPtr) /* The class (possibly) containing the
1333 * reference to the instance. */
1334 {
1335 int i, res = 0;
1336 Object *instPtr;
1337
1338 FOREACH(instPtr, clsPtr->instances) {
1339 if (oPtr == instPtr) {
1340 RemoveItem(Object, clsPtr->instances, i);
1341 TclOODecrRefCount(oPtr);
1342 res++;
1343 break;
1344 }
1345 }
1346 return res;
1347 }
1348
1349 /*
1350 * ----------------------------------------------------------------------
1351 *
1352 * TclOOAddToInstances --
1353 *
1354 * Utility function to add an object to the list of instances within a
1355 * class.
1356 *
1357 * ----------------------------------------------------------------------
1358 */
1359
1360 void
TclOOAddToInstances(Object * oPtr,Class * clsPtr)1361 TclOOAddToInstances(
1362 Object *oPtr, /* The instance to add. */
1363 Class *clsPtr) /* The class to add the instance to. It is
1364 * assumed that the class is not already
1365 * present as an instance in the class. */
1366 {
1367 if (clsPtr->instances.num >= clsPtr->instances.size) {
1368 clsPtr->instances.size += ALLOC_CHUNK;
1369 if (clsPtr->instances.size == ALLOC_CHUNK) {
1370 clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
1371 } else {
1372 clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
1373 sizeof(Object *) * clsPtr->instances.size);
1374 }
1375 }
1376 clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
1377 AddRef(oPtr);
1378 }
1379
1380 /*
1381 * ----------------------------------------------------------------------
1382 *
1383 * TclOORemoveFromMixins --
1384 *
1385 * Utility function to remove a class from the list of mixins within an
1386 * object.
1387 *
1388 * ----------------------------------------------------------------------
1389 */
1390
1391 int
TclOORemoveFromMixins(Class * mixinPtr,Object * oPtr)1392 TclOORemoveFromMixins(
1393 Class *mixinPtr, /* The mixin to remove. */
1394 Object *oPtr) /* The object (possibly) containing the
1395 * reference to the mixin. */
1396 {
1397 int i, res = 0;
1398 Class *mixPtr;
1399
1400 FOREACH(mixPtr, oPtr->mixins) {
1401 if (mixinPtr == mixPtr) {
1402 RemoveItem(Class, oPtr->mixins, i);
1403 TclOODecrRefCount(mixPtr->thisPtr);
1404 res++;
1405 break;
1406 }
1407 }
1408 if (oPtr->mixins.num == 0) {
1409 ckfree(oPtr->mixins.list);
1410 oPtr->mixins.list = NULL;
1411 }
1412 return res;
1413 }
1414
1415 /*
1416 * ----------------------------------------------------------------------
1417 *
1418 * TclOORemoveFromSubclasses --
1419 *
1420 * Utility function to remove a class from the list of subclasses within
1421 * another class. Returns the number of removals performed.
1422 *
1423 * ----------------------------------------------------------------------
1424 */
1425
1426 int
TclOORemoveFromSubclasses(Class * subPtr,Class * superPtr)1427 TclOORemoveFromSubclasses(
1428 Class *subPtr, /* The subclass to remove. */
1429 Class *superPtr) /* The superclass to possibly remove the
1430 * subclass reference from. */
1431 {
1432 int i, res = 0;
1433 Class *subclsPtr;
1434
1435 FOREACH(subclsPtr, superPtr->subclasses) {
1436 if (subPtr == subclsPtr) {
1437 RemoveItem(Class, superPtr->subclasses, i);
1438 TclOODecrRefCount(subPtr->thisPtr);
1439 res++;
1440 }
1441 }
1442 return res;
1443 }
1444
1445 /*
1446 * ----------------------------------------------------------------------
1447 *
1448 * TclOOAddToSubclasses --
1449 *
1450 * Utility function to add a class to the list of subclasses within
1451 * another class.
1452 *
1453 * ----------------------------------------------------------------------
1454 */
1455
1456 void
TclOOAddToSubclasses(Class * subPtr,Class * superPtr)1457 TclOOAddToSubclasses(
1458 Class *subPtr, /* The subclass to add. */
1459 Class *superPtr) /* The superclass to add the subclass to. It
1460 * is assumed that the class is not already
1461 * present as a subclass in the superclass. */
1462 {
1463 if (Destructing(superPtr->thisPtr)) {
1464 return;
1465 }
1466 if (superPtr->subclasses.num >= superPtr->subclasses.size) {
1467 superPtr->subclasses.size += ALLOC_CHUNK;
1468 if (superPtr->subclasses.size == ALLOC_CHUNK) {
1469 superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
1470 } else {
1471 superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
1472 sizeof(Class *) * superPtr->subclasses.size);
1473 }
1474 }
1475 superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
1476 AddRef(subPtr->thisPtr);
1477 }
1478
1479 /*
1480 * ----------------------------------------------------------------------
1481 *
1482 * TclOORemoveFromMixinSubs --
1483 *
1484 * Utility function to remove a class from the list of mixinSubs within
1485 * another class.
1486 *
1487 * ----------------------------------------------------------------------
1488 */
1489
1490 int
TclOORemoveFromMixinSubs(Class * subPtr,Class * superPtr)1491 TclOORemoveFromMixinSubs(
1492 Class *subPtr, /* The subclass to remove. */
1493 Class *superPtr) /* The superclass to possibly remove the
1494 * subclass reference from. */
1495 {
1496 int i, res = 0;
1497 Class *subclsPtr;
1498
1499 FOREACH(subclsPtr, superPtr->mixinSubs) {
1500 if (subPtr == subclsPtr) {
1501 RemoveItem(Class, superPtr->mixinSubs, i);
1502 TclOODecrRefCount(subPtr->thisPtr);
1503 res++;
1504 break;
1505 }
1506 }
1507 return res;
1508 }
1509
1510 /*
1511 * ----------------------------------------------------------------------
1512 *
1513 * TclOOAddToMixinSubs --
1514 *
1515 * Utility function to add a class to the list of mixinSubs within
1516 * another class.
1517 *
1518 * ----------------------------------------------------------------------
1519 */
1520
1521 void
TclOOAddToMixinSubs(Class * subPtr,Class * superPtr)1522 TclOOAddToMixinSubs(
1523 Class *subPtr, /* The subclass to add. */
1524 Class *superPtr) /* The superclass to add the subclass to. It
1525 * is assumed that the class is not already
1526 * present as a subclass in the superclass. */
1527 {
1528 if (Destructing(superPtr->thisPtr)) {
1529 return;
1530 }
1531 if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
1532 superPtr->mixinSubs.size += ALLOC_CHUNK;
1533 if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
1534 superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
1535 } else {
1536 superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
1537 sizeof(Class *) * superPtr->mixinSubs.size);
1538 }
1539 }
1540 superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
1541 AddRef(subPtr->thisPtr);
1542 }
1543
1544 /*
1545 * ----------------------------------------------------------------------
1546 *
1547 * TclOOAllocClass --
1548 *
1549 * Allocate a basic class. Does not add class to its class's instance
1550 * list.
1551 *
1552 * ----------------------------------------------------------------------
1553 */
1554
1555 Class *
TclOOAllocClass(Tcl_Interp * interp,Object * useThisObj)1556 TclOOAllocClass(
1557 Tcl_Interp *interp, /* Interpreter within which to allocate the
1558 * class. */
1559 Object *useThisObj) /* Object that is to act as the class
1560 * representation. */
1561 {
1562 Foundation *fPtr = GetFoundation(interp);
1563 Class *clsPtr = ckalloc(sizeof(Class));
1564
1565 memset(clsPtr, 0, sizeof(Class));
1566 clsPtr->thisPtr = useThisObj;
1567
1568 /*
1569 * Configure the namespace path for the class's object.
1570 */
1571 initClassPath(interp, clsPtr);
1572
1573 /*
1574 * Classes are subclasses of oo::object, i.e. the objects they create are
1575 * objects.
1576 */
1577
1578 clsPtr->superclasses.num = 1;
1579 clsPtr->superclasses.list = ckalloc(sizeof(Class *));
1580 clsPtr->superclasses.list[0] = fPtr->objectCls;
1581 AddRef(fPtr->objectCls->thisPtr);
1582
1583 /*
1584 * Finish connecting the class structure to the object structure.
1585 */
1586
1587 clsPtr->thisPtr->classPtr = clsPtr;
1588
1589 /*
1590 * That's the complicated bit. Now fill in the rest of the non-zero/NULL
1591 * fields.
1592 */
1593
1594 Tcl_InitObjHashTable(&clsPtr->classMethods);
1595 return clsPtr;
1596 }
1597 static void
initClassPath(Tcl_Interp * interp,Class * clsPtr)1598 initClassPath(Tcl_Interp *interp, Class *clsPtr) {
1599 Foundation *fPtr = GetFoundation(interp);
1600 if (fPtr->helpersNs != NULL) {
1601 Tcl_Namespace *path[2];
1602 path[0] = fPtr->helpersNs;
1603 path[1] = fPtr->ooNs;
1604 TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
1605 } else {
1606 TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
1607 &fPtr->ooNs);
1608 }
1609 }
1610
1611 /*
1612 * ----------------------------------------------------------------------
1613 *
1614 * Tcl_NewObjectInstance --
1615 *
1616 * Allocate a new instance of an object.
1617 *
1618 * ----------------------------------------------------------------------
1619 */
1620 Tcl_Object
Tcl_NewObjectInstance(Tcl_Interp * interp,Tcl_Class cls,const char * nameStr,const char * nsNameStr,int objc,Tcl_Obj * const * objv,int skip)1621 Tcl_NewObjectInstance(
1622 Tcl_Interp *interp, /* Interpreter context. */
1623 Tcl_Class cls, /* Class to create an instance of. */
1624 const char *nameStr, /* Name of object to create, or NULL to ask
1625 * the code to pick its own unique name. */
1626 const char *nsNameStr, /* Name of namespace to create inside object,
1627 * or NULL to ask the code to pick its own
1628 * unique name. */
1629 int objc, /* Number of arguments. Negative value means
1630 * do not call constructor. */
1631 Tcl_Obj *const *objv, /* Argument list. */
1632 int skip) /* Number of arguments to _not_ pass to the
1633 * constructor. */
1634 {
1635 Class *classPtr = (Class *) cls;
1636 Object *oPtr;
1637 ClientData clientData[4];
1638
1639 oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
1640 if (oPtr == NULL) {return NULL;}
1641
1642 /*
1643 * Run constructors, except when objc < 0, which is a special flag case
1644 * used for object cloning only.
1645 */
1646
1647 if (objc >= 0) {
1648 CallContext *contextPtr =
1649 TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
1650
1651 if (contextPtr != NULL) {
1652 int isRoot, result;
1653 Tcl_InterpState state;
1654
1655 state = Tcl_SaveInterpState(interp, TCL_OK);
1656 contextPtr->callPtr->flags |= CONSTRUCTOR;
1657 contextPtr->skip = skip;
1658
1659 /*
1660 * Adjust the ensemble tracking record if necessary. [Bug 3514761]
1661 */
1662
1663 isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
1664 result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
1665 objc, objv);
1666
1667 if (isRoot) {
1668 TclResetRewriteEnsemble(interp, 1);
1669 }
1670
1671 clientData[0] = contextPtr;
1672 clientData[1] = oPtr;
1673 clientData[2] = state;
1674 clientData[3] = &oPtr;
1675
1676 result = FinalizeAlloc(clientData, interp, result);
1677 if (result != TCL_OK) {
1678 return NULL;
1679 }
1680 }
1681 }
1682
1683 return (Tcl_Object) oPtr;
1684 }
1685
1686 int
TclNRNewObjectInstance(Tcl_Interp * interp,Tcl_Class cls,const char * nameStr,const char * nsNameStr,int objc,Tcl_Obj * const * objv,int skip,Tcl_Object * objectPtr)1687 TclNRNewObjectInstance(
1688 Tcl_Interp *interp, /* Interpreter context. */
1689 Tcl_Class cls, /* Class to create an instance of. */
1690 const char *nameStr, /* Name of object to create, or NULL to ask
1691 * the code to pick its own unique name. */
1692 const char *nsNameStr, /* Name of namespace to create inside object,
1693 * or NULL to ask the code to pick its own
1694 * unique name. */
1695 int objc, /* Number of arguments. Negative value means
1696 * do not call constructor. */
1697 Tcl_Obj *const *objv, /* Argument list. */
1698 int skip, /* Number of arguments to _not_ pass to the
1699 * constructor. */
1700 Tcl_Object *objectPtr) /* Place to write the object reference upon
1701 * successful allocation. */
1702 {
1703 Class *classPtr = (Class *) cls;
1704 CallContext *contextPtr;
1705 Tcl_InterpState state;
1706 Object *oPtr;
1707
1708 oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
1709 if (oPtr == NULL) {return TCL_ERROR;}
1710
1711 /*
1712 * Run constructors, except when objc < 0 (a special flag case used for
1713 * object cloning only). If there aren't any constructors, we do nothing.
1714 */
1715
1716 if (objc < 0) {
1717 *objectPtr = (Tcl_Object) oPtr;
1718 return TCL_OK;
1719 }
1720 contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
1721 if (contextPtr == NULL) {
1722 *objectPtr = (Tcl_Object) oPtr;
1723 return TCL_OK;
1724 }
1725
1726 state = Tcl_SaveInterpState(interp, TCL_OK);
1727 contextPtr->callPtr->flags |= CONSTRUCTOR;
1728 contextPtr->skip = skip;
1729
1730 /*
1731 * Adjust the ensemble tracking record if necessary. [Bug 3514761]
1732 */
1733
1734 if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
1735 TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
1736 }
1737
1738 /*
1739 * Fire off the constructors non-recursively.
1740 */
1741
1742 TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
1743 objectPtr);
1744 TclPushTailcallPoint(interp);
1745 return TclOOInvokeContext(contextPtr, interp, objc, objv);
1746 }
1747
1748 Object *
TclNewObjectInstanceCommon(Tcl_Interp * interp,Class * classPtr,const char * nameStr,const char * nsNameStr)1749 TclNewObjectInstanceCommon(
1750 Tcl_Interp *interp,
1751 Class *classPtr,
1752 const char *nameStr,
1753 const char *nsNameStr)
1754 {
1755 Tcl_HashEntry *hPtr;
1756 Foundation *fPtr = GetFoundation(interp);
1757 Object *oPtr;
1758 const char *simpleName = NULL;
1759 Namespace *nsPtr = NULL, *dummy,
1760 *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
1761
1762 if (nameStr) {
1763 TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
1764 TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
1765
1766 /*
1767 * Disallow creation of an object over an existing command.
1768 */
1769
1770 hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
1771 if (hPtr) {
1772 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1773 "can't create object \"%s\": command already exists with"
1774 " that name", nameStr));
1775 Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
1776 return NULL;
1777 }
1778 }
1779
1780 /*
1781 * Create the object.
1782 */
1783
1784 oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
1785 oPtr->selfCls = classPtr;
1786 AddRef(classPtr->thisPtr);
1787 TclOOAddToInstances(oPtr, classPtr);
1788
1789 /*
1790 * Check to see if we're really creating a class. If so, allocate the
1791 * class structure as well.
1792 */
1793
1794 if (TclOOIsReachable(fPtr->classCls, classPtr)) {
1795 /*
1796 * Is a class, so attach a class structure. Note that the
1797 * TclOOAllocClass function splices the structure into the object, so
1798 * we don't have to. Once that's done, we need to repatch the object
1799 * to have the right class since TclOOAllocClass interferes with that.
1800 */
1801
1802 TclOOAllocClass(interp, oPtr);
1803 TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
1804 } else {
1805 oPtr->classPtr = NULL;
1806 }
1807 return oPtr;
1808 }
1809
1810 static int
FinalizeAlloc(ClientData data[],Tcl_Interp * interp,int result)1811 FinalizeAlloc(
1812 ClientData data[],
1813 Tcl_Interp *interp,
1814 int result)
1815 {
1816 CallContext *contextPtr = data[0];
1817 Object *oPtr = data[1];
1818 Tcl_InterpState state = data[2];
1819 Tcl_Object *objectPtr = data[3];
1820
1821 /*
1822 * Ensure an error if the object was deleted in the constructor.
1823 * Don't want to lose errors by accident. [Bug 2903011]
1824 */
1825
1826 if (result != TCL_ERROR && Destructing(oPtr)) {
1827 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1828 "object deleted in constructor", -1));
1829 Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
1830 result = TCL_ERROR;
1831 }
1832 if (result != TCL_OK) {
1833 Tcl_DiscardInterpState(state);
1834
1835 /*
1836 * Take care to not delete a deleted object; that would be bad. [Bug
1837 * 2903011] Also take care to make sure that we have the name of the
1838 * command before we delete it. [Bug 9dd1bd7a74]
1839 */
1840
1841 if (!Destructing(oPtr)) {
1842 (void) TclOOObjectName(interp, oPtr);
1843 Tcl_DeleteCommandFromToken(interp, oPtr->command);
1844 }
1845
1846 /*
1847 * This decrements the refcount of oPtr.
1848 */
1849
1850 TclOODeleteContext(contextPtr);
1851 return TCL_ERROR;
1852 }
1853 Tcl_RestoreInterpState(interp, state);
1854 *objectPtr = (Tcl_Object) oPtr;
1855
1856 /*
1857 * This decrements the refcount of oPtr.
1858 */
1859
1860 TclOODeleteContext(contextPtr);
1861 return TCL_OK;
1862 }
1863
1864 /*
1865 * ----------------------------------------------------------------------
1866 *
1867 * Tcl_CopyObjectInstance --
1868 *
1869 * Creates a copy of an object. Does not copy the backing namespace,
1870 * since the correct way to do that (e.g., shallow/deep) depends on the
1871 * object/class's own policies.
1872 *
1873 * ----------------------------------------------------------------------
1874 */
1875
1876 Tcl_Object
Tcl_CopyObjectInstance(Tcl_Interp * interp,Tcl_Object sourceObject,const char * targetName,const char * targetNamespaceName)1877 Tcl_CopyObjectInstance(
1878 Tcl_Interp *interp,
1879 Tcl_Object sourceObject,
1880 const char *targetName,
1881 const char *targetNamespaceName)
1882 {
1883 Object *oPtr = (Object *) sourceObject, *o2Ptr;
1884 FOREACH_HASH_DECLS;
1885 Method *mPtr;
1886 Class *mixinPtr;
1887 CallContext *contextPtr;
1888 Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
1889 int i, result;
1890
1891 /*
1892 * Sanity check.
1893 */
1894
1895 if (IsRootClass(oPtr)) {
1896 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1897 "may not clone the class of classes", -1));
1898 Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
1899 return NULL;
1900 }
1901
1902 /*
1903 * Build the instance. Note that this does not run any constructors.
1904 */
1905
1906 o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
1907 (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1,
1908 NULL, -1);
1909 if (o2Ptr == NULL) {
1910 return NULL;
1911 }
1912
1913 /*
1914 * Copy the object-local methods to the new object.
1915 */
1916
1917 if (oPtr->methodsPtr) {
1918 FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) {
1919 if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) {
1920 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
1921 return NULL;
1922 }
1923 }
1924 }
1925
1926 /*
1927 * Copy the object's mixin references to the new object.
1928 */
1929
1930 if (o2Ptr->mixins.num != 0) {
1931 FOREACH(mixinPtr, o2Ptr->mixins) {
1932 if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
1933 TclOORemoveFromInstances(o2Ptr, mixinPtr);
1934 }
1935 TclOODecrRefCount(mixinPtr->thisPtr);
1936 }
1937 ckfree(o2Ptr->mixins.list);
1938 }
1939 DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
1940 FOREACH(mixinPtr, o2Ptr->mixins) {
1941 if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
1942 TclOOAddToInstances(o2Ptr, mixinPtr);
1943 }
1944
1945 /*
1946 * For the reference just created in DUPLICATE.
1947 */
1948
1949 AddRef(mixinPtr->thisPtr);
1950 }
1951
1952 /*
1953 * Copy the object's filter list to the new object.
1954 */
1955
1956 DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
1957 FOREACH(filterObj, o2Ptr->filters) {
1958 Tcl_IncrRefCount(filterObj);
1959 }
1960
1961 /*
1962 * Copy the object's variable resolution list to the new object.
1963 */
1964
1965 DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
1966 FOREACH(variableObj, o2Ptr->variables) {
1967 Tcl_IncrRefCount(variableObj);
1968 }
1969
1970 /*
1971 * Copy the object's flags to the new object, clearing those that must be
1972 * kept object-local. The duplicate is never deleted at this point, nor is
1973 * it the root of the object system or in the midst of processing a filter
1974 * call.
1975 */
1976
1977 o2Ptr->flags = oPtr->flags & ~(
1978 OBJECT_DESTRUCTING | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
1979
1980 /*
1981 * Copy the object's metadata.
1982 */
1983
1984 if (oPtr->metadataPtr != NULL) {
1985 Tcl_ObjectMetadataType *metadataTypePtr;
1986 ClientData value, duplicate;
1987
1988 FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
1989 if (metadataTypePtr->cloneProc == NULL) {
1990 duplicate = value;
1991 } else {
1992 if (metadataTypePtr->cloneProc(interp, value,
1993 &duplicate) != TCL_OK) {
1994 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
1995 return NULL;
1996 }
1997 }
1998 if (duplicate != NULL) {
1999 Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
2000 duplicate);
2001 }
2002 }
2003 }
2004
2005 /*
2006 * Copy the class, if present. Note that if there is a class present in
2007 * the source object, there must also be one in the copy.
2008 */
2009
2010 if (oPtr->classPtr != NULL) {
2011 Class *clsPtr = oPtr->classPtr;
2012 Class *cls2Ptr = o2Ptr->classPtr;
2013 Class *superPtr;
2014
2015 /*
2016 * Copy the class flags across.
2017 */
2018
2019 cls2Ptr->flags = clsPtr->flags;
2020
2021 /*
2022 * Ensure that the new class's superclass structure is the same as the
2023 * old class's.
2024 */
2025
2026 FOREACH(superPtr, cls2Ptr->superclasses) {
2027 TclOORemoveFromSubclasses(cls2Ptr, superPtr);
2028 TclOODecrRefCount(superPtr->thisPtr);
2029 }
2030 if (cls2Ptr->superclasses.num) {
2031 cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
2032 sizeof(Class *) * clsPtr->superclasses.num);
2033 } else {
2034 cls2Ptr->superclasses.list =
2035 ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
2036 }
2037 memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
2038 sizeof(Class *) * clsPtr->superclasses.num);
2039 cls2Ptr->superclasses.num = clsPtr->superclasses.num;
2040 FOREACH(superPtr, cls2Ptr->superclasses) {
2041 TclOOAddToSubclasses(cls2Ptr, superPtr);
2042
2043 /*
2044 * For the new item in cls2Ptr->superclasses that memcpy just
2045 * created.
2046 */
2047
2048 AddRef(superPtr->thisPtr);
2049 }
2050
2051 /*
2052 * Duplicate the source class's filters.
2053 */
2054
2055 DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
2056 FOREACH(filterObj, cls2Ptr->filters) {
2057 Tcl_IncrRefCount(filterObj);
2058 }
2059
2060 /*
2061 * Copy the source class's variable resolution list.
2062 */
2063
2064 DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
2065 FOREACH(variableObj, cls2Ptr->variables) {
2066 Tcl_IncrRefCount(variableObj);
2067 }
2068
2069 /*
2070 * Duplicate the source class's mixins (which cannot be circular
2071 * references to the duplicate).
2072 */
2073
2074 if (cls2Ptr->mixins.num != 0) {
2075 FOREACH(mixinPtr, cls2Ptr->mixins) {
2076 TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
2077 TclOODecrRefCount(mixinPtr->thisPtr);
2078 }
2079 ckfree(clsPtr->mixins.list);
2080 }
2081 DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
2082 FOREACH(mixinPtr, cls2Ptr->mixins) {
2083 TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
2084
2085 /*
2086 * For the copy just created in DUPLICATE.
2087 */
2088
2089 AddRef(mixinPtr->thisPtr);
2090 }
2091
2092 /*
2093 * Duplicate the source class's methods, constructor and destructor.
2094 */
2095
2096 FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
2097 if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr,
2098 NULL) != TCL_OK) {
2099 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
2100 return NULL;
2101 }
2102 }
2103 if (clsPtr->constructorPtr) {
2104 if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr,
2105 NULL, &cls2Ptr->constructorPtr) != TCL_OK) {
2106 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
2107 return NULL;
2108 }
2109 }
2110 if (clsPtr->destructorPtr) {
2111 if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL,
2112 &cls2Ptr->destructorPtr) != TCL_OK) {
2113 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
2114 return NULL;
2115 }
2116 }
2117
2118 /*
2119 * Duplicate the class's metadata.
2120 */
2121
2122 if (clsPtr->metadataPtr != NULL) {
2123 Tcl_ObjectMetadataType *metadataTypePtr;
2124 ClientData value, duplicate;
2125
2126 FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
2127 if (metadataTypePtr->cloneProc == NULL) {
2128 duplicate = value;
2129 } else {
2130 if (metadataTypePtr->cloneProc(interp, value,
2131 &duplicate) != TCL_OK) {
2132 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
2133 return NULL;
2134 }
2135 }
2136 if (duplicate != NULL) {
2137 Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
2138 duplicate);
2139 }
2140 }
2141 }
2142 }
2143
2144 TclResetRewriteEnsemble(interp, 1);
2145 contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
2146 if (contextPtr) {
2147 args[0] = TclOOObjectName(interp, o2Ptr);
2148 args[1] = oPtr->fPtr->clonedName;
2149 args[2] = TclOOObjectName(interp, oPtr);
2150 Tcl_IncrRefCount(args[0]);
2151 Tcl_IncrRefCount(args[1]);
2152 Tcl_IncrRefCount(args[2]);
2153 result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
2154 args);
2155 TclDecrRefCount(args[0]);
2156 TclDecrRefCount(args[1]);
2157 TclDecrRefCount(args[2]);
2158 TclOODeleteContext(contextPtr);
2159 if (result == TCL_ERROR) {
2160 Tcl_AddErrorInfo(interp,
2161 "\n (while performing post-copy callback)");
2162 }
2163 if (result != TCL_OK) {
2164 Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
2165 return NULL;
2166 }
2167 }
2168
2169 return (Tcl_Object) o2Ptr;
2170 }
2171
2172 /*
2173 * ----------------------------------------------------------------------
2174 *
2175 * CloneObjectMethod, CloneClassMethod --
2176 *
2177 * Helper functions used for cloning methods. They work identically to
2178 * each other, except for the difference between them in how they
2179 * register the cloned method on a successful clone.
2180 *
2181 * ----------------------------------------------------------------------
2182 */
2183
2184 static int
CloneObjectMethod(Tcl_Interp * interp,Object * oPtr,Method * mPtr,Tcl_Obj * namePtr)2185 CloneObjectMethod(
2186 Tcl_Interp *interp,
2187 Object *oPtr,
2188 Method *mPtr,
2189 Tcl_Obj *namePtr)
2190 {
2191 if (mPtr->typePtr == NULL) {
2192 Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
2193 mPtr->flags & PUBLIC_METHOD, NULL, NULL);
2194 } else if (mPtr->typePtr->cloneProc) {
2195 ClientData newClientData;
2196
2197 if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
2198 &newClientData) != TCL_OK) {
2199 return TCL_ERROR;
2200 }
2201 Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
2202 mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
2203 } else {
2204 Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
2205 mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
2206 }
2207 return TCL_OK;
2208 }
2209
2210 static int
CloneClassMethod(Tcl_Interp * interp,Class * clsPtr,Method * mPtr,Tcl_Obj * namePtr,Method ** m2PtrPtr)2211 CloneClassMethod(
2212 Tcl_Interp *interp,
2213 Class *clsPtr,
2214 Method *mPtr,
2215 Tcl_Obj *namePtr,
2216 Method **m2PtrPtr)
2217 {
2218 Method *m2Ptr;
2219
2220 if (mPtr->typePtr == NULL) {
2221 m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
2222 namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
2223 } else if (mPtr->typePtr->cloneProc) {
2224 ClientData newClientData;
2225
2226 if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
2227 &newClientData) != TCL_OK) {
2228 return TCL_ERROR;
2229 }
2230 m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
2231 namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
2232 newClientData);
2233 } else {
2234 m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
2235 namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
2236 mPtr->clientData);
2237 }
2238 if (m2PtrPtr != NULL) {
2239 *m2PtrPtr = m2Ptr;
2240 }
2241 return TCL_OK;
2242 }
2243
2244 /*
2245 * ----------------------------------------------------------------------
2246 *
2247 * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
2248 * Tcl_ObjectSetMetadata --
2249 *
2250 * Metadata management API. The metadata system allows code in extensions
2251 * to attach arbitrary non-NULL pointers to objects and classes without
2252 * the different things that might be interested being able to interfere
2253 * with each other. Apart from non-NULL-ness, these routines attach no
2254 * interpretation to the meaning of the metadata pointers.
2255 *
2256 * The Tcl_*GetMetadata routines get the metadata pointer attached that
2257 * has been related with a particular type, or NULL if no metadata
2258 * associated with the given type has been attached.
2259 *
2260 * The Tcl_*SetMetadata routines set or delete the metadata pointer that
2261 * is related to a particular type. The value associated with the type is
2262 * deleted (if present; no-op otherwise) if the value is NULL, and
2263 * attached (replacing the previous value, which is deleted if present)
2264 * otherwise. This means it is impossible to attach a NULL value for any
2265 * metadata type.
2266 *
2267 * ----------------------------------------------------------------------
2268 */
2269
2270 ClientData
Tcl_ClassGetMetadata(Tcl_Class clazz,const Tcl_ObjectMetadataType * typePtr)2271 Tcl_ClassGetMetadata(
2272 Tcl_Class clazz,
2273 const Tcl_ObjectMetadataType *typePtr)
2274 {
2275 Class *clsPtr = (Class *) clazz;
2276 Tcl_HashEntry *hPtr;
2277
2278 /*
2279 * If there's no metadata store attached, the type in question has
2280 * definitely not been attached either!
2281 */
2282
2283 if (clsPtr->metadataPtr == NULL) {
2284 return NULL;
2285 }
2286
2287 /*
2288 * There is a metadata store, so look in it for the given type.
2289 */
2290
2291 hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
2292
2293 /*
2294 * Return the metadata value if we found it, otherwise NULL.
2295 */
2296
2297 if (hPtr == NULL) {
2298 return NULL;
2299 }
2300 return Tcl_GetHashValue(hPtr);
2301 }
2302
2303 void
Tcl_ClassSetMetadata(Tcl_Class clazz,const Tcl_ObjectMetadataType * typePtr,ClientData metadata)2304 Tcl_ClassSetMetadata(
2305 Tcl_Class clazz,
2306 const Tcl_ObjectMetadataType *typePtr,
2307 ClientData metadata)
2308 {
2309 Class *clsPtr = (Class *) clazz;
2310 Tcl_HashEntry *hPtr;
2311 int isNew;
2312
2313 /*
2314 * Attach the metadata store if not done already.
2315 */
2316
2317 if (clsPtr->metadataPtr == NULL) {
2318 if (metadata == NULL) {
2319 return;
2320 }
2321 clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
2322 Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
2323 }
2324
2325 /*
2326 * If the metadata is NULL, we're deleting the metadata for the type.
2327 */
2328
2329 if (metadata == NULL) {
2330 hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
2331 if (hPtr != NULL) {
2332 typePtr->deleteProc(Tcl_GetHashValue(hPtr));
2333 Tcl_DeleteHashEntry(hPtr);
2334 }
2335 return;
2336 }
2337
2338 /*
2339 * Otherwise we're attaching the metadata. Note that if there was already
2340 * some metadata attached of this type, we delete that first.
2341 */
2342
2343 hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
2344 if (!isNew) {
2345 typePtr->deleteProc(Tcl_GetHashValue(hPtr));
2346 }
2347 Tcl_SetHashValue(hPtr, metadata);
2348 }
2349
2350 ClientData
Tcl_ObjectGetMetadata(Tcl_Object object,const Tcl_ObjectMetadataType * typePtr)2351 Tcl_ObjectGetMetadata(
2352 Tcl_Object object,
2353 const Tcl_ObjectMetadataType *typePtr)
2354 {
2355 Object *oPtr = (Object *) object;
2356 Tcl_HashEntry *hPtr;
2357
2358 /*
2359 * If there's no metadata store attached, the type in question has
2360 * definitely not been attached either!
2361 */
2362
2363 if (oPtr->metadataPtr == NULL) {
2364 return NULL;
2365 }
2366
2367 /*
2368 * There is a metadata store, so look in it for the given type.
2369 */
2370
2371 hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
2372
2373 /*
2374 * Return the metadata value if we found it, otherwise NULL.
2375 */
2376
2377 if (hPtr == NULL) {
2378 return NULL;
2379 }
2380 return Tcl_GetHashValue(hPtr);
2381 }
2382
2383 void
Tcl_ObjectSetMetadata(Tcl_Object object,const Tcl_ObjectMetadataType * typePtr,ClientData metadata)2384 Tcl_ObjectSetMetadata(
2385 Tcl_Object object,
2386 const Tcl_ObjectMetadataType *typePtr,
2387 ClientData metadata)
2388 {
2389 Object *oPtr = (Object *) object;
2390 Tcl_HashEntry *hPtr;
2391 int isNew;
2392
2393 /*
2394 * Attach the metadata store if not done already.
2395 */
2396
2397 if (oPtr->metadataPtr == NULL) {
2398 if (metadata == NULL) {
2399 return;
2400 }
2401 oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
2402 Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
2403 }
2404
2405 /*
2406 * If the metadata is NULL, we're deleting the metadata for the type.
2407 */
2408
2409 if (metadata == NULL) {
2410 hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
2411 if (hPtr != NULL) {
2412 typePtr->deleteProc(Tcl_GetHashValue(hPtr));
2413 Tcl_DeleteHashEntry(hPtr);
2414 }
2415 return;
2416 }
2417
2418 /*
2419 * Otherwise we're attaching the metadata. Note that if there was already
2420 * some metadata attached of this type, we delete that first.
2421 */
2422
2423 hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
2424 if (!isNew) {
2425 typePtr->deleteProc(Tcl_GetHashValue(hPtr));
2426 }
2427 Tcl_SetHashValue(hPtr, metadata);
2428 }
2429
2430 /*
2431 * ----------------------------------------------------------------------
2432 *
2433 * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
2434 *
2435 * Main entry point for object invocations. The Public* and Private*
2436 * wrapper functions (implementations of both object instance commands
2437 * and [my]) are just thin wrappers round the main TclOOObjectCmdCore
2438 * function. Note that the core is function is NRE-aware.
2439 *
2440 * ----------------------------------------------------------------------
2441 */
2442
2443 static int
PublicObjectCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)2444 PublicObjectCmd(
2445 ClientData clientData,
2446 Tcl_Interp *interp,
2447 int objc,
2448 Tcl_Obj *const *objv)
2449 {
2450 return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
2451 }
2452
2453 static int
PublicNRObjectCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)2454 PublicNRObjectCmd(
2455 ClientData clientData,
2456 Tcl_Interp *interp,
2457 int objc,
2458 Tcl_Obj *const *objv)
2459 {
2460 return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
2461 NULL);
2462 }
2463
2464 static int
PrivateObjectCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)2465 PrivateObjectCmd(
2466 ClientData clientData,
2467 Tcl_Interp *interp,
2468 int objc,
2469 Tcl_Obj *const *objv)
2470 {
2471 return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
2472 }
2473
2474 static int
PrivateNRObjectCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)2475 PrivateNRObjectCmd(
2476 ClientData clientData,
2477 Tcl_Interp *interp,
2478 int objc,
2479 Tcl_Obj *const *objv)
2480 {
2481 return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
2482 }
2483
2484 int
TclOOInvokeObject(Tcl_Interp * interp,Tcl_Object object,Tcl_Class startCls,int publicPrivate,int objc,Tcl_Obj * const * objv)2485 TclOOInvokeObject(
2486 Tcl_Interp *interp, /* Interpreter for commands, variables,
2487 * results, error reporting, etc. */
2488 Tcl_Object object, /* The object to invoke. */
2489 Tcl_Class startCls, /* Where in the class chain to start the
2490 * invoke from, or NULL to traverse the whole
2491 * chain including filters. */
2492 int publicPrivate, /* Whether this is an invoke from a public
2493 * context (PUBLIC_METHOD), a private context
2494 * (PRIVATE_METHOD), or a *really* private
2495 * context (any other value; conventionally
2496 * 0). */
2497 int objc, /* Number of arguments. */
2498 Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
2499 * that the name of the method to invoke will
2500 * be at index 1. */
2501 {
2502 switch (publicPrivate) {
2503 case PUBLIC_METHOD:
2504 return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
2505 PUBLIC_METHOD, (Class *) startCls);
2506 case PRIVATE_METHOD:
2507 return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
2508 PRIVATE_METHOD, (Class *) startCls);
2509 default:
2510 return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
2511 (Class *) startCls);
2512 }
2513 }
2514
2515 /*
2516 * ----------------------------------------------------------------------
2517 *
2518 * TclOOObjectCmdCore, FinalizeObjectCall --
2519 *
2520 * Main function for object invocations. Does call chain creation,
2521 * management and invocation. The function FinalizeObjectCall exists to
2522 * clean up after the non-recursive processing of TclOOObjectCmdCore.
2523 *
2524 * ----------------------------------------------------------------------
2525 */
2526
2527 int
TclOOObjectCmdCore(Object * oPtr,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv,int flags,Class * startCls)2528 TclOOObjectCmdCore(
2529 Object *oPtr, /* The object being invoked. */
2530 Tcl_Interp *interp, /* The interpreter containing the object. */
2531 int objc, /* How many arguments are being passed in. */
2532 Tcl_Obj *const *objv, /* The array of arguments. */
2533 int flags, /* Whether this is an invocation through the
2534 * public or the private command interface. */
2535 Class *startCls) /* Where to start in the call chain, or NULL
2536 * if we are to start at the front with
2537 * filters and the object's methods (which is
2538 * the normal case). */
2539 {
2540 CallContext *contextPtr;
2541 Tcl_Obj *methodNamePtr;
2542 int result;
2543
2544 /*
2545 * If we've no method name, throw this directly into the unknown
2546 * processing.
2547 */
2548
2549 if (objc < 2) {
2550 flags |= FORCE_UNKNOWN;
2551 methodNamePtr = NULL;
2552 goto noMapping;
2553 }
2554
2555 /*
2556 * Give plugged in code a chance to remap the method name.
2557 */
2558
2559 methodNamePtr = objv[1];
2560 if (oPtr->mapMethodNameProc != NULL) {
2561 Class **startClsPtr = &startCls;
2562 Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
2563
2564 result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
2565 (Tcl_Class *) startClsPtr, mappedMethodName);
2566 if (result != TCL_OK) {
2567 TclDecrRefCount(mappedMethodName);
2568 if (result == TCL_BREAK) {
2569 goto noMapping;
2570 } else if (result == TCL_ERROR) {
2571 Tcl_AddErrorInfo(interp, "\n (while mapping method name)");
2572 }
2573 return result;
2574 }
2575
2576 /*
2577 * Get the call chain for the remapped name.
2578 */
2579
2580 Tcl_IncrRefCount(mappedMethodName);
2581 contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
2582 flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
2583 TclDecrRefCount(mappedMethodName);
2584 if (contextPtr == NULL) {
2585 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2586 "impossible to invoke method \"%s\": no defined method or"
2587 " unknown method", TclGetString(methodNamePtr)));
2588 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
2589 TclGetString(methodNamePtr), NULL);
2590 return TCL_ERROR;
2591 }
2592 } else {
2593 /*
2594 * Get the call chain.
2595 */
2596
2597 noMapping:
2598 contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
2599 flags | (oPtr->flags & FILTER_HANDLING), NULL);
2600 if (contextPtr == NULL) {
2601 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2602 "impossible to invoke method \"%s\": no defined method or"
2603 " unknown method", TclGetString(methodNamePtr)));
2604 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
2605 TclGetString(methodNamePtr), NULL);
2606 return TCL_ERROR;
2607 }
2608 }
2609
2610 /*
2611 * Check to see if we need to apply magical tricks to start part way
2612 * through the call chain.
2613 */
2614
2615 if (startCls != NULL) {
2616 for (; contextPtr->index < contextPtr->callPtr->numChain;
2617 contextPtr->index++) {
2618 struct MInvoke *miPtr =
2619 &contextPtr->callPtr->chain[contextPtr->index];
2620
2621 if (miPtr->isFilter) {
2622 continue;
2623 }
2624 if (miPtr->mPtr->declaringClassPtr == startCls) {
2625 break;
2626 }
2627 }
2628 if (contextPtr->index >= contextPtr->callPtr->numChain) {
2629 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2630 "no valid method implementation", -1));
2631 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
2632 TclGetString(methodNamePtr), NULL);
2633 TclOODeleteContext(contextPtr);
2634 return TCL_ERROR;
2635 }
2636 }
2637
2638 /*
2639 * Invoke the call chain, locking the object structure against deletion
2640 * for the duration.
2641 */
2642
2643 TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
2644 return TclOOInvokeContext(contextPtr, interp, objc, objv);
2645 }
2646
2647 static int
FinalizeObjectCall(ClientData data[],Tcl_Interp * interp,int result)2648 FinalizeObjectCall(
2649 ClientData data[],
2650 Tcl_Interp *interp,
2651 int result)
2652 {
2653 /*
2654 * Dispose of the call chain, which drops the lock on the object's
2655 * structure.
2656 */
2657
2658 TclOODeleteContext(data[0]);
2659 return result;
2660 }
2661
2662 /*
2663 * ----------------------------------------------------------------------
2664 *
2665 * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
2666 *
2667 * Invokes the next stage of the call chain described in an object
2668 * context. This is the core of the implementation of the [next] command.
2669 * Does not do management of the call-frame stack. Available in public
2670 * (standard API) and private (NRE-aware) forms. FinalizeNext is a
2671 * private function used to clean up in the NRE case.
2672 *
2673 * ----------------------------------------------------------------------
2674 */
2675
2676 int
Tcl_ObjectContextInvokeNext(Tcl_Interp * interp,Tcl_ObjectContext context,int objc,Tcl_Obj * const * objv,int skip)2677 Tcl_ObjectContextInvokeNext(
2678 Tcl_Interp *interp,
2679 Tcl_ObjectContext context,
2680 int objc,
2681 Tcl_Obj *const *objv,
2682 int skip)
2683 {
2684 CallContext *contextPtr = (CallContext *) context;
2685 int savedIndex = contextPtr->index;
2686 int savedSkip = contextPtr->skip;
2687 int result;
2688
2689 if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
2690 /*
2691 * We're at the end of the chain; generate an error message unless the
2692 * interpreter is being torn down, in which case we might be getting
2693 * here because of methods/destructors doing a [next] (or equivalent)
2694 * unexpectedly.
2695 */
2696
2697 const char *methodType;
2698
2699 if (Tcl_InterpDeleted(interp)) {
2700 return TCL_OK;
2701 }
2702
2703 if (contextPtr->callPtr->flags & CONSTRUCTOR) {
2704 methodType = "constructor";
2705 } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
2706 methodType = "destructor";
2707 } else {
2708 methodType = "method";
2709 }
2710
2711 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2712 "no next %s implementation", methodType));
2713 Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
2714 return TCL_ERROR;
2715 }
2716
2717 /*
2718 * Advance to the next method implementation in the chain in the method
2719 * call context while we process the body. However, need to adjust the
2720 * argument-skip control because we're guaranteed to have a single prefix
2721 * arg (i.e., 'next') and not the variable amount that can happen because
2722 * method invocations (i.e., '$obj meth' and 'my meth'), constructors
2723 * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
2724 * all) come through the same code.
2725 */
2726
2727 contextPtr->index++;
2728 contextPtr->skip = skip;
2729
2730 /*
2731 * Invoke the (advanced) method call context in the caller context.
2732 */
2733
2734 result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc,
2735 objv);
2736
2737 /*
2738 * Restore the call chain context index as we've finished the inner invoke
2739 * and want to operate in the outer context again.
2740 */
2741
2742 contextPtr->index = savedIndex;
2743 contextPtr->skip = savedSkip;
2744
2745 return result;
2746 }
2747
2748 int
TclNRObjectContextInvokeNext(Tcl_Interp * interp,Tcl_ObjectContext context,int objc,Tcl_Obj * const * objv,int skip)2749 TclNRObjectContextInvokeNext(
2750 Tcl_Interp *interp,
2751 Tcl_ObjectContext context,
2752 int objc,
2753 Tcl_Obj *const *objv,
2754 int skip)
2755 {
2756 CallContext *contextPtr = (CallContext *) context;
2757
2758 if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
2759 /*
2760 * We're at the end of the chain; generate an error message unless the
2761 * interpreter is being torn down, in which case we might be getting
2762 * here because of methods/destructors doing a [next] (or equivalent)
2763 * unexpectedly.
2764 */
2765
2766 const char *methodType;
2767
2768 if (Tcl_InterpDeleted(interp)) {
2769 return TCL_OK;
2770 }
2771
2772 if (contextPtr->callPtr->flags & CONSTRUCTOR) {
2773 methodType = "constructor";
2774 } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
2775 methodType = "destructor";
2776 } else {
2777 methodType = "method";
2778 }
2779
2780 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2781 "no next %s implementation", methodType));
2782 Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
2783 return TCL_ERROR;
2784 }
2785
2786 /*
2787 * Advance to the next method implementation in the chain in the method
2788 * call context while we process the body. However, need to adjust the
2789 * argument-skip control because we're guaranteed to have a single prefix
2790 * arg (i.e., 'next') and not the variable amount that can happen because
2791 * method invocations (i.e., '$obj meth' and 'my meth'), constructors
2792 * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
2793 * all) come through the same code.
2794 */
2795
2796 TclNRAddCallback(interp, FinalizeNext, contextPtr,
2797 INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
2798 contextPtr->index++;
2799 contextPtr->skip = skip;
2800
2801 /*
2802 * Invoke the (advanced) method call context in the caller context.
2803 */
2804
2805 return TclOOInvokeContext(contextPtr, interp, objc, objv);
2806 }
2807
2808 static int
FinalizeNext(ClientData data[],Tcl_Interp * interp,int result)2809 FinalizeNext(
2810 ClientData data[],
2811 Tcl_Interp *interp,
2812 int result)
2813 {
2814 CallContext *contextPtr = data[0];
2815
2816 /*
2817 * Restore the call chain context index as we've finished the inner invoke
2818 * and want to operate in the outer context again.
2819 */
2820
2821 contextPtr->index = PTR2INT(data[1]);
2822 contextPtr->skip = PTR2INT(data[2]);
2823 return result;
2824 }
2825
2826 /*
2827 * ----------------------------------------------------------------------
2828 *
2829 * Tcl_GetObjectFromObj --
2830 *
2831 * Utility function to get an object from a Tcl_Obj containing its name.
2832 *
2833 * ----------------------------------------------------------------------
2834 */
2835
2836 Tcl_Object
Tcl_GetObjectFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr)2837 Tcl_GetObjectFromObj(
2838 Tcl_Interp *interp, /* Interpreter in which to locate the object.
2839 * Will have an error message placed in it if
2840 * the name does not refer to an object. */
2841 Tcl_Obj *objPtr) /* The name of the object to look up, which is
2842 * exactly the name of its public command. */
2843 {
2844 Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
2845
2846 if (cmdPtr == NULL) {
2847 goto notAnObject;
2848 }
2849 if (cmdPtr->objProc != PublicObjectCmd) {
2850 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
2851 if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
2852 goto notAnObject;
2853 }
2854 }
2855 return cmdPtr->objClientData;
2856
2857 notAnObject:
2858 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2859 "%s does not refer to an object", TclGetString(objPtr)));
2860 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
2861 NULL);
2862 return NULL;
2863 }
2864
2865 /*
2866 * ----------------------------------------------------------------------
2867 *
2868 * TclOOIsReachable --
2869 *
2870 * Utility function that tests whether a class is a subclass (whether
2871 * directly or indirectly) of another class.
2872 *
2873 * ----------------------------------------------------------------------
2874 */
2875
2876 int
TclOOIsReachable(Class * targetPtr,Class * startPtr)2877 TclOOIsReachable(
2878 Class *targetPtr,
2879 Class *startPtr)
2880 {
2881 int i;
2882 Class *superPtr;
2883
2884 tailRecurse:
2885 if (startPtr == targetPtr) {
2886 return 1;
2887 }
2888 if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
2889 startPtr = startPtr->superclasses.list[0];
2890 goto tailRecurse;
2891 }
2892 FOREACH(superPtr, startPtr->superclasses) {
2893 if (TclOOIsReachable(targetPtr, superPtr)) {
2894 return 1;
2895 }
2896 }
2897 FOREACH(superPtr, startPtr->mixins) {
2898 if (TclOOIsReachable(targetPtr, superPtr)) {
2899 return 1;
2900 }
2901 }
2902 return 0;
2903 }
2904
2905 /*
2906 * ----------------------------------------------------------------------
2907 *
2908 * TclOOObjectName, Tcl_GetObjectName --
2909 *
2910 * Utility function that returns the name of the object. Note that this
2911 * simplifies cache management by keeping the code to do it in one place
2912 * and not sprayed all over. The value returned always has a reference
2913 * count of at least one.
2914 *
2915 * ----------------------------------------------------------------------
2916 */
2917
2918 Tcl_Obj *
TclOOObjectName(Tcl_Interp * interp,Object * oPtr)2919 TclOOObjectName(
2920 Tcl_Interp *interp,
2921 Object *oPtr)
2922 {
2923 Tcl_Obj *namePtr;
2924
2925 if (oPtr->cachedNameObj) {
2926 return oPtr->cachedNameObj;
2927 }
2928 namePtr = Tcl_NewObj();
2929 Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
2930 Tcl_IncrRefCount(namePtr);
2931 oPtr->cachedNameObj = namePtr;
2932 return namePtr;
2933 }
2934
2935 Tcl_Obj *
Tcl_GetObjectName(Tcl_Interp * interp,Tcl_Object object)2936 Tcl_GetObjectName(
2937 Tcl_Interp *interp,
2938 Tcl_Object object)
2939 {
2940 return TclOOObjectName(interp, (Object *) object);
2941 }
2942
2943 /*
2944 * ----------------------------------------------------------------------
2945 *
2946 * assorted trivial 'getter' functions
2947 *
2948 * ----------------------------------------------------------------------
2949 */
2950
2951 Tcl_Method
Tcl_ObjectContextMethod(Tcl_ObjectContext context)2952 Tcl_ObjectContextMethod(
2953 Tcl_ObjectContext context)
2954 {
2955 CallContext *contextPtr = (CallContext *) context;
2956 return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr;
2957 }
2958
2959 int
Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context)2960 Tcl_ObjectContextIsFiltering(
2961 Tcl_ObjectContext context)
2962 {
2963 CallContext *contextPtr = (CallContext *) context;
2964 return contextPtr->callPtr->chain[contextPtr->index].isFilter;
2965 }
2966
2967 Tcl_Object
Tcl_ObjectContextObject(Tcl_ObjectContext context)2968 Tcl_ObjectContextObject(
2969 Tcl_ObjectContext context)
2970 {
2971 return (Tcl_Object) ((CallContext *)context)->oPtr;
2972 }
2973
2974 int
Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)2975 Tcl_ObjectContextSkippedArgs(
2976 Tcl_ObjectContext context)
2977 {
2978 return ((CallContext *)context)->skip;
2979 }
2980
2981 Tcl_Namespace *
Tcl_GetObjectNamespace(Tcl_Object object)2982 Tcl_GetObjectNamespace(
2983 Tcl_Object object)
2984 {
2985 return ((Object *)object)->namespacePtr;
2986 }
2987
2988 Tcl_Command
Tcl_GetObjectCommand(Tcl_Object object)2989 Tcl_GetObjectCommand(
2990 Tcl_Object object)
2991 {
2992 return ((Object *)object)->command;
2993 }
2994
2995 Tcl_Class
Tcl_GetObjectAsClass(Tcl_Object object)2996 Tcl_GetObjectAsClass(
2997 Tcl_Object object)
2998 {
2999 return (Tcl_Class) ((Object *)object)->classPtr;
3000 }
3001
3002 int
Tcl_ObjectDeleted(Tcl_Object object)3003 Tcl_ObjectDeleted(
3004 Tcl_Object object)
3005 {
3006 return ((Object *)object)->command == NULL;
3007 }
3008
3009 Tcl_Object
Tcl_GetClassAsObject(Tcl_Class clazz)3010 Tcl_GetClassAsObject(
3011 Tcl_Class clazz)
3012 {
3013 return (Tcl_Object) ((Class *)clazz)->thisPtr;
3014 }
3015
3016 Tcl_ObjectMapMethodNameProc *
Tcl_ObjectGetMethodNameMapper(Tcl_Object object)3017 Tcl_ObjectGetMethodNameMapper(
3018 Tcl_Object object)
3019 {
3020 return ((Object *) object)->mapMethodNameProc;
3021 }
3022
3023 void
Tcl_ObjectSetMethodNameMapper(Tcl_Object object,Tcl_ObjectMapMethodNameProc * mapMethodNameProc)3024 Tcl_ObjectSetMethodNameMapper(
3025 Tcl_Object object,
3026 Tcl_ObjectMapMethodNameProc *mapMethodNameProc)
3027 {
3028 ((Object *) object)->mapMethodNameProc = mapMethodNameProc;
3029 }
3030
3031 /*
3032 * Local Variables:
3033 * mode: c
3034 * c-basic-offset: 4
3035 * fill-column: 78
3036 * End:
3037 */
3038