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 * This segment handles "objects" which are instantiated from class 16 * definitions. Objects contain public/protected/private data members 17 * from all classes in a derivation hierarchy. 18 * 19 * ======================================================================== 20 * AUTHOR: Michael J. McLennan 21 * Bell Labs Innovations for Lucent Technologies 22 * mmclennan@lucent.com 23 * http://www.tcltk.com/itcl 24 * 25 * RCS: $Id: itcl_objects.c,v 1.17 2007/08/07 20:05:30 msofer Exp $ 26 * ======================================================================== 27 * Copyright (c) 1993-1998 Lucent Technologies, Inc. 28 * ------------------------------------------------------------------------ 29 * See the file "license.terms" for information on usage and redistribution 30 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 31 */ 32#include "itclInt.h" 33 34/* 35 * FORWARD DECLARATIONS 36 */ 37static void ItclReportObjectUsage _ANSI_ARGS_((Tcl_Interp *interp, 38 ItclObject* obj)); 39 40static char* ItclTraceThisVar _ANSI_ARGS_((ClientData cdata, 41 Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); 42 43static void ItclDestroyObject _ANSI_ARGS_((ClientData cdata)); 44static void ItclFreeObject _ANSI_ARGS_((char* cdata)); 45 46static int ItclDestructBase _ANSI_ARGS_((Tcl_Interp *interp, 47 ItclObject* obj, ItclClass* cdefn, int flags)); 48 49static void ItclCreateObjVar _ANSI_ARGS_((Tcl_Interp *interp, 50 ItclVarDefn* vdefn, ItclObject* obj)); 51 52 53/* 54 * ------------------------------------------------------------------------ 55 * Itcl_CreateObject() 56 * 57 * Creates a new object instance belonging to the given class. 58 * Supports complex object names like "namesp::namesp::name" by 59 * following the namespace path and creating the object in the 60 * desired namespace. 61 * 62 * Automatically creates and initializes data members, including the 63 * built-in protected "this" variable containing the object name. 64 * Installs an access command in the current namespace, and invokes 65 * the constructor to initialize the object. 66 * 67 * If any errors are encountered, the object is destroyed and this 68 * procedure returns TCL_ERROR (along with an error message in the 69 * interpreter). Otherwise, it returns TCL_OK, along with a pointer 70 * to the new object data in roPtr. 71 * ------------------------------------------------------------------------ 72 */ 73int 74Itcl_CreateObject(interp, name, cdefn, objc, objv, roPtr) 75 Tcl_Interp *interp; /* interpreter mananging new object */ 76 CONST char* name; /* name of new object */ 77 ItclClass *cdefn; /* class for new object */ 78 int objc; /* number of arguments */ 79 Tcl_Obj *CONST objv[]; /* argument objects */ 80 ItclObject **roPtr; /* returns: pointer to object data */ 81{ 82 ItclClass *cdefnPtr = (ItclClass*)cdefn; 83 int result = TCL_OK; 84 85 char *head, *tail; 86 Tcl_DString buffer, objName; 87 Tcl_Namespace *parentNs; 88 ItclContext context; 89 Tcl_Command cmd; 90 ItclObject *newObj; 91 ItclClass *cdPtr; 92 ItclVarDefn *vdefn; 93 ItclHierIter hier; 94 Tcl_HashEntry *entry; 95 Tcl_HashSearch place; 96 int newEntry; 97 Itcl_InterpState istate; 98 99 /* 100 * If installing an object access command will clobber another 101 * command, signal an error. Be careful to look for the object 102 * only in the current namespace context. Otherwise, we might 103 * find a global command, but that wouldn't be clobbered! 104 */ 105 cmd = Tcl_FindCommand(interp, (CONST84 char *)name, 106 (Tcl_Namespace*)NULL, TCL_NAMESPACE_ONLY); 107 108 if (cmd != NULL && !Itcl_IsStub(cmd)) { 109 Tcl_AppendResult(interp, 110 "command \"", name, "\" already exists in namespace \"", 111 Tcl_GetCurrentNamespace(interp)->fullName, "\"", 112 (char*) NULL); 113 return TCL_ERROR; 114 } 115 116 /* 117 * Extract the namespace context and the simple object 118 * name for the new object. 119 */ 120 Itcl_ParseNamespPath(name, &buffer, &head, &tail); 121 if (head) { 122 parentNs = Itcl_FindClassNamespace(interp, head); 123 124 if (!parentNs) { 125 Tcl_AppendResult(interp, 126 "namespace \"", head, "\" not found in context \"", 127 Tcl_GetCurrentNamespace(interp)->fullName, "\"", 128 (char *) NULL); 129 Tcl_DStringFree(&buffer); 130 return TCL_ERROR; 131 } 132 } else { 133 parentNs = Tcl_GetCurrentNamespace(interp); 134 } 135 136 Tcl_DStringInit(&objName); 137 if (parentNs != Tcl_GetGlobalNamespace(interp)) { 138 Tcl_DStringAppend(&objName, parentNs->fullName, -1); 139 } 140 Tcl_DStringAppend(&objName, "::", -1); 141 Tcl_DStringAppend(&objName, tail, -1); 142 143 /* 144 * Create a new object and initialize it. 145 */ 146 newObj = (ItclObject*)ckalloc(sizeof(ItclObject)); 147 newObj->classDefn = cdefnPtr; 148 Itcl_PreserveData((ClientData)cdefnPtr); 149 150 newObj->dataSize = cdefnPtr->numInstanceVars; 151 newObj->data = (Var**)ckalloc((unsigned)(newObj->dataSize*sizeof(Var*))); 152 153 newObj->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); 154 Tcl_InitHashTable(newObj->constructed, TCL_STRING_KEYS); 155 newObj->destructed = NULL; 156 157 /* 158 * Add a command to the current namespace with the object name. 159 * This is done before invoking the constructors so that the 160 * command can be used during construction to query info. 161 */ 162 Itcl_PreserveData((ClientData)newObj); 163 newObj->accessCmd = Tcl_CreateObjCommand(interp, 164 Tcl_DStringValue(&objName), Itcl_HandleInstance, 165 (ClientData)newObj, ItclDestroyObject); 166 167 Itcl_PreserveData((ClientData)newObj); /* while we're using this... */ 168 Itcl_EventuallyFree((ClientData)newObj, ItclFreeObject); 169 170 Tcl_DStringFree(&buffer); 171 Tcl_DStringFree(&objName); 172 173 /* 174 * Install the class namespace and object context so that 175 * the object's data members can be initialized via simple 176 * "set" commands. 177 */ 178 if (Itcl_PushContext(interp, (ItclMember*)NULL, cdefnPtr, newObj, 179 &context) != TCL_OK) { 180 181 return TCL_ERROR; 182 } 183 184 Itcl_InitHierIter(&hier, cdefn); 185 186 cdPtr = Itcl_AdvanceHierIter(&hier); 187 while (cdPtr != NULL) { 188 entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); 189 while (entry) { 190 vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); 191 if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { 192 if (cdPtr == cdefnPtr) { 193 ItclCreateObjVar(interp, vdefn, newObj); 194 Tcl_SetVar2(interp, "this", (char*)NULL, "", 0); 195 Tcl_TraceVar2(interp, "this", NULL, 196 TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar, 197 (ClientData)newObj); 198 } 199 } 200 else if ( (vdefn->member->flags & ITCL_COMMON) == 0) { 201 ItclCreateObjVar(interp, vdefn, newObj); 202 } 203 entry = Tcl_NextHashEntry(&place); 204 } 205 cdPtr = Itcl_AdvanceHierIter(&hier); 206 } 207 Itcl_DeleteHierIter(&hier); 208 209 Itcl_PopContext(interp, &context); /* back to calling context */ 210 211 /* 212 * Now construct the object. Look for a constructor in the 213 * most-specific class, and if there is one, invoke it. 214 * This will cause a chain reaction, making sure that all 215 * base classes constructors are invoked as well, in order 216 * from least- to most-specific. Any constructors that are 217 * not called out explicitly in "initCode" code fragments are 218 * invoked implicitly without arguments. 219 */ 220 result = Itcl_InvokeMethodIfExists(interp, "constructor", 221 cdefn, newObj, objc, objv); 222 223 /* 224 * If there is no constructor, construct the base classes 225 * in case they have constructors. This will cause the 226 * same chain reaction. 227 */ 228 if (!Tcl_FindHashEntry(&cdefn->functions, "constructor")) { 229 result = Itcl_ConstructBase(interp, newObj, cdefn); 230 } 231 232 /* 233 * If construction failed, then delete the object access 234 * command. This will destruct the object and delete the 235 * object data. Be careful to save and restore the interpreter 236 * state, since the destructors may generate errors of their own. 237 */ 238 if (result != TCL_OK) { 239 istate = Itcl_SaveInterpState(interp, result); 240 241 /* Bug 227824. 242 * The constructor may destroy the object, possibly indirectly 243 * through the destruction of the main widget in the iTk 244 * megawidget it tried to construct. If this happens we must 245 * not try to destroy the access command a second time. 246 */ 247 if (newObj->accessCmd != (Tcl_Command) NULL) { 248 Tcl_DeleteCommandFromToken(interp, newObj->accessCmd); 249 newObj->accessCmd = NULL; 250 } 251 result = Itcl_RestoreInterpState(interp, istate); 252 } 253 254 /* 255 * At this point, the object is fully constructed. 256 * Destroy the "constructed" table in the object data, since 257 * it is no longer needed. 258 */ 259 Tcl_DeleteHashTable(newObj->constructed); 260 ckfree((char*)newObj->constructed); 261 newObj->constructed = NULL; 262 263 /* 264 * Add it to the list of all known objects. The only 265 * tricky thing to watch out for is the case where the 266 * object deleted itself inside its own constructor. 267 * In that case, we don't want to add the object to 268 * the list of valid objects. We can determine that 269 * the object deleted itself by checking to see if 270 * its accessCmd member is NULL. 271 */ 272 if (result == TCL_OK && (newObj->accessCmd != NULL)) { 273 entry = Tcl_CreateHashEntry(&cdefnPtr->info->objects, 274 (char*)newObj->accessCmd, &newEntry); 275 276 Tcl_SetHashValue(entry, (ClientData)newObj); 277 } 278 279 /* 280 * Release the object. If it was destructed above, it will 281 * die at this point. 282 */ 283 Itcl_ReleaseData((ClientData)newObj); 284 285 *roPtr = newObj; 286 return result; 287} 288 289 290/* 291 * ------------------------------------------------------------------------ 292 * Itcl_DeleteObject() 293 * 294 * Attempts to delete an object by invoking its destructor. 295 * 296 * If the destructor is successful, then the object is deleted by 297 * removing its access command, and this procedure returns TCL_OK. 298 * Otherwise, the object will remain alive, and this procedure 299 * returns TCL_ERROR (along with an error message in the interpreter). 300 * ------------------------------------------------------------------------ 301 */ 302int 303Itcl_DeleteObject(interp, contextObj) 304 Tcl_Interp *interp; /* interpreter mananging object */ 305 ItclObject *contextObj; /* object to be deleted */ 306{ 307 ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; 308 309 Tcl_HashEntry *entry; 310 Command *cmdPtr; 311 312 Itcl_PreserveData((ClientData)contextObj); 313 314 /* 315 * Invoke the object's destructors. 316 */ 317 if (Itcl_DestructObject(interp, contextObj, 0) != TCL_OK) { 318 Itcl_ReleaseData((ClientData)contextObj); 319 return TCL_ERROR; 320 } 321 322 /* 323 * Remove the object from the global list. 324 */ 325 entry = Tcl_FindHashEntry(&cdefnPtr->info->objects, 326 (char*)contextObj->accessCmd); 327 328 if (entry) { 329 Tcl_DeleteHashEntry(entry); 330 } 331 332 /* 333 * Change the object's access command so that it can be 334 * safely deleted without attempting to destruct the object 335 * again. Then delete the access command. If this is 336 * the last use of the object data, the object will die here. 337 */ 338 cmdPtr = (Command*)contextObj->accessCmd; 339 cmdPtr->deleteProc = Itcl_ReleaseData; 340 341 Tcl_DeleteCommandFromToken(interp, contextObj->accessCmd); 342 contextObj->accessCmd = NULL; 343 344 Itcl_ReleaseData((ClientData)contextObj); /* object should die here */ 345 346 return TCL_OK; 347} 348 349 350/* 351 * ------------------------------------------------------------------------ 352 * Itcl_DestructObject() 353 * 354 * Invokes the destructor for a particular object. Usually invoked 355 * by Itcl_DeleteObject() or Itcl_DestroyObject() as a part of the 356 * object destruction process. If the ITCL_IGNORE_ERRS flag is 357 * included, all destructors are invoked even if errors are 358 * encountered, and the result will always be TCL_OK. 359 * 360 * Returns TCL_OK on success, or TCL_ERROR (along with an error 361 * message in the interpreter) if anything goes wrong. 362 * ------------------------------------------------------------------------ 363 */ 364int 365Itcl_DestructObject(interp, contextObj, flags) 366 Tcl_Interp *interp; /* interpreter mananging new object */ 367 ItclObject *contextObj; /* object to be destructed */ 368 int flags; /* flags: ITCL_IGNORE_ERRS */ 369{ 370 int result; 371 372 /* 373 * If there is a "destructed" table, then this object is already 374 * being destructed. Flag an error, unless errors are being 375 * ignored. 376 */ 377 if (contextObj->destructed) { 378 if ((flags & ITCL_IGNORE_ERRS) == 0) { 379 Tcl_AppendResult(interp, 380 "can't delete an object while it is being destructed", 381 (char*)NULL); 382 return TCL_ERROR; 383 } 384 return TCL_OK; 385 } 386 387 /* 388 * Create a "destructed" table to keep track of which destructors 389 * have been invoked. This is used in ItclDestructBase to make 390 * sure that all base class destructors have been called, 391 * explicitly or implicitly. 392 */ 393 contextObj->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); 394 Tcl_InitHashTable(contextObj->destructed, TCL_STRING_KEYS); 395 396 /* 397 * Destruct the object starting from the most-specific class. 398 * If all goes well, return the null string as the result. 399 */ 400 result = ItclDestructBase(interp, contextObj, contextObj->classDefn, flags); 401 402 if (result == TCL_OK) { 403 Tcl_ResetResult(interp); 404 } 405 406 Tcl_DeleteHashTable(contextObj->destructed); 407 ckfree((char*)contextObj->destructed); 408 contextObj->destructed = NULL; 409 410 return result; 411} 412 413/* 414 * ------------------------------------------------------------------------ 415 * ItclDestructBase() 416 * 417 * Invoked by Itcl_DestructObject() to recursively destruct an object 418 * from the specified class level. Finds and invokes the destructor 419 * for the specified class, and then recursively destructs all base 420 * classes. If the ITCL_IGNORE_ERRS flag is included, all destructors 421 * are invoked even if errors are encountered, and the result will 422 * always be TCL_OK. 423 * 424 * Returns TCL_OK on success, or TCL_ERROR (along with an error message 425 * in interp->result) on error. 426 * ------------------------------------------------------------------------ 427 */ 428static int 429ItclDestructBase(interp, contextObj, contextClass, flags) 430 Tcl_Interp *interp; /* interpreter */ 431 ItclObject *contextObj; /* object being destructed */ 432 ItclClass *contextClass; /* current class being destructed */ 433 int flags; /* flags: ITCL_IGNORE_ERRS */ 434{ 435 int result; 436 Itcl_ListElem *elem; 437 ItclClass *cdefn; 438 439 /* 440 * Look for a destructor in this class, and if found, 441 * invoke it. 442 */ 443 if (!Tcl_FindHashEntry(contextObj->destructed, contextClass->fullname)) { 444 445 result = Itcl_InvokeMethodIfExists(interp, "destructor", 446 contextClass, contextObj, 0, (Tcl_Obj* CONST*)NULL); 447 448 if (result != TCL_OK) { 449 return TCL_ERROR; 450 } 451 } 452 453 /* 454 * Scan through the list of base classes recursively and destruct 455 * them. Traverse the list in normal order, so that we destruct 456 * from most- to least-specific. 457 */ 458 elem = Itcl_FirstListElem(&contextClass->bases); 459 while (elem) { 460 cdefn = (ItclClass*)Itcl_GetListValue(elem); 461 462 if (ItclDestructBase(interp, contextObj, cdefn, flags) != TCL_OK) { 463 return TCL_ERROR; 464 } 465 elem = Itcl_NextListElem(elem); 466 } 467 468 /* 469 * Throw away any result from the destructors and return. 470 */ 471 Tcl_ResetResult(interp); 472 return TCL_OK; 473} 474 475 476/* 477 * ------------------------------------------------------------------------ 478 * Itcl_FindObject() 479 * 480 * Searches for an object with the specified name, which have 481 * namespace scope qualifiers like "namesp::namesp::name", or may 482 * be a scoped value such as "namespace inscope ::foo obj". 483 * 484 * If an error is encountered, this procedure returns TCL_ERROR 485 * along with an error message in the interpreter. Otherwise, it 486 * returns TCL_OK. If an object was found, "roPtr" returns a 487 * pointer to the object data. Otherwise, it returns NULL. 488 * ------------------------------------------------------------------------ 489 */ 490int 491Itcl_FindObject(interp, name, roPtr) 492 Tcl_Interp *interp; /* interpreter containing this object */ 493 CONST char *name; /* name of the object */ 494 ItclObject **roPtr; /* returns: object data or NULL */ 495{ 496 Tcl_Namespace *contextNs = NULL; 497 498 char *cmdName; 499 Tcl_Command cmd; 500 Command *cmdPtr; 501 502 /* 503 * The object name may be a scoped value of the form 504 * "namespace inscope <namesp> <command>". If it is, 505 * decode it. 506 */ 507 if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName) 508 != TCL_OK) { 509 return TCL_ERROR; 510 } 511 512 /* 513 * Look for the object's access command, and see if it has 514 * the appropriate command handler. 515 */ 516 cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0); 517 if (cmd != NULL && Itcl_IsObject(cmd)) { 518 cmdPtr = (Command*)cmd; 519 *roPtr = (ItclObject*)cmdPtr->objClientData; 520 } 521 else { 522 *roPtr = NULL; 523 } 524 525 ckfree(cmdName); 526 527 return TCL_OK; 528} 529 530 531/* 532 * ------------------------------------------------------------------------ 533 * Itcl_IsObject() 534 * 535 * Checks the given Tcl command to see if it represents an itcl object. 536 * Returns non-zero if the command is associated with an object. 537 * ------------------------------------------------------------------------ 538 */ 539int 540Itcl_IsObject(cmd) 541 Tcl_Command cmd; /* command being tested */ 542{ 543 Command *cmdPtr = (Command*)cmd; 544 545 if (cmdPtr->deleteProc == ItclDestroyObject) { 546 return 1; 547 } 548 549 /* 550 * This may be an imported command. Try to get the real 551 * command and see if it represents an object. 552 */ 553 cmdPtr = (Command*)TclGetOriginalCommand(cmd); 554 if (cmdPtr && cmdPtr->deleteProc == ItclDestroyObject) { 555 return 1; 556 } 557 return 0; 558} 559 560 561/* 562 * ------------------------------------------------------------------------ 563 * Itcl_ObjectIsa() 564 * 565 * Checks to see if an object belongs to the given class. An object 566 * "is-a" member of the class if the class appears anywhere in its 567 * inheritance hierarchy. Returns non-zero if the object belongs to 568 * the class, and zero otherwise. 569 * ------------------------------------------------------------------------ 570 */ 571int 572Itcl_ObjectIsa(contextObj, cdefn) 573 ItclObject *contextObj; /* object being tested */ 574 ItclClass *cdefn; /* class to test for "is-a" relationship */ 575{ 576 Tcl_HashEntry *entry; 577 entry = Tcl_FindHashEntry(&contextObj->classDefn->heritage, (char*)cdefn); 578 return (entry != NULL); 579} 580 581 582/* 583 * ------------------------------------------------------------------------ 584 * Itcl_HandleInstance() 585 * 586 * Invoked by Tcl whenever the user issues a command associated with 587 * an object instance. Handles the following syntax: 588 * 589 * <objName> <method> <args>... 590 * 591 * ------------------------------------------------------------------------ 592 */ 593int 594Itcl_HandleInstance(clientData, interp, objc, objv) 595 ClientData clientData; /* object definition */ 596 Tcl_Interp *interp; /* current interpreter */ 597 int objc; /* number of arguments */ 598 Tcl_Obj *CONST objv[]; /* argument objects */ 599{ 600 ItclObject *contextObj = (ItclObject*)clientData; 601 602 int result; 603 char *token; 604 Tcl_HashEntry *entry; 605 ItclMemberFunc *mfunc; 606 ItclObjectInfo *info; 607 ItclContext context; 608 ItclCallFrame *framePtr; 609 610 if (objc < 2) { 611 Tcl_AppendResult(interp, 612 "wrong # args: should be one of...", 613 (char *) NULL); 614 ItclReportObjectUsage(interp, contextObj); 615 return TCL_ERROR; 616 } 617 618 /* 619 * Make sure that the specified operation is really an 620 * object method, and it is accessible. If not, return usage 621 * information for the object. 622 */ 623 token = Tcl_GetStringFromObj(objv[1], (int*)NULL); 624 mfunc = NULL; 625 626 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, token); 627 if (entry) { 628 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 629 630 if ((mfunc->member->flags & ITCL_COMMON) != 0) { 631 mfunc = NULL; 632 } 633 else if (mfunc->member->protection != ITCL_PUBLIC) { 634 Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, 635 mfunc->member->classDefn->info); 636 637 if (!Itcl_CanAccessFunc(mfunc, contextNs)) { 638 mfunc = NULL; 639 } 640 } 641 } 642 643 if ( !mfunc && (*token != 'i' || strcmp(token,"info") != 0) ) { 644 Tcl_AppendResult(interp, 645 "bad option \"", token, "\": should be one of...", 646 (char*)NULL); 647 ItclReportObjectUsage(interp, contextObj); 648 return TCL_ERROR; 649 } 650 651 /* 652 * Install an object context and invoke the method. 653 * 654 * TRICKY NOTE: We need to pass the object context into the 655 * method, but activating the context here puts us one level 656 * down, and when the method is called, it will activate its 657 * own context, putting us another level down. If anyone 658 * were to execute an "uplevel" command in the method, they 659 * would notice the extra call frame. So we mark this frame 660 * as "transparent" and Itcl_EvalMemberCode will automatically 661 * do an "uplevel" operation to correct the problem. 662 */ 663 info = contextObj->classDefn->info; 664 665 if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn, 666 contextObj, &context) != TCL_OK) { 667 668 return TCL_ERROR; 669 } 670 671 framePtr = &context.frame; 672 Itcl_PushStack((ClientData)framePtr, &info->transparentFrames); 673 674 /* Bug 227824 675 * The tcl core will blow up in 'TclLookupVar' if we don't reset 676 * the 'isProcCallFrame'. This happens because without the 677 * callframe refered to by 'framePtr' will be inconsistent 678 * ('isProcCallFrame' set, but 'procPtr' not set). 679 */ 680 if (*token == 'i' && strcmp(token,"info") == 0) { 681 framePtr->isProcCallFrame = 0; 682 } 683 684 result = Itcl_EvalArgs(interp, objc-1, objv+1); 685 686 Itcl_PopStack(&info->transparentFrames); 687 Itcl_PopContext(interp, &context); 688 689 return result; 690} 691 692 693/* 694 * ------------------------------------------------------------------------ 695 * Itcl_GetInstanceVar() 696 * 697 * Returns the current value for an object data member. The member 698 * name is interpreted with respect to the given class scope, which 699 * is usually the most-specific class for the object. 700 * 701 * If successful, this procedure returns a pointer to a string value 702 * which remains alive until the variable changes it value. If 703 * anything goes wrong, this returns NULL. 704 * ------------------------------------------------------------------------ 705 */ 706CONST char* 707Itcl_GetInstanceVar(interp, name, contextObj, contextClass) 708 Tcl_Interp *interp; /* current interpreter */ 709 CONST char *name; /* name of desired instance variable */ 710 ItclObject *contextObj; /* current object */ 711 ItclClass *contextClass; /* name is interpreted in this scope */ 712{ 713 ItclContext context; 714 CONST char *val; 715 716 /* 717 * Make sure that the current namespace context includes an 718 * object that is being manipulated. 719 */ 720 if (contextObj == NULL) { 721 Tcl_ResetResult(interp); 722 Tcl_SetResult(interp, 723 "cannot access object-specific info without an object context", 724 TCL_STATIC); 725 return NULL; 726 } 727 728 /* 729 * Install the object context and access the data member 730 * like any other variable. 731 */ 732 if (Itcl_PushContext(interp, (ItclMember*)NULL, contextClass, 733 contextObj, &context) != TCL_OK) { 734 735 return NULL; 736 } 737 738 val = Tcl_GetVar2(interp, (CONST84 char *)name, (char*)NULL, 739 TCL_LEAVE_ERR_MSG); 740 Itcl_PopContext(interp, &context); 741 742 return val; 743} 744 745 746/* 747 * ------------------------------------------------------------------------ 748 * ItclReportObjectUsage() 749 * 750 * Appends information to the given interp summarizing the usage 751 * for all of the methods available for this object. Useful when 752 * reporting errors in Itcl_HandleInstance(). 753 * ------------------------------------------------------------------------ 754 */ 755static void 756ItclReportObjectUsage(interp, contextObj) 757 Tcl_Interp *interp; /* current interpreter */ 758 ItclObject *contextObj; /* current object */ 759{ 760 ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; 761 int ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON; 762 763 int cmp; 764 char *name; 765 Itcl_List cmdList; 766 Itcl_ListElem *elem; 767 Tcl_HashEntry *entry; 768 Tcl_HashSearch place; 769 ItclMemberFunc *mfunc, *cmpDefn; 770 Tcl_Obj *resultPtr; 771 772 /* 773 * Scan through all methods in the virtual table and sort 774 * them in alphabetical order. Report only the methods 775 * that have simple names (no ::'s) and are accessible. 776 */ 777 Itcl_InitList(&cmdList); 778 entry = Tcl_FirstHashEntry(&cdefnPtr->resolveCmds, &place); 779 while (entry) { 780 name = Tcl_GetHashKey(&cdefnPtr->resolveCmds, entry); 781 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 782 783 if (strstr(name,"::") || (mfunc->member->flags & ignore) != 0) { 784 mfunc = NULL; 785 } 786 else if (mfunc->member->protection != ITCL_PUBLIC) { 787 Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, 788 mfunc->member->classDefn->info); 789 790 if (!Itcl_CanAccessFunc(mfunc, contextNs)) { 791 mfunc = NULL; 792 } 793 } 794 795 if (mfunc) { 796 elem = Itcl_FirstListElem(&cmdList); 797 while (elem) { 798 cmpDefn = (ItclMemberFunc*)Itcl_GetListValue(elem); 799 cmp = strcmp(mfunc->member->name, cmpDefn->member->name); 800 if (cmp < 0) { 801 Itcl_InsertListElem(elem, (ClientData)mfunc); 802 mfunc = NULL; 803 break; 804 } 805 else if (cmp == 0) { 806 mfunc = NULL; 807 break; 808 } 809 elem = Itcl_NextListElem(elem); 810 } 811 if (mfunc) { 812 Itcl_AppendList(&cmdList, (ClientData)mfunc); 813 } 814 } 815 entry = Tcl_NextHashEntry(&place); 816 } 817 818 /* 819 * Add a series of statements showing usage info. 820 */ 821 resultPtr = Tcl_GetObjResult(interp); 822 elem = Itcl_FirstListElem(&cmdList); 823 while (elem) { 824 mfunc = (ItclMemberFunc*)Itcl_GetListValue(elem); 825 Tcl_AppendToObj(resultPtr, "\n ", -1); 826 Itcl_GetMemberFuncUsage(mfunc, contextObj, resultPtr); 827 828 elem = Itcl_NextListElem(elem); 829 } 830 Itcl_DeleteList(&cmdList); 831} 832 833 834/* 835 * ------------------------------------------------------------------------ 836 * ItclTraceThisVar() 837 * 838 * Invoked to handle read/write traces on the "this" variable built 839 * into each object. 840 * 841 * On read, this procedure updates the "this" variable to contain the 842 * current object name. This is done dynamically, since an object's 843 * identity can change if its access command is renamed. 844 * 845 * On write, this procedure returns an error string, warning that 846 * the "this" variable cannot be set. 847 * ------------------------------------------------------------------------ 848 */ 849/* ARGSUSED */ 850static char* 851ItclTraceThisVar(cdata, interp, name1, name2, flags) 852 ClientData cdata; /* object instance data */ 853 Tcl_Interp *interp; /* interpreter managing this variable */ 854 CONST char *name1; /* variable name */ 855 CONST char *name2; /* unused */ 856 int flags; /* flags indicating read/write */ 857{ 858 ItclObject *contextObj = (ItclObject*)cdata; 859 char *objName; 860 Tcl_Obj *objPtr; 861 862 /* 863 * Handle read traces on "this" 864 */ 865 if ((flags & TCL_TRACE_READS) != 0) { 866 objPtr = Tcl_NewStringObj("", -1); 867 Tcl_IncrRefCount(objPtr); 868 869 if (contextObj->accessCmd) { 870 Tcl_GetCommandFullName(contextObj->classDefn->interp, 871 contextObj->accessCmd, objPtr); 872 } 873 874 objName = Tcl_GetString(objPtr); 875 Tcl_SetVar(interp, (CONST84 char *)name1, objName, 0); 876 877 Tcl_DecrRefCount(objPtr); 878 return NULL; 879 } 880 881 /* 882 * Handle write traces on "this" 883 */ 884 if ((flags & TCL_TRACE_WRITES) != 0) { 885 return "variable \"this\" cannot be modified"; 886 } 887 return NULL; 888} 889 890 891/* 892 * ------------------------------------------------------------------------ 893 * ItclDestroyObject() 894 * 895 * Invoked when the object access command is deleted to implicitly 896 * destroy the object. Invokes the object's destructors, ignoring 897 * any errors encountered along the way. Removes the object from 898 * the list of all known objects and releases the access command's 899 * claim to the object data. 900 * 901 * Note that the usual way to delete an object is via Itcl_DeleteObject(). 902 * This procedure is provided as a back-up, to handle the case when 903 * an object is deleted by removing its access command. 904 * ------------------------------------------------------------------------ 905 */ 906static void 907ItclDestroyObject(cdata) 908 ClientData cdata; /* object instance data */ 909{ 910 ItclObject *contextObj = (ItclObject*)cdata; 911 ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; 912 Tcl_HashEntry *entry; 913 Itcl_InterpState istate; 914 915 /* 916 * Attempt to destruct the object, but ignore any errors. 917 */ 918 istate = Itcl_SaveInterpState(cdefnPtr->interp, 0); 919 Itcl_DestructObject(cdefnPtr->interp, contextObj, ITCL_IGNORE_ERRS); 920 Itcl_RestoreInterpState(cdefnPtr->interp, istate); 921 922 /* 923 * Now, remove the object from the global object list. 924 * We're careful to do this here, after calling the destructors. 925 * Once the access command is nulled out, the "this" variable 926 * won't work properly. 927 */ 928 if (contextObj->accessCmd) { 929 entry = Tcl_FindHashEntry(&cdefnPtr->info->objects, 930 (char*)contextObj->accessCmd); 931 932 if (entry) { 933 Tcl_DeleteHashEntry(entry); 934 } 935 contextObj->accessCmd = NULL; 936 } 937 938 Itcl_ReleaseData((ClientData)contextObj); 939} 940 941 942/* 943 * ------------------------------------------------------------------------ 944 * ItclFreeObject() 945 * 946 * Deletes all instance variables and frees all memory associated with 947 * the given object instance. This is usually invoked automatically 948 * by Itcl_ReleaseData(), when an object's data is no longer being used. 949 * ------------------------------------------------------------------------ 950 */ 951static void 952ItclFreeObject(cdata) 953 char* cdata; /* object instance data */ 954{ 955 ItclObject *contextObj = (ItclObject*)cdata; 956 Tcl_Interp *interp = contextObj->classDefn->interp; 957 958 int i; 959 ItclClass *cdPtr; 960 ItclHierIter hier; 961 Tcl_HashSearch place; 962 Tcl_HashEntry *entry; 963 ItclVarDefn *vdefn; 964 ItclContext context; 965 Itcl_InterpState istate; 966 967 /* 968 * Install the class namespace and object context so that 969 * the object's data members can be destroyed via simple 970 * "unset" commands. This makes sure that traces work properly 971 * and all memory gets cleaned up. 972 * 973 * NOTE: Be careful to save and restore the interpreter state. 974 * Data can get freed in the middle of any operation, and 975 * we can't affort to clobber the interpreter with any errors 976 * from below. 977 */ 978 istate = Itcl_SaveInterpState(interp, 0); 979 980 /* 981 * Scan through all object-specific data members and destroy the 982 * actual variables that maintain the object state. Do this 983 * by unsetting each variable, so that traces are fired off 984 * correctly. Make sure that the built-in "this" variable is 985 * only destroyed once. Also, be careful to activate the 986 * namespace for each class, so that private variables can 987 * be accessed. 988 */ 989 Itcl_InitHierIter(&hier, contextObj->classDefn); 990 cdPtr = Itcl_AdvanceHierIter(&hier); 991 while (cdPtr != NULL) { 992 993 if (Itcl_PushContext(interp, (ItclMember*)NULL, cdPtr, 994 contextObj, &context) == TCL_OK) { 995 996 entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); 997 while (entry) { 998 vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); 999 if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { 1000 if (cdPtr == contextObj->classDefn) { 1001 Tcl_UnsetVar2(interp, vdefn->member->fullname, 1002 (char*)NULL, 0); 1003 } 1004 } 1005 else if ((vdefn->member->flags & ITCL_COMMON) == 0) { 1006 Tcl_UnsetVar2(interp, vdefn->member->fullname, 1007 (char*)NULL, 0); 1008 } 1009 entry = Tcl_NextHashEntry(&place); 1010 } 1011 Itcl_PopContext(interp, &context); 1012 } 1013 1014 cdPtr = Itcl_AdvanceHierIter(&hier); 1015 } 1016 Itcl_DeleteHierIter(&hier); 1017 1018 /* 1019 * Free the memory associated with object-specific variables. 1020 * For normal variables this would be done automatically by 1021 * CleanupVar() when the variable is unset. But object-specific 1022 * variables are protected by an extra reference count, and they 1023 * must be deleted explicitly here. 1024 */ 1025 for (i=0; i < contextObj->dataSize; i++) { 1026 if (contextObj->data[i]) { 1027 ckfree((char*)contextObj->data[i]); 1028 } 1029 } 1030 1031 Itcl_RestoreInterpState(interp, istate); 1032 1033 /* 1034 * Free any remaining memory associated with the object. 1035 */ 1036 ckfree((char*)contextObj->data); 1037 1038 if (contextObj->constructed) { 1039 Tcl_DeleteHashTable(contextObj->constructed); 1040 ckfree((char*)contextObj->constructed); 1041 } 1042 if (contextObj->destructed) { 1043 Tcl_DeleteHashTable(contextObj->destructed); 1044 ckfree((char*)contextObj->destructed); 1045 } 1046 Itcl_ReleaseData((ClientData)contextObj->classDefn); 1047 1048 ckfree((char*)contextObj); 1049} 1050 1051 1052/* 1053 * ------------------------------------------------------------------------ 1054 * ItclCreateObjVar() 1055 * 1056 * Creates one variable acting as a data member for a specific 1057 * object. Initializes the variable according to its definition, 1058 * and sets up its reference count so that it cannot be deleted 1059 * by ordinary means. Installs the new variable directly into 1060 * the data array for the specified object. 1061 * ------------------------------------------------------------------------ 1062 */ 1063static void 1064ItclCreateObjVar(interp, vdefn, contextObj) 1065 Tcl_Interp* interp; /* interpreter managing this object */ 1066 ItclVarDefn* vdefn; /* variable definition */ 1067 ItclObject* contextObj; /* object being updated */ 1068{ 1069 Var *varPtr; 1070 Tcl_HashEntry *entry; 1071 ItclVarLookup *vlookup; 1072 ItclContext context; 1073 1074 varPtr = _TclNewVar(); 1075#if ITCL_TCL_PRE_8_5 1076 if (itclOldRuntime) { 1077 varPtr->name = vdefn->member->name; 1078 varPtr->nsPtr = (Namespace*)vdefn->member->classDefn->namesp; 1079 1080 /* 1081 * NOTE: Tcl reports a "dangling upvar" error for variables 1082 * with a null "hPtr" field. Put something non-zero 1083 * in here to keep Tcl_SetVar2() happy. The only time 1084 * this field is really used is it remove a variable 1085 * from the hash table that contains it in CleanupVar, 1086 * but since these variables are protected by their 1087 * higher refCount, they will not be deleted by CleanupVar 1088 * anyway. These variables are unset and removed in 1089 * ItclFreeObject(). 1090 */ 1091 varPtr->hPtr = (Tcl_HashEntry*)0x1; 1092 ItclVarRefCount(varPtr) = 1; /* protect from being deleted */ 1093 } 1094#endif 1095 1096 /* 1097 * Install the new variable in the object's data array. 1098 * Look up the appropriate index for the object using 1099 * the data table in the class definition. 1100 */ 1101 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, 1102 vdefn->member->fullname); 1103 1104 if (entry) { 1105 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1106 contextObj->data[vlookup->var.index] = varPtr; 1107 } 1108 1109 /* 1110 * If this variable has an initial value, initialize it 1111 * here using a "set" command. 1112 * 1113 * TRICKY NOTE: We push an object context for the class that 1114 * owns the variable, so that we don't have any trouble 1115 * accessing it. 1116 */ 1117 if (vdefn->init) { 1118 if (Itcl_PushContext(interp, (ItclMember*)NULL, 1119 vdefn->member->classDefn, contextObj, &context) == TCL_OK) { 1120 1121 Tcl_SetVar2(interp, vdefn->member->fullname, 1122 (char*)NULL, vdefn->init, 0); 1123 Itcl_PopContext(interp, &context); 1124 } 1125 } 1126} 1127 1128 1129/* 1130 * ------------------------------------------------------------------------ 1131 * Itcl_ScopedVarResolver() 1132 * 1133 * This procedure is installed to handle variable resolution throughout 1134 * an entire interpreter. It looks for scoped variable references of 1135 * the form: 1136 * 1137 * @itcl ::namesp::namesp::object variable 1138 * 1139 * If a reference like this is recognized, this procedure finds the 1140 * desired variable in the object and returns the variable, along with 1141 * the status code TCL_OK. If the variable does not start with 1142 * "@itcl", this procedure returns TCL_CONTINUE, and variable 1143 * resolution continues using the normal rules. If anything goes 1144 * wrong, this procedure returns TCL_ERROR, and access to the 1145 * variable is denied. 1146 * ------------------------------------------------------------------------ 1147 */ 1148int 1149Itcl_ScopedVarResolver(interp, name, contextNs, flags, rPtr) 1150 Tcl_Interp *interp; /* current interpreter */ 1151 CONST char *name; /* variable name being resolved */ 1152 Tcl_Namespace *contextNs; /* current namespace context */ 1153 int flags; /* TCL_LEAVE_ERR_MSG => leave error message */ 1154 Tcl_Var *rPtr; /* returns: resolved variable */ 1155{ 1156 int namec; 1157 char **namev; 1158 Tcl_Interp *errs; 1159 Tcl_CmdInfo cmdInfo; 1160 ItclObject *contextObj; 1161 ItclVarLookup *vlookup; 1162 Tcl_HashEntry *entry; 1163 1164 /* 1165 * See if the variable starts with "@itcl". If not, then 1166 * let the variable resolution process continue. 1167 */ 1168 if (*name != '@' || strncmp(name, "@itcl", 5) != 0) { 1169 return TCL_CONTINUE; 1170 } 1171 1172 /* 1173 * Break the variable name into parts and extract the object 1174 * name and the variable name. 1175 */ 1176 if (flags & TCL_LEAVE_ERR_MSG) { 1177 errs = interp; 1178 } else { 1179 errs = NULL; 1180 } 1181 1182 if (Tcl_SplitList(errs, (CONST84 char *)name, &namec, &namev) 1183 != TCL_OK) { 1184 return TCL_ERROR; 1185 } 1186 if (namec != 3) { 1187 if (errs) { 1188 Tcl_AppendResult(errs, 1189 "scoped variable \"", name, "\" is malformed: ", 1190 "should be: @itcl object variable", 1191 (char*) NULL); 1192 } 1193 ckfree((char*)namev); 1194 return TCL_ERROR; 1195 } 1196 1197 /* 1198 * Look for the command representing the object and extract 1199 * the object context. 1200 */ 1201 if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)) { 1202 if (errs) { 1203 Tcl_AppendResult(errs, 1204 "can't resolve scoped variable \"", name, "\": ", 1205 "can't find object ", namev[1], 1206 (char*)NULL); 1207 } 1208 ckfree((char*)namev); 1209 return TCL_ERROR; 1210 } 1211 contextObj = (ItclObject*)cmdInfo.objClientData; 1212 1213 /* 1214 * Resolve the variable with respect to the most-specific 1215 * class definition. 1216 */ 1217 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, namev[2]); 1218 if (!entry) { 1219 if (errs) { 1220 Tcl_AppendResult(errs, 1221 "can't resolve scoped variable \"", name, "\": ", 1222 "no such data member ", namev[2], 1223 (char*)NULL); 1224 } 1225 ckfree((char*)namev); 1226 return TCL_ERROR; 1227 } 1228 1229 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1230 *rPtr = (Tcl_Var) contextObj->data[vlookup->var.index]; 1231 1232 ckfree((char*)namev); 1233 return TCL_OK; 1234} 1235