1 /*
2 * ------------------------------------------------------------------------
3 * PACKAGE: [incr Tcl]
4 * DESCRIPTION: Object-Oriented Extensions to Tcl
5 *
6 * [incr Tcl] provides object-oriented extensions to Tcl, much as
7 * C++ provides object-oriented extensions to C. It provides a means
8 * of encapsulating related procedures together with their shared data
9 * in a local namespace that is hidden from the outside world. It
10 * promotes code re-use through inheritance. More than anything else,
11 * it encourages better organization of Tcl applications through the
12 * object-oriented paradigm, leading to code that is easier to
13 * understand and maintain.
14 *
15 * These procedures handle commands available within a class scope.
16 * In [incr Tcl], the term "method" is used for a procedure that has
17 * access to object-specific data, while the term "proc" is used for
18 * a procedure that has access only to common class data.
19 *
20 * ========================================================================
21 * AUTHOR: Michael J. McLennan
22 * Bell Labs Innovations for Lucent Technologies
23 * mmclennan@lucent.com
24 * http://www.tcltk.com/itcl
25 *
26 * overhauled version author: Arnulf Wiedemann
27 * ========================================================================
28 * Copyright (c) 1993-1998 Lucent Technologies, Inc.
29 * ------------------------------------------------------------------------
30 * See the file "license.terms" for information on usage and redistribution
31 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
32 */
33 #include "itclInt.h"
34
35 static int EquivArgLists(Tcl_Interp *interp, ItclArgList *origArgs,
36 ItclArgList *realArgs);
37 static int ItclCreateMemberCode(Tcl_Interp* interp, ItclClass *iclsPtr,
38 const char* arglist, const char* body, ItclMemberCode** mcodePtr,
39 Tcl_Obj *namePtr, int flags);
40 static int ItclCreateMemberFunc(Tcl_Interp* interp, ItclClass *iclsPtr,
41 Tcl_Obj *namePtr, const char* arglist, const char* body,
42 ItclMemberFunc** imPtrPtr, int flags);
43 static void FreeMemberCode(ItclMemberCode *mcodePtr);
44
45 /*
46 * ------------------------------------------------------------------------
47 * Itcl_BodyCmd()
48 *
49 * Invoked by Tcl whenever the user issues an "itcl::body" command to
50 * define or redefine the implementation for a class method/proc.
51 * Handles the following syntax:
52 *
53 * itcl::body <class>::<func> <arglist> <body>
54 *
55 * Looks for an existing class member function with the name <func>,
56 * and if found, tries to assign the implementation. If an argument
57 * list was specified in the original declaration, it must match
58 * <arglist> or an error is flagged. If <body> has the form "@name"
59 * then it is treated as a reference to a C handling procedure;
60 * otherwise, it is taken as a body of Tcl statements.
61 *
62 * Returns TCL_OK/TCL_ERROR to indicate success/failure.
63 * ------------------------------------------------------------------------
64 */
65 static int
NRBodyCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)66 NRBodyCmd(
67 TCL_UNUSED(ClientData), /* */
68 Tcl_Interp *interp, /* current interpreter */
69 int objc, /* number of arguments */
70 Tcl_Obj *const *objv) /* argument objects */
71 {
72 Tcl_HashEntry *entry;
73 Tcl_DString buffer;
74 Tcl_Obj *objPtr;
75 ItclClass *iclsPtr;
76 ItclMemberFunc *imPtr;
77 const char *head;
78 const char *tail;
79 const char *token;
80 char *arglist;
81 char *body;
82 int status = TCL_OK;
83
84 ItclShowArgs(2, "Itcl_BodyCmd", objc, objv);
85 if (objc != 4) {
86 token = Tcl_GetString(objv[0]);
87 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
88 "wrong # args: should be \"",
89 token, " class::func arglist body\"",
90 NULL);
91 return TCL_ERROR;
92 }
93
94 /*
95 * Parse the member name "namesp::namesp::class::func".
96 * Make sure that a class name was specified, and that the
97 * class exists.
98 */
99 token = Tcl_GetString(objv[1]);
100 Itcl_ParseNamespPath(token, &buffer, &head, &tail);
101
102 if (!head || *head == '\0') {
103 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
104 "missing class specifier for body declaration \"", token, "\"",
105 NULL);
106 status = TCL_ERROR;
107 goto bodyCmdDone;
108 }
109
110 iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1);
111 if (iclsPtr == NULL) {
112 status = TCL_ERROR;
113 goto bodyCmdDone;
114 }
115
116 /*
117 * Find the function and try to change its implementation.
118 * Note that command resolution table contains *all* functions,
119 * even those in a base class. Make sure that the class
120 * containing the method definition is the requested class.
121 */
122
123 imPtr = NULL;
124 objPtr = Tcl_NewStringObj(tail, -1);
125 entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
126 Tcl_DecrRefCount(objPtr);
127 if (entry) {
128 ItclCmdLookup *clookup;
129 clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
130 imPtr = clookup->imPtr;
131 if (imPtr->iclsPtr != iclsPtr) {
132 imPtr = NULL;
133 }
134 }
135
136 if (imPtr == NULL) {
137 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
138 "function \"", tail, "\" is not defined in class \"",
139 Tcl_GetString(iclsPtr->fullNamePtr), "\"",
140 NULL);
141 status = TCL_ERROR;
142 goto bodyCmdDone;
143 }
144
145 arglist = Tcl_GetString(objv[2]);
146 body = Tcl_GetString(objv[3]);
147
148 if (Itcl_ChangeMemberFunc(interp, imPtr, arglist, body) != TCL_OK) {
149 status = TCL_ERROR;
150 goto bodyCmdDone;
151 }
152
153 bodyCmdDone:
154 Tcl_DStringFree(&buffer);
155 return status;
156 }
157
158 /* ARGSUSED */
159 int
Itcl_BodyCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)160 Itcl_BodyCmd(
161 ClientData clientData,
162 Tcl_Interp *interp,
163 int objc,
164 Tcl_Obj *const *objv)
165 {
166 return Tcl_NRCallObjProc(interp, NRBodyCmd, clientData, objc, objv);
167 }
168
169
170
171 /*
172 * ------------------------------------------------------------------------
173 * Itcl_ConfigBodyCmd()
174 *
175 * Invoked by Tcl whenever the user issues an "itcl::configbody" command
176 * to define or redefine the configuration code associated with a
177 * public variable. Handles the following syntax:
178 *
179 * itcl::configbody <class>::<publicVar> <body>
180 *
181 * Looks for an existing public variable with the name <publicVar>,
182 * and if found, tries to assign the implementation. If <body> has
183 * the form "@name" then it is treated as a reference to a C handling
184 * procedure; otherwise, it is taken as a body of Tcl statements.
185 *
186 * Returns TCL_OK/TCL_ERROR to indicate success/failure.
187 * ------------------------------------------------------------------------
188 */
189 /* ARGSUSED */
190 static int
NRConfigBodyCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])191 NRConfigBodyCmd(
192 TCL_UNUSED(ClientData), /* unused */
193 Tcl_Interp *interp, /* current interpreter */
194 int objc, /* number of arguments */
195 Tcl_Obj *const objv[]) /* argument objects */
196 {
197 int status = TCL_OK;
198
199 const char *head;
200 const char *tail;
201 const char *token;
202 Tcl_DString buffer;
203 ItclClass *iclsPtr;
204 ItclVarLookup *vlookup;
205 ItclVariable *ivPtr;
206 ItclMemberCode *mcode;
207 Tcl_HashEntry *entry;
208
209 ItclShowArgs(2, "Itcl_ConfigBodyCmd", objc, objv);
210 if (objc != 3) {
211 Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
212 return TCL_ERROR;
213 }
214
215 /*
216 * Parse the member name "namesp::namesp::class::option".
217 * Make sure that a class name was specified, and that the
218 * class exists.
219 */
220 token = Tcl_GetString(objv[1]);
221 Itcl_ParseNamespPath(token, &buffer, &head, &tail);
222
223 if ((head == NULL) || (*head == '\0')) {
224 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
225 "missing class specifier for body declaration \"", token, "\"",
226 NULL);
227 status = TCL_ERROR;
228 goto configBodyCmdDone;
229 }
230
231 iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1);
232 if (iclsPtr == NULL) {
233 status = TCL_ERROR;
234 goto configBodyCmdDone;
235 }
236
237 /*
238 * Find the variable and change its implementation.
239 * Note that variable resolution table has *all* variables,
240 * even those in a base class. Make sure that the class
241 * containing the variable definition is the requested class.
242 */
243 vlookup = NULL;
244 entry = ItclResolveVarEntry(iclsPtr, tail);
245 if (entry) {
246 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
247 if (vlookup->ivPtr->iclsPtr != iclsPtr) {
248 vlookup = NULL;
249 }
250 }
251
252 if (vlookup == NULL) {
253 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
254 "option \"", tail, "\" is not defined in class \"",
255 Tcl_GetString(iclsPtr->fullNamePtr), "\"",
256 NULL);
257 status = TCL_ERROR;
258 goto configBodyCmdDone;
259 }
260 ivPtr = vlookup->ivPtr;
261
262 if (ivPtr->protection != ITCL_PUBLIC) {
263 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
264 "option \"", Tcl_GetString(ivPtr->fullNamePtr),
265 "\" is not a public configuration option",
266 NULL);
267 status = TCL_ERROR;
268 goto configBodyCmdDone;
269 }
270
271 token = Tcl_GetString(objv[2]);
272
273 if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, token,
274 &mcode) != TCL_OK) {
275 status = TCL_ERROR;
276 goto configBodyCmdDone;
277 }
278
279 Itcl_PreserveData(mcode);
280
281 if (ivPtr->codePtr) {
282 Itcl_ReleaseData(ivPtr->codePtr);
283 }
284 ivPtr->codePtr = mcode;
285
286 configBodyCmdDone:
287 Tcl_DStringFree(&buffer);
288 return status;
289 }
290
291 /* ARGSUSED */
292 int
Itcl_ConfigBodyCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)293 Itcl_ConfigBodyCmd(
294 ClientData clientData,
295 Tcl_Interp *interp,
296 int objc,
297 Tcl_Obj *const *objv)
298 {
299 return Tcl_NRCallObjProc(interp, NRConfigBodyCmd, clientData, objc, objv);
300 }
301
302
303
304 /*
305 * ------------------------------------------------------------------------
306 * Itcl_CreateMethod()
307 *
308 * Installs a method into the namespace associated with a class.
309 * If another command with the same name is already installed, then
310 * it is overwritten.
311 *
312 * Returns TCL_OK on success, or TCL_ERROR (along with an error message
313 * in the specified interp) if anything goes wrong.
314 * ------------------------------------------------------------------------
315 */
316 int
Itcl_CreateMethod(Tcl_Interp * interp,ItclClass * iclsPtr,Tcl_Obj * namePtr,const char * arglist,const char * body)317 Itcl_CreateMethod(
318 Tcl_Interp* interp, /* interpreter managing this action */
319 ItclClass *iclsPtr, /* class definition */
320 Tcl_Obj *namePtr, /* name of new method */
321 const char* arglist, /* space-separated list of arg names */
322 const char* body) /* body of commands for the method */
323 {
324 ItclMemberFunc *imPtr;
325
326 return ItclCreateMethod(interp, iclsPtr, namePtr, arglist, body, &imPtr);
327 }
328
329 /*
330 * ------------------------------------------------------------------------
331 * ItclCreateMethod()
332 *
333 * Installs a method into the namespace associated with a class.
334 * If another command with the same name is already installed, then
335 * it is overwritten.
336 *
337 * Returns TCL_OK on success, or TCL_ERROR (along with an error message
338 * in the specified interp) if anything goes wrong.
339 * ------------------------------------------------------------------------
340 */
341 int
ItclCreateMethod(Tcl_Interp * interp,ItclClass * iclsPtr,Tcl_Obj * namePtr,const char * arglist,const char * body,ItclMemberFunc ** imPtrPtr)342 ItclCreateMethod(
343 Tcl_Interp* interp, /* interpreter managing this action */
344 ItclClass *iclsPtr, /* class definition */
345 Tcl_Obj *namePtr, /* name of new method */
346 const char* arglist, /* space-separated list of arg names */
347 const char* body, /* body of commands for the method */
348 ItclMemberFunc **imPtrPtr)
349 {
350 ItclMemberFunc *imPtr;
351
352 /*
353 * Make sure that the method name does not contain anything
354 * goofy like a "::" scope qualifier.
355 */
356 if (strstr(Tcl_GetString(namePtr),"::")) {
357 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
358 "bad method name \"", Tcl_GetString(namePtr), "\"",
359 NULL);
360 Tcl_DecrRefCount(namePtr);
361 return TCL_ERROR;
362 }
363
364 /*
365 * Create the method definition.
366 */
367 if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, body,
368 &imPtr, 0) != TCL_OK) {
369 return TCL_ERROR;
370 }
371
372 imPtr->flags |= ITCL_METHOD;
373 if (imPtrPtr != NULL) {
374 *imPtrPtr = imPtr;
375 }
376 ItclAddClassFunctionDictInfo(interp, iclsPtr, imPtr);
377 return TCL_OK;
378 }
379
380 /*
381 * ------------------------------------------------------------------------
382 * Itcl_CreateProc()
383 *
384 * Installs a class proc into the namespace associated with a class.
385 * If another command with the same name is already installed, then
386 * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along
387 * with an error message in the specified interp) if anything goes
388 * wrong.
389 * ------------------------------------------------------------------------
390 */
391 int
Itcl_CreateProc(Tcl_Interp * interp,ItclClass * iclsPtr,Tcl_Obj * namePtr,const char * arglist,const char * body)392 Itcl_CreateProc(
393 Tcl_Interp* interp, /* interpreter managing this action */
394 ItclClass *iclsPtr, /* class definition */
395 Tcl_Obj* namePtr, /* name of new proc */
396 const char *arglist, /* space-separated list of arg names */
397 const char *body) /* body of commands for the proc */
398 {
399 ItclMemberFunc *imPtr;
400
401 /*
402 * Make sure that the proc name does not contain anything
403 * goofy like a "::" scope qualifier.
404 */
405 if (strstr(Tcl_GetString(namePtr),"::")) {
406 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
407 "bad proc name \"", Tcl_GetString(namePtr), "\"",
408 NULL);
409 return TCL_ERROR;
410 }
411
412 /*
413 * Create the proc definition.
414 */
415 if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist,
416 body, &imPtr, ITCL_COMMON) != TCL_OK) {
417 return TCL_ERROR;
418 }
419
420 /*
421 * Mark procs as "common". This distinguishes them from methods.
422 */
423 imPtr->flags |= ITCL_COMMON;
424 return TCL_OK;
425 }
426
427
428 /*
429 * ------------------------------------------------------------------------
430 * ItclCreateMemberFunc()
431 *
432 * Creates the data record representing a member function. This
433 * includes the argument list and the body of the function. If the
434 * body is of the form "@name", then it is treated as a label for
435 * a C procedure registered by Itcl_RegisterC().
436 *
437 * If any errors are encountered, this procedure returns TCL_ERROR
438 * along with an error message in the interpreter. Otherwise, it
439 * returns TCL_OK, and "imPtr" returns a pointer to the new
440 * member function.
441 * ------------------------------------------------------------------------
442 */
443 static int
ItclCreateMemberFunc(Tcl_Interp * interp,ItclClass * iclsPtr,Tcl_Obj * namePtr,const char * arglist,const char * body,ItclMemberFunc ** imPtrPtr,int flags)444 ItclCreateMemberFunc(
445 Tcl_Interp* interp, /* interpreter managing this action */
446 ItclClass *iclsPtr, /* class definition */
447 Tcl_Obj *namePtr, /* name of new member */
448 const char* arglist, /* space-separated list of arg names */
449 const char* body, /* body of commands for the method */
450 ItclMemberFunc** imPtrPtr, /* returns: pointer to new method defn */
451 int flags)
452 {
453 int newEntry;
454 char *name;
455 ItclMemberFunc *imPtr;
456 ItclMemberCode *mcode;
457 Tcl_HashEntry *hPtr;
458
459 /*
460 * Add the member function to the list of functions for
461 * the class. Make sure that a member function with the
462 * same name doesn't already exist.
463 */
464 hPtr = Tcl_CreateHashEntry(&iclsPtr->functions, (char *)namePtr, &newEntry);
465 if (!newEntry) {
466 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
467 "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
468 Tcl_GetString(iclsPtr->fullNamePtr), "\"",
469 NULL);
470 return TCL_ERROR;
471 }
472
473 /*
474 * Try to create the implementation for this command member.
475 */
476 if (ItclCreateMemberCode(interp, iclsPtr, arglist, body,
477 &mcode, namePtr, flags) != TCL_OK) {
478
479 Tcl_DeleteHashEntry(hPtr);
480 return TCL_ERROR;
481 }
482
483 /*
484 * Allocate a member function definition and return.
485 */
486 imPtr = (ItclMemberFunc*)Itcl_Alloc(sizeof(ItclMemberFunc));
487 Itcl_EventuallyFree(imPtr, (Tcl_FreeProc *)Itcl_DeleteMemberFunc);
488 imPtr->iclsPtr = iclsPtr;
489 imPtr->infoPtr = iclsPtr->infoPtr;
490 imPtr->protection = Itcl_Protection(interp, 0);
491 imPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(namePtr), -1);
492 Tcl_IncrRefCount(imPtr->namePtr);
493 imPtr->fullNamePtr = Tcl_NewStringObj(
494 Tcl_GetString(iclsPtr->fullNamePtr), -1);
495 Tcl_AppendToObj(imPtr->fullNamePtr, "::", 2);
496 Tcl_AppendToObj(imPtr->fullNamePtr, Tcl_GetString(namePtr), -1);
497 Tcl_IncrRefCount(imPtr->fullNamePtr);
498 if (arglist != NULL) {
499 imPtr->origArgsPtr = Tcl_NewStringObj(arglist, -1);
500 Tcl_IncrRefCount(imPtr->origArgsPtr);
501 }
502 imPtr->codePtr = mcode;
503 Itcl_PreserveData(mcode);
504
505 if (imPtr->protection == ITCL_DEFAULT_PROTECT) {
506 imPtr->protection = ITCL_PUBLIC;
507 }
508
509 imPtr->declaringClassPtr = iclsPtr;
510
511 if (arglist) {
512 imPtr->flags |= ITCL_ARG_SPEC;
513 }
514 if (mcode->argListPtr) {
515 ItclCreateArgList(interp, arglist, &imPtr->argcount,
516 &imPtr->maxargcount, &imPtr->usagePtr,
517 &imPtr->argListPtr, imPtr, NULL);
518 Tcl_IncrRefCount(imPtr->usagePtr);
519 }
520
521 name = Tcl_GetString(namePtr);
522 if ((body != NULL) && (body[0] == '@')) {
523 /* check for builtin cget isa and configure and mark them for
524 * use of a different arglist "args" for TclOO !! */
525 imPtr->codePtr->flags |= ITCL_BUILTIN;
526 if (strcmp(name, "cget") == 0) {
527 }
528 if (strcmp(name, "configure") == 0) {
529 imPtr->argcount = 0;
530 imPtr->maxargcount = -1;
531 }
532 if (strcmp(name, "isa") == 0) {
533 }
534 if (strcmp(name, "createhull") == 0) {
535 imPtr->argcount = 0;
536 imPtr->maxargcount = -1;
537 }
538 if (strcmp(name, "keepcomponentoption") == 0) {
539 imPtr->argcount = 0;
540 imPtr->maxargcount = -1;
541 }
542 if (strcmp(name, "ignorecomponentoption") == 0) {
543 imPtr->argcount = 0;
544 imPtr->maxargcount = -1;
545 }
546 if (strcmp(name, "renamecomponentoption") == 0) {
547 imPtr->argcount = 0;
548 imPtr->maxargcount = -1;
549 }
550 if (strcmp(name, "addoptioncomponent") == 0) {
551 imPtr->argcount = 0;
552 imPtr->maxargcount = -1;
553 }
554 if (strcmp(name, "ignoreoptioncomponent") == 0) {
555 imPtr->argcount = 0;
556 imPtr->maxargcount = -1;
557 }
558 if (strcmp(name, "renameoptioncomponent") == 0) {
559 imPtr->argcount = 0;
560 imPtr->maxargcount = -1;
561 }
562 if (strcmp(name, "setupcomponent") == 0) {
563 imPtr->argcount = 0;
564 imPtr->maxargcount = -1;
565 }
566 if (strcmp(name, "itcl_initoptions") == 0) {
567 imPtr->argcount = 0;
568 imPtr->maxargcount = -1;
569 }
570 if (strcmp(name, "mytypemethod") == 0) {
571 imPtr->argcount = 0;
572 imPtr->maxargcount = -1;
573 imPtr->flags |= ITCL_COMMON;
574 }
575 if (strcmp(name, "mymethod") == 0) {
576 imPtr->argcount = 0;
577 imPtr->maxargcount = -1;
578 }
579 if (strcmp(name, "mytypevar") == 0) {
580 imPtr->argcount = 0;
581 imPtr->maxargcount = -1;
582 imPtr->flags |= ITCL_COMMON;
583 }
584 if (strcmp(name, "myvar") == 0) {
585 imPtr->argcount = 0;
586 imPtr->maxargcount = -1;
587 }
588 if (strcmp(name, "itcl_hull") == 0) {
589 imPtr->argcount = 0;
590 imPtr->maxargcount = -1;
591 imPtr->flags |= ITCL_COMPONENT;
592 }
593 if (strcmp(name, "callinstance") == 0) {
594 imPtr->argcount = 0;
595 imPtr->maxargcount = -1;
596 }
597 if (strcmp(name, "getinstancevar") == 0) {
598 imPtr->argcount = 0;
599 imPtr->maxargcount = -1;
600 }
601 if (strcmp(name, "myproc") == 0) {
602 imPtr->argcount = 0;
603 imPtr->maxargcount = -1;
604 imPtr->flags |= ITCL_COMMON;
605 }
606 if (strcmp(name, "installhull") == 0) {
607 imPtr->argcount = 0;
608 imPtr->maxargcount = -1;
609 }
610 if (strcmp(name, "destroy") == 0) {
611 imPtr->argcount = 0;
612 imPtr->maxargcount = -1;
613 }
614 if (strcmp(name, "installcomponent") == 0) {
615 imPtr->argcount = 0;
616 imPtr->maxargcount = -1;
617 }
618 if (strcmp(name, "info") == 0) {
619 imPtr->flags |= ITCL_COMMON;
620 }
621 }
622 if (strcmp(name, "constructor") == 0) {
623 /*
624 * REVISE mcode->bodyPtr here!
625 * Include a [my ItclConstructBase $iclsPtr] method call.
626 * Inherited from itcl::Root
627 */
628
629 Tcl_Obj *newBody = Tcl_NewStringObj("", -1);
630 Tcl_AppendToObj(newBody,
631 "[::info object namespace ${this}]::my ItclConstructBase ", -1);
632 Tcl_AppendObjToObj(newBody, iclsPtr->fullNamePtr);
633 Tcl_AppendToObj(newBody, "\n", -1);
634
635 Tcl_AppendObjToObj(newBody, mcode->bodyPtr);
636 Tcl_DecrRefCount(mcode->bodyPtr);
637 mcode->bodyPtr = newBody;
638 Tcl_IncrRefCount(mcode->bodyPtr);
639 imPtr->flags |= ITCL_CONSTRUCTOR;
640 }
641 if (strcmp(name, "destructor") == 0) {
642 imPtr->flags |= ITCL_DESTRUCTOR;
643 }
644
645 Tcl_SetHashValue(hPtr, imPtr);
646 Itcl_PreserveData(imPtr);
647
648 *imPtrPtr = imPtr;
649 return TCL_OK;
650 }
651
652 /*
653 * ------------------------------------------------------------------------
654 * Itcl_CreateMemberFunc()
655 *
656 * Creates the data record representing a member function. This
657 * includes the argument list and the body of the function. If the
658 * body is of the form "@name", then it is treated as a label for
659 * a C procedure registered by Itcl_RegisterC().
660 *
661 * If any errors are encountered, this procedure returns TCL_ERROR
662 * along with an error message in the interpreter. Otherwise, it
663 * returns TCL_OK, and "imPtr" returns a pointer to the new
664 * member function.
665 * ------------------------------------------------------------------------
666 */
667 int
Itcl_CreateMemberFunc(Tcl_Interp * interp,ItclClass * iclsPtr,Tcl_Obj * namePtr,const char * arglist,const char * body,ItclMemberFunc ** imPtrPtr)668 Itcl_CreateMemberFunc(
669 Tcl_Interp* interp, /* interpreter managing this action */
670 ItclClass *iclsPtr, /* class definition */
671 Tcl_Obj *namePtr, /* name of new member */
672 const char* arglist, /* space-separated list of arg names */
673 const char* body, /* body of commands for the method */
674 ItclMemberFunc** imPtrPtr) /* returns: pointer to new method defn */
675 {
676 return ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist,
677 body, imPtrPtr, 0);
678 }
679
680 /*
681 * ------------------------------------------------------------------------
682 * Itcl_ChangeMemberFunc()
683 *
684 * Modifies the data record representing a member function. This
685 * is usually the body of the function, but can include the argument
686 * list if it was not defined when the member was first created.
687 * If the body is of the form "@name", then it is treated as a label
688 * for a C procedure registered by Itcl_RegisterC().
689 *
690 * If any errors are encountered, this procedure returns TCL_ERROR
691 * along with an error message in the interpreter. Otherwise, it
692 * returns TCL_OK, and "imPtr" returns a pointer to the new
693 * member function.
694 * ------------------------------------------------------------------------
695 */
696 int
Itcl_ChangeMemberFunc(Tcl_Interp * interp,ItclMemberFunc * imPtr,const char * arglist,const char * body)697 Itcl_ChangeMemberFunc(
698 Tcl_Interp* interp, /* interpreter managing this action */
699 ItclMemberFunc* imPtr, /* command member being changed */
700 const char* arglist, /* space-separated list of arg names */
701 const char* body) /* body of commands for the method */
702 {
703 Tcl_HashEntry *hPtr;
704 ItclMemberCode *mcode = NULL;
705 int isNewEntry;
706
707 /*
708 * Try to create the implementation for this command member.
709 */
710 if (ItclCreateMemberCode(interp, imPtr->iclsPtr,
711 arglist, body, &mcode, imPtr->namePtr, 0) != TCL_OK) {
712
713 return TCL_ERROR;
714 }
715
716 /*
717 * If the argument list was defined when the function was
718 * created, compare the arg lists or usage strings to make sure
719 * that the interface is not being redefined.
720 */
721 if ((imPtr->flags & ITCL_ARG_SPEC) != 0 &&
722 (imPtr->argListPtr != NULL) &&
723 !EquivArgLists(interp, imPtr->argListPtr, mcode->argListPtr)) {
724 const char *argsStr;
725 if (imPtr->origArgsPtr != NULL) {
726 argsStr = Tcl_GetString(imPtr->origArgsPtr);
727 } else {
728 argsStr = "";
729 }
730 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
731 "argument list changed for function \"",
732 Tcl_GetString(imPtr->fullNamePtr), "\": should be \"",
733 argsStr, "\"",
734 NULL);
735
736 Itcl_PreserveData(mcode);
737 Itcl_ReleaseData(mcode);
738 return TCL_ERROR;
739 }
740
741 if (imPtr->flags & ITCL_CONSTRUCTOR) {
742 /*
743 * REVISE mcode->bodyPtr here!
744 * Include a [my ItclConstructBase $iclsPtr] method call.
745 * Inherited from itcl::Root
746 */
747
748 Tcl_Obj *newBody = Tcl_NewStringObj("", -1);
749 Tcl_AppendToObj(newBody,
750 "[::info object namespace ${this}]::my ItclConstructBase ", -1);
751 Tcl_AppendObjToObj(newBody, imPtr->iclsPtr->fullNamePtr);
752 Tcl_AppendToObj(newBody, "\n", -1);
753
754 Tcl_AppendObjToObj(newBody, mcode->bodyPtr);
755 Tcl_DecrRefCount(mcode->bodyPtr);
756 mcode->bodyPtr = newBody;
757 Tcl_IncrRefCount(mcode->bodyPtr);
758 }
759
760 /*
761 * Free up the old implementation and install the new one.
762 */
763 Itcl_PreserveData(mcode);
764 Itcl_ReleaseData(imPtr->codePtr);
765 imPtr->codePtr = mcode;
766 if (mcode->flags & ITCL_IMPLEMENT_TCL) {
767 ClientData pmPtr;
768 imPtr->tmPtr = Itcl_NewProcClassMethod(interp,
769 imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod,
770 ItclProcErrorProc, imPtr, imPtr->namePtr, mcode->argumentPtr,
771 mcode->bodyPtr, &pmPtr);
772 hPtr = Tcl_CreateHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
773 (char *)imPtr->tmPtr, &isNewEntry);
774 if (isNewEntry) {
775 Tcl_SetHashValue(hPtr, imPtr);
776 }
777 }
778 ItclAddClassFunctionDictInfo(interp, imPtr->iclsPtr, imPtr);
779 return TCL_OK;
780 }
781
782 static const char * type_reserved_words [] = {
783 "type",
784 "self",
785 "selfns",
786 NULL
787 };
788
789 /*
790 * ------------------------------------------------------------------------
791 * ItclCreateMemberCode()
792 *
793 * Creates the data record representing the implementation behind a
794 * class member function. This includes the argument list and the body
795 * of the function. If the body is of the form "@name", then it is
796 * treated as a label for a C procedure registered by Itcl_RegisterC().
797 *
798 * The implementation is kept by the member function definition, and
799 * controlled by a preserve/release paradigm. That way, if it is in
800 * use while it is being redefined, it will stay around long enough
801 * to avoid a core dump.
802 *
803 * If any errors are encountered, this procedure returns TCL_ERROR
804 * along with an error message in the interpreter. Otherwise, it
805 * returns TCL_OK, and "mcodePtr" returns a pointer to the new
806 * implementation.
807 * ------------------------------------------------------------------------
808 */
809 static int
ItclCreateMemberCode(Tcl_Interp * interp,ItclClass * iclsPtr,const char * arglist,const char * body,ItclMemberCode ** mcodePtr,Tcl_Obj * namePtr,int flags)810 ItclCreateMemberCode(
811 Tcl_Interp* interp, /* interpreter managing this action */
812 ItclClass *iclsPtr, /* class containing this member */
813 const char* arglist, /* space-separated list of arg names */
814 const char* body, /* body of commands for the method */
815 ItclMemberCode** mcodePtr, /* returns: pointer to new implementation */
816 Tcl_Obj *namePtr,
817 int flags)
818 {
819 int argc;
820 int maxArgc;
821 Tcl_Obj *usagePtr;
822 ItclArgList *argListPtr;
823 ItclMemberCode *mcode;
824 const char **cPtrPtr;
825 int haveError;
826
827 /*
828 * Allocate some space to hold the implementation.
829 */
830 mcode = (ItclMemberCode*)Itcl_Alloc(sizeof(ItclMemberCode));
831 Itcl_EventuallyFree(mcode, (Tcl_FreeProc *)FreeMemberCode);
832
833 if (arglist) {
834 if (ItclCreateArgList(interp, arglist, &argc, &maxArgc, &usagePtr,
835 &argListPtr, NULL, NULL) != TCL_OK) {
836 Itcl_PreserveData(mcode);
837 Itcl_ReleaseData(mcode);
838 return TCL_ERROR;
839 }
840 mcode->argcount = argc;
841 mcode->maxargcount = maxArgc;
842 mcode->argListPtr = argListPtr;
843 mcode->usagePtr = usagePtr;
844 Tcl_IncrRefCount(mcode->usagePtr);
845 mcode->argumentPtr = Tcl_NewStringObj((const char *)arglist, -1);
846 Tcl_IncrRefCount(mcode->argumentPtr);
847 if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
848 haveError = 0;
849 while (argListPtr != NULL) {
850 cPtrPtr = &type_reserved_words[0];
851 while (*cPtrPtr != NULL) {
852 if ((argListPtr->namePtr != NULL) &&
853 (strcmp(Tcl_GetString(argListPtr->namePtr),
854 *cPtrPtr) == 0)) {
855 haveError = 1;
856 }
857 if ((flags & ITCL_COMMON) != 0) {
858 if (! (iclsPtr->infoPtr->functionFlags &
859 ITCL_TYPE_METHOD)) {
860 haveError = 0;
861 }
862 }
863 if (haveError) {
864 const char *startStr = "method ";
865 if (iclsPtr->infoPtr->functionFlags &
866 ITCL_TYPE_METHOD) {
867 startStr = "typemethod ";
868 }
869 /* FIXME should use iclsPtr->infoPtr->functionFlags here */
870 if ((namePtr != NULL) &&
871 (strcmp(Tcl_GetString(namePtr),
872 "constructor") == 0)) {
873 startStr = "";
874 }
875 Tcl_AppendResult(interp, startStr,
876 namePtr == NULL ? "??" :
877 Tcl_GetString(namePtr),
878 "'s arglist may not contain \"",
879 *cPtrPtr, "\" explicitly", NULL);
880 Itcl_PreserveData(mcode);
881 Itcl_ReleaseData(mcode);
882 return TCL_ERROR;
883 }
884 cPtrPtr++;
885 }
886 argListPtr = argListPtr->nextPtr;
887 }
888 }
889 mcode->flags |= ITCL_ARG_SPEC;
890 } else {
891 argc = 0;
892 argListPtr = NULL;
893 }
894
895 if (body) {
896 mcode->bodyPtr = Tcl_NewStringObj((const char *)body, -1);
897 } else {
898 mcode->bodyPtr = Tcl_NewStringObj((const char *)"", -1);
899 mcode->flags |= ITCL_IMPLEMENT_NONE;
900 }
901 Tcl_IncrRefCount(mcode->bodyPtr);
902
903 /*
904 * If the body definition starts with '@', then treat the value
905 * as a symbolic name for a C procedure.
906 */
907 if (body == NULL) {
908 /* No-op */
909 } else {
910 if (*body == '@') {
911 Tcl_CmdProc *argCmdProc;
912 Tcl_ObjCmdProc *objCmdProc;
913 ClientData cdata;
914 int isDone;
915
916 isDone = 0;
917 if (strcmp(body, "@itcl-builtin-cget") == 0) {
918 isDone = 1;
919 }
920 if (strcmp(body, "@itcl-builtin-configure") == 0) {
921 isDone = 1;
922 }
923 if (strcmp(body, "@itcl-builtin-isa") == 0) {
924 isDone = 1;
925 }
926 if (strcmp(body, "@itcl-builtin-createhull") == 0) {
927 isDone = 1;
928 }
929 if (strcmp(body, "@itcl-builtin-keepcomponentoption") == 0) {
930 isDone = 1;
931 }
932 if (strcmp(body, "@itcl-builtin-ignorecomponentoption") == 0) {
933 isDone = 1;
934 }
935 if (strcmp(body, "@itcl-builtin-renamecomponentoption") == 0) {
936 isDone = 1;
937 }
938 if (strcmp(body, "@itcl-builtin-addoptioncomponent") == 0) {
939 isDone = 1;
940 }
941 if (strcmp(body, "@itcl-builtin-ignoreoptioncomponent") == 0) {
942 isDone = 1;
943 }
944 if (strcmp(body, "@itcl-builtin-renameoptioncomponent") == 0) {
945 isDone = 1;
946 }
947 if (strcmp(body, "@itcl-builtin-setupcomponent") == 0) {
948 isDone = 1;
949 }
950 if (strcmp(body, "@itcl-builtin-initoptions") == 0) {
951 isDone = 1;
952 }
953 if (strcmp(body, "@itcl-builtin-mytypemethod") == 0) {
954 isDone = 1;
955 }
956 if (strcmp(body, "@itcl-builtin-mymethod") == 0) {
957 isDone = 1;
958 }
959 if (strcmp(body, "@itcl-builtin-myproc") == 0) {
960 isDone = 1;
961 }
962 if (strcmp(body, "@itcl-builtin-mytypevar") == 0) {
963 isDone = 1;
964 }
965 if (strcmp(body, "@itcl-builtin-myvar") == 0) {
966 isDone = 1;
967 }
968 if (strcmp(body, "@itcl-builtin-itcl_hull") == 0) {
969 isDone = 1;
970 }
971 if (strcmp(body, "@itcl-builtin-callinstance") == 0) {
972 isDone = 1;
973 }
974 if (strcmp(body, "@itcl-builtin-getinstancevar") == 0) {
975 isDone = 1;
976 }
977 if (strcmp(body, "@itcl-builtin-installhull") == 0) {
978 isDone = 1;
979 }
980 if (strcmp(body, "@itcl-builtin-installcomponent") == 0) {
981 isDone = 1;
982 }
983 if (strcmp(body, "@itcl-builtin-destroy") == 0) {
984 isDone = 1;
985 }
986 if (strncmp(body, "@itcl-builtin-setget", 20) == 0) {
987 isDone = 1;
988 }
989 if (strcmp(body, "@itcl-builtin-classunknown") == 0) {
990 isDone = 1;
991 }
992 if (!isDone) {
993 if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc,
994 &cdata)) {
995 Tcl_AppendResult(interp,
996 "no registered C procedure with name \"",
997 body+1, "\"", NULL);
998 Itcl_PreserveData(mcode);
999 Itcl_ReleaseData(mcode);
1000 return TCL_ERROR;
1001 }
1002
1003 /*
1004 * WARNING! WARNING! WARNING!
1005 * This is a pretty dangerous approach. What's done here is
1006 * to copy over the proc + clientData implementation that
1007 * happens to be in place at the moment the method is
1008 * (re-)defined. This denies any freedom for the clientData
1009 * to be changed dynamically or for the implementation to
1010 * shift from OBJCMD to ARGCMD or vice versa, which the
1011 * Itcl_Register(Obj)C routines explicitly permit. The whole
1012 * system also lacks any scheme to unregister.
1013 */
1014
1015 if (objCmdProc != NULL) {
1016 mcode->flags |= ITCL_IMPLEMENT_OBJCMD;
1017 mcode->cfunc.objCmd = objCmdProc;
1018 mcode->clientData = cdata;
1019 } else {
1020 if (argCmdProc != NULL) {
1021 mcode->flags |= ITCL_IMPLEMENT_ARGCMD;
1022 mcode->cfunc.argCmd = argCmdProc;
1023 mcode->clientData = cdata;
1024 }
1025 }
1026 } else {
1027 mcode->flags |= ITCL_IMPLEMENT_TCL|ITCL_BUILTIN;
1028 }
1029 } else {
1030
1031 /*
1032 * Otherwise, treat the body as a chunk of Tcl code.
1033 */
1034 mcode->flags |= ITCL_IMPLEMENT_TCL;
1035 }
1036 }
1037
1038 *mcodePtr = mcode;
1039
1040 return TCL_OK;
1041 }
1042
1043 /*
1044 * ------------------------------------------------------------------------
1045 * Itcl_CreateMemberCode()
1046 *
1047 * Creates the data record representing the implementation behind a
1048 * class member function. This includes the argument list and the body
1049 * of the function. If the body is of the form "@name", then it is
1050 * treated as a label for a C procedure registered by Itcl_RegisterC().
1051 *
1052 * A member function definition holds a handle for the implementation, and
1053 * uses Itcl_PreserveData and Itcl_ReleaseData to manage its interest in it.
1054 *
1055 * If any errors are encountered, this procedure returns TCL_ERROR
1056 * along with an error message in the interpreter. Otherwise, it
1057 * returns TCL_OK, and stores a pointer to the new implementation in
1058 * "mcodePtr".
1059 * ------------------------------------------------------------------------
1060 */
1061 int
Itcl_CreateMemberCode(Tcl_Interp * interp,ItclClass * iclsPtr,const char * arglist,const char * body,ItclMemberCode ** mcodePtr)1062 Itcl_CreateMemberCode(
1063 Tcl_Interp* interp, /* interpreter managing this action */
1064 ItclClass *iclsPtr, /* class containing this member */
1065 const char* arglist, /* space-separated list of arg names */
1066 const char* body, /* body of commands for the method */
1067 ItclMemberCode** mcodePtr) /* returns: pointer to new implementation */
1068 {
1069 return ItclCreateMemberCode(interp, iclsPtr, arglist, body, mcodePtr,
1070 NULL, 0);
1071 }
1072
1073 /*
1074 * ------------------------------------------------------------------------
1075 * Itcl_DeleteMemberCode()
1076 *
1077 * Destroys all data associated with the given command implementation.
1078 * Invoked automatically by ItclReleaseData() when the implementation
1079 * is no longer being used.
1080 * ------------------------------------------------------------------------
1081 */
FreeMemberCode(ItclMemberCode * mCodePtr)1082 void FreeMemberCode (
1083 ItclMemberCode* mCodePtr)
1084 {
1085 if (mCodePtr == NULL) {
1086 return;
1087 }
1088 if (mCodePtr->argListPtr != NULL) {
1089 ItclDeleteArgList(mCodePtr->argListPtr);
1090 }
1091 if (mCodePtr->usagePtr != NULL) {
1092 Tcl_DecrRefCount(mCodePtr->usagePtr);
1093 }
1094 if (mCodePtr->argumentPtr != NULL) {
1095 Tcl_DecrRefCount(mCodePtr->argumentPtr);
1096 }
1097 if (mCodePtr->bodyPtr != NULL) {
1098 Tcl_DecrRefCount(mCodePtr->bodyPtr);
1099 }
1100 Itcl_Free(mCodePtr);
1101 }
1102
1103
1104 void
Itcl_DeleteMemberCode(void * cdata)1105 Itcl_DeleteMemberCode(
1106 void* cdata) /* pointer to member code definition */
1107 {
1108 Itcl_ReleaseData((ItclMemberCode *)cdata);
1109 }
1110
1111
1112 /*
1113 * ------------------------------------------------------------------------
1114 * Itcl_GetMemberCode()
1115 *
1116 * Makes sure that the implementation for an [incr Tcl] code body is
1117 * ready to run. Note that a member function can be declared without
1118 * being defined. The class definition may contain a declaration of
1119 * the member function, but its body may be defined in a separate file.
1120 * If an undefined function is encountered, this routine automatically
1121 * attempts to autoload it. If the body is implemented via Tcl code,
1122 * then it is compiled here as well.
1123 *
1124 * Returns TCL_ERROR (along with an error message in the interpreter)
1125 * if an error is encountered, or if the implementation is not defined
1126 * and cannot be autoloaded. Returns TCL_OK if implementation is
1127 * ready to use.
1128 * ------------------------------------------------------------------------
1129 */
1130 int
Itcl_GetMemberCode(Tcl_Interp * interp,ItclMemberFunc * imPtr)1131 Itcl_GetMemberCode(
1132 Tcl_Interp* interp, /* interpreter managing this action */
1133 ItclMemberFunc* imPtr) /* member containing code body */
1134 {
1135 int result;
1136 ItclMemberCode *mcode = imPtr->codePtr;
1137 assert(mcode != NULL);
1138
1139 /*
1140 * If the implementation has not yet been defined, try to
1141 * autoload it now.
1142 */
1143
1144 if (!Itcl_IsMemberCodeImplemented(mcode)) {
1145 Tcl_DString buf;
1146
1147 Tcl_DStringInit(&buf);
1148 Tcl_DStringAppend(&buf, "::auto_load ", -1);
1149 Tcl_DStringAppend(&buf, Tcl_GetString(imPtr->fullNamePtr), -1);
1150 result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
1151 Tcl_DStringFree(&buf);
1152 if (result != TCL_OK) {
1153 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1154 "\n (while autoloading code for \"%s\")",
1155 Tcl_GetString(imPtr->fullNamePtr)));
1156 return result;
1157 }
1158 Tcl_ResetResult(interp); /* get rid of 1/0 status */
1159 }
1160
1161 /*
1162 * If the implementation is still not available, then
1163 * autoloading must have failed.
1164 *
1165 * TRICKY NOTE: If code has been autoloaded, then the
1166 * old mcode pointer is probably invalid. Go back to
1167 * the member and look at the current code pointer again.
1168 */
1169 mcode = imPtr->codePtr;
1170 assert(mcode != NULL);
1171
1172 if (!Itcl_IsMemberCodeImplemented(mcode)) {
1173 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1174 "member function \"", Tcl_GetString(imPtr->fullNamePtr),
1175 "\" is not defined and cannot be autoloaded",
1176 NULL);
1177 return TCL_ERROR;
1178 }
1179
1180 return TCL_OK;
1181 }
1182
1183
1184
1185 static int
CallItclObjectCmd(ClientData data[],Tcl_Interp * interp,int result)1186 CallItclObjectCmd(
1187 ClientData data[],
1188 Tcl_Interp *interp,
1189 int result)
1190 {
1191 Tcl_Object oPtr;
1192 ItclMemberFunc *imPtr = (ItclMemberFunc *)data[0];
1193 ItclObject *ioPtr = (ItclObject *)data[1];
1194 int objc = PTR2INT(data[2]);
1195 Tcl_Obj **objv = (Tcl_Obj **)data[3];
1196
1197 ItclShowArgs(1, "CallItclObjectCmd", objc, objv);
1198 if (ioPtr != NULL) {
1199 ioPtr->hadConstructorError = 0;
1200 }
1201 if (imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR)) {
1202 oPtr = ioPtr->oPtr;
1203 } else {
1204 oPtr = NULL;
1205 }
1206 if (oPtr != NULL) {
1207 result = ItclObjectCmd(imPtr, interp, oPtr, imPtr->iclsPtr->clsPtr,
1208 objc, objv);
1209 } else {
1210 result = ItclObjectCmd(imPtr, interp, NULL, NULL, objc, objv);
1211 }
1212 if (result != TCL_OK) {
1213 if (ioPtr != NULL && ioPtr->hadConstructorError == 0) {
1214 /* we are in a constructor call and did not yet have an error */
1215 /* -1 means we are not in a constructor */
1216 ioPtr->hadConstructorError = 1;
1217 }
1218 }
1219 return result;
1220 }
1221 /*
1222 * ------------------------------------------------------------------------
1223 * Itcl_EvalMemberCode()
1224 *
1225 * Used to execute an ItclMemberCode representation of a code
1226 * fragment. This code may be a body of Tcl commands, or a C handler
1227 * procedure.
1228 *
1229 * Executes the command with the given arguments (objc,objv) and
1230 * returns an integer status code (TCL_OK/TCL_ERROR). Returns the
1231 * result string or an error message in the interpreter.
1232 * ------------------------------------------------------------------------
1233 */
1234
1235 int
Itcl_EvalMemberCode(Tcl_Interp * interp,ItclMemberFunc * imPtr,ItclObject * contextIoPtr,int objc,Tcl_Obj * const objv[])1236 Itcl_EvalMemberCode(
1237 Tcl_Interp *interp, /* current interpreter */
1238 ItclMemberFunc *imPtr, /* member func, or NULL (for error messages) */
1239 ItclObject *contextIoPtr, /* object context, or NULL */
1240 int objc, /* number of arguments */
1241 Tcl_Obj *const objv[]) /* argument objects */
1242 {
1243 ItclMemberCode *mcode;
1244 void *callbackPtr;
1245 int result = TCL_OK;
1246 int i;
1247
1248 ItclShowArgs(1, "Itcl_EvalMemberCode", objc, objv);
1249 /*
1250 * If this code does not have an implementation yet, then
1251 * try to autoload one. Also, if this is Tcl code, make sure
1252 * that it's compiled and ready to use.
1253 */
1254 if (Itcl_GetMemberCode(interp, imPtr) != TCL_OK) {
1255 return TCL_ERROR;
1256 }
1257 mcode = imPtr->codePtr;
1258
1259 /*
1260 * Bump the reference count on this code, in case it is
1261 * redefined or deleted during execution.
1262 */
1263 Itcl_PreserveData(mcode);
1264
1265 if ((imPtr->flags & ITCL_DESTRUCTOR) && (contextIoPtr != NULL)) {
1266 contextIoPtr->destructorHasBeenCalled = 1;
1267 }
1268
1269 /*
1270 * Execute the code body...
1271 */
1272 if (((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) ||
1273 ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0)) {
1274
1275 if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) {
1276 result = (*mcode->cfunc.objCmd)(mcode->clientData,
1277 interp, objc, objv);
1278 } else {
1279 if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) {
1280 char **argv;
1281 argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) );
1282 for (i=0; i < objc; i++) {
1283 argv[i] = Tcl_GetString(objv[i]);
1284 }
1285
1286 result = (*mcode->cfunc.argCmd)(mcode->clientData,
1287 interp, objc, (const char **)argv);
1288
1289 ckfree((char*)argv);
1290 }
1291 }
1292 } else {
1293 if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
1294 callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
1295 Tcl_NRAddCallback(interp, CallItclObjectCmd, imPtr, contextIoPtr,
1296 INT2PTR(objc), (void *)objv);
1297 result = Itcl_NRRunCallbacks(interp, callbackPtr);
1298 }
1299 }
1300
1301 Itcl_ReleaseData(mcode);
1302 return result;
1303 }
1304
1305 /*
1306 * ------------------------------------------------------------------------
1307 * ItclEquivArgLists()
1308 *
1309 * Compares two argument lists to see if they are equivalent. The
1310 * first list is treated as a prototype, and the second list must
1311 * match it. Argument names may be different, but they must match in
1312 * meaning. If one argument is optional, the corresponding argument
1313 * must also be optional. If the prototype list ends with the magic
1314 * "args" argument, then it matches everything in the other list.
1315 *
1316 * Returns non-zero if the argument lists are equivalent.
1317 * ------------------------------------------------------------------------
1318 */
1319
1320 static int
EquivArgLists(TCL_UNUSED (Tcl_Interp *),ItclArgList * origArgs,ItclArgList * realArgs)1321 EquivArgLists(
1322 TCL_UNUSED(Tcl_Interp*),
1323 ItclArgList *origArgs,
1324 ItclArgList *realArgs)
1325 {
1326 ItclArgList *currPtr;
1327 char *argName;
1328
1329 for (currPtr=origArgs; currPtr != NULL; currPtr=currPtr->nextPtr) {
1330 if ((realArgs != NULL) && (realArgs->namePtr == NULL)) {
1331 if (currPtr->namePtr != NULL) {
1332 if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) {
1333 /* the definition has more arguments */
1334 return 0;
1335 }
1336 }
1337 }
1338 if (realArgs == NULL) {
1339 if (currPtr->defaultValuePtr != NULL) {
1340 /* default args must be there ! */
1341 return 0;
1342 }
1343 if (currPtr->namePtr != NULL) {
1344 if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) {
1345 /* the definition has more arguments */
1346 return 0;
1347 }
1348 }
1349 return 1;
1350 }
1351 if (currPtr->namePtr == NULL) {
1352 /* no args defined */
1353 if (realArgs->namePtr != NULL) {
1354 return 0;
1355 }
1356 return 1;
1357 }
1358 argName = Tcl_GetString(currPtr->namePtr);
1359 if (strcmp(argName, "args") == 0) {
1360 if (currPtr->nextPtr == NULL) {
1361 /* this is the last arument */
1362 return 1;
1363 }
1364 }
1365 if (currPtr->defaultValuePtr != NULL) {
1366 if (realArgs->defaultValuePtr != NULL) {
1367 /* default values must be the same */
1368 if (strcmp(Tcl_GetString(currPtr->defaultValuePtr),
1369 Tcl_GetString(realArgs->defaultValuePtr)) != 0) {
1370 return 0;
1371 }
1372 }
1373 }
1374 realArgs = realArgs->nextPtr;
1375 }
1376 if ((currPtr == NULL) && (realArgs != NULL)) {
1377 /* new definition has more args then the old one */
1378 return 0;
1379 }
1380 return 1;
1381 }
1382
1383 /*
1384 * ------------------------------------------------------------------------
1385 * Itcl_GetContext()
1386 *
1387 * Convenience routine for looking up the current object/class context.
1388 * Useful in implementing methods/procs to see what class, and perhaps
1389 * what object, is active.
1390 *
1391 * Returns TCL_OK if the current namespace is a class namespace.
1392 * Also returns pointers to the class definition, and to object
1393 * data if an object context is active. Returns TCL_ERROR (along
1394 * with an error message in the interpreter) if a class namespace
1395 * is not active.
1396 * ------------------------------------------------------------------------
1397 */
1398
1399 void
Itcl_SetContext(Tcl_Interp * interp,ItclObject * ioPtr)1400 Itcl_SetContext(
1401 Tcl_Interp *interp,
1402 ItclObject *ioPtr)
1403 {
1404 int isNew;
1405 Itcl_Stack *stackPtr;
1406 Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
1407 ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
1408 ITCL_INTERP_DATA, NULL);
1409 Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
1410 (char *)framePtr, &isNew);
1411 ItclCallContext *contextPtr
1412 = (ItclCallContext *) ckalloc(sizeof(ItclCallContext));
1413
1414 memset(contextPtr, 0, sizeof(ItclCallContext));
1415 contextPtr->ioPtr = ioPtr;
1416 contextPtr->refCount = 1;
1417
1418 if (!isNew) {
1419 Tcl_Panic("frame already has context?!");
1420 }
1421
1422 stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack));
1423 Itcl_InitStack(stackPtr);
1424 Tcl_SetHashValue(hPtr, stackPtr);
1425
1426 Itcl_PushStack(contextPtr, stackPtr);
1427 }
1428
1429 void
Itcl_UnsetContext(Tcl_Interp * interp)1430 Itcl_UnsetContext(
1431 Tcl_Interp *interp)
1432 {
1433 Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
1434 ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
1435 ITCL_INTERP_DATA, NULL);
1436 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext,
1437 (char *)framePtr);
1438 Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr);
1439 ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr);
1440
1441 if (Itcl_GetStackSize(stackPtr) > 0) {
1442 Tcl_Panic("frame context stack not empty!");
1443 }
1444 Itcl_DeleteStack(stackPtr);
1445 ckfree((char *) stackPtr);
1446 Tcl_DeleteHashEntry(hPtr);
1447 if (contextPtr->refCount-- > 1) {
1448 Tcl_Panic("frame context ref count not zero!");
1449 }
1450 ckfree((char *)contextPtr);
1451 }
1452
1453 int
Itcl_GetContext(Tcl_Interp * interp,ItclClass ** iclsPtrPtr,ItclObject ** ioPtrPtr)1454 Itcl_GetContext(
1455 Tcl_Interp *interp, /* current interpreter */
1456 ItclClass **iclsPtrPtr, /* returns: class definition or NULL */
1457 ItclObject **ioPtrPtr) /* returns: object data or NULL */
1458 {
1459 Tcl_Namespace *nsPtr;
1460
1461 /* Fetch the current call frame. That determines context. */
1462 Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
1463
1464 /* Try to map it to a context stack. */
1465 ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
1466 ITCL_INTERP_DATA, NULL);
1467 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext,
1468 (char *)framePtr);
1469 if (hPtr) {
1470 /* Frame maps to a context stack. */
1471 Itcl_Stack *stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
1472 ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr);
1473
1474 assert(contextPtr);
1475
1476 if (contextPtr->objectFlags & ITCL_OBJECT_ROOT_METHOD) {
1477 ItclObject *ioPtr = contextPtr->ioPtr;
1478
1479 *iclsPtrPtr = ioPtr->iclsPtr;
1480 *ioPtrPtr = ioPtr;
1481 return TCL_OK;
1482 }
1483
1484 *iclsPtrPtr = contextPtr->imPtr ? contextPtr->imPtr->iclsPtr
1485 : contextPtr->ioPtr->iclsPtr;
1486 *ioPtrPtr = contextPtr->ioPtr ? contextPtr->ioPtr : infoPtr->currIoPtr;
1487 return TCL_OK;
1488 }
1489
1490 /* Frame has no Itcl context data. No way to get object context. */
1491 *ioPtrPtr = NULL;
1492
1493 /* Fall back to namespace for possible class context info. */
1494 nsPtr = Tcl_GetCurrentNamespace(interp);
1495 hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
1496 if (hPtr) {
1497 *iclsPtrPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
1498
1499 /*
1500 * DANGER! Following stanza of code was added to address a
1501 * regression from Itcl 4.0 -> Itcl 4.1 reported in Ticket
1502 * [c949e73d3e] without really understanding. May be trouble here!
1503 */
1504 if ((*iclsPtrPtr)->nsPtr) {
1505 *ioPtrPtr = (*iclsPtrPtr)->infoPtr->currIoPtr;
1506 }
1507 return TCL_OK;
1508 }
1509
1510 /* Cannot get any context. Record an error message. */
1511 if (interp) {
1512 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1513 "namespace \"%s\" is not a class namespace", nsPtr->fullName));
1514 }
1515 return TCL_ERROR;
1516 }
1517
1518 /*
1519 * ------------------------------------------------------------------------
1520 * Itcl_GetMemberFuncUsage()
1521 *
1522 * Returns a string showing how a command member should be invoked.
1523 * If the command member is a method, then the specified object name
1524 * is reported as part of the invocation path:
1525 *
1526 * obj method arg ?arg arg ...?
1527 *
1528 * Otherwise, the "obj" pointer is ignored, and the class name is
1529 * used as the invocation path:
1530 *
1531 * class::proc arg ?arg arg ...?
1532 *
1533 * Returns the string by appending it onto the Tcl_Obj passed in as
1534 * an argument.
1535 * ------------------------------------------------------------------------
1536 */
1537 void
Itcl_GetMemberFuncUsage(ItclMemberFunc * imPtr,ItclObject * contextIoPtr,Tcl_Obj * objPtr)1538 Itcl_GetMemberFuncUsage(
1539 ItclMemberFunc *imPtr, /* command member being examined */
1540 ItclObject *contextIoPtr, /* invoked with respect to this object */
1541 Tcl_Obj *objPtr) /* returns: string showing usage */
1542 {
1543 Tcl_HashEntry *entry;
1544 ItclMemberFunc *mf;
1545 ItclClass *iclsPtr;
1546 char *name;
1547 char *arglist;
1548
1549 /*
1550 * If the command is a method and an object context was
1551 * specified, then add the object context. If the method
1552 * was a constructor, and if the object is being created,
1553 * then report the invocation via the class creation command.
1554 */
1555 if ((imPtr->flags & ITCL_COMMON) == 0) {
1556 if ((imPtr->flags & ITCL_CONSTRUCTOR) != 0 &&
1557 contextIoPtr->constructed) {
1558
1559 iclsPtr = (ItclClass*)contextIoPtr->iclsPtr;
1560 mf = NULL;
1561 objPtr = Tcl_NewStringObj("constructor", -1);
1562 entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
1563 Tcl_DecrRefCount(objPtr);
1564 if (entry) {
1565 ItclCmdLookup *clookup;
1566 clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
1567 mf = clookup->imPtr;
1568 }
1569
1570 if (mf == imPtr) {
1571 Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp,
1572 contextIoPtr->iclsPtr->accessCmd, objPtr);
1573 Tcl_AppendToObj(objPtr, " ", -1);
1574 name = (char *) Tcl_GetCommandName(
1575 contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd);
1576 Tcl_AppendToObj(objPtr, name, -1);
1577 } else {
1578 Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1);
1579 }
1580 } else {
1581 if (contextIoPtr && contextIoPtr->accessCmd) {
1582 name = (char *) Tcl_GetCommandName(
1583 contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd);
1584 Tcl_AppendStringsToObj(objPtr, name, " ",
1585 Tcl_GetString(imPtr->namePtr), NULL);
1586 } else {
1587 Tcl_AppendStringsToObj(objPtr, "<object> ",
1588 Tcl_GetString(imPtr->namePtr), NULL);
1589 }
1590 }
1591 } else {
1592 Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1);
1593 }
1594
1595 /*
1596 * Add the argument usage info.
1597 */
1598 if (imPtr->codePtr) {
1599 if (imPtr->codePtr->usagePtr != NULL) {
1600 arglist = Tcl_GetString(imPtr->codePtr->usagePtr);
1601 } else {
1602 arglist = NULL;
1603 }
1604 } else {
1605 if (imPtr->argListPtr != NULL) {
1606 arglist = Tcl_GetString(imPtr->usagePtr);
1607 } else {
1608 arglist = NULL;
1609 }
1610 }
1611 if (arglist) {
1612 if (strlen(arglist) > 0) {
1613 Tcl_AppendToObj(objPtr, " ", -1);
1614 Tcl_AppendToObj(objPtr, arglist, -1);
1615 }
1616 }
1617 }
1618
1619 /*
1620 * ------------------------------------------------------------------------
1621 * Itcl_ExecMethod()
1622 *
1623 * Invoked by Tcl to handle the execution of a user-defined method.
1624 * A method is similar to the usual Tcl proc, but has access to
1625 * object-specific data. If for some reason there is no current
1626 * object context, then a method call is inappropriate, and an error
1627 * is returned.
1628 *
1629 * Methods are implemented either as Tcl code fragments, or as C-coded
1630 * procedures. For Tcl code fragments, command arguments are parsed
1631 * according to the argument list, and the body is executed in the
1632 * scope of the class where it was defined. For C procedures, the
1633 * arguments are passed in "as-is", and the procedure is executed in
1634 * the most-specific class scope.
1635 * ------------------------------------------------------------------------
1636 */
1637 static int
NRExecMethod(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)1638 NRExecMethod(
1639 ClientData clientData, /* method definition */
1640 Tcl_Interp *interp, /* current interpreter */
1641 int objc, /* number of arguments */
1642 Tcl_Obj *const *objv) /* argument objects */
1643 {
1644 ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData;
1645 int result = TCL_OK;
1646
1647 const char *token;
1648 Tcl_HashEntry *entry;
1649 ItclClass *iclsPtr;
1650 ItclObject *ioPtr;
1651
1652 ItclShowArgs(1, "NRExecMethod", objc, objv);
1653
1654 /*
1655 * Make sure that the current namespace context includes an
1656 * object that is being manipulated. Methods can be executed
1657 * only if an object context exists.
1658 */
1659 iclsPtr = imPtr->iclsPtr;
1660 if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
1661 return TCL_ERROR;
1662 }
1663 if (ioPtr == NULL) {
1664 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1665 "cannot access object-specific info without an object context",
1666 NULL);
1667 return TCL_ERROR;
1668 }
1669
1670 /*
1671 * Make sure that this command member can be accessed from
1672 * the current namespace context.
1673 * That is now done in ItclMapMethodNameProc !!
1674 */
1675
1676 /*
1677 * All methods should be "virtual" unless they are invoked with
1678 * a "::" scope qualifier.
1679 *
1680 * To implement the "virtual" behavior, find the most-specific
1681 * implementation for the method by looking in the "resolveCmds"
1682 * table for this class.
1683 */
1684 token = Tcl_GetString(objv[0]);
1685 if (strstr(token, "::") == NULL) {
1686 if (ioPtr != NULL) {
1687 entry = Tcl_FindHashEntry(&ioPtr->iclsPtr->resolveCmds,
1688 (char *)imPtr->namePtr);
1689
1690 if (entry) {
1691 ItclCmdLookup *clookup;
1692 clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
1693 imPtr = clookup->imPtr;
1694 }
1695 }
1696 }
1697
1698 /*
1699 * Execute the code for the method. Be careful to protect
1700 * the method in case it gets deleted during execution.
1701 */
1702 Itcl_PreserveData(imPtr);
1703 result = Itcl_EvalMemberCode(interp, imPtr, ioPtr, objc, objv);
1704 Itcl_ReleaseData(imPtr);
1705 return result;
1706 }
1707
1708 /* ARGSUSED */
1709 int
Itcl_ExecMethod(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)1710 Itcl_ExecMethod(
1711 ClientData clientData,
1712 Tcl_Interp *interp,
1713 int objc,
1714 Tcl_Obj *const *objv)
1715 {
1716 return Tcl_NRCallObjProc(interp, NRExecMethod, clientData, objc, objv);
1717 }
1718
1719
1720 /*
1721 * ------------------------------------------------------------------------
1722 * Itcl_ExecProc()
1723 *
1724 * Invoked by Tcl to handle the execution of a user-defined proc.
1725 *
1726 * Procs are implemented either as Tcl code fragments, or as C-coded
1727 * procedures. For Tcl code fragments, command arguments are parsed
1728 * according to the argument list, and the body is executed in the
1729 * scope of the class where it was defined. For C procedures, the
1730 * arguments are passed in "as-is", and the procedure is executed in
1731 * the most-specific class scope.
1732 * ------------------------------------------------------------------------
1733 */
1734 static int
NRExecProc(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1735 NRExecProc(
1736 ClientData clientData, /* proc definition */
1737 Tcl_Interp *interp, /* current interpreter */
1738 int objc, /* number of arguments */
1739 Tcl_Obj *const objv[]) /* argument objects */
1740 {
1741 ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData;
1742 int result = TCL_OK;
1743
1744 ItclShowArgs(1, "NRExecProc", objc, objv);
1745
1746 /*
1747 * Make sure that this command member can be accessed from
1748 * the current namespace context.
1749 */
1750 if (imPtr->protection != ITCL_PUBLIC) {
1751 if (!Itcl_CanAccessFunc(imPtr, Tcl_GetCurrentNamespace(interp))) {
1752 ItclMemberFunc *imPtr2 = NULL;
1753 Tcl_HashEntry *hPtr;
1754 Tcl_ObjectContext context;
1755 context = (Tcl_ObjectContext)Itcl_GetCallFrameClientData(interp);
1756 if (context == NULL) {
1757 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1758 "can't access \"", Tcl_GetString(imPtr->fullNamePtr),
1759 "\": ", Itcl_ProtectionStr(imPtr->protection),
1760 " function", NULL);
1761 return TCL_ERROR;
1762 }
1763 hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
1764 (char *)Tcl_ObjectContextMethod(context));
1765 if (hPtr != NULL) {
1766 imPtr2 = (ItclMemberFunc *)Tcl_GetHashValue(hPtr);
1767 }
1768 if ((imPtr->protection & ITCL_PRIVATE) && (imPtr2 != NULL) &&
1769 (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) {
1770 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1771 "invalid command name \"",
1772 Tcl_GetString(objv[0]),
1773 "\"", NULL);
1774 return TCL_ERROR;
1775 }
1776 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1777 "can't access \"", Tcl_GetString(imPtr->fullNamePtr),
1778 "\": ", Itcl_ProtectionStr(imPtr->protection),
1779 " function", NULL);
1780 return TCL_ERROR;
1781 }
1782 }
1783
1784 /*
1785 * Execute the code for the proc. Be careful to protect
1786 * the proc in case it gets deleted during execution.
1787 */
1788 Itcl_PreserveData(imPtr);
1789
1790 result = Itcl_EvalMemberCode(interp, imPtr, NULL,
1791 objc, objv);
1792 Itcl_ReleaseData(imPtr);
1793 return result;
1794 }
1795
1796 /* ARGSUSED */
1797 int
Itcl_ExecProc(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)1798 Itcl_ExecProc(
1799 ClientData clientData,
1800 Tcl_Interp *interp,
1801 int objc,
1802 Tcl_Obj *const *objv)
1803 {
1804 return Tcl_NRCallObjProc(interp, NRExecProc, clientData, objc, objv);
1805 }
1806
1807 static int
CallInvokeMethodIfExists(ClientData data[],Tcl_Interp * interp,int result)1808 CallInvokeMethodIfExists(
1809 ClientData data[],
1810 Tcl_Interp *interp,
1811 int result)
1812 {
1813 ItclClass *iclsPtr = (ItclClass *)data[0];
1814 ItclObject *contextObj = (ItclObject *)data[1];
1815 int objc = PTR2INT(data[2]);
1816 Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3];
1817
1818 result = Itcl_InvokeMethodIfExists(interp, "constructor",
1819 iclsPtr, contextObj, objc, (Tcl_Obj* const*)objv);
1820
1821 if (result != TCL_OK) {
1822 return TCL_ERROR;
1823 }
1824 return TCL_OK;
1825 }
1826 /*
1827 * ------------------------------------------------------------------------
1828 * Itcl_ConstructBase()
1829 *
1830 * Usually invoked just before executing the body of a constructor
1831 * when an object is first created. This procedure makes sure that
1832 * all base classes are properly constructed. If an "initCode" fragment
1833 * was defined with the constructor for the class, then it is invoked.
1834 * After that, the list of base classes is checked for constructors
1835 * that are defined but have not yet been invoked. Each of these is
1836 * invoked implicitly with no arguments.
1837 *
1838 * Assumes that a local call frame is already installed, and that
1839 * constructor arguments have already been matched and are sitting in
1840 * this frame. Returns TCL_OK on success; otherwise, this procedure
1841 * returns TCL_ERROR, along with an error message in the interpreter.
1842 * ------------------------------------------------------------------------
1843 */
1844
1845 int
Itcl_ConstructBase(Tcl_Interp * interp,ItclObject * contextObj,ItclClass * contextClass)1846 Itcl_ConstructBase(
1847 Tcl_Interp *interp, /* interpreter */
1848 ItclObject *contextObj, /* object being constructed */
1849 ItclClass *contextClass) /* current class being constructed */
1850 {
1851 int result = TCL_OK;
1852 Tcl_Obj *objPtr;
1853 Itcl_ListElem *elem;
1854
1855 /*
1856 * If the class has an "initCode", invoke it in the current context.
1857 */
1858
1859 if (contextClass->initCode) {
1860
1861 /* TODO: NRE */
1862 result = Tcl_EvalObjEx(interp, contextClass->initCode, 0);
1863 }
1864
1865 /*
1866 * Scan through the list of base classes and see if any of these
1867 * have not been constructed. Invoke base class constructors
1868 * implicitly, as needed. Go through the list of base classes
1869 * in reverse order, so that least-specific classes are constructed
1870 * first.
1871 */
1872
1873 objPtr = Tcl_NewStringObj("constructor", -1);
1874 Tcl_IncrRefCount(objPtr);
1875 for (elem = Itcl_LastListElem(&contextClass->bases);
1876 result == TCL_OK && elem != NULL;
1877 elem = Itcl_PrevListElem(elem)) {
1878
1879 Tcl_HashEntry *entry;
1880 ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem);
1881
1882 if (Tcl_FindHashEntry(contextObj->constructed,
1883 (char *)iclsPtr->namePtr)) {
1884
1885 /* Already constructed, nothing to do. */
1886 continue;
1887 }
1888
1889 entry = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr);
1890 if (entry) {
1891 void *callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
1892 Tcl_NRAddCallback(interp, CallInvokeMethodIfExists, iclsPtr,
1893 contextObj, INT2PTR(0), NULL);
1894 result = Itcl_NRRunCallbacks(interp, callbackPtr);
1895 } else {
1896 result = Itcl_ConstructBase(interp, contextObj, iclsPtr);
1897 }
1898 }
1899 Tcl_DecrRefCount(objPtr);
1900 return result;
1901 }
1902
1903 int
ItclConstructGuts(ItclObject * contextObj,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1904 ItclConstructGuts(
1905 ItclObject *contextObj,
1906 Tcl_Interp *interp,
1907 int objc,
1908 Tcl_Obj *const objv[])
1909 {
1910 ItclClass *contextClass;
1911
1912 /* Ignore syntax error */
1913 if (objc != 3) {
1914 return TCL_OK;
1915 }
1916
1917 /* Object is fully constructed. This becomes no-op. */
1918 if (contextObj->constructed == NULL) {
1919 return TCL_OK;
1920 }
1921
1922 contextClass = Itcl_FindClass(interp, Tcl_GetString(objv[2]), 0);
1923 if (contextClass == NULL) {
1924 return TCL_OK;
1925 }
1926
1927
1928 return Itcl_ConstructBase(interp, contextObj, contextClass);
1929 }
1930
1931 /*
1932 * ------------------------------------------------------------------------
1933 * Itcl_InvokeMethodIfExists()
1934 *
1935 * Looks for a particular method in the specified class. If the
1936 * method is found, it is invoked with the given arguments. Any
1937 * protection level (protected/private) for the method is ignored.
1938 * If the method does not exist, this procedure does nothing.
1939 *
1940 * This procedure is used primarily to invoke the constructor/destructor
1941 * when an object is created/destroyed.
1942 *
1943 * Returns TCL_OK on success; otherwise, this procedure returns
1944 * TCL_ERROR along with an error message in the interpreter.
1945 * ------------------------------------------------------------------------
1946 */
1947 int
Itcl_InvokeMethodIfExists(Tcl_Interp * interp,const char * name,ItclClass * contextClassPtr,ItclObject * contextObjectPtr,int objc,Tcl_Obj * const objv[])1948 Itcl_InvokeMethodIfExists(
1949 Tcl_Interp *interp, /* interpreter */
1950 const char *name, /* name of desired method */
1951 ItclClass *contextClassPtr, /* current class being constructed */
1952 ItclObject *contextObjectPtr, /* object being constructed */
1953 int objc, /* number of arguments */
1954 Tcl_Obj *const objv[]) /* argument objects */
1955 {
1956 Tcl_HashEntry *hPtr;
1957 Tcl_Obj *cmdlinePtr;
1958 Tcl_Obj **cmdlinev;
1959 Tcl_Obj **newObjv;
1960 Tcl_CallFrame frame;
1961 ItclMemberFunc *imPtr;
1962 int cmdlinec;
1963 int result = TCL_OK;
1964 Tcl_Obj *objPtr = Tcl_NewStringObj(name, -1);
1965
1966 ItclShowArgs(1, "Itcl_InvokeMethodIfExists", objc, objv);
1967 hPtr = Tcl_FindHashEntry(&contextClassPtr->functions, (char *)objPtr);
1968 Tcl_DecrRefCount(objPtr);
1969 if (hPtr) {
1970 imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr);
1971
1972 /*
1973 * Prepend the method name to the list of arguments.
1974 */
1975 cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv);
1976
1977 (void) Tcl_ListObjGetElements(NULL, cmdlinePtr,
1978 &cmdlinec, &cmdlinev);
1979
1980 ItclShowArgs(1, "EMC", cmdlinec, cmdlinev);
1981 /*
1982 * Execute the code for the method. Be careful to protect
1983 * the method in case it gets deleted during execution.
1984 */
1985 Itcl_PreserveData(imPtr);
1986
1987 if (contextObjectPtr->oPtr == NULL) {
1988 Tcl_DecrRefCount(cmdlinePtr);
1989 return TCL_ERROR;
1990 }
1991 result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr,
1992 cmdlinec, cmdlinev);
1993 Itcl_ReleaseData(imPtr);
1994 Tcl_DecrRefCount(cmdlinePtr);
1995 } else {
1996 if (contextClassPtr->flags &
1997 (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
1998 if (strcmp(name, "constructor") == 0) {
1999 if (objc > 0) {
2000 if (contextClassPtr->numOptions == 0) {
2001 /* check if all options are delegeted */
2002 Tcl_Obj *objPtr;
2003 objPtr = Tcl_NewStringObj("*", -1);
2004 hPtr = Tcl_FindHashEntry(
2005 &contextClassPtr->delegatedOptions,
2006 (char *)objPtr);
2007 Tcl_DecrRefCount(objPtr);
2008 if (hPtr == NULL) {
2009 Tcl_AppendResult(interp, "type \"",
2010 Tcl_GetString(contextClassPtr->namePtr),
2011 "\" has no options, but constructor has",
2012 " option arguments", NULL);
2013 return TCL_ERROR;
2014 }
2015 }
2016 if (Itcl_PushCallFrame(interp, &frame,
2017 contextClassPtr->nsPtr,
2018 /*isProcCallFrame*/0) != TCL_OK) {
2019 Tcl_AppendResult(interp, "INTERNAL ERROR in",
2020 "Itcl_InvokeMethodIfExists Itcl_PushCallFrame",
2021 NULL);
2022 }
2023 newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc + 2));
2024 newObjv[0] = Tcl_NewStringObj("my", -1);
2025 Tcl_IncrRefCount(newObjv[0]);
2026 newObjv[1] = Tcl_NewStringObj("configure", -1);
2027 Tcl_IncrRefCount(newObjv[1]);
2028 memcpy(newObjv + 2, objv, (objc * sizeof(Tcl_Obj *)));
2029 ItclShowArgs(1, "DEFAULT Constructor", objc + 2, newObjv);
2030 result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0);
2031 Tcl_DecrRefCount(newObjv[1]);
2032 Tcl_DecrRefCount(newObjv[0]);
2033 ckfree((char *)newObjv);
2034 Itcl_PopCallFrame(interp);
2035 }
2036 }
2037 }
2038 }
2039 return result;
2040 }
2041
2042
2043 /*
2044 * ------------------------------------------------------------------------
2045 * Itcl_ReportFuncErrors()
2046 *
2047 * Used to interpret the status code returned when the body of a
2048 * Tcl-style proc is executed. Handles the "errorInfo" and "errorCode"
2049 * variables properly, and adds error information into the interpreter
2050 * if anything went wrong. Returns a new status code that should be
2051 * treated as the return status code for the command.
2052 *
2053 * This same operation is usually buried in the Tcl InterpProc()
2054 * procedure. It is defined here so that it can be reused more easily.
2055 * ------------------------------------------------------------------------
2056 */
2057 int
Itcl_ReportFuncErrors(TCL_UNUSED (Tcl_Interp *),TCL_UNUSED (ItclMemberFunc *),TCL_UNUSED (ItclObject *),int result)2058 Itcl_ReportFuncErrors(
2059 TCL_UNUSED(Tcl_Interp*), /* interpreter being modified */
2060 TCL_UNUSED(ItclMemberFunc*), /* command member that was invoked */
2061 TCL_UNUSED(ItclObject*), /* object context for this command */
2062 int result) /* integer status code from proc body */
2063 {
2064 /* FIXME !!! */
2065 /* adapt to use of ItclProcErrorProc for stubs compatibility !! */
2066 return result;
2067 }
2068
2069 /*
2070 * ------------------------------------------------------------------------
2071 * Itcl_CmdAliasProc()
2072 *
2073 * ------------------------------------------------------------------------
2074 */
2075 Tcl_Command
Itcl_CmdAliasProc(Tcl_Interp * interp,Tcl_Namespace * nsPtr,const char * cmdName,ClientData clientData)2076 Itcl_CmdAliasProc(
2077 Tcl_Interp *interp,
2078 Tcl_Namespace *nsPtr,
2079 const char *cmdName,
2080 ClientData clientData)
2081 {
2082 Tcl_HashEntry *hPtr;
2083 Tcl_Obj *objPtr;
2084 ItclObjectInfo *infoPtr;
2085 ItclClass *iclsPtr;
2086 ItclObject *ioPtr;
2087 ItclMemberFunc *imPtr;
2088 ItclResolveInfo *resolveInfoPtr;
2089 ItclCmdLookup *clookup;
2090
2091 resolveInfoPtr = (ItclResolveInfo *)clientData;
2092 if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) {
2093 ioPtr = resolveInfoPtr->ioPtr;
2094 iclsPtr = ioPtr->iclsPtr;
2095 } else {
2096 ioPtr = NULL;
2097 iclsPtr = resolveInfoPtr->iclsPtr;
2098 }
2099 infoPtr = iclsPtr->infoPtr;
2100 hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
2101 if (hPtr == NULL) {
2102 return NULL;
2103 }
2104 iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
2105 objPtr = Tcl_NewStringObj(cmdName, -1);
2106 hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
2107 Tcl_DecrRefCount(objPtr);
2108 if (hPtr == NULL) {
2109 if (strcmp(cmdName, "@itcl-builtin-cget") == 0) {
2110 return Tcl_FindCommand(interp, "::itcl::builtin::cget", NULL, 0);
2111 }
2112 if (strcmp(cmdName, "@itcl-builtin-configure") == 0) {
2113 return Tcl_FindCommand(interp, "::itcl::builtin::configure", NULL, 0);
2114 }
2115 if (strcmp(cmdName, "@itcl-builtin-destroy") == 0) {
2116 return Tcl_FindCommand(interp, "::itcl::builtin::destroy", NULL, 0);
2117 }
2118 if (strncmp(cmdName, "@itcl-builtin-setget", 20) == 0) {
2119 return Tcl_FindCommand(interp, "::itcl::builtin::setget", NULL, 0);
2120 }
2121 if (strcmp(cmdName, "@itcl-builtin-isa") == 0) {
2122 return Tcl_FindCommand(interp, "::itcl::builtin::isa", NULL, 0);
2123 }
2124 if (strcmp(cmdName, "@itcl-builtin-createhull") == 0) {
2125 return Tcl_FindCommand(interp, "::itcl::builtin::createhull", NULL, 0);
2126 }
2127 if (strcmp(cmdName, "@itcl-builtin-keepcomponentoption") == 0) {
2128 return Tcl_FindCommand(interp, "::itcl::builtin::keepcomponentoption", NULL, 0);
2129 }
2130 if (strcmp(cmdName, "@itcl-builtin-ignorecomponentoption") == 0) {
2131 return Tcl_FindCommand(interp, "::itcl::builtin::removecomponentoption", NULL, 0);
2132 }
2133 if (strcmp(cmdName, "@itcl-builtin-irgnorecomponentoption") == 0) {
2134 return Tcl_FindCommand(interp, "::itcl::builtin::ignorecomponentoption", NULL, 0);
2135 }
2136 if (strcmp(cmdName, "@itcl-builtin-setupcomponent") == 0) {
2137 return Tcl_FindCommand(interp, "::itcl::builtin::setupcomponent", NULL, 0);
2138 }
2139 if (strcmp(cmdName, "@itcl-builtin-initoptions") == 0) {
2140 return Tcl_FindCommand(interp, "::itcl::builtin::initoptions", NULL, 0);
2141 }
2142 if (strcmp(cmdName, "@itcl-builtin-mytypemethod") == 0) {
2143 return Tcl_FindCommand(interp, "::itcl::builtin::mytypemethod",
2144 NULL, 0);
2145 }
2146 if (strcmp(cmdName, "@itcl-builtin-mymethod") == 0) {
2147 return Tcl_FindCommand(interp, "::itcl::builtin::mymethod",
2148 NULL, 0);
2149 }
2150 if (strcmp(cmdName, "@itcl-builtin-myproc") == 0) {
2151 return Tcl_FindCommand(interp, "::itcl::builtin::myproc",
2152 NULL, 0);
2153 }
2154 if (strcmp(cmdName, "@itcl-builtin-mytypevar") == 0) {
2155 return Tcl_FindCommand(interp, "::itcl::builtin::mytypevar",
2156 NULL, 0);
2157 }
2158 if (strcmp(cmdName, "@itcl-builtin-myvar") == 0) {
2159 return Tcl_FindCommand(interp, "::itcl::builtin::myvar",
2160 NULL, 0);
2161 }
2162 if (strcmp(cmdName, "@itcl-builtin-itcl_hull") == 0) {
2163 return Tcl_FindCommand(interp, "::itcl::builtin::itcl_hull",
2164 NULL, 0);
2165 }
2166 if (strcmp(cmdName, "@itcl-builtin-callinstance") == 0) {
2167 return Tcl_FindCommand(interp, "::itcl::builtin::callinstance",
2168 NULL, 0);
2169 }
2170 if (strcmp(cmdName, "@itcl-builtin-getinstancevar") == 0) {
2171 return Tcl_FindCommand(interp, "::itcl::builtin::getinstancevar",
2172 NULL, 0);
2173 }
2174 if (strcmp(cmdName, "@itcl-builtin-classunknown") == 0) {
2175 return Tcl_FindCommand(interp, "::itcl::builtin::classunknown", NULL, 0);
2176 }
2177 return NULL;
2178 }
2179 clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
2180 imPtr = clookup->imPtr;
2181 return imPtr->accessCmd;
2182 }
2183
2184 /*
2185 * ------------------------------------------------------------------------
2186 * Itcl_VarAliasProc()
2187 *
2188 * ------------------------------------------------------------------------
2189 */
2190 Tcl_Var
Itcl_VarAliasProc(TCL_UNUSED (Tcl_Interp *),Tcl_Namespace * nsPtr,const char * varName,ClientData clientData)2191 Itcl_VarAliasProc(
2192 TCL_UNUSED(Tcl_Interp*),
2193 Tcl_Namespace *nsPtr,
2194 const char *varName,
2195 ClientData clientData)
2196 {
2197
2198 Tcl_HashEntry *hPtr;
2199 ItclObjectInfo *infoPtr;
2200 ItclClass *iclsPtr;
2201 ItclObject *ioPtr;
2202 ItclVarLookup *ivlPtr;
2203 ItclResolveInfo *resolveInfoPtr;
2204 ItclCallContext *callContextPtr;
2205 Tcl_Var varPtr;
2206
2207 varPtr = NULL;
2208 hPtr = NULL;
2209 callContextPtr = NULL;
2210 resolveInfoPtr = (ItclResolveInfo *)clientData;
2211 if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) {
2212 ioPtr = resolveInfoPtr->ioPtr;
2213 iclsPtr = ioPtr->iclsPtr;
2214 } else {
2215 ioPtr = NULL;
2216 iclsPtr = resolveInfoPtr->iclsPtr;
2217 }
2218 infoPtr = iclsPtr->infoPtr;
2219 hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
2220 if (hPtr != NULL) {
2221 iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
2222 }
2223 hPtr = ItclResolveVarEntry(iclsPtr, varName);
2224 if (hPtr == NULL) {
2225 /* no class/object variable */
2226 return NULL;
2227 }
2228 ivlPtr = (ItclVarLookup *)Tcl_GetHashValue(hPtr);
2229 if (ivlPtr == NULL) {
2230 return NULL;
2231 }
2232 if (!ivlPtr->accessible) {
2233 return NULL;
2234 }
2235
2236 if (ioPtr != NULL) {
2237 hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables,
2238 (char *)ivlPtr->ivPtr);
2239 } else {
2240 hPtr = Tcl_FindHashEntry(&iclsPtr->classCommons,
2241 (char *)ivlPtr->ivPtr);
2242 if (hPtr == NULL) {
2243 if (callContextPtr != NULL) {
2244 ioPtr = callContextPtr->ioPtr;
2245 }
2246 if (ioPtr != NULL) {
2247 hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables,
2248 (char *)ivlPtr->ivPtr);
2249 }
2250 }
2251 }
2252 if (hPtr != NULL) {
2253 varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
2254 }
2255 return varPtr;
2256 }
2257
2258 /*
2259 * ------------------------------------------------------------------------
2260 * ItclCheckCallProc()
2261 *
2262 *
2263 * ------------------------------------------------------------------------
2264 */
2265 int
ItclCheckCallProc(ClientData clientData,Tcl_Interp * interp,TCL_UNUSED (Tcl_ObjectContext),TCL_UNUSED (Tcl_CallFrame *),int * isFinished)2266 ItclCheckCallProc(
2267 ClientData clientData,
2268 Tcl_Interp *interp,
2269 TCL_UNUSED(Tcl_ObjectContext),
2270 TCL_UNUSED(Tcl_CallFrame*),
2271 int *isFinished)
2272 {
2273 int result;
2274 ItclMemberFunc *imPtr;
2275
2276 imPtr = (ItclMemberFunc *)clientData;
2277 if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
2278 Itcl_SetCallFrameResolver(interp, imPtr->iclsPtr->resolvePtr);
2279 }
2280 result = TCL_OK;
2281
2282 if (isFinished != NULL) {
2283 *isFinished = 0;
2284 }
2285 return result;
2286 }
2287
2288 /*
2289 * ------------------------------------------------------------------------
2290 * ItclCheckCallMethod()
2291 *
2292 *
2293 * ------------------------------------------------------------------------
2294 */
2295 int
ItclCheckCallMethod(ClientData clientData,Tcl_Interp * interp,Tcl_ObjectContext contextPtr,Tcl_CallFrame * framePtr,int * isFinished)2296 ItclCheckCallMethod(
2297 ClientData clientData,
2298 Tcl_Interp *interp,
2299 Tcl_ObjectContext contextPtr,
2300 Tcl_CallFrame *framePtr,
2301 int *isFinished)
2302 {
2303 Itcl_Stack *stackPtr;
2304
2305 Tcl_Object oPtr;
2306 ItclObject *ioPtr;
2307 Tcl_HashEntry *hPtr;
2308 Tcl_Obj *const * cObjv;
2309 Tcl_Namespace *currNsPtr;
2310 ItclCallContext *callContextPtr;
2311 ItclCallContext *callContextPtr2;
2312 ItclMemberFunc *imPtr;
2313 int result;
2314 int isNew;
2315 int cObjc;
2316 int min_allowed_args;
2317
2318 ItclObjectInfo *infoPtr;
2319
2320 oPtr = NULL;
2321 hPtr = NULL;
2322 imPtr = (ItclMemberFunc *)clientData;
2323 Itcl_PreserveData(imPtr);
2324 if (imPtr->flags & ITCL_CONSTRUCTOR) {
2325 ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr;
2326 } else {
2327 if (contextPtr == NULL) {
2328 if ((imPtr->flags & ITCL_COMMON) ||
2329 (imPtr->codePtr->flags & ITCL_BUILTIN)) {
2330 if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
2331 Itcl_SetCallFrameResolver(interp,
2332 imPtr->iclsPtr->resolvePtr);
2333 }
2334 if (isFinished != NULL) {
2335 *isFinished = 0;
2336 }
2337 return TCL_OK;
2338 }
2339 Tcl_AppendResult(interp,
2340 "ItclCheckCallMethod cannot get context object (NULL)",
2341 " for ", Tcl_GetString(imPtr->fullNamePtr),
2342 NULL);
2343 result = TCL_ERROR;
2344 goto finishReturn;
2345 }
2346 oPtr = Tcl_ObjectContextObject(contextPtr);
2347 ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2348 imPtr->iclsPtr->infoPtr->object_meta_type);
2349 }
2350 if ((imPtr->codePtr != NULL) &&
2351 (imPtr->codePtr->flags & ITCL_IMPLEMENT_NONE)) {
2352 Tcl_AppendResult(interp, "member function \"",
2353 Tcl_GetString(imPtr->fullNamePtr),
2354 "\" is not defined and cannot be autoloaded", NULL);
2355 if (isFinished != NULL) {
2356 *isFinished = 1;
2357 }
2358 result = TCL_ERROR;
2359 goto finishReturn;
2360 }
2361 if (framePtr) {
2362 /*
2363 * This stanza is in place to seize control over usage error messages
2364 * before TclOO examines the arguments and produces its own. This
2365 * gives Itcl stability in its error messages at the cost of inconsistency
2366 * with Tcl's evolving conventions.
2367 */
2368 cObjc = Itcl_GetCallFrameObjc(interp);
2369 cObjv = Itcl_GetCallFrameObjv(interp);
2370 min_allowed_args = cObjc-2;
2371 if (strcmp(Tcl_GetString(cObjv[0]), "next") == 0) {
2372 min_allowed_args++;
2373 }
2374 if (min_allowed_args < imPtr->argcount) {
2375 Tcl_AppendResult(interp, "wrong # args: should be \"",
2376 Tcl_GetString(cObjv[0]), " ", Tcl_GetString(imPtr->namePtr),
2377 " ", Tcl_GetString(imPtr->usagePtr), "\"", NULL);
2378 if (isFinished != NULL) {
2379 *isFinished = 1;
2380 }
2381 result = TCL_ERROR;
2382 goto finishReturn;
2383 }
2384 }
2385 isNew = 0;
2386 callContextPtr = NULL;
2387 currNsPtr = Tcl_GetCurrentNamespace(interp);
2388 if (ioPtr != NULL) {
2389 hPtr = Tcl_CreateHashEntry(&ioPtr->contextCache, (char *)imPtr, &isNew);
2390 if (!isNew) {
2391 callContextPtr2 = (ItclCallContext *)Tcl_GetHashValue(hPtr);
2392 if (callContextPtr2->refCount == 0) {
2393 callContextPtr = callContextPtr2;
2394 callContextPtr->objectFlags = ioPtr->flags;
2395 callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp);
2396 callContextPtr->ioPtr = ioPtr;
2397 callContextPtr->imPtr = imPtr;
2398 callContextPtr->refCount = 1;
2399 } else {
2400 if ((callContextPtr2->objectFlags == ioPtr->flags)
2401 && (callContextPtr2->nsPtr == currNsPtr)) {
2402 callContextPtr = callContextPtr2;
2403 callContextPtr->refCount++;
2404 }
2405 }
2406 }
2407 }
2408 if (callContextPtr == NULL) {
2409 callContextPtr = (ItclCallContext *)ckalloc(
2410 sizeof(ItclCallContext));
2411 if (ioPtr == NULL) {
2412 callContextPtr->objectFlags = 0;
2413 callContextPtr->ioPtr = NULL;
2414 } else {
2415 callContextPtr->objectFlags = ioPtr->flags;
2416 callContextPtr->ioPtr = ioPtr;
2417 }
2418 callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp);
2419 callContextPtr->imPtr = imPtr;
2420 callContextPtr->refCount = 1;
2421 }
2422 if (isNew) {
2423 Tcl_SetHashValue(hPtr, callContextPtr);
2424 }
2425
2426 if (framePtr == NULL) {
2427 framePtr = Itcl_GetUplevelCallFrame(interp, 0);
2428 }
2429
2430 isNew = 0;
2431 infoPtr = imPtr->iclsPtr->infoPtr;
2432 hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
2433 (char *)framePtr, &isNew);
2434 if (isNew) {
2435 stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack));
2436 Itcl_InitStack(stackPtr);
2437 Tcl_SetHashValue(hPtr, stackPtr);
2438 } else {
2439 stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
2440 }
2441
2442 assert (callContextPtr) ;
2443 Itcl_PushStack(callContextPtr, stackPtr);
2444
2445 /* Ugly abuse alert. Two maps in one table */
2446 hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
2447 (char *)contextPtr, &isNew);
2448 if (isNew) {
2449 stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack));
2450 Itcl_InitStack(stackPtr);
2451 Tcl_SetHashValue(hPtr, stackPtr);
2452 } else {
2453 stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
2454 }
2455
2456 Itcl_PushStack(framePtr, stackPtr);
2457
2458 if (ioPtr != NULL) {
2459 ioPtr->callRefCount++;
2460 Itcl_PreserveData(ioPtr); /* ++ preserve until ItclAfterCallMethod releases it */
2461 }
2462 imPtr->iclsPtr->callRefCount++;
2463 if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
2464 Itcl_SetCallFrameResolver(interp, ioPtr->resolvePtr);
2465 }
2466 result = TCL_OK;
2467
2468 if (isFinished != NULL) {
2469 *isFinished = 0;
2470 }
2471 return result;
2472 finishReturn:
2473 Itcl_ReleaseData(imPtr);
2474 return result;
2475 }
2476
2477 /*
2478 * ------------------------------------------------------------------------
2479 * ItclAfterCallMethod()
2480 *
2481 *
2482 * ------------------------------------------------------------------------
2483 */
2484 int
ItclAfterCallMethod(ClientData clientData,Tcl_Interp * interp,Tcl_ObjectContext contextPtr,TCL_UNUSED (Tcl_Namespace *),int call_result)2485 ItclAfterCallMethod(
2486 ClientData clientData,
2487 Tcl_Interp *interp,
2488 Tcl_ObjectContext contextPtr,
2489 TCL_UNUSED(Tcl_Namespace*),
2490 int call_result)
2491 {
2492 Tcl_HashEntry *hPtr;
2493 ItclObject *ioPtr;
2494 ItclMemberFunc *imPtr;
2495 ItclCallContext *callContextPtr;
2496 int newEntry;
2497 int result;
2498
2499 imPtr = (ItclMemberFunc *)clientData;
2500 callContextPtr = NULL;
2501 if (contextPtr != NULL) {
2502 ItclObjectInfo *infoPtr = imPtr->infoPtr;
2503 Tcl_CallFrame *framePtr;
2504 Itcl_Stack *stackPtr;
2505
2506 hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)contextPtr);
2507 assert(hPtr);
2508 stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
2509 framePtr = (Tcl_CallFrame *)Itcl_PopStack(stackPtr);
2510 if (Itcl_GetStackSize(stackPtr) == 0) {
2511 Itcl_DeleteStack(stackPtr);
2512 ckfree((char *) stackPtr);
2513 Tcl_DeleteHashEntry(hPtr);
2514 }
2515
2516 hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr);
2517 assert(hPtr);
2518 stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
2519 callContextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr);
2520 if (Itcl_GetStackSize(stackPtr) == 0) {
2521 Itcl_DeleteStack(stackPtr);
2522 ckfree((char *) stackPtr);
2523 Tcl_DeleteHashEntry(hPtr);
2524 }
2525 }
2526 if (callContextPtr == NULL) {
2527 if ((imPtr->flags & ITCL_COMMON) ||
2528 (imPtr->codePtr->flags & ITCL_BUILTIN)) {
2529 result = call_result;
2530 goto finishReturn;
2531 }
2532 Tcl_AppendResult(interp,
2533 "ItclAfterCallMethod cannot get context object (NULL)",
2534 " for ", Tcl_GetString(imPtr->fullNamePtr), NULL);
2535 result = TCL_ERROR;
2536 goto finishReturn;
2537 }
2538 /*
2539 * If this is a constructor or destructor, and if it is being
2540 * invoked at the appropriate time, keep track of which methods
2541 * have been called. This information is used to implicitly
2542 * invoke constructors/destructors as needed.
2543 */
2544 ioPtr = callContextPtr->ioPtr;
2545 if (ioPtr != NULL) {
2546 if (imPtr->iclsPtr) {
2547 imPtr->iclsPtr->callRefCount--;
2548 if (imPtr->flags & (ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR)) {
2549 if ((imPtr->flags & ITCL_DESTRUCTOR) && ioPtr &&
2550 ioPtr->destructed) {
2551 Tcl_CreateHashEntry(ioPtr->destructed,
2552 (char *)imPtr->iclsPtr->namePtr, &newEntry);
2553 }
2554 if ((imPtr->flags & ITCL_CONSTRUCTOR) && ioPtr &&
2555 ioPtr->constructed) {
2556 Tcl_CreateHashEntry(ioPtr->constructed,
2557 (char *)imPtr->iclsPtr->namePtr, &newEntry);
2558 }
2559 }
2560 }
2561 ioPtr->callRefCount--;
2562 if (ioPtr->flags & ITCL_OBJECT_SHOULD_VARNS_DELETE) {
2563 ItclDeleteObjectVariablesNamespace(interp, ioPtr);
2564 }
2565 }
2566
2567 if (callContextPtr->refCount-- <= 1) {
2568 if (callContextPtr->ioPtr != NULL) {
2569 hPtr = Tcl_FindHashEntry(&callContextPtr->ioPtr->contextCache,
2570 (char *)callContextPtr->imPtr);
2571 if (hPtr == NULL) {
2572 ckfree((char *)callContextPtr);
2573 }
2574 } else {
2575 ckfree((char *)callContextPtr);
2576 }
2577 }
2578
2579 if (ioPtr != NULL) {
2580 Itcl_ReleaseData(ioPtr); /* -- paired release for preserve in ItclCheckCallMethod */
2581 }
2582 result = call_result;
2583 finishReturn:
2584 Itcl_ReleaseData(imPtr);
2585 return result;
2586 }
2587
2588 void
ItclProcErrorProc(Tcl_Interp * interp,TCL_UNUSED (Tcl_Obj *))2589 ItclProcErrorProc(
2590 Tcl_Interp *interp,
2591 TCL_UNUSED(Tcl_Obj*))
2592 {
2593 Tcl_Obj *objPtr;
2594 Tcl_HashEntry *hPtr;
2595 ItclObjectInfo *infoPtr;
2596 ItclCallContext *callContextPtr;
2597 ItclMemberFunc *imPtr;
2598 ItclObject *contextIoPtr;
2599 ItclClass *currIclsPtr;
2600 char num[20];
2601 Itcl_Stack *stackPtr;
2602
2603 /* Fetch the current call frame. That determines context. */
2604 Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
2605
2606 /* Try to map it to a context stack. */
2607 infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
2608 ITCL_INTERP_DATA, NULL);
2609 hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr);
2610 if (hPtr == NULL) {
2611 /* Can this happen? */
2612 return;
2613 }
2614
2615 /* Frame maps to a context stack. */
2616 stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
2617 callContextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr);
2618
2619 if (callContextPtr == NULL) {
2620 return;
2621 }
2622
2623 currIclsPtr = NULL;
2624 objPtr = NULL;
2625 {
2626 imPtr = callContextPtr->imPtr;
2627 contextIoPtr = callContextPtr->ioPtr;
2628 objPtr = Tcl_NewStringObj("\n ", -1);
2629
2630 if (imPtr->flags & ITCL_CONSTRUCTOR) {
2631 currIclsPtr = imPtr->iclsPtr;
2632 Tcl_AppendToObj(objPtr, "while constructing object \"", -1);
2633 Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
2634 Tcl_AppendToObj(objPtr, "\" in ", -1);
2635 Tcl_AppendToObj(objPtr, currIclsPtr->nsPtr->fullName, -1);
2636 Tcl_AppendToObj(objPtr, "::constructor", -1);
2637 if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
2638 Tcl_AppendToObj(objPtr, " (", -1);
2639 }
2640 }
2641 if (imPtr->flags & ITCL_DESTRUCTOR) {
2642 contextIoPtr->flags = 0;
2643 Tcl_AppendToObj(objPtr, "while deleting object \"", -1);
2644 Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
2645 Tcl_AppendToObj(objPtr, "\" in ", -1);
2646 Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1);
2647 if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
2648 Tcl_AppendToObj(objPtr, " (", -1);
2649 }
2650 }
2651 if (!(imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR))) {
2652 Tcl_AppendToObj(objPtr, "(", -1);
2653
2654 hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr);
2655 if (hPtr != NULL) {
2656 if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd)) {
2657 Tcl_AppendToObj(objPtr, "object \"", -1);
2658 Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
2659 Tcl_AppendToObj(objPtr, "\" ", -1);
2660 }
2661 }
2662
2663 if ((imPtr->flags & ITCL_COMMON) != 0) {
2664 Tcl_AppendToObj(objPtr, "procedure", -1);
2665 } else {
2666 Tcl_AppendToObj(objPtr, "method", -1);
2667 }
2668 Tcl_AppendToObj(objPtr, " \"", -1);
2669 Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), -1);
2670 Tcl_AppendToObj(objPtr, "\" ", -1);
2671 }
2672
2673 if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
2674 Tcl_Obj *dictPtr;
2675 Tcl_Obj *keyPtr;
2676 Tcl_Obj *valuePtr;
2677 int lineNo;
2678
2679 keyPtr = Tcl_NewStringObj("-errorline", -1);
2680 dictPtr = Tcl_GetReturnOptions(interp, TCL_ERROR);
2681 if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
2682 /* how should we handle an error ? */
2683 Tcl_DecrRefCount(dictPtr);
2684 Tcl_DecrRefCount(keyPtr);
2685 Tcl_DecrRefCount(objPtr);
2686 return;
2687 }
2688 if (valuePtr == NULL) {
2689 /* how should we handle an error ? */
2690 Tcl_DecrRefCount(dictPtr);
2691 Tcl_DecrRefCount(keyPtr);
2692 Tcl_DecrRefCount(objPtr);
2693 return;
2694 }
2695 if (Tcl_GetIntFromObj(interp, valuePtr, &lineNo) != TCL_OK) {
2696 /* how should we handle an error ? */
2697 Tcl_DecrRefCount(dictPtr);
2698 Tcl_DecrRefCount(keyPtr);
2699 Tcl_DecrRefCount(objPtr);
2700 return;
2701 }
2702 Tcl_DecrRefCount(dictPtr);
2703 Tcl_DecrRefCount(keyPtr);
2704 Tcl_AppendToObj(objPtr, "body line ", -1);
2705 sprintf(num, "%d", lineNo);
2706 Tcl_AppendToObj(objPtr, num, -1);
2707 Tcl_AppendToObj(objPtr, ")", -1);
2708 } else {
2709 Tcl_AppendToObj(objPtr, ")", -1);
2710 }
2711
2712 Tcl_AppendObjToErrorInfo(interp, objPtr);
2713 objPtr = NULL;
2714 }
2715 if (objPtr != NULL) {
2716 Tcl_DecrRefCount(objPtr);
2717 }
2718 }
2719