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 class definitions. Classes are composed of 16 * data members (public/protected/common) and the member functions 17 * (methods/procs) that operate on them. Each class has its own 18 * namespace which manages the class scope. 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 * RCS: $Id: itcl_class.c,v 1.24 2007/08/07 20:05:29 msofer Exp $ 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/* 36 * This structure is a subclass of Tcl_ResolvedVarInfo that contains the 37 * ItclVarLookup info needed at runtime. 38 */ 39typedef struct ItclResolvedVarInfo { 40 Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ 41 ItclVarLookup *vlookup; /* Pointer to lookup info. */ 42} ItclResolvedVarInfo; 43 44/* 45 * FORWARD DECLARATIONS 46 */ 47static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata)); 48static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata)); 49static void ItclFreeClass _ANSI_ARGS_((char* cdata)); 50 51static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_(( 52 Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr)); 53 54extern int itclCompatFlags; 55 56 57/* 58 * ------------------------------------------------------------------------ 59 * Itcl_CreateClass() 60 * 61 * Creates a namespace and its associated class definition data. 62 * If a namespace already exists with that name, then this routine 63 * returns TCL_ERROR, along with an error message in the interp. 64 * If successful, it returns TCL_OK and a pointer to the new class 65 * definition. 66 * ------------------------------------------------------------------------ 67 */ 68int 69Itcl_CreateClass(interp, path, info, rPtr) 70 Tcl_Interp* interp; /* interpreter that will contain new class */ 71 CONST char* path; /* name of new class */ 72 ItclObjectInfo *info; /* info for all known objects */ 73 ItclClass **rPtr; /* returns: pointer to class definition */ 74{ 75 char *head, *tail; 76 Tcl_DString buffer; 77 Tcl_Command cmd; 78 Tcl_Namespace *classNs; 79 ItclClass *cdPtr; 80 ItclVarDefn *vdefn; 81 Tcl_HashEntry *entry; 82 int newEntry; 83 84 /* 85 * Make sure that a class with the given name does not 86 * already exist in the current namespace context. If a 87 * namespace exists, that's okay. It may have been created 88 * to contain stubs during a "namespace import" operation. 89 * We'll just replace the namespace data below with the 90 * proper class data. 91 */ 92 classNs = Tcl_FindNamespace(interp, (CONST84 char *)path, 93 (Tcl_Namespace*)NULL, /* flags */ 0); 94 95 if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { 96 Tcl_AppendResult(interp, 97 "class \"", path, "\" already exists", 98 (char*)NULL); 99 return TCL_ERROR; 100 } 101 102 /* 103 * Make sure that a command with the given class name does not 104 * already exist in the current namespace. This prevents the 105 * usual Tcl commands from being clobbered when a programmer 106 * makes a bogus call like "class info". 107 */ 108 cmd = Tcl_FindCommand(interp, (CONST84 char *)path, 109 (Tcl_Namespace*)NULL, /* flags */ TCL_NAMESPACE_ONLY); 110 111 if (cmd != NULL && !Itcl_IsStub(cmd)) { 112 Tcl_AppendResult(interp, 113 "command \"", path, "\" already exists", 114 (char*)NULL); 115 116 if (strstr(path,"::") == NULL) { 117 Tcl_AppendResult(interp, 118 " in namespace \"", 119 Tcl_GetCurrentNamespace(interp)->fullName, "\"", 120 (char*)NULL); 121 } 122 return TCL_ERROR; 123 } 124 125 /* 126 * Make sure that the class name does not have any goofy 127 * characters: 128 * 129 * . => reserved for member access like: class.publicVar 130 */ 131 Itcl_ParseNamespPath(path, &buffer, &head, &tail); 132 133 if (strstr(tail,".")) { 134 Tcl_AppendResult(interp, 135 "bad class name \"", tail, "\"", 136 (char*)NULL); 137 Tcl_DStringFree(&buffer); 138 return TCL_ERROR; 139 } 140 Tcl_DStringFree(&buffer); 141 142 /* 143 * Allocate class definition data. 144 */ 145 cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass)); 146 cdPtr->name = NULL; 147 cdPtr->fullname = NULL; 148 cdPtr->interp = interp; 149 cdPtr->info = info; Itcl_PreserveData((ClientData)info); 150 cdPtr->namesp = NULL; 151 cdPtr->accessCmd = NULL; 152 153 Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS); 154 Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS); 155 156 cdPtr->numInstanceVars = 0; 157 Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS); 158 Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS); 159 160 Itcl_InitList(&cdPtr->bases); 161 Itcl_InitList(&cdPtr->derived); 162 163 cdPtr->initCode = NULL; 164 cdPtr->unique = 0; 165 cdPtr->flags = 0; 166 167 /* 168 * Initialize the heritage info--each class starts with its 169 * own class definition in the heritage. Base classes are 170 * added to the heritage from the "inherit" statement. 171 */ 172 Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS); 173 (void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry); 174 175 /* 176 * Create a namespace to represent the class. Add the class 177 * definition info as client data for the namespace. If the 178 * namespace already exists, then replace any existing client 179 * data with the class data. 180 */ 181 Itcl_PreserveData((ClientData)cdPtr); 182 183 if (classNs == NULL) { 184 classNs = Tcl_CreateNamespace(interp, (CONST84 char *)path, 185 (ClientData)cdPtr, ItclDestroyClassNamesp); 186 } 187 else { 188 if (classNs->clientData && classNs->deleteProc) { 189 (*classNs->deleteProc)(classNs->clientData); 190 } 191 classNs->clientData = (ClientData)cdPtr; 192 classNs->deleteProc = ItclDestroyClassNamesp; 193 } 194 195 Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass); 196 197 if (classNs == NULL) { 198 Itcl_ReleaseData((ClientData)cdPtr); 199 return TCL_ERROR; 200 } 201 202 cdPtr->namesp = classNs; 203 204 cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1)); 205 strcpy(cdPtr->name, classNs->name); 206 207 cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1)); 208 strcpy(cdPtr->fullname, classNs->fullName); 209 210 /* 211 * Add special name resolution procedures to the class namespace 212 * so that members are accessed according to the rules for 213 * [incr Tcl]. 214 */ 215 Tcl_SetNamespaceResolvers(classNs, 216 (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, 217 (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, 218 (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); 219 220 /* 221 * Add the built-in "this" variable to the list of data members. 222 */ 223 (void) Itcl_CreateVarDefn(interp, cdPtr, "this", 224 (char*)NULL, (char*)NULL, &vdefn); 225 226 vdefn->member->protection = ITCL_PROTECTED; /* always "protected" */ 227 vdefn->member->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ 228 229 entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry); 230 Tcl_SetHashValue(entry, (ClientData)vdefn); 231 232 /* 233 * Create a command in the current namespace to manage the class: 234 * <className> 235 * <className> <objName> ?<constructor-args>? 236 */ 237 Itcl_PreserveData((ClientData)cdPtr); 238 239 cdPtr->accessCmd = Tcl_CreateObjCommand(interp, 240 cdPtr->fullname, Itcl_HandleClass, 241 (ClientData)cdPtr, ItclDestroyClass); 242 243 *rPtr = cdPtr; 244 return TCL_OK; 245} 246 247 248/* 249 * ------------------------------------------------------------------------ 250 * Itcl_DeleteClass() 251 * 252 * Deletes a class by deleting all derived classes and all objects in 253 * that class, and finally, by destroying the class namespace. This 254 * procedure provides a friendly way of doing this. If any errors 255 * are detected along the way, the process is aborted. 256 * 257 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 258 * message in the interpreter) if anything goes wrong. 259 * ------------------------------------------------------------------------ 260 */ 261int 262Itcl_DeleteClass(interp, cdefnPtr) 263 Tcl_Interp *interp; /* interpreter managing this class */ 264 ItclClass *cdefnPtr; /* class namespace */ 265{ 266 ItclClass *cdPtr = NULL; 267 268 Itcl_ListElem *elem; 269 ItclObject *contextObj; 270 Tcl_HashEntry *entry; 271 Tcl_HashSearch place; 272 Tcl_DString buffer; 273 274 /* 275 * Destroy all derived classes, since these lose their meaning 276 * when the base class goes away. If anything goes wrong, 277 * abort with an error. 278 * 279 * TRICKY NOTE: When a derived class is destroyed, it 280 * automatically deletes itself from the "derived" list. 281 */ 282 elem = Itcl_FirstListElem(&cdefnPtr->derived); 283 while (elem) { 284 cdPtr = (ItclClass*)Itcl_GetListValue(elem); 285 elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ 286 287 if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) { 288 goto deleteClassFail; 289 } 290 } 291 292 /* 293 * Scan through and find all objects that belong to this class. 294 * Note that more specialized objects have already been 295 * destroyed above, when derived classes were destroyed. 296 * Destroy objects and report any errors. 297 */ 298 entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); 299 while (entry) { 300 contextObj = (ItclObject*)Tcl_GetHashValue(entry); 301 302 if (contextObj->classDefn == cdefnPtr) { 303 if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) { 304 cdPtr = cdefnPtr; 305 goto deleteClassFail; 306 } 307 308 /* 309 * Fix 227804: Whenever an object to delete was found we 310 * have to reset the search to the beginning as the 311 * current entry in the search was deleted and accessing it 312 * is therefore not allowed anymore. 313 */ 314 315 entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); 316 continue; 317 } 318 319 entry = Tcl_NextHashEntry(&place); 320 } 321 322 /* 323 * Destroy the namespace associated with this class. 324 * 325 * TRICKY NOTE: 326 * The cleanup procedure associated with the namespace is 327 * invoked automatically. It does all of the same things 328 * above, but it also disconnects this class from its 329 * base-class lists, and removes the class access command. 330 */ 331 Tcl_DeleteNamespace(cdefnPtr->namesp); 332 return TCL_OK; 333 334deleteClassFail: 335 Tcl_DStringInit(&buffer); 336 Tcl_DStringAppend(&buffer, "\n (while deleting class \"", -1); 337 Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1); 338 Tcl_DStringAppend(&buffer, "\")", -1); 339 Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer)); 340 Tcl_DStringFree(&buffer); 341 return TCL_ERROR; 342} 343 344 345/* 346 * ------------------------------------------------------------------------ 347 * ItclDestroyClass() 348 * 349 * Invoked whenever the access command for a class is destroyed. 350 * Destroys the namespace associated with the class, which also 351 * destroys all objects in the class and all derived classes. 352 * Disconnects this class from the "derived" class lists of its 353 * base classes, and releases any claim to the class definition 354 * data. If this is the last use of that data, the class will 355 * completely vanish at this point. 356 * ------------------------------------------------------------------------ 357 */ 358static void 359ItclDestroyClass(cdata) 360 ClientData cdata; /* class definition to be destroyed */ 361{ 362 ItclClass *cdefnPtr = (ItclClass*)cdata; 363 cdefnPtr->accessCmd = NULL; 364 365 Tcl_DeleteNamespace(cdefnPtr->namesp); 366 Itcl_ReleaseData((ClientData)cdefnPtr); 367} 368 369 370/* 371 * ------------------------------------------------------------------------ 372 * ItclDestroyClassNamesp() 373 * 374 * Invoked whenever the namespace associated with a class is destroyed. 375 * Destroys all objects associated with this class and all derived 376 * classes. Disconnects this class from the "derived" class lists 377 * of its base classes, and removes the class access command. Releases 378 * any claim to the class definition data. If this is the last use 379 * of that data, the class will completely vanish at this point. 380 * ------------------------------------------------------------------------ 381 */ 382static void 383ItclDestroyClassNamesp(cdata) 384 ClientData cdata; /* class definition to be destroyed */ 385{ 386 ItclClass *cdefnPtr = (ItclClass*)cdata; 387 ItclObject *contextObj; 388 Itcl_ListElem *elem, *belem; 389 ItclClass *cdPtr, *basePtr, *derivedPtr; 390 Tcl_HashEntry *entry; 391 Tcl_HashSearch place; 392 393 /* 394 * Destroy all derived classes, since these lose their meaning 395 * when the base class goes away. 396 * 397 * TRICKY NOTE: When a derived class is destroyed, it 398 * automatically deletes itself from the "derived" list. 399 */ 400 elem = Itcl_FirstListElem(&cdefnPtr->derived); 401 while (elem) { 402 cdPtr = (ItclClass*)Itcl_GetListValue(elem); 403 Tcl_DeleteNamespace(cdPtr->namesp); 404 405 /* As the first namespace is now destroyed we have to get the 406 * new first element of the hash table. We cannot go to the 407 * next element from the current one, because the current one 408 * is deleted. itcl Patch #593112, for Bug #577719. 409 */ 410 411 elem = Itcl_FirstListElem(&cdefnPtr->derived); 412 } 413 414 /* 415 * Scan through and find all objects that belong to this class. 416 * Destroy them quietly by deleting their access command. 417 */ 418 entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); 419 while (entry) { 420 contextObj = (ItclObject*)Tcl_GetHashValue(entry); 421 if (contextObj->classDefn == cdefnPtr) { 422 Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->accessCmd); 423 /* 424 * Fix 227804: Whenever an object to delete was found we 425 * have to reset the search to the beginning as the 426 * current entry in the search was deleted and accessing it 427 * is therefore not allowed anymore. 428 */ 429 430 entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); 431 continue; 432 } 433 entry = Tcl_NextHashEntry(&place); 434 } 435 436 /* 437 * Next, remove this class from the "derived" list in 438 * all base classes. 439 */ 440 belem = Itcl_FirstListElem(&cdefnPtr->bases); 441 while (belem) { 442 basePtr = (ItclClass*)Itcl_GetListValue(belem); 443 444 elem = Itcl_FirstListElem(&basePtr->derived); 445 while (elem) { 446 derivedPtr = (ItclClass*)Itcl_GetListValue(elem); 447 if (derivedPtr == cdefnPtr) { 448 Itcl_ReleaseData( Itcl_GetListValue(elem) ); 449 elem = Itcl_DeleteListElem(elem); 450 } else { 451 elem = Itcl_NextListElem(elem); 452 } 453 } 454 belem = Itcl_NextListElem(belem); 455 } 456 457 /* 458 * Next, destroy the access command associated with the class. 459 */ 460 if (cdefnPtr->accessCmd) { 461 Command *cmdPtr = (Command*)cdefnPtr->accessCmd; 462 463 cmdPtr->deleteProc = Itcl_ReleaseData; 464 Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd); 465 } 466 467 /* 468 * Release the namespace's claim on the class definition. 469 */ 470 Itcl_ReleaseData((ClientData)cdefnPtr); 471} 472 473 474/* 475 * ------------------------------------------------------------------------ 476 * ItclFreeClass() 477 * 478 * Frees all memory associated with a class definition. This is 479 * usually invoked automatically by Itcl_ReleaseData(), when class 480 * data is no longer being used. 481 * ------------------------------------------------------------------------ 482 */ 483static void 484ItclFreeClass(cdata) 485 char *cdata; /* class definition to be destroyed */ 486{ 487 ItclClass *cdefnPtr = (ItclClass*)cdata; 488 489 Itcl_ListElem *elem; 490 Tcl_HashSearch place; 491 Tcl_HashEntry *entry; 492 ItclVarDefn *vdefn; 493 ItclVarLookup *vlookup; 494 VarInHash *varPtr; 495 496 /* 497 * Tear down the list of derived classes. This list should 498 * really be empty if everything is working properly, but 499 * release it here just in case. 500 */ 501 elem = Itcl_FirstListElem(&cdefnPtr->derived); 502 while (elem) { 503 Itcl_ReleaseData( Itcl_GetListValue(elem) ); 504 elem = Itcl_NextListElem(elem); 505 } 506 Itcl_DeleteList(&cdefnPtr->derived); 507 508 /* 509 * Tear down the variable resolution table. Some records 510 * appear multiple times in the table (for x, foo::x, etc.) 511 * so each one has a reference count. 512 */ 513 514 entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); 515 while (entry) { 516 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 517 if (--vlookup->usage == 0) { 518 /* 519 * If this is a common variable owned by this class, 520 * then release the class's hold on it. If it's no 521 * longer being used, move it into a variable table 522 * for destruction. 523 */ 524 if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 && 525 vlookup->vdefn->member->classDefn == cdefnPtr ) { 526 varPtr = (VarInHash*)vlookup->var.common; 527 if (--ItclVarRefCount(varPtr) == 0) { 528 /* 529 * This is called after the namespace is already gone: the 530 * variable is already unset and ready to be freed. 531 */ 532 533 ckfree((char *)varPtr); 534 } 535 } 536 ckfree((char*)vlookup); 537 } 538 entry = Tcl_NextHashEntry(&place); 539 } 540 Tcl_DeleteHashTable(&cdefnPtr->resolveVars); 541 542 /* 543 * Tear down the virtual method table... 544 */ 545 Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); 546 547 /* 548 * Delete all variable definitions. 549 */ 550 entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place); 551 while (entry) { 552 vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); 553 Itcl_DeleteVarDefn(vdefn); 554 entry = Tcl_NextHashEntry(&place); 555 } 556 Tcl_DeleteHashTable(&cdefnPtr->variables); 557 558 /* 559 * Delete all function definitions. 560 */ 561 entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place); 562 while (entry) { 563 Itcl_ReleaseData( Tcl_GetHashValue(entry) ); 564 entry = Tcl_NextHashEntry(&place); 565 } 566 Tcl_DeleteHashTable(&cdefnPtr->functions); 567 568 /* 569 * Release the claim on all base classes. 570 */ 571 elem = Itcl_FirstListElem(&cdefnPtr->bases); 572 while (elem) { 573 Itcl_ReleaseData( Itcl_GetListValue(elem) ); 574 elem = Itcl_NextListElem(elem); 575 } 576 Itcl_DeleteList(&cdefnPtr->bases); 577 Tcl_DeleteHashTable(&cdefnPtr->heritage); 578 579 /* 580 * Free up the object initialization code. 581 */ 582 if (cdefnPtr->initCode) { 583 Tcl_DecrRefCount(cdefnPtr->initCode); 584 } 585 586 Itcl_ReleaseData((ClientData)cdefnPtr->info); 587 588 ckfree(cdefnPtr->name); 589 ckfree(cdefnPtr->fullname); 590 591 ckfree((char*)cdefnPtr); 592} 593 594 595/* 596 * ------------------------------------------------------------------------ 597 * Itcl_IsClassNamespace() 598 * 599 * Checks to see whether or not the given namespace represents an 600 * [incr Tcl] class. Returns non-zero if so, and zero otherwise. 601 * ------------------------------------------------------------------------ 602 */ 603int 604Itcl_IsClassNamespace(namesp) 605 Tcl_Namespace *namesp; /* namespace being tested */ 606{ 607 Namespace *nsPtr = (Namespace*)namesp; 608 609 if (nsPtr != NULL) { 610 return (nsPtr->deleteProc == ItclDestroyClassNamesp); 611 } 612 return 0; 613} 614 615 616/* 617 * ------------------------------------------------------------------------ 618 * Itcl_IsClass() 619 * 620 * Checks the given Tcl command to see if it represents an itcl class. 621 * Returns non-zero if the command is associated with a class. 622 * ------------------------------------------------------------------------ 623 */ 624int 625Itcl_IsClass(cmd) 626 Tcl_Command cmd; /* command being tested */ 627{ 628 Command *cmdPtr = (Command*)cmd; 629 630 if (cmdPtr->deleteProc == ItclDestroyClass) { 631 return 1; 632 } 633 634 /* 635 * This may be an imported command. Try to get the real 636 * command and see if it represents a class. 637 */ 638 cmdPtr = (Command*)TclGetOriginalCommand(cmd); 639 if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) { 640 return 1; 641 } 642 return 0; 643} 644 645 646/* 647 * ------------------------------------------------------------------------ 648 * Itcl_FindClass() 649 * 650 * Searches for the specified class in the active namespace. If the 651 * class is found, this procedure returns a pointer to the class 652 * definition. Otherwise, if the autoload flag is non-zero, an 653 * attempt will be made to autoload the class definition. If it 654 * still can't be found, this procedure returns NULL, along with an 655 * error message in the interpreter. 656 * ------------------------------------------------------------------------ 657 */ 658ItclClass* 659Itcl_FindClass(interp, path, autoload) 660 Tcl_Interp* interp; /* interpreter containing class */ 661 CONST char* path; /* path name for class */ 662 int autoload; /* should class be loaded */ 663{ 664 Tcl_Namespace* classNs; 665 666 /* 667 * Search for a namespace with the specified name, and if 668 * one is found, see if it is a class namespace. 669 */ 670 classNs = Itcl_FindClassNamespace(interp, path); 671 672 if (classNs && Itcl_IsClassNamespace(classNs)) { 673 return (ItclClass*)classNs->clientData; 674 } 675 676 /* 677 * If the autoload flag is set, try to autoload the class 678 * definition. 679 */ 680 if (autoload) { 681 if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) { 682 char msg[256]; 683 sprintf(msg, "\n (while attempting to autoload class \"%.200s\")", path); 684 Tcl_AddErrorInfo(interp, msg); 685 return NULL; 686 } 687 Tcl_ResetResult(interp); 688 689 classNs = Itcl_FindClassNamespace(interp, path); 690 if (classNs && Itcl_IsClassNamespace(classNs)) { 691 return (ItclClass*)classNs->clientData; 692 } 693 } 694 695 Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", 696 Tcl_GetCurrentNamespace(interp)->fullName, "\"", 697 (char*)NULL); 698 699 return NULL; 700} 701 702/* 703 * ------------------------------------------------------------------------ 704 * Itcl_FindClassNamespace() 705 * 706 * Searches for the specified class namespace. The normal Tcl procedure 707 * Tcl_FindNamespace also searches for namespaces, but only in the 708 * current namespace context. This makes it hard to find one class 709 * from within another. For example, suppose. you have two namespaces 710 * Foo and Bar. If you're in the context of Foo and you look for 711 * Bar, you won't find it with Tcl_FindNamespace. This behavior is 712 * okay for namespaces, but wrong for classes. 713 * 714 * This procedure search for a class namespace. If the name is 715 * absolute (i.e., starts with "::"), then that one name is checked, 716 * and the class is either found or not. But if the name is relative, 717 * it is sought in the current namespace context and in the global 718 * context, just like the normal command lookup. 719 * 720 * This procedure returns a pointer to the desired namespace, or 721 * NULL if the namespace was not found. 722 * ------------------------------------------------------------------------ 723 */ 724Tcl_Namespace* 725Itcl_FindClassNamespace(interp, path) 726 Tcl_Interp* interp; /* interpreter containing class */ 727 CONST char* path; /* path name for class */ 728{ 729 Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); 730 Tcl_Namespace* classNs; 731 Tcl_DString buffer; 732 733 /* 734 * Look up the namespace. If the name is not absolute, then 735 * see if it's the current namespace, and try the global 736 * namespace as well. 737 */ 738 classNs = Tcl_FindNamespace(interp, (CONST84 char *)path, 739 (Tcl_Namespace*)NULL, /* flags */ 0); 740 741 if ( !classNs && contextNs->parentPtr != NULL && 742 !(*path == ':' && *(path+1) == ':') ) { 743 744 if (strcmp(contextNs->name, path) == 0) { 745 classNs = contextNs; 746 } 747 else { 748 Tcl_DStringInit(&buffer); 749 Tcl_DStringAppend(&buffer, "::", -1); 750 Tcl_DStringAppend(&buffer, path, -1); 751 752 classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), 753 (Tcl_Namespace*)NULL, /* flags */ 0); 754 755 Tcl_DStringFree(&buffer); 756 } 757 } 758 return classNs; 759} 760 761 762/* 763 * ------------------------------------------------------------------------ 764 * Itcl_HandleClass() 765 * 766 * Invoked by Tcl whenever the user issues the command associated with 767 * a class name. Handles the following syntax: 768 * 769 * <className> 770 * <className> <objName> ?<args>...? 771 * 772 * Without any arguments, the command does nothing. In the olden days, 773 * this allowed the class name to be invoked by itself to prompt the 774 * autoloader to load the class definition. Today, this behavior is 775 * retained for backward compatibility with old releases. 776 * 777 * If arguments are specified, then this procedure creates a new 778 * object named <objName> in the appropriate class. Note that if 779 * <objName> contains "#auto", that part is automatically replaced 780 * by a unique string built from the class name. 781 * ------------------------------------------------------------------------ 782 */ 783int 784Itcl_HandleClass(clientData, interp, objc, objv) 785 ClientData clientData; /* class definition */ 786 Tcl_Interp *interp; /* current interpreter */ 787 int objc; /* number of arguments */ 788 Tcl_Obj *CONST objv[]; /* argument objects */ 789{ 790 ItclClass *cdefnPtr = (ItclClass*)clientData; 791 int result = TCL_OK; 792 793 Tcl_DString buffer; /* buffer used to build object names */ 794 char *token, *objName, *match; 795 796 ItclObject *newObj; 797 Itcl_CallFrame frame; 798 799 /* 800 * If the command is invoked without an object name, then do nothing. 801 * This used to support autoloading--that the class name could be 802 * invoked as a command by itself, prompting the autoloader to 803 * load the class definition. We retain the behavior here for 804 * backward-compatibility with earlier releases. 805 */ 806 if (objc == 1) { 807 return TCL_OK; 808 } 809 810 /* 811 * If the object name is "::", and if this is an old-style class 812 * definition, then treat the remaining arguments as a command 813 * in the class namespace. This used to be the way of invoking 814 * a class proc, but the new syntax is "class::proc" (without 815 * spaces). 816 */ 817 token = Tcl_GetStringFromObj(objv[1], (int*)NULL); 818 if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) { 819 if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) { 820 821 result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, 822 cdefnPtr->namesp, /* isProcCallFrame */ 0); 823 824 if (result != TCL_OK) { 825 return result; 826 } 827 result = Itcl_EvalArgs(interp, objc-2, objv+2); 828 829 Tcl_PopCallFrame(interp); 830 return result; 831 } 832 833 /* 834 * If this is not an old-style class, then return an error 835 * describing the syntax change. 836 */ 837 Tcl_AppendResult(interp, 838 "syntax \"class :: proc\" is an anachronism\n", 839 "[incr Tcl] no longer supports this syntax.\n", 840 "Instead, remove the spaces from your procedure invocations:\n", 841 " ", 842 Tcl_GetStringFromObj(objv[0], (int*)NULL), "::", 843 Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?", 844 (char*)NULL); 845 return TCL_ERROR; 846 } 847 848 /* 849 * Otherwise, we have a proper object name. Create a new instance 850 * with that name. If the name contains "#auto", replace this with 851 * a uniquely generated string based on the class name. 852 */ 853 Tcl_DStringInit(&buffer); 854 objName = token; 855 match = strstr(token, "#auto"); 856 if (match != NULL) { 857 int len; 858 char unique[TCL_INTEGER_SPACE]; /* for unique part of object names */ 859 Tcl_CmdInfo dummy; 860 Tcl_UniChar ch; 861 862 Tcl_DStringAppend(&buffer, token, (match - token)); 863 864 /* 865 * Only lowercase the first char of $class, per itcl #auto semantics 866 */ 867 len = Tcl_UtfToUniChar(cdefnPtr->name, &ch); 868 ch = Tcl_UniCharToLower(ch); 869 Tcl_UniCharToUtfDString(&ch, 1, &buffer); 870 Tcl_DStringAppend(&buffer, cdefnPtr->name + len, -1); 871 872 /* 873 * Substitute a unique part in for "#auto", and keep 874 * incrementing a counter until a valid name is found. 875 */ 876 len = Tcl_DStringLength(&buffer); 877 do { 878 sprintf(unique, "%d", cdefnPtr->unique++); 879 880 Tcl_DStringTrunc(&buffer, len); 881 Tcl_DStringAppend(&buffer, unique, -1); 882 Tcl_DStringAppend(&buffer, match+5, -1); 883 884 objName = Tcl_DStringValue(&buffer); 885 886 /* 887 * [Fix 227811] Check for any command with the given name, not 888 * only objects. 889 */ 890 891 if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { 892 break; /* if an error is found, bail out! */ 893 } 894 } while (1); 895 } 896 897 /* 898 * Try to create a new object. If successful, return the 899 * object name as the result of this command. 900 */ 901 result = Itcl_CreateObject(interp, objName, cdefnPtr, 902 objc-2, objv+2, &newObj); 903 904 if (result == TCL_OK) { 905 Tcl_SetObjResult(interp, Tcl_NewStringObj(objName, -1)); 906 } 907 908 Tcl_DStringFree(&buffer); 909 return result; 910} 911 912 913/* 914 * ------------------------------------------------------------------------ 915 * Itcl_ClassCmdResolver() 916 * 917 * Used by the class namespaces to handle name resolution for all 918 * commands. This procedure looks for references to class methods 919 * and procs, and returns TCL_OK along with the appropriate Tcl 920 * command in the rPtr argument. If a particular command is private, 921 * this procedure returns TCL_ERROR and access to the command is 922 * denied. If a command is not recognized, this procedure returns 923 * TCL_CONTINUE, and lookup continues via the normal Tcl name 924 * resolution rules. 925 * ------------------------------------------------------------------------ 926 */ 927int 928Itcl_ClassCmdResolver(interp, name, context, flags, rPtr) 929 Tcl_Interp *interp; /* current interpreter */ 930 CONST char* name; /* name of the command being accessed */ 931 Tcl_Namespace *context; /* namespace performing the resolution */ 932 int flags; /* TCL_LEAVE_ERR_MSG => leave error messages 933 * in interp if anything goes wrong */ 934 Tcl_Command *rPtr; /* returns: resolved command */ 935{ 936 ItclClass *cdefn = (ItclClass*)context->clientData; 937 938 Tcl_HashEntry *entry; 939 ItclMemberFunc *mfunc; 940 Command *cmdPtr; 941 int isCmdDeleted; 942 943 /* 944 * If the command is a member function, and if it is 945 * accessible, return its Tcl command handle. 946 */ 947 entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name); 948 if (!entry) { 949 return TCL_CONTINUE; 950 } 951 952 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 953 954 955 /* 956 * For protected/private functions, figure out whether or 957 * not the function is accessible from the current context. 958 * 959 * TRICKY NOTE: Use Itcl_GetTrueNamespace to determine 960 * the current context. If the current call frame is 961 * "transparent", this handles it properly. 962 */ 963 if (mfunc->member->protection != ITCL_PUBLIC) { 964 context = Itcl_GetTrueNamespace(interp, cdefn->info); 965 966 if (!Itcl_CanAccessFunc(mfunc, context)) { 967 968 if ((flags & TCL_LEAVE_ERR_MSG) != 0) { 969 Tcl_AppendResult(interp, 970 "can't access \"", name, "\": ", 971 Itcl_ProtectionStr(mfunc->member->protection), 972 " variable", 973 (char*)NULL); 974 } 975 return TCL_ERROR; 976 } 977 } 978 979 /* 980 * Looks like we found an accessible member function. 981 * 982 * TRICKY NOTE: Check to make sure that the command handle 983 * is still valid. If someone has deleted or renamed the 984 * command, it may not be. This is just the time to catch 985 * it--as it is being resolved again by the compiler. 986 */ 987 cmdPtr = (Command*)mfunc->accessCmd; 988 989 /* 990 * The following #if is needed so itcl can be compiled with 991 * all versions of Tcl. The integer "deleted" was renamed to 992 * "flags" in tcl8.4a2. This #if is also found in itcl_ensemble.c . 993 * We're using a runtime check with itclCompatFlags to adjust for 994 * the behavior of this change, too. 995 * 996 */ 997#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 4) 998# define CMD_IS_DELETED 0x1 /* If someone ever changes this from tcl.h, 999 * we must change our logic here, too */ 1000 isCmdDeleted = (!cmdPtr || 1001 (itclCompatFlags & ITCL_COMPAT_USECMDFLAGS ? 1002 (cmdPtr->deleted & CMD_IS_DELETED) : 1003 cmdPtr->deleted)); 1004#else 1005 isCmdDeleted = (!cmdPtr || 1006 (itclCompatFlags & ITCL_COMPAT_USECMDFLAGS ? 1007 (cmdPtr->flags & CMD_IS_DELETED) : 1008 cmdPtr->flags)); 1009#endif 1010 1011 if (isCmdDeleted) { 1012 mfunc->accessCmd = NULL; 1013 1014 if ((flags & TCL_LEAVE_ERR_MSG) != 0) { 1015 Tcl_AppendResult(interp, 1016 "can't access \"", name, "\": deleted or redefined\n", 1017 "(use the \"body\" command to redefine methods/procs)", 1018 (char*)NULL); 1019 } 1020 return TCL_ERROR; /* disallow access! */ 1021 } 1022 1023 *rPtr = mfunc->accessCmd; 1024 return TCL_OK; 1025} 1026 1027 1028/* 1029 * ------------------------------------------------------------------------ 1030 * Itcl_ClassVarResolver() 1031 * 1032 * Used by the class namespaces to handle name resolution for runtime 1033 * variable accesses. This procedure looks for references to both 1034 * common variables and instance variables at runtime. It is used as 1035 * a second line of defense, to handle references that could not be 1036 * resolved as compiled locals. 1037 * 1038 * If a variable is found, this procedure returns TCL_OK along with 1039 * the appropriate Tcl variable in the rPtr argument. If a particular 1040 * variable is private, this procedure returns TCL_ERROR and access 1041 * to the variable is denied. If a variable is not recognized, this 1042 * procedure returns TCL_CONTINUE, and lookup continues via the normal 1043 * Tcl name resolution rules. 1044 * ------------------------------------------------------------------------ 1045 */ 1046int 1047Itcl_ClassVarResolver(interp, name, context, flags, rPtr) 1048 Tcl_Interp *interp; /* current interpreter */ 1049 CONST char* name; /* name of the variable being accessed */ 1050 Tcl_Namespace *context; /* namespace performing the resolution */ 1051 int flags; /* TCL_LEAVE_ERR_MSG => leave error messages 1052 * in interp if anything goes wrong */ 1053 Tcl_Var *rPtr; /* returns: resolved variable */ 1054{ 1055 Interp *iPtr = (Interp *) interp; 1056 ItclCallFrame *varFramePtr = (ItclCallFrame *) iPtr->varFramePtr; 1057 1058 ItclClass *cdefn = (ItclClass*)context->clientData; 1059 ItclObject *contextObj; 1060 Itcl_CallFrame *framePtr; 1061 Tcl_HashEntry *entry; 1062 ItclVarLookup *vlookup; 1063 1064 assert(Itcl_IsClassNamespace(context)); 1065 1066 /* 1067 * If this is a global variable, handle it in the usual 1068 * Tcl manner. 1069 */ 1070 if (flags & TCL_GLOBAL_ONLY) { 1071 return TCL_CONTINUE; 1072 } 1073 1074 /* 1075 * See if this is a formal parameter in the current proc scope. 1076 * If so, that variable has precedence. Look it up and return 1077 * it here. This duplicates some of the functionality of 1078 * TclLookupVar, but we return it here (instead of returning 1079 * TCL_CONTINUE) to avoid looking it up again later. 1080 */ 1081 if (varFramePtr && varFramePtr->isProcCallFrame 1082 && strstr(name,"::") == NULL) { 1083 1084 Proc *procPtr = varFramePtr->procPtr; 1085 1086 /* 1087 * Search through compiled locals first... 1088 */ 1089 if (procPtr) { 1090 int localCt = procPtr->numCompiledLocals; 1091 CompiledLocal *localPtr = procPtr->firstLocalPtr; 1092 Var *localVarPtr = varFramePtr->compiledLocals; 1093 int nameLen = strlen(name); 1094 int i; 1095 1096 for (i=0; i < localCt; i++) { 1097 if (!TclIsVarTemporary(localPtr)) { 1098 register char *localName = localPtr->name; 1099 if ((name[0] == localName[0]) 1100 && (nameLen == localPtr->nameLength) 1101 && (strcmp(name, localName) == 0)) { 1102 *rPtr = (Tcl_Var)localVarPtr; 1103 return TCL_OK; 1104 } 1105 } 1106 ItclNextLocal(localVarPtr); 1107 localPtr = localPtr->nextPtr; 1108 } 1109 } 1110 1111 /* 1112 * If it's not a compiled local, then look in the frame's 1113 * var hash table next. This variable may have been 1114 * created on the fly. 1115 */ 1116 if (varFramePtr->varTablePtr != NULL) { 1117 *rPtr = (Tcl_Var) ItclVarHashFindVar(varFramePtr->varTablePtr, name); 1118 if (*rPtr) { 1119 return TCL_OK; 1120 } 1121 } 1122 } 1123 1124 /* 1125 * See if the variable is a known data member and accessible. 1126 */ 1127 entry = Tcl_FindHashEntry(&cdefn->resolveVars, name); 1128 if (entry == NULL) { 1129 return TCL_CONTINUE; 1130 } 1131 1132 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1133 if (!vlookup->accessible) { 1134 return TCL_CONTINUE; 1135 } 1136 1137 /* 1138 * If this is a common data member, then its variable 1139 * is easy to find. Return it directly. 1140 */ 1141 if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { 1142 *rPtr = vlookup->var.common; 1143 return TCL_OK; 1144 } 1145 1146 /* 1147 * If this is an instance variable, then we have to 1148 * find the object context, then index into its data 1149 * array to get the actual variable. 1150 */ 1151 framePtr = _Tcl_GetCallFrame(interp, 0); 1152 1153 entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); 1154 if (entry == NULL) { 1155 return TCL_CONTINUE; 1156 } 1157 contextObj = (ItclObject*)Tcl_GetHashValue(entry); 1158 1159 /* 1160 * TRICKY NOTE: We've resolved the variable in the current 1161 * class context, but we must also be careful to get its 1162 * index from the most-specific class context. Variables 1163 * are arranged differently depending on which class 1164 * constructed the object. 1165 */ 1166 if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { 1167 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, 1168 vlookup->vdefn->member->fullname); 1169 1170 if (entry) { 1171 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1172 } 1173 } 1174 *rPtr = (Tcl_Var)contextObj->data[vlookup->var.index]; 1175 return TCL_OK; 1176} 1177 1178 1179/* 1180 * ------------------------------------------------------------------------ 1181 * Itcl_ClassCompiledVarResolver() 1182 * 1183 * Used by the class namespaces to handle name resolution for compile 1184 * time variable accesses. This procedure looks for references to 1185 * both common variables and instance variables at compile time. If 1186 * the variables are found, they are characterized in a generic way 1187 * by their ItclVarLookup record. At runtime, Tcl constructs the 1188 * compiled local variables by calling ItclClassRuntimeVarResolver. 1189 * 1190 * If a variable is found, this procedure returns TCL_OK along with 1191 * information about the variable in the rPtr argument. If a particular 1192 * variable is private, this procedure returns TCL_ERROR and access 1193 * to the variable is denied. If a variable is not recognized, this 1194 * procedure returns TCL_CONTINUE, and lookup continues via the normal 1195 * Tcl name resolution rules. 1196 * ------------------------------------------------------------------------ 1197 */ 1198int 1199Itcl_ClassCompiledVarResolver(interp, name, length, context, rPtr) 1200 Tcl_Interp *interp; /* current interpreter */ 1201 CONST char* name; /* name of the variable being accessed */ 1202 int length; /* number of characters in name */ 1203 Tcl_Namespace *context; /* namespace performing the resolution */ 1204 Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to 1205 * resolve the variable at runtime */ 1206{ 1207 ItclClass *cdefn = (ItclClass*)context->clientData; 1208 Tcl_HashEntry *entry; 1209 ItclVarLookup *vlookup; 1210 char *buffer, storage[64]; 1211 1212 assert(Itcl_IsClassNamespace(context)); 1213 1214 /* 1215 * Copy the name to local storage so we can NULL terminate it. 1216 * If the name is long, allocate extra space for it. 1217 */ 1218 if (length < sizeof(storage)) { 1219 buffer = storage; 1220 } else { 1221 buffer = (char*)ckalloc((unsigned)(length+1)); 1222 } 1223 memcpy((void*)buffer, (void*)name, (size_t)length); 1224 buffer[length] = '\0'; 1225 1226 entry = Tcl_FindHashEntry(&cdefn->resolveVars, buffer); 1227 1228 if (buffer != storage) { 1229 ckfree(buffer); 1230 } 1231 1232 /* 1233 * If the name is not found, or if it is inaccessible, 1234 * continue on with the normal Tcl name resolution rules. 1235 */ 1236 if (entry == NULL) { 1237 return TCL_CONTINUE; 1238 } 1239 1240 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1241 if (!vlookup->accessible) { 1242 return TCL_CONTINUE; 1243 } 1244 1245 /* 1246 * Return the ItclVarLookup record. At runtime, Tcl will 1247 * call ItclClassRuntimeVarResolver with this record, to 1248 * plug in the appropriate variable for the current object 1249 * context. 1250 */ 1251 (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); 1252 (*rPtr)->fetchProc = ItclClassRuntimeVarResolver; 1253 (*rPtr)->deleteProc = NULL; 1254 ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; 1255 1256 return TCL_OK; 1257} 1258 1259 1260/* 1261 * ------------------------------------------------------------------------ 1262 * ItclClassRuntimeVarResolver() 1263 * 1264 * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc 1265 * at runtime. Resolves data members identified earlier by 1266 * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation 1267 * for the data member. 1268 * ------------------------------------------------------------------------ 1269 */ 1270static Tcl_Var 1271ItclClassRuntimeVarResolver(interp, resVarInfo) 1272 Tcl_Interp *interp; /* current interpreter */ 1273 Tcl_ResolvedVarInfo *resVarInfo; /* contains ItclVarLookup rep 1274 * for variable */ 1275{ 1276 ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; 1277 1278 Itcl_CallFrame *framePtr; 1279 ItclClass *cdefn; 1280 ItclObject *contextObj; 1281 Tcl_HashEntry *entry; 1282 1283 /* 1284 * If this is a common data member, then the associated 1285 * variable is known directly. 1286 */ 1287 if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { 1288 return vlookup->var.common; 1289 } 1290 cdefn = vlookup->vdefn->member->classDefn; 1291 1292 /* 1293 * Otherwise, get the current object context and find the 1294 * variable in its data table. 1295 * 1296 * TRICKY NOTE: Get the index for this variable using the 1297 * virtual table for the MOST-SPECIFIC class. 1298 */ 1299 framePtr = _Tcl_GetCallFrame(interp, 0); 1300 1301 entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); 1302 if (entry) { 1303 contextObj = (ItclObject*)Tcl_GetHashValue(entry); 1304 1305 if (contextObj != NULL) { 1306 if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { 1307 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, 1308 vlookup->vdefn->member->fullname); 1309 1310 if (entry) { 1311 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1312 } 1313 } 1314 return (Tcl_Var)contextObj->data[vlookup->var.index]; 1315 } 1316 } 1317 return NULL; 1318} 1319 1320 1321/* 1322 * ------------------------------------------------------------------------ 1323 * Itcl_BuildVirtualTables() 1324 * 1325 * Invoked whenever the class heritage changes or members are added or 1326 * removed from a class definition to rebuild the member lookup 1327 * tables. There are two tables: 1328 * 1329 * METHODS: resolveCmds 1330 * Used primarily in Itcl_ClassCmdResolver() to resolve all 1331 * command references in a namespace. 1332 * 1333 * DATA MEMBERS: resolveVars 1334 * Used primarily in Itcl_ClassVarResolver() to quickly resolve 1335 * variable references in each class scope. 1336 * 1337 * These tables store every possible name for each command/variable 1338 * (member, class::member, namesp::class::member, etc.). Members 1339 * in a derived class may shadow members with the same name in a 1340 * base class. In that case, the simple name in the resolution 1341 * table will point to the most-specific member. 1342 * ------------------------------------------------------------------------ 1343 */ 1344void 1345Itcl_BuildVirtualTables(cdefnPtr) 1346 ItclClass* cdefnPtr; /* class definition being updated */ 1347{ 1348 Tcl_HashEntry *entry; 1349 Tcl_HashSearch place; 1350 ItclVarLookup *vlookup; 1351 ItclVarDefn *vdefn; 1352 ItclMemberFunc *mfunc; 1353 ItclHierIter hier; 1354 ItclClass *cdPtr; 1355 Namespace* nsPtr; 1356 Tcl_DString buffer, buffer2; 1357 int newEntry; 1358 1359 Tcl_DStringInit(&buffer); 1360 Tcl_DStringInit(&buffer2); 1361 1362 /* 1363 * Clear the variable resolution table. 1364 */ 1365 entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); 1366 while (entry) { 1367 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 1368 if (--vlookup->usage == 0) { 1369 ckfree((char*)vlookup); 1370 } 1371 entry = Tcl_NextHashEntry(&place); 1372 } 1373 Tcl_DeleteHashTable(&cdefnPtr->resolveVars); 1374 Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS); 1375 cdefnPtr->numInstanceVars = 0; 1376 1377 /* 1378 * Set aside the first object-specific slot for the built-in 1379 * "this" variable. Only allocate one of these, even though 1380 * there is a definition for "this" in each class scope. 1381 */ 1382 cdefnPtr->numInstanceVars++; 1383 1384 /* 1385 * Scan through all classes in the hierarchy, from most to 1386 * least specific. Add a lookup entry for each variable 1387 * into the table. 1388 */ 1389 Itcl_InitHierIter(&hier, cdefnPtr); 1390 cdPtr = Itcl_AdvanceHierIter(&hier); 1391 while (cdPtr != NULL) { 1392 entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); 1393 while (entry) { 1394 vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); 1395 1396 vlookup = (ItclVarLookup*)ckalloc(sizeof(ItclVarLookup)); 1397 vlookup->vdefn = vdefn; 1398 vlookup->usage = 0; 1399 vlookup->leastQualName = NULL; 1400 1401 /* 1402 * If this variable is PRIVATE to another class scope, 1403 * then mark it as "inaccessible". 1404 */ 1405 vlookup->accessible = 1406 ( vdefn->member->protection != ITCL_PRIVATE || 1407 vdefn->member->classDefn == cdefnPtr ); 1408 1409 /* 1410 * If this is a common variable, then keep a reference to 1411 * the variable directly. Otherwise, keep an index into 1412 * the object's variable table. 1413 */ 1414 if ((vdefn->member->flags & ITCL_COMMON) != 0) { 1415 nsPtr = (Namespace*)cdPtr->namesp; 1416 vlookup->var.common = (Tcl_Var) ItclVarHashFindVar(&nsPtr->varTable, vdefn->member->name); 1417 assert(vlookup->var.common != NULL); 1418 } 1419 else { 1420 /* 1421 * If this is a reference to the built-in "this" 1422 * variable, then its index is "0". Otherwise, 1423 * add another slot to the end of the table. 1424 */ 1425 if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { 1426 vlookup->var.index = 0; 1427 } 1428 else { 1429 vlookup->var.index = cdefnPtr->numInstanceVars++; 1430 } 1431 } 1432 1433 /* 1434 * Create all possible names for this variable and enter 1435 * them into the variable resolution table: 1436 * var 1437 * class::var 1438 * namesp1::class::var 1439 * namesp2::namesp1::class::var 1440 * ... 1441 */ 1442 Tcl_DStringSetLength(&buffer, 0); 1443 Tcl_DStringAppend(&buffer, vdefn->member->name, -1); 1444 nsPtr = (Namespace*)cdPtr->namesp; 1445 1446 while (1) { 1447 entry = Tcl_CreateHashEntry(&cdefnPtr->resolveVars, 1448 Tcl_DStringValue(&buffer), &newEntry); 1449 1450 if (newEntry) { 1451 Tcl_SetHashValue(entry, (ClientData)vlookup); 1452 vlookup->usage++; 1453 1454 if (!vlookup->leastQualName) { 1455 vlookup->leastQualName = 1456 Tcl_GetHashKey(&cdefnPtr->resolveVars, entry); 1457 } 1458 } 1459 1460 if (nsPtr == NULL) { 1461 break; 1462 } 1463 Tcl_DStringSetLength(&buffer2, 0); 1464 Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); 1465 Tcl_DStringSetLength(&buffer, 0); 1466 Tcl_DStringAppend(&buffer, nsPtr->name, -1); 1467 Tcl_DStringAppend(&buffer, "::", -1); 1468 Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); 1469 1470 nsPtr = nsPtr->parentPtr; 1471 } 1472 1473 /* 1474 * If this record is not needed, free it now. 1475 */ 1476 if (vlookup->usage == 0) { 1477 ckfree((char*)vlookup); 1478 } 1479 entry = Tcl_NextHashEntry(&place); 1480 } 1481 cdPtr = Itcl_AdvanceHierIter(&hier); 1482 } 1483 Itcl_DeleteHierIter(&hier); 1484 1485 /* 1486 * Clear the command resolution table. 1487 */ 1488 Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); 1489 Tcl_InitHashTable(&cdefnPtr->resolveCmds, TCL_STRING_KEYS); 1490 1491 /* 1492 * Scan through all classes in the hierarchy, from most to 1493 * least specific. Look for the first (most-specific) definition 1494 * of each member function, and enter it into the table. 1495 */ 1496 Itcl_InitHierIter(&hier, cdefnPtr); 1497 cdPtr = Itcl_AdvanceHierIter(&hier); 1498 while (cdPtr != NULL) { 1499 entry = Tcl_FirstHashEntry(&cdPtr->functions, &place); 1500 while (entry) { 1501 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 1502 1503 /* 1504 * Create all possible names for this function and enter 1505 * them into the command resolution table: 1506 * func 1507 * class::func 1508 * namesp1::class::func 1509 * namesp2::namesp1::class::func 1510 * ... 1511 */ 1512 Tcl_DStringSetLength(&buffer, 0); 1513 Tcl_DStringAppend(&buffer, mfunc->member->name, -1); 1514 nsPtr = (Namespace*)cdPtr->namesp; 1515 1516 while (1) { 1517 entry = Tcl_CreateHashEntry(&cdefnPtr->resolveCmds, 1518 Tcl_DStringValue(&buffer), &newEntry); 1519 1520 if (newEntry) { 1521 Tcl_SetHashValue(entry, (ClientData)mfunc); 1522 } 1523 1524 if (nsPtr == NULL) { 1525 break; 1526 } 1527 Tcl_DStringSetLength(&buffer2, 0); 1528 Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); 1529 Tcl_DStringSetLength(&buffer, 0); 1530 Tcl_DStringAppend(&buffer, nsPtr->name, -1); 1531 Tcl_DStringAppend(&buffer, "::", -1); 1532 Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); 1533 1534 nsPtr = nsPtr->parentPtr; 1535 } 1536 entry = Tcl_NextHashEntry(&place); 1537 } 1538 cdPtr = Itcl_AdvanceHierIter(&hier); 1539 } 1540 Itcl_DeleteHierIter(&hier); 1541 1542 Tcl_DStringFree(&buffer); 1543 Tcl_DStringFree(&buffer2); 1544} 1545 1546 1547/* 1548 * ------------------------------------------------------------------------ 1549 * Itcl_CreateVarDefn() 1550 * 1551 * Creates a new class variable definition. If this is a public 1552 * variable, it may have a bit of "config" code that is used to 1553 * update the object whenever the variable is modified via the 1554 * built-in "configure" method. 1555 * 1556 * Returns TCL_ERROR along with an error message in the specified 1557 * interpreter if anything goes wrong. Otherwise, this returns 1558 * TCL_OK and a pointer to the new variable definition in "vdefnPtr". 1559 * ------------------------------------------------------------------------ 1560 */ 1561int 1562Itcl_CreateVarDefn(interp, cdefn, name, init, config, vdefnPtr) 1563 Tcl_Interp *interp; /* interpreter managing this transaction */ 1564 ItclClass* cdefn; /* class containing this variable */ 1565 char* name; /* variable name */ 1566 char* init; /* initial value */ 1567 char* config; /* code invoked when variable is configured */ 1568 ItclVarDefn** vdefnPtr; /* returns: new variable definition */ 1569{ 1570 int newEntry; 1571 ItclVarDefn *vdefn; 1572 ItclMemberCode *mcode; 1573 Tcl_HashEntry *entry; 1574 1575 /* 1576 * Add this variable to the variable table for the class. 1577 * Make sure that the variable name does not already exist. 1578 */ 1579 entry = Tcl_CreateHashEntry(&cdefn->variables, name, &newEntry); 1580 if (!newEntry) { 1581 Tcl_AppendResult(interp, 1582 "variable name \"", name, "\" already defined in class \"", 1583 cdefn->fullname, "\"", 1584 (char*)NULL); 1585 return TCL_ERROR; 1586 } 1587 1588 /* 1589 * If this variable has some "config" code, try to capture 1590 * its implementation. 1591 */ 1592 if (config) { 1593 if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config, 1594 &mcode) != TCL_OK) { 1595 1596 Tcl_DeleteHashEntry(entry); 1597 return TCL_ERROR; 1598 } 1599 Itcl_PreserveData((ClientData)mcode); 1600 Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); 1601 } 1602 else { 1603 mcode = NULL; 1604 } 1605 1606 /* 1607 * If everything looks good, create the variable definition. 1608 */ 1609 vdefn = (ItclVarDefn*)ckalloc(sizeof(ItclVarDefn)); 1610 vdefn->member = Itcl_CreateMember(interp, cdefn, name); 1611 vdefn->member->code = mcode; 1612 1613 if (vdefn->member->protection == ITCL_DEFAULT_PROTECT) { 1614 vdefn->member->protection = ITCL_PROTECTED; 1615 } 1616 1617 if (init) { 1618 vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1)); 1619 strcpy(vdefn->init, init); 1620 } 1621 else { 1622 vdefn->init = NULL; 1623 } 1624 1625 Tcl_SetHashValue(entry, (ClientData)vdefn); 1626 1627 *vdefnPtr = vdefn; 1628 return TCL_OK; 1629} 1630 1631/* 1632 * ------------------------------------------------------------------------ 1633 * Itcl_DeleteVarDefn() 1634 * 1635 * Destroys a variable definition created by Itcl_CreateVarDefn(), 1636 * freeing all resources associated with it. 1637 * ------------------------------------------------------------------------ 1638 */ 1639void 1640Itcl_DeleteVarDefn(vdefn) 1641 ItclVarDefn *vdefn; /* variable definition to be destroyed */ 1642{ 1643 Itcl_DeleteMember(vdefn->member); 1644 1645 if (vdefn->init) { 1646 ckfree(vdefn->init); 1647 } 1648 ckfree((char*)vdefn); 1649} 1650 1651 1652/* 1653 * ------------------------------------------------------------------------ 1654 * Itcl_GetCommonVar() 1655 * 1656 * Returns the current value for a common class variable. The member 1657 * name is interpreted with respect to the given class scope. That 1658 * scope is installed as the current context before querying the 1659 * variable. This by-passes the protection level in case the variable 1660 * is "private". 1661 * 1662 * If successful, this procedure returns a pointer to a string value 1663 * which remains alive until the variable changes it value. If 1664 * anything goes wrong, this returns NULL. 1665 * ------------------------------------------------------------------------ 1666 */ 1667CONST char* 1668Itcl_GetCommonVar(interp, name, contextClass) 1669 Tcl_Interp *interp; /* current interpreter */ 1670 CONST char *name; /* name of desired instance variable */ 1671 ItclClass *contextClass; /* name is interpreted in this scope */ 1672{ 1673 CONST char *val = NULL; 1674 int result; 1675 Itcl_CallFrame frame; 1676 1677 /* 1678 * Activate the namespace for the given class. That installs 1679 * the appropriate name resolution rules and by-passes any 1680 * security restrictions. 1681 */ 1682 result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, 1683 contextClass->namesp, /*isProcCallFrame*/ 0); 1684 1685 if (result == TCL_OK) { 1686 val = Tcl_GetVar2(interp, (CONST84 char *)name, (char*)NULL, 0); 1687 Tcl_PopCallFrame(interp); 1688 } 1689 return val; 1690} 1691 1692 1693/* 1694 * ------------------------------------------------------------------------ 1695 * Itcl_CreateMember() 1696 * 1697 * Creates the data record representing a class member. This is the 1698 * generic representation for a data member or member function. 1699 * Returns a pointer to the new representation. 1700 * ------------------------------------------------------------------------ 1701 */ 1702ItclMember* 1703Itcl_CreateMember(interp, cdefn, name) 1704 Tcl_Interp* interp; /* interpreter managing this action */ 1705 ItclClass *cdefn; /* class definition */ 1706 CONST char* name; /* name of new member */ 1707{ 1708 ItclMember *memPtr; 1709 int fullsize; 1710 1711 /* 1712 * Allocate the memory for a class member and fill in values. 1713 */ 1714 memPtr = (ItclMember*)ckalloc(sizeof(ItclMember)); 1715 memPtr->interp = interp; 1716 memPtr->classDefn = cdefn; 1717 memPtr->flags = 0; 1718 memPtr->protection = Itcl_Protection(interp, 0); 1719 memPtr->code = NULL; 1720 1721 fullsize = strlen(cdefn->fullname) + strlen(name) + 2; 1722 memPtr->fullname = (char*)ckalloc((unsigned)(fullsize+1)); 1723 strcpy(memPtr->fullname, cdefn->fullname); 1724 strcat(memPtr->fullname, "::"); 1725 strcat(memPtr->fullname, name); 1726 1727 memPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); 1728 strcpy(memPtr->name, name); 1729 1730 return memPtr; 1731} 1732 1733 1734/* 1735 * ------------------------------------------------------------------------ 1736 * Itcl_DeleteMember() 1737 * 1738 * Destroys all data associated with the given member function definition. 1739 * Usually invoked by the interpreter when a member function is deleted. 1740 * ------------------------------------------------------------------------ 1741 */ 1742void 1743Itcl_DeleteMember(memPtr) 1744 ItclMember *memPtr; /* pointer to member function definition */ 1745{ 1746 if (memPtr) { 1747 ckfree(memPtr->name); 1748 ckfree(memPtr->fullname); 1749 1750 if (memPtr->code) { 1751 Itcl_ReleaseData((ClientData)memPtr->code); 1752 } 1753 memPtr->code = NULL; 1754 1755 ckfree((char*)memPtr); 1756 } 1757} 1758 1759 1760/* 1761 * ------------------------------------------------------------------------ 1762 * Itcl_InitHierIter() 1763 * 1764 * Initializes an iterator for traversing the hierarchy of the given 1765 * class. Subsequent calls to Itcl_AdvanceHierIter() will return 1766 * the base classes in order from most-to-least specific. 1767 * ------------------------------------------------------------------------ 1768 */ 1769void 1770Itcl_InitHierIter(iter,cdefn) 1771 ItclHierIter *iter; /* iterator used for traversal */ 1772 ItclClass *cdefn; /* class definition for start of traversal */ 1773{ 1774 Itcl_InitStack(&iter->stack); 1775 Itcl_PushStack((ClientData)cdefn, &iter->stack); 1776 iter->current = cdefn; 1777} 1778 1779/* 1780 * ------------------------------------------------------------------------ 1781 * Itcl_DeleteHierIter() 1782 * 1783 * Destroys an iterator for traversing class hierarchies, freeing 1784 * all memory associated with it. 1785 * ------------------------------------------------------------------------ 1786 */ 1787void 1788Itcl_DeleteHierIter(iter) 1789 ItclHierIter *iter; /* iterator used for traversal */ 1790{ 1791 Itcl_DeleteStack(&iter->stack); 1792 iter->current = NULL; 1793} 1794 1795/* 1796 * ------------------------------------------------------------------------ 1797 * Itcl_AdvanceHierIter() 1798 * 1799 * Moves a class hierarchy iterator forward to the next base class. 1800 * Returns a pointer to the current class definition, or NULL when 1801 * the end of the hierarchy has been reached. 1802 * ------------------------------------------------------------------------ 1803 */ 1804ItclClass* 1805Itcl_AdvanceHierIter(iter) 1806 ItclHierIter *iter; /* iterator used for traversal */ 1807{ 1808 register Itcl_ListElem *elem; 1809 ItclClass *cdPtr; 1810 1811 iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); 1812 1813 /* 1814 * Push classes onto the stack in reverse order, so that 1815 * they will be popped off in the proper order. 1816 */ 1817 if (iter->current) { 1818 cdPtr = (ItclClass*)iter->current; 1819 elem = Itcl_LastListElem(&cdPtr->bases); 1820 while (elem) { 1821 Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack); 1822 elem = Itcl_PrevListElem(elem); 1823 } 1824 } 1825 return iter->current; 1826} 1827