1 /*
2 * tclOOMethod.c --
3 *
4 * This file contains code to create and manage methods.
5 *
6 * Copyright © 2005-2011 Donal K. Fellows
7 *
8 * See the file "license.terms" for information on usage and redistribution of
9 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 */
11
12 #ifdef HAVE_CONFIG_H
13 #include "config.h"
14 #endif
15 #include "tclInt.h"
16 #include "tclOOInt.h"
17 #include "tclCompile.h"
18
19 /*
20 * Structure used to help delay computing names of objects or classes for
21 * [info frame] until needed, making invokation faster in the normal case.
22 */
23
24 struct PNI {
25 Tcl_Interp *interp; /* Interpreter in which to compute the name of
26 * a method. */
27 Tcl_Method method; /* Method to compute the name of. */
28 };
29
30 /*
31 * Structure used to contain all the information needed about a call frame
32 * used in a procedure-like method.
33 */
34
35 typedef struct {
36 CallFrame *framePtr; /* Reference to the call frame itself (it's
37 * actually allocated on the Tcl stack). */
38 ProcErrorProc *errProc; /* The error handler for the body. */
39 Tcl_Obj *nameObj; /* The "name" of the command. */
40 Command cmd; /* The command structure. Mostly bogus. */
41 ExtraFrameInfo efi; /* Extra information used for [info frame]. */
42 Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a
43 * recursive call returns. */
44 struct PNI pni; /* Specialist information used in the efi
45 * field for this type of call. */
46 } PMFrameData;
47
48 /*
49 * Structure used to pass information about variable resolution to the
50 * on-the-ground resolvers used when working with resolved compiled variables.
51 */
52
53 typedef struct {
54 Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
55 * variable can be linked to the namespace
56 * variable at the right time. */
57 Tcl_Obj *variableObj; /* The name of the variable. */
58 Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
59 * variables be cached? */
60 } OOResVarInfo;
61
62 /*
63 * Function declarations for things defined in this file.
64 */
65
66 static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
67 Tcl_Obj *const *objv, int toRewrite,
68 int rewriteLength, Tcl_Obj *const *rewriteObjs,
69 int *lengthPtr);
70 static int InvokeProcedureMethod(void *clientData,
71 Tcl_Interp *interp, Tcl_ObjectContext context,
72 int objc, Tcl_Obj *const *objv);
73 static Tcl_NRPostProc FinalizeForwardCall;
74 static Tcl_NRPostProc FinalizePMCall;
75 static int PushMethodCallFrame(Tcl_Interp *interp,
76 CallContext *contextPtr, ProcedureMethod *pmPtr,
77 int objc, Tcl_Obj *const *objv,
78 PMFrameData *fdPtr);
79 static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
80 static void DeleteProcedureMethod(void *clientData);
81 static int CloneProcedureMethod(Tcl_Interp *interp,
82 void *clientData, void **newClientData);
83 static ProcErrorProc MethodErrorHandler;
84 static ProcErrorProc ConstructorErrorHandler;
85 static ProcErrorProc DestructorErrorHandler;
86 static Tcl_Obj * RenderDeclarerName(void *clientData);
87 static int InvokeForwardMethod(void *clientData,
88 Tcl_Interp *interp, Tcl_ObjectContext context,
89 int objc, Tcl_Obj *const *objv);
90 static void DeleteForwardMethod(void *clientData);
91 static int CloneForwardMethod(Tcl_Interp *interp,
92 void *clientData, void **newClientData);
93 static Tcl_ResolveVarProc ProcedureMethodVarResolver;
94 static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
95
96 /*
97 * The types of methods defined by the core OO system.
98 */
99
100 static const Tcl_MethodType procMethodType = {
101 TCL_OO_METHOD_VERSION_CURRENT, "method",
102 InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
103 };
104 static const Tcl_MethodType fwdMethodType = {
105 TCL_OO_METHOD_VERSION_CURRENT, "forward",
106 InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
107 };
108
109 /*
110 * Helper macros (derived from things private to tclVar.c)
111 */
112
113 #define TclVarTable(contextNs) \
114 ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
115 #define TclVarHashGetValue(hPtr) \
116 ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
117
118 /*
119 * ----------------------------------------------------------------------
120 *
121 * Tcl_NewInstanceMethod --
122 *
123 * Attach a method to an object instance.
124 *
125 * ----------------------------------------------------------------------
126 */
127
128 Tcl_Method
Tcl_NewInstanceMethod(TCL_UNUSED (Tcl_Interp *),Tcl_Object object,Tcl_Obj * nameObj,int flags,const Tcl_MethodType * typePtr,void * clientData)129 Tcl_NewInstanceMethod(
130 TCL_UNUSED(Tcl_Interp *),
131 Tcl_Object object, /* The object that has the method attached to
132 * it. */
133 Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
134 * up to caller to manage storage (e.g., when
135 * it is a constructor or destructor). */
136 int flags, /* Whether this is a public method. */
137 const Tcl_MethodType *typePtr,
138 /* The type of method this is, which defines
139 * how to invoke, delete and clone the
140 * method. */
141 void *clientData) /* Some data associated with the particular
142 * method to be created. */
143 {
144 Object *oPtr = (Object *) object;
145 Method *mPtr;
146 Tcl_HashEntry *hPtr;
147 int isNew;
148
149 if (nameObj == NULL) {
150 mPtr = (Method *)ckalloc(sizeof(Method));
151 mPtr->namePtr = NULL;
152 mPtr->refCount = 1;
153 goto populate;
154 }
155 if (!oPtr->methodsPtr) {
156 oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
157 Tcl_InitObjHashTable(oPtr->methodsPtr);
158 oPtr->flags &= ~USE_CLASS_CACHE;
159 }
160 hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
161 if (isNew) {
162 mPtr = (Method *)ckalloc(sizeof(Method));
163 mPtr->namePtr = nameObj;
164 mPtr->refCount = 1;
165 Tcl_IncrRefCount(nameObj);
166 Tcl_SetHashValue(hPtr, mPtr);
167 } else {
168 mPtr = (Method *)Tcl_GetHashValue(hPtr);
169 if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
170 mPtr->typePtr->deleteProc(mPtr->clientData);
171 }
172 }
173
174 populate:
175 mPtr->typePtr = typePtr;
176 mPtr->clientData = clientData;
177 mPtr->flags = 0;
178 mPtr->declaringObjectPtr = oPtr;
179 mPtr->declaringClassPtr = NULL;
180 if (flags) {
181 mPtr->flags |= flags &
182 (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
183 if (flags & TRUE_PRIVATE_METHOD) {
184 oPtr->flags |= HAS_PRIVATE_METHODS;
185 }
186 }
187 oPtr->epoch++;
188 return (Tcl_Method) mPtr;
189 }
190
191 /*
192 * ----------------------------------------------------------------------
193 *
194 * Tcl_NewMethod --
195 *
196 * Attach a method to a class.
197 *
198 * ----------------------------------------------------------------------
199 */
200
201 Tcl_Method
Tcl_NewMethod(TCL_UNUSED (Tcl_Interp *),Tcl_Class cls,Tcl_Obj * nameObj,int flags,const Tcl_MethodType * typePtr,void * clientData)202 Tcl_NewMethod(
203 TCL_UNUSED(Tcl_Interp *),
204 Tcl_Class cls, /* The class to attach the method to. */
205 Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
206 * for constructors or destructors); if so, up
207 * to caller to manage storage. */
208 int flags, /* Whether this is a public method. */
209 const Tcl_MethodType *typePtr,
210 /* The type of method this is, which defines
211 * how to invoke, delete and clone the
212 * method. */
213 void *clientData) /* Some data associated with the particular
214 * method to be created. */
215 {
216 Class *clsPtr = (Class *) cls;
217 Method *mPtr;
218 Tcl_HashEntry *hPtr;
219 int isNew;
220
221 if (nameObj == NULL) {
222 mPtr = (Method *)ckalloc(sizeof(Method));
223 mPtr->namePtr = NULL;
224 mPtr->refCount = 1;
225 goto populate;
226 }
227 hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
228 if (isNew) {
229 mPtr = (Method *)ckalloc(sizeof(Method));
230 mPtr->refCount = 1;
231 mPtr->namePtr = nameObj;
232 Tcl_IncrRefCount(nameObj);
233 Tcl_SetHashValue(hPtr, mPtr);
234 } else {
235 mPtr = (Method *)Tcl_GetHashValue(hPtr);
236 if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
237 mPtr->typePtr->deleteProc(mPtr->clientData);
238 }
239 }
240
241 populate:
242 clsPtr->thisPtr->fPtr->epoch++;
243 mPtr->typePtr = typePtr;
244 mPtr->clientData = clientData;
245 mPtr->flags = 0;
246 mPtr->declaringObjectPtr = NULL;
247 mPtr->declaringClassPtr = clsPtr;
248 if (flags) {
249 mPtr->flags |= flags &
250 (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
251 if (flags & TRUE_PRIVATE_METHOD) {
252 clsPtr->flags |= HAS_PRIVATE_METHODS;
253 }
254 }
255
256 return (Tcl_Method) mPtr;
257 }
258
259 /*
260 * ----------------------------------------------------------------------
261 *
262 * TclOODelMethodRef --
263 *
264 * How to delete a method.
265 *
266 * ----------------------------------------------------------------------
267 */
268
269 void
TclOODelMethodRef(Method * mPtr)270 TclOODelMethodRef(
271 Method *mPtr)
272 {
273 if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) {
274 if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
275 mPtr->typePtr->deleteProc(mPtr->clientData);
276 }
277 if (mPtr->namePtr != NULL) {
278 Tcl_DecrRefCount(mPtr->namePtr);
279 }
280
281 ckfree(mPtr);
282 }
283 }
284
285 /*
286 * ----------------------------------------------------------------------
287 *
288 * TclOONewBasicMethod --
289 *
290 * Helper that makes it cleaner to create very simple methods during
291 * basic system initialization. Not suitable for general use.
292 *
293 * ----------------------------------------------------------------------
294 */
295
296 void
TclOONewBasicMethod(Tcl_Interp * interp,Class * clsPtr,const DeclaredClassMethod * dcm)297 TclOONewBasicMethod(
298 Tcl_Interp *interp,
299 Class *clsPtr, /* Class to attach the method to. */
300 const DeclaredClassMethod *dcm)
301 /* Name of the method, whether it is public,
302 * and the function to implement it. */
303 {
304 Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
305
306 Tcl_IncrRefCount(namePtr);
307 Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
308 (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
309 Tcl_DecrRefCount(namePtr);
310 }
311
312 /*
313 * ----------------------------------------------------------------------
314 *
315 * TclOONewProcInstanceMethod --
316 *
317 * Create a new procedure-like method for an object.
318 *
319 * ----------------------------------------------------------------------
320 */
321
322 Method *
TclOONewProcInstanceMethod(Tcl_Interp * interp,Object * oPtr,int flags,Tcl_Obj * nameObj,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,ProcedureMethod ** pmPtrPtr)323 TclOONewProcInstanceMethod(
324 Tcl_Interp *interp, /* The interpreter containing the object. */
325 Object *oPtr, /* The object to modify. */
326 int flags, /* Whether this is a public method. */
327 Tcl_Obj *nameObj, /* The name of the method, which must not be
328 * NULL. */
329 Tcl_Obj *argsObj, /* The formal argument list for the method,
330 * which must not be NULL. */
331 Tcl_Obj *bodyObj, /* The body of the method, which must not be
332 * NULL. */
333 ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
334 * structure to allow for deeper tuning of the
335 * structure's contents. NULL if caller is not
336 * interested. */
337 {
338 int argsLen;
339 ProcedureMethod *pmPtr;
340 Tcl_Method method;
341
342 if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
343 return NULL;
344 }
345 pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
346 memset(pmPtr, 0, sizeof(ProcedureMethod));
347 pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
348 pmPtr->flags = flags & USE_DECLARER_NS;
349 pmPtr->refCount = 1;
350
351 method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
352 argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
353 if (method == NULL) {
354 ckfree(pmPtr);
355 } else if (pmPtrPtr != NULL) {
356 *pmPtrPtr = pmPtr;
357 }
358 return (Method *) method;
359 }
360
361 /*
362 * ----------------------------------------------------------------------
363 *
364 * TclOONewProcMethod --
365 *
366 * Create a new procedure-like method for a class.
367 *
368 * ----------------------------------------------------------------------
369 */
370
371 Method *
TclOONewProcMethod(Tcl_Interp * interp,Class * clsPtr,int flags,Tcl_Obj * nameObj,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,ProcedureMethod ** pmPtrPtr)372 TclOONewProcMethod(
373 Tcl_Interp *interp, /* The interpreter containing the class. */
374 Class *clsPtr, /* The class to modify. */
375 int flags, /* Whether this is a public method. */
376 Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
377 * if so, up to caller to manage storage
378 * (e.g., because it is a constructor or
379 * destructor). */
380 Tcl_Obj *argsObj, /* The formal argument list for the method,
381 * which may be NULL; if so, it is equivalent
382 * to an empty list. */
383 Tcl_Obj *bodyObj, /* The body of the method, which must not be
384 * NULL. */
385 ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
386 * structure to allow for deeper tuning of the
387 * structure's contents. NULL if caller is not
388 * interested. */
389 {
390 int argsLen; /* -1 => delete argsObj before exit */
391 ProcedureMethod *pmPtr;
392 const char *procName;
393 Tcl_Method method;
394
395 if (argsObj == NULL) {
396 argsLen = -1;
397 TclNewObj(argsObj);
398 Tcl_IncrRefCount(argsObj);
399 procName = "<destructor>";
400 } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
401 return NULL;
402 } else {
403 procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
404 }
405
406 pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
407 memset(pmPtr, 0, sizeof(ProcedureMethod));
408 pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
409 pmPtr->flags = flags & USE_DECLARER_NS;
410 pmPtr->refCount = 1;
411
412 method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
413 argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
414
415 if (argsLen == -1) {
416 Tcl_DecrRefCount(argsObj);
417 }
418 if (method == NULL) {
419 ckfree(pmPtr);
420 } else if (pmPtrPtr != NULL) {
421 *pmPtrPtr = pmPtr;
422 }
423
424 return (Method *) method;
425 }
426
427 /*
428 * ----------------------------------------------------------------------
429 *
430 * TclOOMakeProcInstanceMethod --
431 *
432 * The guts of the code to make a procedure-like method for an object.
433 * Split apart so that it is easier for other extensions to reuse (in
434 * particular, it frees them from having to pry so deeply into Tcl's
435 * guts).
436 *
437 * ----------------------------------------------------------------------
438 */
439
440 Tcl_Method
TclOOMakeProcInstanceMethod(Tcl_Interp * interp,Object * oPtr,int flags,Tcl_Obj * nameObj,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,const Tcl_MethodType * typePtr,void * clientData,Proc ** procPtrPtr)441 TclOOMakeProcInstanceMethod(
442 Tcl_Interp *interp, /* The interpreter containing the object. */
443 Object *oPtr, /* The object to modify. */
444 int flags, /* Whether this is a public method. */
445 Tcl_Obj *nameObj, /* The name of the method, which _must not_ be
446 * NULL. */
447 Tcl_Obj *argsObj, /* The formal argument list for the method,
448 * which _must not_ be NULL. */
449 Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
450 * NULL. */
451 const Tcl_MethodType *typePtr,
452 /* The type of the method to create. */
453 void *clientData, /* The per-method type-specific data. */
454 Proc **procPtrPtr) /* A pointer to the variable in which to write
455 * the procedure record reference. Presumably
456 * inside the structure indicated by the
457 * pointer in clientData. */
458 {
459 Interp *iPtr = (Interp *) interp;
460 Proc *procPtr;
461
462 if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
463 procPtrPtr) != TCL_OK) {
464 return NULL;
465 }
466 procPtr = *procPtrPtr;
467 procPtr->cmdPtr = NULL;
468
469 if (iPtr->cmdFramePtr) {
470 CmdFrame context = *iPtr->cmdFramePtr;
471
472 if (context.type == TCL_LOCATION_BC) {
473 /*
474 * Retrieve source information from the bytecode, if possible. If
475 * the information is retrieved successfully, context.type will be
476 * TCL_LOCATION_SOURCE and the reference held by
477 * context.data.eval.path will be counted.
478 */
479
480 TclGetSrcInfoForPc(&context);
481 } else if (context.type == TCL_LOCATION_SOURCE) {
482 /*
483 * The copy into 'context' up above has created another reference
484 * to 'context.data.eval.path'; account for it.
485 */
486
487 Tcl_IncrRefCount(context.data.eval.path);
488 }
489
490 if (context.type == TCL_LOCATION_SOURCE) {
491 /*
492 * We can account for source location within a proc only if the
493 * proc body was not created by substitution.
494 * (FIXME: check that this is sane and correct!)
495 */
496
497 if (context.line
498 && (context.nline >= 4) && (context.line[3] >= 0)) {
499 int isNew;
500 CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
501 Tcl_HashEntry *hPtr;
502
503 cfPtr->level = -1;
504 cfPtr->type = context.type;
505 cfPtr->line = (int *)ckalloc(sizeof(int));
506 cfPtr->line[0] = context.line[3];
507 cfPtr->nline = 1;
508 cfPtr->framePtr = NULL;
509 cfPtr->nextPtr = NULL;
510
511 cfPtr->data.eval.path = context.data.eval.path;
512 Tcl_IncrRefCount(cfPtr->data.eval.path);
513
514 cfPtr->cmd = NULL;
515 cfPtr->len = 0;
516
517 hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
518 (char *) procPtr, &isNew);
519 Tcl_SetHashValue(hPtr, cfPtr);
520 }
521
522 /*
523 * 'context' is going out of scope; account for the reference that
524 * it's holding to the path name.
525 */
526
527 Tcl_DecrRefCount(context.data.eval.path);
528 context.data.eval.path = NULL;
529 }
530 }
531
532 return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
533 typePtr, clientData);
534 }
535
536 /*
537 * ----------------------------------------------------------------------
538 *
539 * TclOOMakeProcMethod --
540 *
541 * The guts of the code to make a procedure-like method for a class.
542 * Split apart so that it is easier for other extensions to reuse (in
543 * particular, it frees them from having to pry so deeply into Tcl's
544 * guts).
545 *
546 * ----------------------------------------------------------------------
547 */
548
549 Tcl_Method
TclOOMakeProcMethod(Tcl_Interp * interp,Class * clsPtr,int flags,Tcl_Obj * nameObj,const char * namePtr,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,const Tcl_MethodType * typePtr,void * clientData,Proc ** procPtrPtr)550 TclOOMakeProcMethod(
551 Tcl_Interp *interp, /* The interpreter containing the class. */
552 Class *clsPtr, /* The class to modify. */
553 int flags, /* Whether this is a public method. */
554 Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
555 * if so, up to caller to manage storage
556 * (e.g., because it is a constructor or
557 * destructor). */
558 const char *namePtr, /* The name of the method as a string, which
559 * _must not_ be NULL. */
560 Tcl_Obj *argsObj, /* The formal argument list for the method,
561 * which _must not_ be NULL. */
562 Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be
563 * NULL. */
564 const Tcl_MethodType *typePtr,
565 /* The type of the method to create. */
566 void *clientData, /* The per-method type-specific data. */
567 Proc **procPtrPtr) /* A pointer to the variable in which to write
568 * the procedure record reference. Presumably
569 * inside the structure indicated by the
570 * pointer in clientData. */
571 {
572 Interp *iPtr = (Interp *) interp;
573 Proc *procPtr;
574
575 if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
576 procPtrPtr) != TCL_OK) {
577 return NULL;
578 }
579 procPtr = *procPtrPtr;
580 procPtr->cmdPtr = NULL;
581
582 if (iPtr->cmdFramePtr) {
583 CmdFrame context = *iPtr->cmdFramePtr;
584
585 if (context.type == TCL_LOCATION_BC) {
586 /*
587 * Retrieve source information from the bytecode, if possible. If
588 * the information is retrieved successfully, context.type will be
589 * TCL_LOCATION_SOURCE and the reference held by
590 * context.data.eval.path will be counted.
591 */
592
593 TclGetSrcInfoForPc(&context);
594 } else if (context.type == TCL_LOCATION_SOURCE) {
595 /*
596 * The copy into 'context' up above has created another reference
597 * to 'context.data.eval.path'; account for it.
598 */
599
600 Tcl_IncrRefCount(context.data.eval.path);
601 }
602
603 if (context.type == TCL_LOCATION_SOURCE) {
604 /*
605 * We can account for source location within a proc only if the
606 * proc body was not created by substitution.
607 * (FIXME: check that this is sane and correct!)
608 */
609
610 if (context.line
611 && (context.nline >= 4) && (context.line[3] >= 0)) {
612 int isNew;
613 CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
614 Tcl_HashEntry *hPtr;
615
616 cfPtr->level = -1;
617 cfPtr->type = context.type;
618 cfPtr->line = (int *)ckalloc(sizeof(int));
619 cfPtr->line[0] = context.line[3];
620 cfPtr->nline = 1;
621 cfPtr->framePtr = NULL;
622 cfPtr->nextPtr = NULL;
623
624 cfPtr->data.eval.path = context.data.eval.path;
625 Tcl_IncrRefCount(cfPtr->data.eval.path);
626
627 cfPtr->cmd = NULL;
628 cfPtr->len = 0;
629
630 hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
631 (char *) procPtr, &isNew);
632 Tcl_SetHashValue(hPtr, cfPtr);
633 }
634
635 /*
636 * 'context' is going out of scope; account for the reference that
637 * it's holding to the path name.
638 */
639
640 Tcl_DecrRefCount(context.data.eval.path);
641 context.data.eval.path = NULL;
642 }
643 }
644
645 return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
646 clientData);
647 }
648
649 /*
650 * ----------------------------------------------------------------------
651 *
652 * InvokeProcedureMethod, PushMethodCallFrame --
653 *
654 * How to invoke a procedure-like method.
655 *
656 * ----------------------------------------------------------------------
657 */
658
659 static int
InvokeProcedureMethod(void * clientData,Tcl_Interp * interp,Tcl_ObjectContext context,int objc,Tcl_Obj * const * objv)660 InvokeProcedureMethod(
661 void *clientData, /* Pointer to some per-method context. */
662 Tcl_Interp *interp,
663 Tcl_ObjectContext context, /* The method calling context. */
664 int objc, /* Number of arguments. */
665 Tcl_Obj *const *objv) /* Arguments as actually seen. */
666 {
667 ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
668 int result;
669 PMFrameData *fdPtr; /* Important data that has to have a lifetime
670 * matched by this function (or rather, by the
671 * call frame's lifetime). */
672
673 /*
674 * If the object namespace (or interpreter) were deleted, we just skip to
675 * the next thing in the chain.
676 */
677
678 if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) ||
679 Tcl_InterpDeleted(interp)
680 ) {
681 return TclNRObjectContextInvokeNext(interp, context, objc, objv,
682 Tcl_ObjectContextSkippedArgs(context));
683 }
684
685 /*
686 * Allocate the special frame data.
687 */
688
689 fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData));
690
691 /*
692 * Create a call frame for this method.
693 */
694
695 result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
696 objc, objv, fdPtr);
697 if (result != TCL_OK) {
698 TclStackFree(interp, fdPtr);
699 return result;
700 }
701 pmPtr->refCount++;
702
703 /*
704 * Give the pre-call callback a chance to do some setup and, possibly,
705 * veto the call.
706 */
707
708 if (pmPtr->preCallProc != NULL) {
709 int isFinished;
710
711 result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
712 (Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
713 if (isFinished || result != TCL_OK) {
714 /*
715 * Restore the old cmdPtr so that a subsequent use of [info frame]
716 * won't crash on us. [Bug 3001438]
717 */
718
719 pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
720
721 Tcl_PopCallFrame(interp);
722 TclStackFree(interp, fdPtr->framePtr);
723 if (pmPtr->refCount-- <= 1) {
724 DeleteProcedureMethodRecord(pmPtr);
725 }
726 TclStackFree(interp, fdPtr);
727 return result;
728 }
729 }
730
731 /*
732 * Now invoke the body of the method.
733 */
734
735 TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
736 return TclNRInterpProcCore(interp, fdPtr->nameObj,
737 Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
738 }
739
740 static int
FinalizePMCall(void * data[],Tcl_Interp * interp,int result)741 FinalizePMCall(
742 void *data[],
743 Tcl_Interp *interp,
744 int result)
745 {
746 ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
747 Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];
748 PMFrameData *fdPtr = (PMFrameData *)data[2];
749
750 /*
751 * Give the post-call callback a chance to do some cleanup. Note that at
752 * this point the call frame itself is invalid; it's already been popped.
753 */
754
755 if (pmPtr->postCallProc) {
756 result = pmPtr->postCallProc(pmPtr->clientData, interp, context,
757 Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),
758 result);
759 }
760
761 /*
762 * Restore the old cmdPtr so that a subsequent use of [info frame] won't
763 * crash on us. [Bug 3001438]
764 */
765
766 pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
767
768 /*
769 * Scrap the special frame data now that we're done with it. Note that we
770 * are inlining DeleteProcedureMethod() here; this location is highly
771 * sensitive when it comes to performance!
772 */
773
774 if (pmPtr->refCount-- <= 1) {
775 DeleteProcedureMethodRecord(pmPtr);
776 }
777 TclStackFree(interp, fdPtr);
778 return result;
779 }
780
781 static int
PushMethodCallFrame(Tcl_Interp * interp,CallContext * contextPtr,ProcedureMethod * pmPtr,int objc,Tcl_Obj * const * objv,PMFrameData * fdPtr)782 PushMethodCallFrame(
783 Tcl_Interp *interp, /* Current interpreter. */
784 CallContext *contextPtr, /* Current method call context. */
785 ProcedureMethod *pmPtr, /* Information about this procedure-like
786 * method. */
787 int objc, /* Number of arguments. */
788 Tcl_Obj *const *objv, /* Array of arguments. */
789 PMFrameData *fdPtr) /* Place to store information about the call
790 * frame. */
791 {
792 Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
793 int result;
794 const char *namePtr;
795 CallFrame **framePtrPtr = &fdPtr->framePtr;
796 ByteCode *codePtr;
797
798 /*
799 * Compute basic information on the basis of the type of method it is.
800 */
801
802 if (contextPtr->callPtr->flags & CONSTRUCTOR) {
803 namePtr = "<constructor>";
804 fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName;
805 fdPtr->errProc = ConstructorErrorHandler;
806 } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
807 namePtr = "<destructor>";
808 fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName;
809 fdPtr->errProc = DestructorErrorHandler;
810 } else {
811 fdPtr->nameObj = Tcl_MethodName(
812 Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
813 namePtr = TclGetString(fdPtr->nameObj);
814 fdPtr->errProc = MethodErrorHandler;
815 }
816 if (pmPtr->errProc != NULL) {
817 fdPtr->errProc = pmPtr->errProc;
818 }
819
820 /*
821 * Magic to enable things like [incr Tcl], which wants methods to run in
822 * their class's namespace.
823 */
824
825 if (pmPtr->flags & USE_DECLARER_NS) {
826 Method *mPtr =
827 contextPtr->callPtr->chain[contextPtr->index].mPtr;
828
829 if (mPtr->declaringClassPtr != NULL) {
830 nsPtr = (Namespace *)
831 mPtr->declaringClassPtr->thisPtr->namespacePtr;
832 } else {
833 nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
834 }
835 }
836
837 /*
838 * Save the old cmdPtr so that when this recursive call returns, we can
839 * restore it. To do otherwise causes crashes in [info frame] after we
840 * return from a recursive call. [Bug 3001438]
841 */
842
843 fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr;
844
845 /*
846 * Compile the body. This operation may fail.
847 */
848
849 fdPtr->efi.length = 2;
850 memset(&fdPtr->cmd, 0, sizeof(Command));
851 fdPtr->cmd.nsPtr = nsPtr;
852 fdPtr->cmd.clientData = &fdPtr->efi;
853 pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
854
855 /*
856 * [Bug 2037727] Always call TclProcCompileProc so that we check not only
857 * that we have bytecode, but also that it remains valid. Note that we set
858 * the namespace of the code here directly; this is a hack, but the
859 * alternative is *so* slow...
860 */
861
862 ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
863 if (codePtr) {
864 codePtr->nsPtr = nsPtr;
865 }
866 result = TclProcCompileProc(interp, pmPtr->procPtr,
867 pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr);
868 if (result != TCL_OK) {
869 goto failureReturn;
870 }
871
872 /*
873 * Make the stack frame and fill it out with information about this call.
874 * This operation may fail.
875 */
876
877 (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
878 (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD);
879
880 fdPtr->framePtr->clientData = contextPtr;
881 fdPtr->framePtr->objc = objc;
882 fdPtr->framePtr->objv = objv;
883 fdPtr->framePtr->procPtr = pmPtr->procPtr;
884
885 /*
886 * Finish filling out the extra frame info so that [info frame] works.
887 */
888
889 fdPtr->efi.fields[0].name = "method";
890 fdPtr->efi.fields[0].proc = NULL;
891 fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
892 if (pmPtr->gfivProc != NULL) {
893 fdPtr->efi.fields[1].name = "";
894 fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
895 fdPtr->efi.fields[1].clientData = pmPtr;
896 } else {
897 Tcl_Method method =
898 Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
899
900 if (Tcl_MethodDeclarerObject(method) != NULL) {
901 fdPtr->efi.fields[1].name = "object";
902 } else {
903 fdPtr->efi.fields[1].name = "class";
904 }
905 fdPtr->efi.fields[1].proc = RenderDeclarerName;
906 fdPtr->efi.fields[1].clientData = &fdPtr->pni;
907 fdPtr->pni.interp = interp;
908 fdPtr->pni.method = method;
909 }
910
911 return TCL_OK;
912
913 /*
914 * Restore the old cmdPtr so that a subsequent use of [info frame] won't
915 * crash on us. [Bug 3001438]
916 */
917
918 failureReturn:
919 pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
920 return result;
921 }
922
923 /*
924 * ----------------------------------------------------------------------
925 *
926 * TclOOSetupVariableResolver, etc. --
927 *
928 * Variable resolution engine used to connect declared variables to local
929 * variables used in methods. The compiled variable resolver is more
930 * important, but both are needed as it is possible to have a variable
931 * that is only referred to in ways that aren't compilable and we can't
932 * force LVT presence. [TIP #320, #500]
933 *
934 * ----------------------------------------------------------------------
935 */
936
937 void
TclOOSetupVariableResolver(Tcl_Namespace * nsPtr)938 TclOOSetupVariableResolver(
939 Tcl_Namespace *nsPtr)
940 {
941 Tcl_ResolverInfo info;
942
943 Tcl_GetNamespaceResolvers(nsPtr, &info);
944 if (info.compiledVarResProc == NULL) {
945 Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
946 ProcedureMethodCompiledVarResolver);
947 }
948 }
949
950 static int
ProcedureMethodVarResolver(Tcl_Interp * interp,const char * varName,Tcl_Namespace * contextNs,TCL_UNUSED (int),Tcl_Var * varPtr)951 ProcedureMethodVarResolver(
952 Tcl_Interp *interp,
953 const char *varName,
954 Tcl_Namespace *contextNs,
955 TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
956 Tcl_Var *varPtr)
957 {
958 int result;
959 Tcl_ResolvedVarInfo *rPtr = NULL;
960
961 result = ProcedureMethodCompiledVarResolver(interp, varName,
962 strlen(varName), contextNs, &rPtr);
963
964 if (result != TCL_OK) {
965 return result;
966 }
967
968 *varPtr = rPtr->fetchProc(interp, rPtr);
969
970 /*
971 * Must not retain reference to resolved information. [Bug 3105999]
972 */
973
974 rPtr->deleteProc(rPtr);
975 return (*varPtr ? TCL_OK : TCL_CONTINUE);
976 }
977
978 static Tcl_Var
ProcedureMethodCompiledVarConnect(Tcl_Interp * interp,Tcl_ResolvedVarInfo * rPtr)979 ProcedureMethodCompiledVarConnect(
980 Tcl_Interp *interp,
981 Tcl_ResolvedVarInfo *rPtr)
982 {
983 OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
984 Interp *iPtr = (Interp *) interp;
985 CallFrame *framePtr = iPtr->varFramePtr;
986 CallContext *contextPtr;
987 Tcl_Obj *variableObj;
988 PrivateVariableMapping *privateVar;
989 Tcl_HashEntry *hPtr;
990 int i, isNew, cacheIt, varLen, len;
991 const char *match, *varName;
992
993 /*
994 * Check that the variable is being requested in a context that is also a
995 * method call; if not (i.e. we're evaluating in the object's namespace or
996 * in a procedure of that namespace) then we do nothing.
997 */
998
999 if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
1000 return NULL;
1001 }
1002 contextPtr = (CallContext *)framePtr->clientData;
1003
1004 /*
1005 * If we've done the work before (in a comparable context) then reuse that
1006 * rather than performing resolution ourselves.
1007 */
1008
1009 if (infoPtr->cachedObjectVar) {
1010 return infoPtr->cachedObjectVar;
1011 }
1012
1013 /*
1014 * Check if the variable is one we want to resolve at all (i.e. whether it
1015 * is in the list provided by the user). If not, we mustn't do anything
1016 * either.
1017 */
1018
1019 varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
1020 if (contextPtr->callPtr->chain[contextPtr->index]
1021 .mPtr->declaringClassPtr != NULL) {
1022 FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
1023 .mPtr->declaringClassPtr->privateVariables) {
1024 match = TclGetStringFromObj(privateVar->variableObj, &len);
1025 if ((len == varLen) && !memcmp(match, varName, len)) {
1026 variableObj = privateVar->fullNameObj;
1027 cacheIt = 0;
1028 goto gotMatch;
1029 }
1030 }
1031 FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
1032 .mPtr->declaringClassPtr->variables) {
1033 match = TclGetStringFromObj(variableObj, &len);
1034 if ((len == varLen) && !memcmp(match, varName, len)) {
1035 cacheIt = 0;
1036 goto gotMatch;
1037 }
1038 }
1039 } else {
1040 FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
1041 match = TclGetStringFromObj(privateVar->variableObj, &len);
1042 if ((len == varLen) && !memcmp(match, varName, len)) {
1043 variableObj = privateVar->fullNameObj;
1044 cacheIt = 1;
1045 goto gotMatch;
1046 }
1047 }
1048 FOREACH(variableObj, contextPtr->oPtr->variables) {
1049 match = TclGetStringFromObj(variableObj, &len);
1050 if ((len == varLen) && !memcmp(match, varName, len)) {
1051 cacheIt = 1;
1052 goto gotMatch;
1053 }
1054 }
1055 }
1056 return NULL;
1057
1058 /*
1059 * It is a variable we want to resolve, so resolve it.
1060 */
1061
1062 gotMatch:
1063 hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
1064 (char *) variableObj, &isNew);
1065 if (isNew) {
1066 TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
1067 }
1068 if (cacheIt) {
1069 infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
1070
1071 /*
1072 * We must keep a reference to the variable so everything will
1073 * continue to work correctly even if it is unset; being unset does
1074 * not end the life of the variable at this level. [Bug 3185009]
1075 */
1076
1077 VarHashRefCount(infoPtr->cachedObjectVar)++;
1078 }
1079 return TclVarHashGetValue(hPtr);
1080 }
1081
1082 static void
ProcedureMethodCompiledVarDelete(Tcl_ResolvedVarInfo * rPtr)1083 ProcedureMethodCompiledVarDelete(
1084 Tcl_ResolvedVarInfo *rPtr)
1085 {
1086 OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
1087
1088 /*
1089 * Release the reference to the variable if we were holding it.
1090 */
1091
1092 if (infoPtr->cachedObjectVar) {
1093 VarHashRefCount(infoPtr->cachedObjectVar)--;
1094 TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
1095 }
1096 Tcl_DecrRefCount(infoPtr->variableObj);
1097 ckfree(infoPtr);
1098 }
1099
1100 static int
ProcedureMethodCompiledVarResolver(TCL_UNUSED (Tcl_Interp *),const char * varName,int length,TCL_UNUSED (Tcl_Namespace *),Tcl_ResolvedVarInfo ** rPtrPtr)1101 ProcedureMethodCompiledVarResolver(
1102 TCL_UNUSED(Tcl_Interp *),
1103 const char *varName,
1104 int length,
1105 TCL_UNUSED(Tcl_Namespace *),
1106 Tcl_ResolvedVarInfo **rPtrPtr)
1107 {
1108 OOResVarInfo *infoPtr;
1109 Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
1110
1111 /*
1112 * Do not create resolvers for cases that contain namespace separators or
1113 * which look like array accesses. Both will lead us astray.
1114 */
1115
1116 if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
1117 Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
1118 Tcl_DecrRefCount(variableObj);
1119 return TCL_CONTINUE;
1120 }
1121
1122 infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo));
1123 infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
1124 infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
1125 infoPtr->cachedObjectVar = NULL;
1126 infoPtr->variableObj = variableObj;
1127 Tcl_IncrRefCount(variableObj);
1128 *rPtrPtr = &infoPtr->info;
1129 return TCL_OK;
1130 }
1131
1132 /*
1133 * ----------------------------------------------------------------------
1134 *
1135 * RenderDeclarerName --
1136 *
1137 * Returns the name of the entity (object or class) which declared a
1138 * method. Used for producing information for [info frame] in such a way
1139 * that the expensive part of this (generating the object or class name
1140 * itself) isn't done until it is needed.
1141 *
1142 * ----------------------------------------------------------------------
1143 */
1144
1145 static Tcl_Obj *
RenderDeclarerName(void * clientData)1146 RenderDeclarerName(
1147 void *clientData)
1148 {
1149 struct PNI *pni = (struct PNI *)clientData;
1150 Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
1151
1152 if (object == NULL) {
1153 object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
1154 }
1155 return TclOOObjectName(pni->interp, (Object *) object);
1156 }
1157
1158 /*
1159 * ----------------------------------------------------------------------
1160 *
1161 * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler --
1162 *
1163 * How to fill in the stack trace correctly upon error in various forms
1164 * of procedure-like methods. LIMIT is how long the inserted strings in
1165 * the error traces should get before being converted to have ellipses,
1166 * and ELLIPSIFY is a macro to do the conversion (with the help of a
1167 * %.*s%s format field). Note that ELLIPSIFY is only safe for use in
1168 * suitable formatting contexts.
1169 *
1170 * ----------------------------------------------------------------------
1171 */
1172
1173 /* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
1174
1175 #define LIMIT 60
1176 #define ELLIPSIFY(str,len) \
1177 ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
1178
1179 static void
MethodErrorHandler(Tcl_Interp * interp,TCL_UNUSED (Tcl_Obj *))1180 MethodErrorHandler(
1181 Tcl_Interp *interp,
1182 TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
1183 /* We pull the method name out of context instead of from argument */
1184 {
1185 int nameLen, objectNameLen;
1186 CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
1187 Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
1188 const char *objectName, *kindName, *methodName =
1189 TclGetStringFromObj(mPtr->namePtr, &nameLen);
1190 Object *declarerPtr;
1191
1192 if (mPtr->declaringObjectPtr != NULL) {
1193 declarerPtr = mPtr->declaringObjectPtr;
1194 kindName = "object";
1195 } else {
1196 if (mPtr->declaringClassPtr == NULL) {
1197 Tcl_Panic("method not declared in class or object");
1198 }
1199 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1200 kindName = "class";
1201 }
1202
1203 objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
1204 &objectNameLen);
1205 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1206 "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
1207 kindName, ELLIPSIFY(objectName, objectNameLen),
1208 ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
1209 }
1210
1211 static void
ConstructorErrorHandler(Tcl_Interp * interp,TCL_UNUSED (Tcl_Obj *))1212 ConstructorErrorHandler(
1213 Tcl_Interp *interp,
1214 TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
1215 /* Ignore. We know it is the constructor. */
1216 {
1217 CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
1218 Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
1219 Object *declarerPtr;
1220 const char *objectName, *kindName;
1221 int objectNameLen;
1222
1223 if (mPtr->declaringObjectPtr != NULL) {
1224 declarerPtr = mPtr->declaringObjectPtr;
1225 kindName = "object";
1226 } else {
1227 if (mPtr->declaringClassPtr == NULL) {
1228 Tcl_Panic("method not declared in class or object");
1229 }
1230 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1231 kindName = "class";
1232 }
1233
1234 objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
1235 &objectNameLen);
1236 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1237 "\n (%s \"%.*s%s\" constructor line %d)", kindName,
1238 ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
1239 }
1240
1241 static void
DestructorErrorHandler(Tcl_Interp * interp,TCL_UNUSED (Tcl_Obj *))1242 DestructorErrorHandler(
1243 Tcl_Interp *interp,
1244 TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
1245 /* Ignore. We know it is the destructor. */
1246 {
1247 CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
1248 Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
1249 Object *declarerPtr;
1250 const char *objectName, *kindName;
1251 int objectNameLen;
1252
1253 if (mPtr->declaringObjectPtr != NULL) {
1254 declarerPtr = mPtr->declaringObjectPtr;
1255 kindName = "object";
1256 } else {
1257 if (mPtr->declaringClassPtr == NULL) {
1258 Tcl_Panic("method not declared in class or object");
1259 }
1260 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1261 kindName = "class";
1262 }
1263
1264 objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
1265 &objectNameLen);
1266 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1267 "\n (%s \"%.*s%s\" destructor line %d)", kindName,
1268 ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
1269 }
1270
1271 /*
1272 * ----------------------------------------------------------------------
1273 *
1274 * DeleteProcedureMethod, CloneProcedureMethod --
1275 *
1276 * How to delete and clone procedure-like methods.
1277 *
1278 * ----------------------------------------------------------------------
1279 */
1280
1281 static void
DeleteProcedureMethodRecord(ProcedureMethod * pmPtr)1282 DeleteProcedureMethodRecord(
1283 ProcedureMethod *pmPtr)
1284 {
1285 TclProcDeleteProc(pmPtr->procPtr);
1286 if (pmPtr->deleteClientdataProc) {
1287 pmPtr->deleteClientdataProc(pmPtr->clientData);
1288 }
1289 ckfree(pmPtr);
1290 }
1291
1292 static void
DeleteProcedureMethod(void * clientData)1293 DeleteProcedureMethod(
1294 void *clientData)
1295 {
1296 ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
1297
1298 if (pmPtr->refCount-- <= 1) {
1299 DeleteProcedureMethodRecord(pmPtr);
1300 }
1301 }
1302
1303 static int
CloneProcedureMethod(Tcl_Interp * interp,void * clientData,void ** newClientData)1304 CloneProcedureMethod(
1305 Tcl_Interp *interp,
1306 void *clientData,
1307 void **newClientData)
1308 {
1309 ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
1310 ProcedureMethod *pm2Ptr;
1311 Tcl_Obj *bodyObj, *argsObj;
1312 CompiledLocal *localPtr;
1313
1314 /*
1315 * Copy the argument list.
1316 */
1317
1318 TclNewObj(argsObj);
1319 for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
1320 localPtr=localPtr->nextPtr) {
1321 if (TclIsVarArgument(localPtr)) {
1322 Tcl_Obj *argObj;
1323
1324 TclNewObj(argObj);
1325 Tcl_ListObjAppendElement(NULL, argObj,
1326 Tcl_NewStringObj(localPtr->name, -1));
1327 if (localPtr->defValuePtr != NULL) {
1328 Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
1329 }
1330 Tcl_ListObjAppendElement(NULL, argsObj, argObj);
1331 }
1332 }
1333
1334 /*
1335 * Must strip the internal representation in order to ensure that any
1336 * bound references to instance variables are removed. [Bug 3609693]
1337 */
1338
1339 bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
1340 Tcl_GetString(bodyObj);
1341 Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
1342
1343 /*
1344 * Create the actual copy of the method record, manufacturing a new proc
1345 * record.
1346 */
1347
1348 pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
1349 memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
1350 pm2Ptr->refCount = 1;
1351 Tcl_IncrRefCount(argsObj);
1352 Tcl_IncrRefCount(bodyObj);
1353 if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
1354 &pm2Ptr->procPtr) != TCL_OK) {
1355 Tcl_DecrRefCount(argsObj);
1356 Tcl_DecrRefCount(bodyObj);
1357 ckfree(pm2Ptr);
1358 return TCL_ERROR;
1359 }
1360 Tcl_DecrRefCount(argsObj);
1361 Tcl_DecrRefCount(bodyObj);
1362
1363 if (pmPtr->cloneClientdataProc) {
1364 pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
1365 }
1366 *newClientData = pm2Ptr;
1367 return TCL_OK;
1368 }
1369
1370 /*
1371 * ----------------------------------------------------------------------
1372 *
1373 * TclOONewForwardInstanceMethod --
1374 *
1375 * Create a forwarded method for an object.
1376 *
1377 * ----------------------------------------------------------------------
1378 */
1379
1380 Method *
TclOONewForwardInstanceMethod(Tcl_Interp * interp,Object * oPtr,int flags,Tcl_Obj * nameObj,Tcl_Obj * prefixObj)1381 TclOONewForwardInstanceMethod(
1382 Tcl_Interp *interp, /* Interpreter for error reporting. */
1383 Object *oPtr, /* The object to attach the method to. */
1384 int flags, /* Whether the method is public or not. */
1385 Tcl_Obj *nameObj, /* The name of the method. */
1386 Tcl_Obj *prefixObj) /* List of arguments that form the command
1387 * prefix to forward to. */
1388 {
1389 int prefixLen;
1390 ForwardMethod *fmPtr;
1391
1392 if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
1393 return NULL;
1394 }
1395 if (prefixLen < 1) {
1396 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1397 "method forward prefix must be non-empty", -1));
1398 Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
1399 return NULL;
1400 }
1401
1402 fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
1403 fmPtr->prefixObj = prefixObj;
1404 Tcl_IncrRefCount(prefixObj);
1405 return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
1406 nameObj, flags, &fwdMethodType, fmPtr);
1407 }
1408
1409 /*
1410 * ----------------------------------------------------------------------
1411 *
1412 * TclOONewForwardMethod --
1413 *
1414 * Create a new forwarded method for a class.
1415 *
1416 * ----------------------------------------------------------------------
1417 */
1418
1419 Method *
TclOONewForwardMethod(Tcl_Interp * interp,Class * clsPtr,int flags,Tcl_Obj * nameObj,Tcl_Obj * prefixObj)1420 TclOONewForwardMethod(
1421 Tcl_Interp *interp, /* Interpreter for error reporting. */
1422 Class *clsPtr, /* The class to attach the method to. */
1423 int flags, /* Whether the method is public or not. */
1424 Tcl_Obj *nameObj, /* The name of the method. */
1425 Tcl_Obj *prefixObj) /* List of arguments that form the command
1426 * prefix to forward to. */
1427 {
1428 int prefixLen;
1429 ForwardMethod *fmPtr;
1430
1431 if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
1432 return NULL;
1433 }
1434 if (prefixLen < 1) {
1435 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1436 "method forward prefix must be non-empty", -1));
1437 Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
1438 return NULL;
1439 }
1440
1441 fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
1442 fmPtr->prefixObj = prefixObj;
1443 Tcl_IncrRefCount(prefixObj);
1444 return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
1445 flags, &fwdMethodType, fmPtr);
1446 }
1447
1448 /*
1449 * ----------------------------------------------------------------------
1450 *
1451 * InvokeForwardMethod --
1452 *
1453 * How to invoke a forwarded method. Works by doing some ensemble-like
1454 * command rearranging and then invokes some other Tcl command.
1455 *
1456 * ----------------------------------------------------------------------
1457 */
1458
1459 static int
InvokeForwardMethod(void * clientData,Tcl_Interp * interp,Tcl_ObjectContext context,int objc,Tcl_Obj * const * objv)1460 InvokeForwardMethod(
1461 void *clientData, /* Pointer to some per-method context. */
1462 Tcl_Interp *interp,
1463 Tcl_ObjectContext context, /* The method calling context. */
1464 int objc, /* Number of arguments. */
1465 Tcl_Obj *const *objv) /* Arguments as actually seen. */
1466 {
1467 CallContext *contextPtr = (CallContext *) context;
1468 ForwardMethod *fmPtr = (ForwardMethod *)clientData;
1469 Tcl_Obj **argObjs, **prefixObjs;
1470 int numPrefixes, len, skip = contextPtr->skip;
1471
1472 /*
1473 * Build the real list of arguments to use. Note that we know that the
1474 * prefixObj field of the ForwardMethod structure holds a reference to a
1475 * non-empty list, so there's a whole class of failures ("not a list") we
1476 * can ignore here.
1477 */
1478
1479 Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
1480 argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
1481 numPrefixes, prefixObjs, &len);
1482 Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
1483 /*
1484 * NOTE: The combination of direct set of iPtr->lookupNsPtr and the use
1485 * of the TCL_EVAL_NOERR flag results in an evaluation configuration
1486 * very much like TCL_EVAL_INVOKE.
1487 */
1488 ((Interp *)interp)->lookupNsPtr
1489 = (Namespace *) contextPtr->oPtr->namespacePtr;
1490 return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
1491 }
1492
1493 static int
FinalizeForwardCall(void * data[],Tcl_Interp * interp,int result)1494 FinalizeForwardCall(
1495 void *data[],
1496 Tcl_Interp *interp,
1497 int result)
1498 {
1499 Tcl_Obj **argObjs = (Tcl_Obj **)data[0];
1500
1501 TclStackFree(interp, argObjs);
1502 return result;
1503 }
1504
1505 /*
1506 * ----------------------------------------------------------------------
1507 *
1508 * DeleteForwardMethod, CloneForwardMethod --
1509 *
1510 * How to delete and clone forwarded methods.
1511 *
1512 * ----------------------------------------------------------------------
1513 */
1514
1515 static void
DeleteForwardMethod(void * clientData)1516 DeleteForwardMethod(
1517 void *clientData)
1518 {
1519 ForwardMethod *fmPtr = (ForwardMethod *)clientData;
1520
1521 Tcl_DecrRefCount(fmPtr->prefixObj);
1522 ckfree(fmPtr);
1523 }
1524
1525 static int
CloneForwardMethod(TCL_UNUSED (Tcl_Interp *),void * clientData,void ** newClientData)1526 CloneForwardMethod(
1527 TCL_UNUSED(Tcl_Interp *),
1528 void *clientData,
1529 void **newClientData)
1530 {
1531 ForwardMethod *fmPtr = (ForwardMethod *)clientData;
1532 ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
1533
1534 fm2Ptr->prefixObj = fmPtr->prefixObj;
1535 Tcl_IncrRefCount(fm2Ptr->prefixObj);
1536 *newClientData = fm2Ptr;
1537 return TCL_OK;
1538 }
1539
1540 /*
1541 * ----------------------------------------------------------------------
1542 *
1543 * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
1544 *
1545 * Utility functions used for procedure-like and forwarding method
1546 * introspection.
1547 *
1548 * ----------------------------------------------------------------------
1549 */
1550
1551 Proc *
TclOOGetProcFromMethod(Method * mPtr)1552 TclOOGetProcFromMethod(
1553 Method *mPtr)
1554 {
1555 if (mPtr->typePtr == &procMethodType) {
1556 ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
1557
1558 return pmPtr->procPtr;
1559 }
1560 return NULL;
1561 }
1562
1563 Tcl_Obj *
TclOOGetMethodBody(Method * mPtr)1564 TclOOGetMethodBody(
1565 Method *mPtr)
1566 {
1567 if (mPtr->typePtr == &procMethodType) {
1568 ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
1569
1570 (void) TclGetString(pmPtr->procPtr->bodyPtr);
1571 return pmPtr->procPtr->bodyPtr;
1572 }
1573 return NULL;
1574 }
1575
1576 Tcl_Obj *
TclOOGetFwdFromMethod(Method * mPtr)1577 TclOOGetFwdFromMethod(
1578 Method *mPtr)
1579 {
1580 if (mPtr->typePtr == &fwdMethodType) {
1581 ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData;
1582
1583 return fwPtr->prefixObj;
1584 }
1585 return NULL;
1586 }
1587
1588 /*
1589 * ----------------------------------------------------------------------
1590 *
1591 * InitEnsembleRewrite --
1592 *
1593 * Utility function that wraps up a lot of the complexity involved in
1594 * doing ensemble-like command forwarding. Here is a picture of memory
1595 * management plan:
1596 *
1597 * <-----------------objc---------------------->
1598 * objv: |=============|===============================|
1599 * <-toRewrite-> |
1600 * \
1601 * <-rewriteLength-> \
1602 * rewriteObjs: |=================| \
1603 * | |
1604 * V V
1605 * argObjs: |=================|===============================|
1606 * <------------------*lengthPtr------------------->
1607 *
1608 * ----------------------------------------------------------------------
1609 */
1610
1611 static Tcl_Obj **
InitEnsembleRewrite(Tcl_Interp * interp,int objc,Tcl_Obj * const * objv,int toRewrite,int rewriteLength,Tcl_Obj * const * rewriteObjs,int * lengthPtr)1612 InitEnsembleRewrite(
1613 Tcl_Interp *interp, /* Place to log the rewrite info. */
1614 int objc, /* Number of real arguments. */
1615 Tcl_Obj *const *objv, /* The real arguments. */
1616 int toRewrite, /* Number of real arguments to replace. */
1617 int rewriteLength, /* Number of arguments to insert instead. */
1618 Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
1619 int *lengthPtr) /* Where to write the resulting length of the
1620 * array of rewritten arguments. */
1621 {
1622 unsigned len = rewriteLength + objc - toRewrite;
1623 Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
1624
1625 memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
1626 memcpy(argObjs + rewriteLength, objv + toRewrite,
1627 sizeof(Tcl_Obj *) * (objc - toRewrite));
1628
1629 /*
1630 * Now plumb this into the core ensemble rewrite logging system so that
1631 * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
1632 * how to store the rewrite rules get complex solely because of the case
1633 * where an ensemble rewrites itself out of the picture; when that
1634 * happens, the quality of the error message rewrite falls drastically
1635 * (and unavoidably).
1636 */
1637
1638 if (TclInitRewriteEnsemble(interp, toRewrite, rewriteLength, objv)) {
1639 TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
1640 }
1641 *lengthPtr = len;
1642 return argObjs;
1643 }
1644
1645 /*
1646 * ----------------------------------------------------------------------
1647 *
1648 * assorted trivial 'getter' functions
1649 *
1650 * ----------------------------------------------------------------------
1651 */
1652
1653 Tcl_Object
Tcl_MethodDeclarerObject(Tcl_Method method)1654 Tcl_MethodDeclarerObject(
1655 Tcl_Method method)
1656 {
1657 return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
1658 }
1659
1660 Tcl_Class
Tcl_MethodDeclarerClass(Tcl_Method method)1661 Tcl_MethodDeclarerClass(
1662 Tcl_Method method)
1663 {
1664 return (Tcl_Class) ((Method *) method)->declaringClassPtr;
1665 }
1666
1667 Tcl_Obj *
Tcl_MethodName(Tcl_Method method)1668 Tcl_MethodName(
1669 Tcl_Method method)
1670 {
1671 return ((Method *) method)->namePtr;
1672 }
1673
1674 int
Tcl_MethodIsType(Tcl_Method method,const Tcl_MethodType * typePtr,void ** clientDataPtr)1675 Tcl_MethodIsType(
1676 Tcl_Method method,
1677 const Tcl_MethodType *typePtr,
1678 void **clientDataPtr)
1679 {
1680 Method *mPtr = (Method *) method;
1681
1682 if (mPtr->typePtr == typePtr) {
1683 if (clientDataPtr != NULL) {
1684 *clientDataPtr = mPtr->clientData;
1685 }
1686 return 1;
1687 }
1688 return 0;
1689 }
1690
1691 int
Tcl_MethodIsPublic(Tcl_Method method)1692 Tcl_MethodIsPublic(
1693 Tcl_Method method)
1694 {
1695 return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
1696 }
1697
1698 int
Tcl_MethodIsPrivate(Tcl_Method method)1699 Tcl_MethodIsPrivate(
1700 Tcl_Method method)
1701 {
1702 return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
1703 }
1704
1705 /*
1706 * Extended method construction for itcl-ng.
1707 */
1708
1709 Tcl_Method
TclOONewProcInstanceMethodEx(Tcl_Interp * interp,Tcl_Object oPtr,TclOO_PreCallProc * preCallPtr,TclOO_PostCallProc * postCallPtr,ProcErrorProc * errProc,void * clientData,Tcl_Obj * nameObj,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,int flags,void ** internalTokenPtr)1710 TclOONewProcInstanceMethodEx(
1711 Tcl_Interp *interp, /* The interpreter containing the object. */
1712 Tcl_Object oPtr, /* The object to modify. */
1713 TclOO_PreCallProc *preCallPtr,
1714 TclOO_PostCallProc *postCallPtr,
1715 ProcErrorProc *errProc,
1716 void *clientData,
1717 Tcl_Obj *nameObj, /* The name of the method, which must not be
1718 * NULL. */
1719 Tcl_Obj *argsObj, /* The formal argument list for the method,
1720 * which must not be NULL. */
1721 Tcl_Obj *bodyObj, /* The body of the method, which must not be
1722 * NULL. */
1723 int flags, /* Whether this is a public method. */
1724 void **internalTokenPtr) /* If non-NULL, points to a variable that gets
1725 * the reference to the ProcedureMethod
1726 * structure. */
1727 {
1728 ProcedureMethod *pmPtr;
1729 Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp,
1730 (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
1731
1732 if (method == NULL) {
1733 return NULL;
1734 }
1735 pmPtr->flags = flags & USE_DECLARER_NS;
1736 pmPtr->preCallProc = preCallPtr;
1737 pmPtr->postCallProc = postCallPtr;
1738 pmPtr->errProc = errProc;
1739 pmPtr->clientData = clientData;
1740 if (internalTokenPtr != NULL) {
1741 *internalTokenPtr = pmPtr;
1742 }
1743 return method;
1744 }
1745
1746 Tcl_Method
TclOONewProcMethodEx(Tcl_Interp * interp,Tcl_Class clsPtr,TclOO_PreCallProc * preCallPtr,TclOO_PostCallProc * postCallPtr,ProcErrorProc * errProc,void * clientData,Tcl_Obj * nameObj,Tcl_Obj * argsObj,Tcl_Obj * bodyObj,int flags,void ** internalTokenPtr)1747 TclOONewProcMethodEx(
1748 Tcl_Interp *interp, /* The interpreter containing the class. */
1749 Tcl_Class clsPtr, /* The class to modify. */
1750 TclOO_PreCallProc *preCallPtr,
1751 TclOO_PostCallProc *postCallPtr,
1752 ProcErrorProc *errProc,
1753 void *clientData,
1754 Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
1755 * if so, up to caller to manage storage
1756 * (e.g., because it is a constructor or
1757 * destructor). */
1758 Tcl_Obj *argsObj, /* The formal argument list for the method,
1759 * which may be NULL; if so, it is equivalent
1760 * to an empty list. */
1761 Tcl_Obj *bodyObj, /* The body of the method, which must not be
1762 * NULL. */
1763 int flags, /* Whether this is a public method. */
1764 void **internalTokenPtr) /* If non-NULL, points to a variable that gets
1765 * the reference to the ProcedureMethod
1766 * structure. */
1767 {
1768 ProcedureMethod *pmPtr;
1769 Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp,
1770 (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);
1771
1772 if (method == NULL) {
1773 return NULL;
1774 }
1775 pmPtr->flags = flags & USE_DECLARER_NS;
1776 pmPtr->preCallProc = preCallPtr;
1777 pmPtr->postCallProc = postCallPtr;
1778 pmPtr->errProc = errProc;
1779 pmPtr->clientData = clientData;
1780 if (internalTokenPtr != NULL) {
1781 *internalTokenPtr = pmPtr;
1782 }
1783 return method;
1784 }
1785
1786 /*
1787 * Local Variables:
1788 * mode: c
1789 * c-basic-offset: 4
1790 * fill-column: 78
1791 * End:
1792 */
1793