1/* 2 * ------------------------------------------------------------------------ 3 * PACKAGE: [incr Tcl] 4 * DESCRIPTION: Object-Oriented Extensions to Tcl 5 * 6 * [incr Tcl] provides object-oriented extensions to Tcl, much as 7 * C++ provides object-oriented extensions to C. It provides a means 8 * of encapsulating related procedures together with their shared data 9 * in a local namespace that is hidden from the outside world. It 10 * promotes code re-use through inheritance. More than anything else, 11 * it encourages better organization of Tcl applications through the 12 * object-oriented paradigm, leading to code that is easier to 13 * understand and maintain. 14 * 15 * These procedures handle commands available within a class scope. 16 * In [incr Tcl], the term "method" is used for a procedure that has 17 * access to object-specific data, while the term "proc" is used for 18 * a procedure that has access only to common class data. 19 * 20 * ======================================================================== 21 * AUTHOR: Michael J. McLennan 22 * Bell Labs Innovations for Lucent Technologies 23 * mmclennan@lucent.com 24 * http://www.tcltk.com/itcl 25 * 26 * RCS: $Id: itcl_methods.c,v 1.24 2008/12/15 20:02:58 andreas_kupries 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 * FORWARD DECLARATIONS 37 */ 38static int ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp, 39 int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj, 40 int *rargc, ItclVarDefn ***rvars, char ***rvals)); 41 42static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp, 43 int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj)); 44 45 46/* 47 * ------------------------------------------------------------------------ 48 * Itcl_BodyCmd() 49 * 50 * Invoked by Tcl whenever the user issues an "itcl::body" command to 51 * define or redefine the implementation for a class method/proc. 52 * Handles the following syntax: 53 * 54 * itcl::body <class>::<func> <arglist> <body> 55 * 56 * Looks for an existing class member function with the name <func>, 57 * and if found, tries to assign the implementation. If an argument 58 * list was specified in the original declaration, it must match 59 * <arglist> or an error is flagged. If <body> has the form "@name" 60 * then it is treated as a reference to a C handling procedure; 61 * otherwise, it is taken as a body of Tcl statements. 62 * 63 * Returns TCL_OK/TCL_ERROR to indicate success/failure. 64 * ------------------------------------------------------------------------ 65 */ 66/* ARGSUSED */ 67int 68Itcl_BodyCmd(dummy, interp, objc, objv) 69 ClientData dummy; /* unused */ 70 Tcl_Interp *interp; /* current interpreter */ 71 int objc; /* number of arguments */ 72 Tcl_Obj *CONST objv[]; /* argument objects */ 73{ 74 int status = TCL_OK; 75 76 char *head, *tail, *token, *arglist, *body; 77 ItclClass *cdefn; 78 ItclMemberFunc *mfunc; 79 Tcl_HashEntry *entry; 80 Tcl_DString buffer; 81 82 if (objc != 4) { 83 token = Tcl_GetStringFromObj(objv[0], (int*)NULL); 84 Tcl_AppendResult(interp, 85 "wrong # args: should be \"", 86 token, " class::func arglist body\"", 87 (char*)NULL); 88 return TCL_ERROR; 89 } 90 91 /* 92 * Parse the member name "namesp::namesp::class::func". 93 * Make sure that a class name was specified, and that the 94 * class exists. 95 */ 96 token = Tcl_GetStringFromObj(objv[1], (int*)NULL); 97 Itcl_ParseNamespPath(token, &buffer, &head, &tail); 98 99 if (!head || *head == '\0') { 100 Tcl_AppendResult(interp, 101 "missing class specifier for body declaration \"", token, "\"", 102 (char*)NULL); 103 status = TCL_ERROR; 104 goto bodyCmdDone; 105 } 106 107 cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); 108 if (cdefn == NULL) { 109 status = TCL_ERROR; 110 goto bodyCmdDone; 111 } 112 113 /* 114 * Find the function and try to change its implementation. 115 * Note that command resolution table contains *all* functions, 116 * even those in a base class. Make sure that the class 117 * containing the method definition is the requested class. 118 */ 119 120 mfunc = NULL; 121 entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail); 122 if (entry) { 123 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 124 if (mfunc->member->classDefn != cdefn) { 125 mfunc = NULL; 126 } 127 } 128 129 if (mfunc == NULL) { 130 Tcl_AppendResult(interp, 131 "function \"", tail, "\" is not defined in class \"", 132 cdefn->fullname, "\"", 133 (char*)NULL); 134 status = TCL_ERROR; 135 goto bodyCmdDone; 136 } 137 138 arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); 139 body = Tcl_GetStringFromObj(objv[3], (int*)NULL); 140 141 if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) { 142 status = TCL_ERROR; 143 goto bodyCmdDone; 144 } 145 146bodyCmdDone: 147 Tcl_DStringFree(&buffer); 148 return status; 149} 150 151 152/* 153 * ------------------------------------------------------------------------ 154 * Itcl_ConfigBodyCmd() 155 * 156 * Invoked by Tcl whenever the user issues an "itcl::configbody" command 157 * to define or redefine the configuration code associated with a 158 * public variable. Handles the following syntax: 159 * 160 * itcl::configbody <class>::<publicVar> <body> 161 * 162 * Looks for an existing public variable with the name <publicVar>, 163 * and if found, tries to assign the implementation. If <body> has 164 * the form "@name" then it is treated as a reference to a C handling 165 * procedure; otherwise, it is taken as a body of Tcl statements. 166 * 167 * Returns TCL_OK/TCL_ERROR to indicate success/failure. 168 * ------------------------------------------------------------------------ 169 */ 170/* ARGSUSED */ 171int 172Itcl_ConfigBodyCmd(dummy, interp, objc, objv) 173 ClientData dummy; /* unused */ 174 Tcl_Interp *interp; /* current interpreter */ 175 int objc; /* number of arguments */ 176 Tcl_Obj *CONST objv[]; /* argument objects */ 177{ 178 int status = TCL_OK; 179 180 char *head, *tail, *token; 181 Tcl_DString buffer; 182 ItclClass *cdefn; 183 ItclVarLookup *vlookup; 184 ItclMember *member; 185 ItclMemberCode *mcode; 186 Tcl_HashEntry *entry; 187 188 if (objc != 3) { 189 Tcl_WrongNumArgs(interp, 1, objv, "class::option body"); 190 return TCL_ERROR; 191 } 192 193 /* 194 * Parse the member name "namesp::namesp::class::option". 195 * Make sure that a class name was specified, and that the 196 * class exists. 197 */ 198 token = Tcl_GetStringFromObj(objv[1], (int*)NULL); 199 Itcl_ParseNamespPath(token, &buffer, &head, &tail); 200 201 if (!head || *head == '\0') { 202 Tcl_AppendResult(interp, 203 "missing class specifier for body declaration \"", token, "\"", 204 (char*)NULL); 205 status = TCL_ERROR; 206 goto configBodyCmdDone; 207 } 208 209 cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); 210 if (cdefn == NULL) { 211 status = TCL_ERROR; 212 goto configBodyCmdDone; 213 } 214 215 /* 216 * Find the variable and change its implementation. 217 * Note that variable resolution table has *all* variables, 218 * even those in a base class. Make sure that the class 219 * containing the variable definition is the requested class. 220 */ 221 vlookup = NULL; 222 entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail); 223 if (entry) { 224 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 225 if (vlookup->vdefn->member->classDefn != cdefn) { 226 vlookup = NULL; 227 } 228 } 229 230 if (vlookup == NULL) { 231 Tcl_AppendResult(interp, 232 "option \"", tail, "\" is not defined in class \"", 233 cdefn->fullname, "\"", 234 (char*)NULL); 235 status = TCL_ERROR; 236 goto configBodyCmdDone; 237 } 238 member = vlookup->vdefn->member; 239 240 if (member->protection != ITCL_PUBLIC) { 241 Tcl_AppendResult(interp, 242 "option \"", member->fullname, 243 "\" is not a public configuration option", 244 (char*)NULL); 245 status = TCL_ERROR; 246 goto configBodyCmdDone; 247 } 248 249 token = Tcl_GetStringFromObj(objv[2], (int*)NULL); 250 251 if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token, 252 &mcode) != TCL_OK) { 253 254 status = TCL_ERROR; 255 goto configBodyCmdDone; 256 } 257 258 Itcl_PreserveData((ClientData)mcode); 259 Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); 260 261 if (member->code) { 262 Itcl_ReleaseData((ClientData)member->code); 263 } 264 member->code = mcode; 265 266configBodyCmdDone: 267 Tcl_DStringFree(&buffer); 268 return status; 269} 270 271 272/* 273 * ------------------------------------------------------------------------ 274 * Itcl_CreateMethod() 275 * 276 * Installs a method into the namespace associated with a class. 277 * If another command with the same name is already installed, then 278 * it is overwritten. 279 * 280 * Returns TCL_OK on success, or TCL_ERROR (along with an error message 281 * in the specified interp) if anything goes wrong. 282 * ------------------------------------------------------------------------ 283 */ 284int 285Itcl_CreateMethod(interp, cdefn, name, arglist, body) 286 Tcl_Interp* interp; /* interpreter managing this action */ 287 ItclClass *cdefn; /* class definition */ 288 CONST char* name; /* name of new method */ 289 CONST char* arglist; /* space-separated list of arg names */ 290 CONST char* body; /* body of commands for the method */ 291{ 292 ItclMemberFunc *mfunc; 293 Tcl_DString buffer; 294 295 /* 296 * Make sure that the method name does not contain anything 297 * goofy like a "::" scope qualifier. 298 */ 299 if (strstr(name,"::")) { 300 Tcl_AppendResult(interp, 301 "bad method name \"", name, "\"", 302 (char*)NULL); 303 return TCL_ERROR; 304 } 305 306 /* 307 * Create the method definition. 308 */ 309 if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) 310 != TCL_OK) { 311 return TCL_ERROR; 312 } 313 314 /* 315 * Build a fully-qualified name for the method, and install 316 * the command handler. 317 */ 318 Tcl_DStringInit(&buffer); 319 Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); 320 Tcl_DStringAppend(&buffer, "::", 2); 321 Tcl_DStringAppend(&buffer, name, -1); 322 name = Tcl_DStringValue(&buffer); 323 324 Itcl_PreserveData((ClientData)mfunc); 325 mfunc->accessCmd = Tcl_CreateObjCommand(interp, (CONST84 char *)name, 326 Itcl_ExecMethod, (ClientData)mfunc, Itcl_ReleaseData); 327 328 Tcl_DStringFree(&buffer); 329 return TCL_OK; 330} 331 332 333/* 334 * ------------------------------------------------------------------------ 335 * Itcl_CreateProc() 336 * 337 * Installs a class proc into the namespace associated with a class. 338 * If another command with the same name is already installed, then 339 * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along 340 * with an error message in the specified interp) if anything goes 341 * wrong. 342 * ------------------------------------------------------------------------ 343 */ 344int 345Itcl_CreateProc(interp, cdefn, name, arglist, body) 346 Tcl_Interp* interp; /* interpreter managing this action */ 347 ItclClass *cdefn; /* class definition */ 348 CONST char* name; /* name of new proc */ 349 CONST char* arglist; /* space-separated list of arg names */ 350 CONST char* body; /* body of commands for the proc */ 351{ 352 ItclMemberFunc *mfunc; 353 Tcl_DString buffer; 354 355 /* 356 * Make sure that the proc name does not contain anything 357 * goofy like a "::" scope qualifier. 358 */ 359 if (strstr(name,"::")) { 360 Tcl_AppendResult(interp, 361 "bad proc name \"", name, "\"", 362 (char*)NULL); 363 return TCL_ERROR; 364 } 365 366 /* 367 * Create the proc definition. 368 */ 369 if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) 370 != TCL_OK) { 371 return TCL_ERROR; 372 } 373 374 /* 375 * Mark procs as "common". This distinguishes them from methods. 376 */ 377 mfunc->member->flags |= ITCL_COMMON; 378 379 /* 380 * Build a fully-qualified name for the proc, and install 381 * the command handler. 382 */ 383 Tcl_DStringInit(&buffer); 384 Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); 385 Tcl_DStringAppend(&buffer, "::", 2); 386 Tcl_DStringAppend(&buffer, name, -1); 387 name = Tcl_DStringValue(&buffer); 388 389 Itcl_PreserveData((ClientData)mfunc); 390 mfunc->accessCmd = Tcl_CreateObjCommand(interp, (CONST84 char *)name, 391 Itcl_ExecProc, (ClientData)mfunc, Itcl_ReleaseData); 392 393 Tcl_DStringFree(&buffer); 394 return TCL_OK; 395} 396 397 398/* 399 * ------------------------------------------------------------------------ 400 * Itcl_CreateMemberFunc() 401 * 402 * Creates the data record representing a member function. This 403 * includes the argument list and the body of the function. If the 404 * body is of the form "@name", then it is treated as a label for 405 * a C procedure registered by Itcl_RegisterC(). 406 * 407 * If any errors are encountered, this procedure returns TCL_ERROR 408 * along with an error message in the interpreter. Otherwise, it 409 * returns TCL_OK, and "mfuncPtr" returns a pointer to the new 410 * member function. 411 * ------------------------------------------------------------------------ 412 */ 413int 414Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr) 415 Tcl_Interp* interp; /* interpreter managing this action */ 416 ItclClass *cdefn; /* class definition */ 417 CONST char* name; /* name of new member */ 418 CONST char* arglist; /* space-separated list of arg names */ 419 CONST char* body; /* body of commands for the method */ 420 ItclMemberFunc** mfuncPtr; /* returns: pointer to new method defn */ 421{ 422 int newEntry; 423 ItclMemberFunc *mfunc; 424 ItclMemberCode *mcode; 425 Tcl_HashEntry *entry; 426 427 /* 428 * Add the member function to the list of functions for 429 * the class. Make sure that a member function with the 430 * same name doesn't already exist. 431 */ 432 entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry); 433 434 if (!newEntry) { 435 Tcl_AppendResult(interp, 436 "\"", name, "\" already defined in class \"", 437 cdefn->fullname, "\"", 438 (char*)NULL); 439 return TCL_ERROR; 440 } 441 442 /* 443 * Try to create the implementation for this command member. 444 */ 445 if (Itcl_CreateMemberCode(interp, cdefn, arglist, body, 446 &mcode) != TCL_OK) { 447 448 Tcl_DeleteHashEntry(entry); 449 return TCL_ERROR; 450 } 451 Itcl_PreserveData((ClientData)mcode); 452 Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); 453 454 /* 455 * Allocate a member function definition and return. 456 */ 457 mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc)); 458 mfunc->member = Itcl_CreateMember(interp, cdefn, name); 459 mfunc->member->code = mcode; 460 461 if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) { 462 mfunc->member->protection = ITCL_PUBLIC; 463 } 464 465 mfunc->arglist = NULL; 466 mfunc->argcount = 0; 467 mfunc->accessCmd = NULL; 468 469 if (arglist) { 470 mfunc->member->flags |= ITCL_ARG_SPEC; 471 } 472 if (mcode->arglist) { 473 Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist); 474 } 475 476 if (strcmp(name,"constructor") == 0) { 477 mfunc->member->flags |= ITCL_CONSTRUCTOR; 478 } 479 if (strcmp(name,"destructor") == 0) { 480 mfunc->member->flags |= ITCL_DESTRUCTOR; 481 } 482 483 Tcl_SetHashValue(entry, (ClientData)mfunc); 484 Itcl_PreserveData((ClientData)mfunc); 485 Itcl_EventuallyFree((ClientData)mfunc, (Tcl_FreeProc*) Itcl_DeleteMemberFunc); 486 487 *mfuncPtr = mfunc; 488 return TCL_OK; 489} 490 491 492/* 493 * ------------------------------------------------------------------------ 494 * Itcl_ChangeMemberFunc() 495 * 496 * Modifies the data record representing a member function. This 497 * is usually the body of the function, but can include the argument 498 * list if it was not defined when the member was first created. 499 * If the body is of the form "@name", then it is treated as a label 500 * for a C procedure registered by Itcl_RegisterC(). 501 * 502 * If any errors are encountered, this procedure returns TCL_ERROR 503 * along with an error message in the interpreter. Otherwise, it 504 * returns TCL_OK, and "mfuncPtr" returns a pointer to the new 505 * member function. 506 * ------------------------------------------------------------------------ 507 */ 508int 509Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) 510 Tcl_Interp* interp; /* interpreter managing this action */ 511 ItclMemberFunc* mfunc; /* command member being changed */ 512 CONST char* arglist; /* space-separated list of arg names */ 513 CONST char* body; /* body of commands for the method */ 514{ 515 ItclMemberCode *mcode = NULL; 516 Tcl_Obj *objPtr; 517 518 /* 519 * Try to create the implementation for this command member. 520 */ 521 if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn, 522 arglist, body, &mcode) != TCL_OK) { 523 524 return TCL_ERROR; 525 } 526 527 /* 528 * If the argument list was defined when the function was 529 * created, compare the arg lists or usage strings to make sure 530 * that the interface is not being redefined. 531 */ 532 if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 && 533 !Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount, 534 mcode->arglist, mcode->argcount)) { 535 536 objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist); 537 Tcl_IncrRefCount(objPtr); 538 539 Tcl_AppendResult(interp, 540 "argument list changed for function \"", 541 mfunc->member->fullname, "\": should be \"", 542 Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"", 543 (char*)NULL); 544 Tcl_DecrRefCount(objPtr); 545 546 Itcl_DeleteMemberCode((char*)mcode); 547 return TCL_ERROR; 548 } 549 550 /* 551 * Free up the old implementation and install the new one. 552 */ 553 Itcl_PreserveData((ClientData)mcode); 554 Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); 555 556 Itcl_ReleaseData((ClientData)mfunc->member->code); 557 mfunc->member->code = mcode; 558 559 return TCL_OK; 560} 561 562 563/* 564 * ------------------------------------------------------------------------ 565 * Itcl_DeleteMemberFunc() 566 * 567 * Destroys all data associated with the given member function definition. 568 * Usually invoked by the interpreter when a member function is deleted. 569 * ------------------------------------------------------------------------ 570 */ 571void 572Itcl_DeleteMemberFunc(cdata) 573 CONST char* cdata; /* pointer to member function definition */ 574{ 575 ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata; 576 577 if (mfunc) { 578 Itcl_DeleteMember(mfunc->member); 579 580 if (mfunc->arglist) { 581 Itcl_DeleteArgList(mfunc->arglist); 582 } 583 ckfree((char*)mfunc); 584 } 585} 586 587 588/* 589 * ------------------------------------------------------------------------ 590 * Itcl_CreateMemberCode() 591 * 592 * Creates the data record representing the implementation behind a 593 * class member function. This includes the argument list and the body 594 * of the function. If the body is of the form "@name", then it is 595 * treated as a label for a C procedure registered by Itcl_RegisterC(). 596 * 597 * The implementation is kept by the member function definition, and 598 * controlled by a preserve/release paradigm. That way, if it is in 599 * use while it is being redefined, it will stay around long enough 600 * to avoid a core dump. 601 * 602 * If any errors are encountered, this procedure returns TCL_ERROR 603 * along with an error message in the interpreter. Otherwise, it 604 * returns TCL_OK, and "mcodePtr" returns a pointer to the new 605 * implementation. 606 * ------------------------------------------------------------------------ 607 */ 608int 609Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr) 610 Tcl_Interp* interp; /* interpreter managing this action */ 611 ItclClass *cdefn; /* class containing this member */ 612 CONST char* arglist; /* space-separated list of arg names */ 613 CONST char* body; /* body of commands for the method */ 614 ItclMemberCode** mcodePtr; /* returns: pointer to new implementation */ 615{ 616 int argc; 617 CompiledLocal *args, *localPtr; 618 ItclMemberCode *mcode; 619 Proc *procPtr; 620 621 /* 622 * Allocate some space to hold the implementation. 623 */ 624 mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode)); 625 memset(mcode, 0, sizeof(ItclMemberCode)); 626 627 if (arglist) { 628 if (Itcl_CreateArgList(interp, arglist, &argc, &args) 629 != TCL_OK) { 630 631 Itcl_DeleteMemberCode((char*)mcode); 632 return TCL_ERROR; 633 } 634 mcode->argcount = argc; 635 mcode->arglist = args; 636 mcode->flags |= ITCL_ARG_SPEC; 637 } else { 638 argc = 0; 639 args = NULL; 640 } 641 642 /* 643 * Create a standard Tcl Proc representation for this code body. 644 * This is required, since the Tcl compiler looks for a proc 645 * when handling things such as the call frame context and 646 * compiled locals. 647 */ 648 procPtr = (Proc*)ckalloc(sizeof(Proc)); 649 mcode->procPtr = procPtr; 650 651 procPtr->iPtr = (Interp*)interp; 652 procPtr->refCount = 1; 653 procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command)); 654 memset(procPtr->cmdPtr, 0, sizeof(Command)); 655 procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp; 656 657 if (body) { 658 procPtr->bodyPtr = Tcl_NewStringObj((CONST84 char *)body, -1); 659 } else { 660 procPtr->bodyPtr = Tcl_NewStringObj((CONST84 char *)"", -1); 661 mcode->flags |= ITCL_IMPLEMENT_NONE; 662 } 663 Tcl_IncrRefCount(procPtr->bodyPtr); 664 665 /* 666 * Plug the argument list into the "compiled locals" list. 667 * 668 * NOTE: The storage for this argument list is owned by 669 * the caller, so although we plug it in here, it is not 670 * our responsibility to free it. 671 */ 672 procPtr->firstLocalPtr = args; 673 procPtr->lastLocalPtr = NULL; 674 675 for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) { 676 procPtr->lastLocalPtr = localPtr; 677 } 678 procPtr->numArgs = argc; 679 procPtr->numCompiledLocals = argc; 680 681 /* 682 * If the body definition starts with '@', then treat the value 683 * as a symbolic name for a C procedure. 684 */ 685 if (body == NULL) { 686 /* No-op */ 687 } 688 else if (*body == '@') { 689 Tcl_CmdProc *argCmdProc; 690 Tcl_ObjCmdProc *objCmdProc; 691 ClientData cdata; 692 693 if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) { 694 Tcl_AppendResult(interp, 695 "no registered C procedure with name \"", body+1, "\"", 696 (char*)NULL); 697 Itcl_DeleteMemberCode((char*)mcode); 698 return TCL_ERROR; 699 } 700 701 if (objCmdProc != NULL) { 702 mcode->flags |= ITCL_IMPLEMENT_OBJCMD; 703 mcode->cfunc.objCmd = objCmdProc; 704 mcode->clientData = cdata; 705 } 706 else if (argCmdProc != NULL) { 707 mcode->flags |= ITCL_IMPLEMENT_ARGCMD; 708 mcode->cfunc.argCmd = argCmdProc; 709 mcode->clientData = cdata; 710 } 711 } 712 713 /* 714 * Otherwise, treat the body as a chunk of Tcl code. 715 */ 716 else { 717 mcode->flags |= ITCL_IMPLEMENT_TCL; 718 } 719 720 *mcodePtr = mcode; 721 return TCL_OK; 722} 723 724 725/* 726 * ------------------------------------------------------------------------ 727 * Itcl_DeleteMemberCode() 728 * 729 * Destroys all data associated with the given command implementation. 730 * Invoked automatically by Itcl_ReleaseData() when the implementation 731 * is no longer being used. 732 * ------------------------------------------------------------------------ 733 */ 734void 735Itcl_DeleteMemberCode(cdata) 736 CONST char* cdata; /* pointer to member function definition */ 737{ 738 ItclMemberCode* mcode = (ItclMemberCode*)cdata; 739 740 /* 741 * Free the argument list. If empty, free the compiled locals, if any. 742 */ 743 if (mcode->arglist) { 744 Itcl_DeleteArgList(mcode->arglist); 745 } else if (mcode->procPtr && mcode->procPtr->firstLocalPtr) { 746 Itcl_DeleteArgList(mcode->procPtr->firstLocalPtr); 747 } 748 749 if (mcode->procPtr) { 750 ckfree((char*) mcode->procPtr->cmdPtr); 751 752 if (mcode->procPtr->bodyPtr) { 753 Tcl_DecrRefCount(mcode->procPtr->bodyPtr); 754 } 755 ckfree((char*)mcode->procPtr); 756 } 757 ckfree((char*)mcode); 758} 759 760 761/* 762 * ------------------------------------------------------------------------ 763 * Itcl_GetMemberCode() 764 * 765 * Makes sure that the implementation for an [incr Tcl] code body is 766 * ready to run. Note that a member function can be declared without 767 * being defined. The class definition may contain a declaration of 768 * the member function, but its body may be defined in a separate file. 769 * If an undefined function is encountered, this routine automatically 770 * attempts to autoload it. If the body is implemented via Tcl code, 771 * then it is compiled here as well. 772 * 773 * Returns TCL_ERROR (along with an error message in the interpreter) 774 * if an error is encountered, or if the implementation is not defined 775 * and cannot be autoloaded. Returns TCL_OK if implementation is 776 * ready to use. 777 * ------------------------------------------------------------------------ 778 */ 779int 780Itcl_GetMemberCode(interp, member) 781 Tcl_Interp* interp; /* interpreter managing this action */ 782 ItclMember* member; /* member containing code body */ 783{ 784 int result; 785 ItclMemberCode *mcode = member->code; 786 assert(mcode != NULL); 787 788 /* 789 * If the implementation has not yet been defined, try to 790 * autoload it now. 791 */ 792 793 if (!Itcl_IsMemberCodeImplemented(mcode)) { 794 result = Tcl_VarEval(interp, "::auto_load ", member->fullname, 795 (char*)NULL); 796 if (result != TCL_OK) { 797 char msg[256]; 798 sprintf(msg, "\n (while autoloading code for \"%.100s\")", 799 member->fullname); 800 Tcl_AddErrorInfo(interp, msg); 801 return result; 802 } 803 Tcl_ResetResult(interp); /* get rid of 1/0 status */ 804 } 805 806 /* 807 * If the implementation is still not available, then 808 * autoloading must have failed. 809 * 810 * TRICKY NOTE: If code has been autoloaded, then the 811 * old mcode pointer is probably invalid. Go back to 812 * the member and look at the current code pointer again. 813 */ 814 mcode = member->code; 815 assert(mcode != NULL); 816 817 if (!Itcl_IsMemberCodeImplemented(mcode)) { 818 Tcl_AppendResult(interp, 819 "member function \"", member->fullname, 820 "\" is not defined and cannot be autoloaded", 821 (char*)NULL); 822 return TCL_ERROR; 823 } 824 825 /* 826 * If the member is a constructor and the class has an 827 * initialization command, compile it here. 828 */ 829 if ((member->flags & ITCL_CONSTRUCTOR) != 0 && 830 (member->classDefn->initCode != NULL)) { 831 result = TclProcCompileProc(interp, mcode->procPtr, 832 member->classDefn->initCode, (Namespace*)member->classDefn->namesp, 833 "initialization code for", member->fullname); 834 835 if (result != TCL_OK) { 836 return result; 837 } 838 } 839 840 /* 841 * If the code body has a Tcl implementation, then compile it here. 842 */ 843 if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { 844 845 result = TclProcCompileProc(interp, mcode->procPtr, 846 mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, 847 "body for", member->fullname); 848 849 if (result != TCL_OK) { 850 return result; 851 } 852 } 853 return TCL_OK; 854} 855 856 857/* 858 * ------------------------------------------------------------------------ 859 * Itcl_EvalMemberCode() 860 * 861 * Used to execute an ItclMemberCode representation of a code 862 * fragment. This code may be a body of Tcl commands, or a C handler 863 * procedure. 864 * 865 * Executes the command with the given arguments (objc,objv) and 866 * returns an integer status code (TCL_OK/TCL_ERROR). Returns the 867 * result string or an error message in the interpreter. 868 * ------------------------------------------------------------------------ 869 */ 870int 871Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv) 872 Tcl_Interp *interp; /* current interpreter */ 873 ItclMemberFunc *mfunc; /* member func, or NULL (for error messages) */ 874 ItclMember *member; /* command member containing code */ 875 ItclObject *contextObj; /* object context, or NULL */ 876 int objc; /* number of arguments */ 877 Tcl_Obj *CONST objv[]; /* argument objects */ 878{ 879 int result = TCL_OK; 880 Itcl_CallFrame *oldFramePtr = NULL; 881 882 int i, transparent, newEntry; 883 ItclObjectInfo *info; 884 ItclMemberCode *mcode; 885 ItclContext context; 886 Itcl_CallFrame *framePtr, *transFramePtr; 887 888 /* 889 * If this code does not have an implementation yet, then 890 * try to autoload one. Also, if this is Tcl code, make sure 891 * that it's compiled and ready to use. 892 */ 893 if (Itcl_GetMemberCode(interp, member) != TCL_OK) { 894 return TCL_ERROR; 895 } 896 mcode = member->code; 897 898 /* 899 * Bump the reference count on this code, in case it is 900 * redefined or deleted during execution. 901 */ 902 Itcl_PreserveData((ClientData)mcode); 903 904 /* 905 * Install a new call frame context for the current code. 906 * If the current call frame is marked as "transparent", then 907 * do an "uplevel" operation to move past it. Transparent 908 * call frames are installed by Itcl_HandleInstance. They 909 * provide a way of entering an object context without 910 * interfering with the normal call stack. 911 */ 912 transparent = 0; 913 914 info = member->classDefn->info; 915 framePtr = _Tcl_GetCallFrame(interp, 0); 916 for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) { 917 transFramePtr = (Itcl_CallFrame*) 918 Itcl_GetStackValue(&info->transparentFrames, i); 919 920 if (framePtr == transFramePtr) { 921 transparent = 1; 922 break; 923 } 924 } 925 926 if (transparent) { 927 framePtr = _Tcl_GetCallFrame(interp, 1); 928 oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr); 929 } 930 931 if (Itcl_PushContext(interp, member, member->classDefn, contextObj, 932 &context) != TCL_OK) { 933 934 return TCL_ERROR; 935 } 936 937 /* 938 * If this is a method with a Tcl implementation, or a 939 * constructor with initCode, then parse its arguments now. 940 */ 941 if (mfunc && objc > 0) { 942 if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 || 943 ( (member->flags & ITCL_CONSTRUCTOR) != 0 && 944 (member->classDefn->initCode != NULL) ) ) { 945 946 if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) { 947 result = TCL_ERROR; 948 goto evalMemberCodeDone; 949 } 950 } 951 } 952 953 /* 954 * If this code is a constructor, and if it is being invoked 955 * when an object is first constructed (i.e., the "constructed" 956 * table is still active within the object), then handle the 957 * "initCode" associated with the constructor and make sure that 958 * all base classes are properly constructed. 959 * 960 * TRICKY NOTE: 961 * The "initCode" must be executed here. This is the only 962 * opportunity where the arguments of the constructor are 963 * available in a call frame. 964 */ 965 if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && 966 contextObj->constructed) { 967 968 result = Itcl_ConstructBase(interp, contextObj, member->classDefn); 969 970 if (result != TCL_OK) { 971 goto evalMemberCodeDone; 972 } 973 } 974 975 /* 976 * Execute the code body... 977 */ 978 if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) { 979 result = (*mcode->cfunc.objCmd)(mcode->clientData, 980 interp, objc, objv); 981 } 982 else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) { 983 char **argv; 984 argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) ); 985 for (i=0; i < objc; i++) { 986 argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); 987 } 988 989 result = (*mcode->cfunc.argCmd)(mcode->clientData, 990 interp, objc, argv); 991 992 ckfree((char*)argv); 993 } 994 else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { 995 result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr); 996 } 997 else { 998 Tcl_Panic("itcl: bad implementation flag for %s", member->fullname); 999 } 1000 1001 /* 1002 * If this is a constructor or destructor, and if it is being 1003 * invoked at the appropriate time, keep track of which methods 1004 * have been called. This information is used to implicitly 1005 * invoke constructors/destructors as needed. 1006 */ 1007 if ((member->flags & ITCL_DESTRUCTOR) && contextObj && 1008 contextObj->destructed) { 1009 1010 Tcl_CreateHashEntry(contextObj->destructed, 1011 member->classDefn->fullname, &newEntry); 1012 } 1013 if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && 1014 contextObj->constructed) { 1015 1016 Tcl_CreateHashEntry(contextObj->constructed, 1017 member->classDefn->name, &newEntry); 1018 } 1019 1020evalMemberCodeDone: 1021 Itcl_PopContext(interp, &context); 1022 1023 if (transparent) { 1024 (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); 1025 } 1026 Itcl_ReleaseData((ClientData)mcode); 1027 1028 return result; 1029} 1030 1031 1032/* 1033 * ------------------------------------------------------------------------ 1034 * Itcl_CreateArgList() 1035 * 1036 * Parses a Tcl list representing an argument declaration and returns 1037 * a linked list of CompiledLocal values. Usually invoked as part 1038 * of Itcl_CreateMemberFunc() when a new method or procedure is being 1039 * defined. 1040 * ------------------------------------------------------------------------ 1041 */ 1042int 1043Itcl_CreateArgList(interp, decl, argcPtr, argPtr) 1044 Tcl_Interp* interp; /* interpreter managing this function */ 1045 CONST char* decl; /* string representing argument list */ 1046 int* argcPtr; /* returns number of args in argument list */ 1047 CompiledLocal** argPtr; /* returns pointer to parsed argument list */ 1048{ 1049 int status = TCL_OK; /* assume that this will succeed */ 1050 1051 int i, argc, fargc; 1052 char **argv, **fargv; 1053 CompiledLocal *localPtr, *last; 1054 1055 *argPtr = last = NULL; 1056 *argcPtr = 0; 1057 1058 if (decl) { 1059 if (Tcl_SplitList(interp, (CONST84 char *)decl, &argc, &argv) 1060 != TCL_OK) { 1061 return TCL_ERROR; 1062 } 1063 1064 for (i=0; i < argc && status == TCL_OK; i++) { 1065 if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) { 1066 status = TCL_ERROR; 1067 } 1068 else { 1069 localPtr = NULL; 1070 1071 if (fargc == 0 || *fargv[0] == '\0') { 1072 char mesg[100]; 1073 sprintf(mesg, "argument #%d has no name", i); 1074 Tcl_SetResult(interp, mesg, TCL_VOLATILE); 1075 status = TCL_ERROR; 1076 } 1077 else if (fargc > 2) { 1078 Tcl_AppendResult(interp, 1079 "too many fields in argument specifier \"", 1080 argv[i], "\"", 1081 (char*)NULL); 1082 status = TCL_ERROR; 1083 } 1084 else if (strstr(fargv[0],"::")) { 1085 Tcl_AppendResult(interp, 1086 "bad argument name \"", fargv[0], "\"", 1087 (char*)NULL); 1088 status = TCL_ERROR; 1089 } 1090 else if (fargc == 1) { 1091 localPtr = Itcl_CreateArg(fargv[0], (char*)NULL); 1092 } 1093 else { 1094 localPtr = Itcl_CreateArg(fargv[0], fargv[1]); 1095 } 1096 1097 if (localPtr) { 1098 localPtr->frameIndex = i; 1099 1100 if (*argPtr == NULL) { 1101 *argPtr = last = localPtr; 1102 } 1103 else { 1104 last->nextPtr = localPtr; 1105 last = localPtr; 1106 } 1107 } 1108 } 1109 ckfree((char*)fargv); 1110 } 1111 ckfree((char*)argv); 1112 } 1113 1114 /* 1115 * If anything went wrong, destroy whatever arguments were 1116 * created and return an error. 1117 */ 1118 if (status == TCL_OK) { 1119 *argcPtr = argc; 1120 } else { 1121 Itcl_DeleteArgList(*argPtr); 1122 *argPtr = NULL; 1123 } 1124 return status; 1125} 1126 1127 1128/* 1129 * ------------------------------------------------------------------------ 1130 * Itcl_CreateArg() 1131 * 1132 * Creates a new Tcl Arg structure and fills it with the given 1133 * information. Returns a pointer to the new Arg structure. 1134 * ------------------------------------------------------------------------ 1135 */ 1136CompiledLocal* 1137Itcl_CreateArg(name, init) 1138 CONST char* name; /* name of new argument */ 1139 CONST char* init; /* initial value */ 1140{ 1141 CompiledLocal *localPtr = NULL; 1142 int nameLen; 1143 1144 if (name == NULL) { 1145 name = ""; 1146 } 1147 nameLen = strlen(name); 1148 1149 localPtr = (CompiledLocal*)ckalloc( 1150 (unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1) 1151 ); 1152 1153 localPtr->nextPtr = NULL; 1154 localPtr->nameLength = nameLen; 1155 localPtr->frameIndex = 0; /* set this later */ 1156 ItclInitVarArgument(localPtr); 1157 localPtr->resolveInfo = NULL; 1158 1159 if (init != NULL) { 1160 localPtr->defValuePtr = Tcl_NewStringObj((CONST84 char *)init, -1); 1161 Tcl_IncrRefCount(localPtr->defValuePtr); 1162 } else { 1163 localPtr->defValuePtr = NULL; 1164 } 1165 1166 strcpy(localPtr->name, name); 1167 1168 return localPtr; 1169} 1170 1171/* 1172 * ------------------------------------------------------------------------ 1173 * Itcl_DeleteArgList() 1174 * 1175 * Destroys a chain of arguments acting as an argument list. Usually 1176 * invoked when a method/proc is being destroyed, to discard its 1177 * argument list. 1178 * ------------------------------------------------------------------------ 1179 */ 1180void 1181Itcl_DeleteArgList(arglist) 1182 CompiledLocal *arglist; /* first argument in arg list chain */ 1183{ 1184 CompiledLocal *localPtr, *next; 1185 1186 for (localPtr=arglist; localPtr; localPtr=next) { 1187 if (localPtr->defValuePtr != NULL) { 1188 Tcl_DecrRefCount(localPtr->defValuePtr); 1189 } 1190 if (localPtr->resolveInfo) { 1191 if (localPtr->resolveInfo->deleteProc) { 1192 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); 1193 } else { 1194 ckfree((char*)localPtr->resolveInfo); 1195 } 1196 localPtr->resolveInfo = NULL; 1197 } 1198 next = localPtr->nextPtr; 1199 ckfree((char*)localPtr); 1200 } 1201} 1202 1203/* 1204 * ------------------------------------------------------------------------ 1205 * Itcl_ArgList() 1206 * 1207 * Returns a Tcl_Obj containing the string representation for the 1208 * given argument list. This object has a reference count of 1. 1209 * The reference count should be decremented when the string is no 1210 * longer needed, and it will free itself. 1211 * ------------------------------------------------------------------------ 1212 */ 1213Tcl_Obj* 1214Itcl_ArgList(argc, arglist) 1215 int argc; /* number of arguments */ 1216 CompiledLocal* arglist; /* first argument in arglist */ 1217{ 1218 char *val; 1219 Tcl_Obj *objPtr; 1220 Tcl_DString buffer; 1221 1222 Tcl_DStringInit(&buffer); 1223 1224 while (arglist && argc-- > 0) { 1225 if (arglist->defValuePtr) { 1226 val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL); 1227 Tcl_DStringStartSublist(&buffer); 1228 Tcl_DStringAppendElement(&buffer, arglist->name); 1229 Tcl_DStringAppendElement(&buffer, val); 1230 Tcl_DStringEndSublist(&buffer); 1231 } 1232 else { 1233 Tcl_DStringAppendElement(&buffer, arglist->name); 1234 } 1235 arglist = arglist->nextPtr; 1236 } 1237 1238 objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), 1239 Tcl_DStringLength(&buffer)); 1240 1241 Tcl_DStringFree(&buffer); 1242 1243 return objPtr; 1244} 1245 1246 1247/* 1248 * ------------------------------------------------------------------------ 1249 * Itcl_EquivArgLists() 1250 * 1251 * Compares two argument lists to see if they are equivalent. The 1252 * first list is treated as a prototype, and the second list must 1253 * match it. Argument names may be different, but they must match in 1254 * meaning. If one argument is optional, the corresponding argument 1255 * must also be optional. If the prototype list ends with the magic 1256 * "args" argument, then it matches everything in the other list. 1257 * 1258 * Returns non-zero if the argument lists are equivalent. 1259 * ------------------------------------------------------------------------ 1260 */ 1261int 1262Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c) 1263 CompiledLocal* arg1; /* prototype argument list */ 1264 int arg1c; /* number of args in prototype arg list */ 1265 CompiledLocal* arg2; /* another argument list to match against */ 1266 int arg2c; /* number of args in matching list */ 1267{ 1268 char *dval1, *dval2; 1269 1270 while (arg1 && arg1c > 0 && arg2 && arg2c > 0) { 1271 /* 1272 * If the prototype argument list ends with the magic "args" 1273 * argument, then it matches everything in the other list. 1274 */ 1275 if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { 1276 return 1; 1277 } 1278 1279 /* 1280 * If one has a default value, then the other must have the 1281 * same default value. 1282 */ 1283 if (arg1->defValuePtr) { 1284 if (arg2->defValuePtr == NULL) { 1285 return 0; 1286 } 1287 1288 dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL); 1289 dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL); 1290 if (strcmp(dval1, dval2) != 0) { 1291 return 0; 1292 } 1293 } 1294 else if (arg2->defValuePtr) { 1295 return 0; 1296 } 1297 1298 arg1 = arg1->nextPtr; arg1c--; 1299 arg2 = arg2->nextPtr; arg2c--; 1300 } 1301 if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { 1302 return 1; 1303 } 1304 return (arg1c == 0 && arg2c == 0); 1305} 1306 1307 1308/* 1309 * ------------------------------------------------------------------------ 1310 * Itcl_GetMemberFuncUsage() 1311 * 1312 * Returns a string showing how a command member should be invoked. 1313 * If the command member is a method, then the specified object name 1314 * is reported as part of the invocation path: 1315 * 1316 * obj method arg ?arg arg ...? 1317 * 1318 * Otherwise, the "obj" pointer is ignored, and the class name is 1319 * used as the invocation path: 1320 * 1321 * class::proc arg ?arg arg ...? 1322 * 1323 * Returns the string by appending it onto the Tcl_Obj passed in as 1324 * an argument. 1325 * ------------------------------------------------------------------------ 1326 */ 1327void 1328Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr) 1329 ItclMemberFunc *mfunc; /* command member being examined */ 1330 ItclObject *contextObj; /* invoked with respect to this object */ 1331 Tcl_Obj *objPtr; /* returns: string showing usage */ 1332{ 1333 int argcount; 1334 char *name; 1335 CompiledLocal *arglist, *argPtr; 1336 Tcl_HashEntry *entry; 1337 ItclMemberFunc *mf; 1338 ItclClass *cdefnPtr; 1339 1340 /* 1341 * If the command is a method and an object context was 1342 * specified, then add the object context. If the method 1343 * was a constructor, and if the object is being created, 1344 * then report the invocation via the class creation command. 1345 */ 1346 if ((mfunc->member->flags & ITCL_COMMON) == 0) { 1347 if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 && 1348 contextObj->constructed) { 1349 1350 cdefnPtr = (ItclClass*)contextObj->classDefn; 1351 mf = NULL; 1352 entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor"); 1353 if (entry) { 1354 mf = (ItclMemberFunc*)Tcl_GetHashValue(entry); 1355 } 1356 1357 if (mf == mfunc) { 1358 Tcl_GetCommandFullName(contextObj->classDefn->interp, 1359 contextObj->classDefn->accessCmd, objPtr); 1360 Tcl_AppendToObj(objPtr, " ", -1); 1361 name = (char *) Tcl_GetCommandName( 1362 contextObj->classDefn->interp, contextObj->accessCmd); 1363 Tcl_AppendToObj(objPtr, name, -1); 1364 } else { 1365 Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); 1366 } 1367 } else if (contextObj && contextObj->accessCmd) { 1368 name = (char *) Tcl_GetCommandName(contextObj->classDefn->interp, 1369 contextObj->accessCmd); 1370 Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name, 1371 (char*)NULL); 1372 } else { 1373 Tcl_AppendStringsToObj(objPtr, "<object> ", mfunc->member->name, 1374 (char*)NULL); 1375 } 1376 } else { 1377 Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); 1378 } 1379 1380 /* 1381 * Add the argument usage info. 1382 */ 1383 if (mfunc->member->code) { 1384 arglist = mfunc->member->code->arglist; 1385 argcount = mfunc->member->code->argcount; 1386 } else if (mfunc->arglist) { 1387 arglist = mfunc->arglist; 1388 argcount = mfunc->argcount; 1389 } else { 1390 arglist = NULL; 1391 argcount = 0; 1392 } 1393 1394 if (arglist) { 1395 for (argPtr=arglist; 1396 argPtr && argcount > 0; 1397 argPtr=argPtr->nextPtr, argcount--) { 1398 1399 if (argcount == 1 && strcmp(argPtr->name, "args") == 0) { 1400 Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1); 1401 } 1402 else if (argPtr->defValuePtr) { 1403 Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?", 1404 (char*)NULL); 1405 } 1406 else { 1407 Tcl_AppendStringsToObj(objPtr, " ", argPtr->name, 1408 (char*)NULL); 1409 } 1410 } 1411 } 1412} 1413 1414 1415/* 1416 * ------------------------------------------------------------------------ 1417 * Itcl_ExecMethod() 1418 * 1419 * Invoked by Tcl to handle the execution of a user-defined method. 1420 * A method is similar to the usual Tcl proc, but has access to 1421 * object-specific data. If for some reason there is no current 1422 * object context, then a method call is inappropriate, and an error 1423 * is returned. 1424 * 1425 * Methods are implemented either as Tcl code fragments, or as C-coded 1426 * procedures. For Tcl code fragments, command arguments are parsed 1427 * according to the argument list, and the body is executed in the 1428 * scope of the class where it was defined. For C procedures, the 1429 * arguments are passed in "as-is", and the procedure is executed in 1430 * the most-specific class scope. 1431 * ------------------------------------------------------------------------ 1432 */ 1433int 1434Itcl_ExecMethod(clientData, interp, objc, objv) 1435 ClientData clientData; /* method definition */ 1436 Tcl_Interp *interp; /* current interpreter */ 1437 int objc; /* number of arguments */ 1438 Tcl_Obj *CONST objv[]; /* argument objects */ 1439{ 1440 ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; 1441 ItclMember *member = mfunc->member; 1442 int result = TCL_OK; 1443 1444 char *token; 1445 Tcl_HashEntry *entry; 1446 ItclClass *contextClass; 1447 ItclObject *contextObj; 1448 1449 /* 1450 * Make sure that the current namespace context includes an 1451 * object that is being manipulated. Methods can be executed 1452 * only if an object context exists. 1453 */ 1454 if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { 1455 return TCL_ERROR; 1456 } 1457 if (contextObj == NULL) { 1458 Tcl_AppendResult(interp, 1459 "cannot access object-specific info without an object context", 1460 (char*)NULL); 1461 return TCL_ERROR; 1462 } 1463 1464 /* 1465 * Make sure that this command member can be accessed from 1466 * the current namespace context. 1467 */ 1468 if (mfunc->member->protection != ITCL_PUBLIC) { 1469 Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, 1470 contextClass->info); 1471 1472 if (!Itcl_CanAccessFunc(mfunc, contextNs)) { 1473 Tcl_AppendResult(interp, 1474 "can't access \"", member->fullname, "\": ", 1475 Itcl_ProtectionStr(member->protection), " function", 1476 (char*)NULL); 1477 return TCL_ERROR; 1478 } 1479 } 1480 1481 /* 1482 * All methods should be "virtual" unless they are invoked with 1483 * a "::" scope qualifier. 1484 * 1485 * To implement the "virtual" behavior, find the most-specific 1486 * implementation for the method by looking in the "resolveCmds" 1487 * table for this class. 1488 */ 1489 token = Tcl_GetStringFromObj(objv[0], (int*)NULL); 1490 if (strstr(token, "::") == NULL) { 1491 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, 1492 member->name); 1493 1494 if (entry) { 1495 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 1496 member = mfunc->member; 1497 } 1498 } 1499 1500 /* 1501 * Execute the code for the method. Be careful to protect 1502 * the method in case it gets deleted during execution. 1503 */ 1504 Itcl_PreserveData((ClientData)mfunc); 1505 1506 result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, 1507 objc, objv); 1508 1509 result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); 1510 1511 Itcl_ReleaseData((ClientData)mfunc); 1512 1513 return result; 1514} 1515 1516 1517/* 1518 * ------------------------------------------------------------------------ 1519 * Itcl_ExecProc() 1520 * 1521 * Invoked by Tcl to handle the execution of a user-defined proc. 1522 * 1523 * Procs are implemented either as Tcl code fragments, or as C-coded 1524 * procedures. For Tcl code fragments, command arguments are parsed 1525 * according to the argument list, and the body is executed in the 1526 * scope of the class where it was defined. For C procedures, the 1527 * arguments are passed in "as-is", and the procedure is executed in 1528 * the most-specific class scope. 1529 * ------------------------------------------------------------------------ 1530 */ 1531int 1532Itcl_ExecProc(clientData, interp, objc, objv) 1533 ClientData clientData; /* proc definition */ 1534 Tcl_Interp *interp; /* current interpreter */ 1535 int objc; /* number of arguments */ 1536 Tcl_Obj *CONST objv[]; /* argument objects */ 1537{ 1538 ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; 1539 ItclMember *member = mfunc->member; 1540 int result = TCL_OK; 1541 1542 /* 1543 * Make sure that this command member can be accessed from 1544 * the current namespace context. 1545 */ 1546 if (mfunc->member->protection != ITCL_PUBLIC) { 1547 Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, 1548 mfunc->member->classDefn->info); 1549 1550 if (!Itcl_CanAccessFunc(mfunc, contextNs)) { 1551 Tcl_AppendResult(interp, 1552 "can't access \"", member->fullname, "\": ", 1553 Itcl_ProtectionStr(member->protection), " function", 1554 (char*)NULL); 1555 return TCL_ERROR; 1556 } 1557 } 1558 1559 /* 1560 * Execute the code for the proc. Be careful to protect 1561 * the proc in case it gets deleted during execution. 1562 */ 1563 Itcl_PreserveData((ClientData)mfunc); 1564 1565 result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL, 1566 objc, objv); 1567 1568 result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result); 1569 1570 Itcl_ReleaseData((ClientData)mfunc); 1571 1572 return result; 1573} 1574 1575 1576/* 1577 * ------------------------------------------------------------------------ 1578 * Itcl_PushContext() 1579 * 1580 * Sets up the class/object context so that a body of [incr Tcl] 1581 * code can be executed. This procedure pushes a call frame with 1582 * the proper namespace context for the class. If an object context 1583 * is supplied, the object's instance variables are integrated into 1584 * the call frame so they can be accessed as local variables. 1585 * ------------------------------------------------------------------------ 1586 */ 1587int 1588Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr) 1589 Tcl_Interp *interp; /* interpreter managing this body of code */ 1590 ItclMember *member; /* member containing code body */ 1591 ItclClass *contextClass; /* class context */ 1592 ItclObject *contextObj; /* object context, or NULL */ 1593 ItclContext *contextPtr; /* storage space for class/object context */ 1594{ 1595 ItclCallFrame *framePtr = &contextPtr->frame; 1596 1597 int result, localCt, newEntry; 1598 ItclMemberCode *mcode; 1599 Proc *procPtr; 1600 Tcl_HashEntry *entry; 1601 1602 /* 1603 * Activate the call frame. If this fails, we'll bail out 1604 * before allocating any resources. 1605 * 1606 * NOTE: Always push a call frame that looks like a proc. 1607 * This causes global variables to be handled properly 1608 * inside methods/procs. 1609 */ 1610 result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr, 1611 contextClass->namesp, /* isProcCallFrame */ 1); 1612 1613 if (result != TCL_OK) { 1614 return result; 1615 } 1616 1617 contextPtr->classDefn = contextClass; 1618 contextPtr->compiledLocals = &contextPtr->localStorage[0]; 1619 1620 /* 1621 * If this is an object context, register it in a hash table 1622 * of all known contexts. We'll need this later if we 1623 * call Itcl_GetContext to get the object context for the 1624 * current call frame. 1625 */ 1626 if (contextObj) { 1627 entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames, 1628 (char*)framePtr, &newEntry); 1629 1630 Itcl_PreserveData((ClientData)contextObj); 1631 Tcl_SetHashValue(entry, (ClientData)contextObj); 1632 } 1633 1634 /* 1635 * Set up the compiled locals in the call frame and assign 1636 * argument variables. 1637 */ 1638 if (member) { 1639 mcode = member->code; 1640 procPtr = mcode->procPtr; 1641 1642 /* 1643 * Invoking TclInitCompiledLocals with a framePtr->procPtr->bodyPtr 1644 * that is not a compiled byte code type leads to a crash. So 1645 * make sure that the body is compiled here. This needs to 1646 * be done even if the body of the Itcl method is not implemented 1647 * as a Tcl proc or has no implementation. The empty string should 1648 * have been defined as the body if no implementation was defined. 1649 */ 1650 assert(mcode->procPtr->bodyPtr != NULL); 1651 1652 result = TclProcCompileProc(interp, mcode->procPtr, 1653 mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, 1654 "body for", member->fullname); 1655 1656 if (result != TCL_OK) { 1657 return result; 1658 } 1659 1660 /* 1661 * If there are too many compiled locals to fit in the default 1662 * storage space for the context, then allocate more space. 1663 */ 1664 localCt = procPtr->numCompiledLocals; 1665 if (localCt > 1666 (int)(sizeof(contextPtr->localStorage)/itclVarLocalSize)) { 1667 contextPtr->compiledLocals = (Var*)ckalloc( 1668 (unsigned)(localCt * itclVarLocalSize) 1669 ); 1670 } 1671 1672 /* 1673 * Initialize and resolve compiled variable references. 1674 * Class variables will have special resolution rules. 1675 * In that case, we call their "resolver" procs to get our 1676 * hands on the variable, and we make the compiled local a 1677 * link to the real variable. 1678 */ 1679 1680 framePtr->procPtr = procPtr; 1681 framePtr->numCompiledLocals = localCt; 1682 framePtr->compiledLocals = contextPtr->compiledLocals; 1683 1684 TclInitCompiledLocals(interp, (CallFrame *) framePtr, 1685 (Namespace*)contextClass->namesp); 1686 } 1687 return result; 1688} 1689 1690 1691/* 1692 * ------------------------------------------------------------------------ 1693 * Itcl_PopContext() 1694 * 1695 * Removes a class/object context previously set up by Itcl_PushContext. 1696 * Usually called after an [incr Tcl] code body has been executed, 1697 * to clean up. 1698 * ------------------------------------------------------------------------ 1699 */ 1700void 1701Itcl_PopContext(interp, contextPtr) 1702 Tcl_Interp *interp; /* interpreter managing this body of code */ 1703 ItclContext *contextPtr; /* storage space for class/object context */ 1704{ 1705 Itcl_CallFrame *framePtr; 1706 ItclObjectInfo *info; 1707 ItclObject *contextObj; 1708 Tcl_HashEntry *entry; 1709 1710 /* 1711 * See if the current call frame has an object context 1712 * associated with it. If so, release the claim on the 1713 * object info. 1714 */ 1715 framePtr = _Tcl_GetCallFrame(interp, 0); 1716 info = contextPtr->classDefn->info; 1717 1718 entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); 1719 if (entry != NULL) { 1720 contextObj = (ItclObject*)Tcl_GetHashValue(entry); 1721 Itcl_ReleaseData((ClientData)contextObj); 1722 Tcl_DeleteHashEntry(entry); 1723 } 1724 1725 /* 1726 * Remove the call frame. 1727 */ 1728 Tcl_PopCallFrame(interp); 1729 1730 /* 1731 * Free the compiledLocals array if malloc'ed storage was used. 1732 */ 1733 if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) { 1734 ckfree((char*)contextPtr->compiledLocals); 1735 } 1736} 1737 1738 1739/* 1740 * ------------------------------------------------------------------------ 1741 * Itcl_GetContext() 1742 * 1743 * Convenience routine for looking up the current object/class context. 1744 * Useful in implementing methods/procs to see what class, and perhaps 1745 * what object, is active. 1746 * 1747 * Returns TCL_OK if the current namespace is a class namespace. 1748 * Also returns pointers to the class definition, and to object 1749 * data if an object context is active. Returns TCL_ERROR (along 1750 * with an error message in the interpreter) if a class namespace 1751 * is not active. 1752 * ------------------------------------------------------------------------ 1753 */ 1754int 1755Itcl_GetContext(interp, cdefnPtr, odefnPtr) 1756 Tcl_Interp *interp; /* current interpreter */ 1757 ItclClass **cdefnPtr; /* returns: class definition or NULL */ 1758 ItclObject **odefnPtr; /* returns: object data or NULL */ 1759{ 1760 Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); 1761 ItclObjectInfo *info; 1762 Itcl_CallFrame *framePtr; 1763 Tcl_HashEntry *entry; 1764 1765 /* 1766 * Return NULL for anything that cannot be found. 1767 */ 1768 *cdefnPtr = NULL; 1769 *odefnPtr = NULL; 1770 1771 /* 1772 * If the active namespace is a class namespace, then return 1773 * all known info. See if the current call frame is a known 1774 * object context, and if so, return that context. 1775 */ 1776 if (Itcl_IsClassNamespace(activeNs)) { 1777 *cdefnPtr = (ItclClass*)activeNs->clientData; 1778 1779 framePtr = _Tcl_GetCallFrame(interp, 0); 1780 1781 info = (*cdefnPtr)->info; 1782 entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); 1783 1784 if (entry != NULL) { 1785 *odefnPtr = (ItclObject*)Tcl_GetHashValue(entry); 1786 } 1787 return TCL_OK; 1788 } 1789 1790 /* 1791 * If there is no class/object context, return an error message. 1792 */ 1793 Tcl_AppendResult(interp, 1794 "namespace \"", activeNs->fullName, "\" is not a class namespace", 1795 (char*)NULL); 1796 1797 return TCL_ERROR; 1798} 1799 1800 1801/* 1802 * ------------------------------------------------------------------------ 1803 * Itcl_AssignArgs() 1804 * 1805 * Matches a list of arguments against a Tcl argument specification. 1806 * Supports all of the rules regarding arguments for Tcl procs, including 1807 * default arguments and variable-length argument lists. 1808 * 1809 * Assumes that a local call frame is already installed. As variables 1810 * are successfully matched, they are stored as variables in the call 1811 * frame. Returns TCL_OK on success, or TCL_ERROR (along with an error 1812 * message in interp->result) on error. 1813 * ------------------------------------------------------------------------ 1814 */ 1815int 1816Itcl_AssignArgs(interp, objc, objv, mfunc) 1817 Tcl_Interp *interp; /* interpreter */ 1818 int objc; /* number of arguments */ 1819 Tcl_Obj *CONST objv[]; /* argument objects */ 1820 ItclMemberFunc *mfunc; /* member function info (for error messages) */ 1821{ 1822 ItclMemberCode *mcode = mfunc->member->code; 1823 1824 int result = TCL_OK; 1825 1826 int defargc; 1827 char **defargv = NULL; 1828 Tcl_Obj **defobjv = NULL; 1829 int configc = 0; 1830 ItclVarDefn **configVars = NULL; 1831 char **configVals = NULL; 1832 1833 int vi, argsLeft; 1834 ItclClass *contextClass; 1835 ItclObject *contextObj; 1836 CompiledLocal *argPtr; 1837 ItclCallFrame *framePtr; 1838 Var *varPtr; 1839 Tcl_Obj *objPtr, *listPtr; 1840 char *value; 1841 1842 framePtr = (ItclCallFrame *) _Tcl_GetCallFrame(interp, 0); 1843 framePtr->objc = objc; 1844 framePtr->objv = objv; /* ref counts for args are incremented below */ 1845 1846 /* 1847 * See if there is a current object context. We may need 1848 * it later on. 1849 */ 1850 (void) Itcl_GetContext(interp, &contextClass, &contextObj); 1851 Tcl_ResetResult(interp); 1852 1853 /* 1854 * Match the actual arguments against the procedure's formal 1855 * parameters to compute local variables. 1856 */ 1857 varPtr = framePtr->compiledLocals; 1858 1859 for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--; 1860 argsLeft > 0; 1861 argPtr=argPtr->nextPtr, argsLeft--, ItclNextLocal(varPtr), objv++, objc--) 1862 { 1863 if (!TclIsVarArgument(argPtr)) { 1864 Tcl_Panic("local variable %s is not argument but should be", 1865 argPtr->name); 1866 return TCL_ERROR; 1867 } 1868 if (TclIsVarTemporary(argPtr)) { 1869 Tcl_Panic("local variable is temporary but should be an argument"); 1870 return TCL_ERROR; 1871 } 1872 1873 /* 1874 * Handle the special case of the last formal being "args". 1875 * When it occurs, assign it a list consisting of all the 1876 * remaining actual arguments. 1877 */ 1878 if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) { 1879 if (objc < 0) objc = 0; 1880 1881 listPtr = Tcl_NewListObj(objc, objv); 1882 ItclVarObjValue(varPtr) = listPtr; 1883 Tcl_IncrRefCount(listPtr); /* local var is a reference */ 1884 ItclClearVarUndefined(varPtr); 1885 objc = 0; 1886 1887 break; 1888 } 1889 1890 /* 1891 * Handle the special case of the last formal being "config". 1892 * When it occurs, treat all remaining arguments as public 1893 * variable assignments. Set the local "config" variable 1894 * to the list of public variables assigned. 1895 */ 1896 else if ( (argsLeft == 1) && 1897 (strcmp(argPtr->name, "config") == 0) && 1898 contextObj ) 1899 { 1900 /* 1901 * If this is not an old-style method, discourage against 1902 * the use of the "config" argument. 1903 */ 1904 if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) { 1905 Tcl_AppendResult(interp, 1906 "\"config\" argument is an anachronism\n", 1907 "[incr Tcl] no longer supports the \"config\" argument.\n", 1908 "Instead, use the \"args\" argument and then use the\n", 1909 "built-in configure method to handle args like this:\n", 1910 " eval configure $args", 1911 (char*)NULL); 1912 result = TCL_ERROR; 1913 goto argErrors; 1914 } 1915 1916 /* 1917 * Otherwise, handle the "config" argument in the usual way... 1918 * - parse all "-name value" assignments 1919 * - set "config" argument to the list of variable names 1920 */ 1921 if (objc > 0) { /* still have some arguments left? */ 1922 1923 result = ItclParseConfig(interp, objc, objv, contextObj, 1924 &configc, &configVars, &configVals); 1925 1926 if (result != TCL_OK) { 1927 goto argErrors; 1928 } 1929 1930 listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); 1931 for (vi=0; vi < configc; vi++) { 1932 objPtr = Tcl_NewStringObj( 1933 configVars[vi]->member->classDefn->name, -1); 1934 Tcl_AppendToObj(objPtr, "::", -1); 1935 Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); 1936 1937 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 1938 } 1939 1940 ItclVarObjValue(varPtr) = listPtr; 1941 Tcl_IncrRefCount(listPtr); /* local var is a reference */ 1942 ItclClearVarUndefined(varPtr); 1943 1944 objc = 0; /* all remaining args handled */ 1945 } 1946 1947 else if (argPtr->defValuePtr) { 1948 value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL); 1949 1950 result = Tcl_SplitList(interp, value, &defargc, &defargv); 1951 if (result != TCL_OK) { 1952 goto argErrors; 1953 } 1954 defobjv = (Tcl_Obj**)ckalloc( 1955 (unsigned)(defargc*sizeof(Tcl_Obj*)) 1956 ); 1957 for (vi=0; vi < defargc; vi++) { 1958 objPtr = Tcl_NewStringObj(defargv[vi], -1); 1959 Tcl_IncrRefCount(objPtr); 1960 defobjv[vi] = objPtr; 1961 } 1962 1963 result = ItclParseConfig(interp, defargc, defobjv, contextObj, 1964 &configc, &configVars, &configVals); 1965 1966 if (result != TCL_OK) { 1967 goto argErrors; 1968 } 1969 1970 listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); 1971 for (vi=0; vi < configc; vi++) { 1972 objPtr = Tcl_NewStringObj( 1973 configVars[vi]->member->classDefn->name, -1); 1974 Tcl_AppendToObj(objPtr, "::", -1); 1975 Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); 1976 1977 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 1978 } 1979 1980 ItclVarObjValue(varPtr) = listPtr; 1981 Tcl_IncrRefCount(listPtr); /* local var is a reference */ 1982 ItclClearVarUndefined(varPtr); 1983 } 1984 else { 1985 objPtr = Tcl_NewStringObj("", 0); 1986 ItclVarObjValue(varPtr) = objPtr; 1987 Tcl_IncrRefCount(objPtr); /* local var is a reference */ 1988 ItclClearVarUndefined(varPtr); 1989 } 1990 } 1991 1992 /* 1993 * Resume the usual processing of arguments... 1994 */ 1995 else if (objc > 0) { /* take next arg as value */ 1996 objPtr = *objv; 1997 ItclVarObjValue(varPtr) = objPtr; 1998 ItclClearVarUndefined(varPtr); 1999 Tcl_IncrRefCount(objPtr); /* local var is a reference */ 2000 } 2001 else if (argPtr->defValuePtr) { /* ...or use default value */ 2002 objPtr = argPtr->defValuePtr; 2003 ItclVarObjValue(varPtr) = objPtr; 2004 ItclClearVarUndefined(varPtr); 2005 Tcl_IncrRefCount(objPtr); /* local var is a reference */ 2006 } 2007 else { 2008 if (mfunc) { 2009 objPtr = Tcl_GetObjResult(interp); 2010 Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); 2011 Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); 2012 Tcl_AppendToObj(objPtr, "\"", -1); 2013 } else { 2014 Tcl_AppendResult(interp, 2015 "no value given for parameter \"", argPtr->name, "\"", 2016 (char*)NULL); 2017 } 2018 result = TCL_ERROR; 2019 goto argErrors; 2020 } 2021 } 2022 2023 if (objc > 0) { 2024 if (mfunc) { 2025 objPtr = Tcl_GetObjResult(interp); 2026 Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); 2027 Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); 2028 Tcl_AppendToObj(objPtr, "\"", -1); 2029 } else { 2030 Tcl_AppendResult(interp, 2031 "too many arguments", 2032 (char*)NULL); 2033 } 2034 result = TCL_ERROR; 2035 goto argErrors; 2036 } 2037 2038 /* 2039 * Handle any "config" assignments. 2040 */ 2041 if (configc > 0) { 2042 if (ItclHandleConfig(interp, configc, configVars, configVals, 2043 contextObj) != TCL_OK) { 2044 2045 result = TCL_ERROR; 2046 goto argErrors; 2047 } 2048 } 2049 2050 /* 2051 * All arguments were successfully matched. 2052 */ 2053 result = TCL_OK; 2054 2055 /* 2056 * If any errors were found, clean up and return error status. 2057 */ 2058argErrors: 2059 if (defobjv) { 2060 for (vi=0; vi < defargc; vi++) { 2061 Tcl_DecrRefCount(defobjv[vi]); 2062 } 2063 ckfree((char*)defobjv); 2064 } 2065 if (defargv) { 2066 ckfree((char*)defargv); 2067 } 2068 if (configVars) { 2069 ckfree((char*)configVars); 2070 } 2071 if (configVals) { 2072 ckfree((char*)configVals); 2073 } 2074 return result; 2075} 2076 2077 2078/* 2079 * ------------------------------------------------------------------------ 2080 * ItclParseConfig() 2081 * 2082 * Parses a set of arguments as "-variable value" assignments. 2083 * Interprets all variable names in the most-specific class scope, 2084 * so that an inherited method with a "config" parameter will work 2085 * correctly. Returns a list of public variable names and their 2086 * corresponding values; both lists should passed to ItclHandleConfig() 2087 * to perform assignments, and freed when no longer in use. Returns a 2088 * status TCL_OK/TCL_ERROR and returns error messages in the interpreter. 2089 * ------------------------------------------------------------------------ 2090 */ 2091static int 2092ItclParseConfig(interp, objc, objv, contextObj, rargc, rvars, rvals) 2093 Tcl_Interp *interp; /* interpreter */ 2094 int objc; /* number of arguments */ 2095 Tcl_Obj *CONST objv[]; /* argument objects */ 2096 ItclObject *contextObj; /* object whose public vars are being config'd */ 2097 int *rargc; /* return: number of variables accessed */ 2098 ItclVarDefn ***rvars; /* return: list of variables */ 2099 char ***rvals; /* return: list of values */ 2100{ 2101 int result = TCL_OK; 2102 ItclVarLookup *vlookup; 2103 Tcl_HashEntry *entry; 2104 char *varName, *value; 2105 2106 if (objc < 0) objc = 0; 2107 *rargc = 0; 2108 *rvars = (ItclVarDefn**)ckalloc((unsigned)(objc*sizeof(ItclVarDefn*))); 2109 *rvals = (char**)ckalloc((unsigned)(objc*sizeof(char*))); 2110 2111 while (objc-- > 0) { 2112 /* 2113 * Next argument should be "-variable" 2114 */ 2115 varName = Tcl_GetStringFromObj(*objv, (int*)NULL); 2116 if (*varName != '-') { 2117 Tcl_AppendResult(interp, 2118 "syntax error in config assignment \"", 2119 varName, "\": should be \"-variable value\"", 2120 (char*)NULL); 2121 result = TCL_ERROR; 2122 break; 2123 } 2124 else if (objc-- <= 0) { 2125 Tcl_AppendResult(interp, 2126 "syntax error in config assignment \"", 2127 varName, "\": should be \"-variable value\" (missing value)", 2128 (char*)NULL); 2129 result = TCL_ERROR; 2130 break; 2131 } 2132 2133 entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, 2134 varName+1); 2135 2136 if (entry) { 2137 vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 2138 value = Tcl_GetStringFromObj(*(objv+1), (int*)NULL); 2139 2140 (*rvars)[*rargc] = vlookup->vdefn; /* variable definition */ 2141 (*rvals)[*rargc] = value; /* config value */ 2142 (*rargc)++; 2143 objv += 2; 2144 } 2145 else { 2146 Tcl_AppendResult(interp, 2147 "syntax error in config assignment \"", 2148 varName, "\": unrecognized variable", 2149 (char*)NULL); 2150 result = TCL_ERROR; 2151 break; 2152 } 2153 } 2154 return result; 2155} 2156 2157/* 2158 * ------------------------------------------------------------------------ 2159 * ItclHandleConfig() 2160 * 2161 * Handles the assignment of "config" values to public variables. 2162 * The list of assignments is parsed in ItclParseConfig(), but the 2163 * actual assignments are performed here. If the variables have any 2164 * associated "config" code, it is invoked here as well. If errors 2165 * are detected during assignment or "config" code execution, the 2166 * variable is set back to its previous value and an error is returned. 2167 * 2168 * Returns a status TCL_OK/TCL_ERROR, and returns any error messages 2169 * in the given interpreter. 2170 * ------------------------------------------------------------------------ 2171 */ 2172static int 2173ItclHandleConfig(interp, argc, vars, vals, contextObj) 2174 Tcl_Interp *interp; /* interpreter currently in control */ 2175 int argc; /* number of assignments */ 2176 ItclVarDefn **vars; /* list of public variable definitions */ 2177 char **vals; /* list of public variable values */ 2178 ItclObject *contextObj; /* object whose public vars are being config'd */ 2179{ 2180 int result = TCL_OK; 2181 2182 int i; 2183 CONST char *val; 2184 Tcl_DString lastval; 2185 ItclContext context; 2186 Itcl_CallFrame *oldFramePtr, *uplevelFramePtr; 2187 2188 Tcl_DStringInit(&lastval); 2189 2190 /* 2191 * All "config" assignments are performed in the most-specific 2192 * class scope, so that inherited methods with "config" arguments 2193 * will work correctly. 2194 */ 2195 result = Itcl_PushContext(interp, (ItclMember*)NULL, 2196 contextObj->classDefn, contextObj, &context); 2197 2198 if (result != TCL_OK) { 2199 return TCL_ERROR; 2200 } 2201 2202 /* 2203 * Perform each assignment and execute the "config" code 2204 * associated with each variable. If any errors are encountered, 2205 * set the variable back to its previous value, and return an error. 2206 */ 2207 for (i=0; i < argc; i++) { 2208 val = Tcl_GetVar2(interp, vars[i]->member->fullname, (char*)NULL, 0); 2209 if (!val) { 2210 val = ""; 2211 } 2212 Tcl_DStringSetLength(&lastval, 0); 2213 Tcl_DStringAppend(&lastval, val, -1); 2214 2215 /* 2216 * Set the variable to the specified value. 2217 */ 2218 if (!Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, 2219 vals[i], 0)) { 2220 2221 char msg[256]; 2222 sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); 2223 Tcl_AddErrorInfo(interp, msg); 2224 result = TCL_ERROR; 2225 break; 2226 } 2227 2228 /* 2229 * If the variable has a "config" condition, then execute it. 2230 * If it fails, put the variable back the way it was and return 2231 * an error. 2232 * 2233 * TRICKY NOTE: Be careful to evaluate the code one level 2234 * up in the call stack, so that it's executed in the 2235 * calling context, and not in the context that we've 2236 * set up for public variable access. 2237 */ 2238 if (vars[i]->member->code) { 2239 2240 uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); 2241 oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr); 2242 2243 result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL, 2244 vars[i]->member, contextObj, 0, (Tcl_Obj* CONST*)NULL); 2245 2246 (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); 2247 2248 if (result != TCL_OK) { 2249 char msg[256]; 2250 sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); 2251 Tcl_AddErrorInfo(interp, msg); 2252 Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, 2253 Tcl_DStringValue(&lastval), 0); 2254 break; 2255 } 2256 } 2257 } 2258 2259 /* 2260 * Clean up and return. 2261 */ 2262 Itcl_PopContext(interp, &context); 2263 Tcl_DStringFree(&lastval); 2264 2265 return result; 2266} 2267 2268 2269/* 2270 * ------------------------------------------------------------------------ 2271 * Itcl_ConstructBase() 2272 * 2273 * Usually invoked just before executing the body of a constructor 2274 * when an object is first created. This procedure makes sure that 2275 * all base classes are properly constructed. If an "initCode" fragment 2276 * was defined with the constructor for the class, then it is invoked. 2277 * After that, the list of base classes is checked for constructors 2278 * that are defined but have not yet been invoked. Each of these is 2279 * invoked implicitly with no arguments. 2280 * 2281 * Assumes that a local call frame is already installed, and that 2282 * constructor arguments have already been matched and are sitting in 2283 * this frame. Returns TCL_OK on success; otherwise, this procedure 2284 * returns TCL_ERROR, along with an error message in the interpreter. 2285 * ------------------------------------------------------------------------ 2286 */ 2287int 2288Itcl_ConstructBase(interp, contextObj, contextClass) 2289 Tcl_Interp *interp; /* interpreter */ 2290 ItclObject *contextObj; /* object being constructed */ 2291 ItclClass *contextClass; /* current class being constructed */ 2292{ 2293 int result; 2294 Itcl_ListElem *elem; 2295 ItclClass *cdefn; 2296 Tcl_HashEntry *entry; 2297 2298 /* 2299 * If the class has an "initCode", invoke it in the current context. 2300 * 2301 * TRICKY NOTE: 2302 * This context is the call frame containing the arguments 2303 * for the constructor. The "initCode" makes sense right 2304 * now--just before the body of the constructor is executed. 2305 */ 2306 if (contextClass->initCode) { 2307 if (Tcl_EvalObj(interp, contextClass->initCode) != TCL_OK) { 2308 return TCL_ERROR; 2309 } 2310 } 2311 2312 /* 2313 * Scan through the list of base classes and see if any of these 2314 * have not been constructed. Invoke base class constructors 2315 * implicitly, as needed. Go through the list of base classes 2316 * in reverse order, so that least-specific classes are constructed 2317 * first. 2318 */ 2319 elem = Itcl_LastListElem(&contextClass->bases); 2320 while (elem) { 2321 cdefn = (ItclClass*)Itcl_GetListValue(elem); 2322 2323 if (!Tcl_FindHashEntry(contextObj->constructed, cdefn->name)) { 2324 2325 result = Itcl_InvokeMethodIfExists(interp, "constructor", 2326 cdefn, contextObj, 0, (Tcl_Obj* CONST*)NULL); 2327 2328 if (result != TCL_OK) { 2329 return TCL_ERROR; 2330 } 2331 2332 /* 2333 * The base class may not have a constructor, but its 2334 * own base classes could have one. If the constructor 2335 * wasn't found in the last step, then other base classes 2336 * weren't constructed either. Make sure that all of its 2337 * base classes are properly constructed. 2338 */ 2339 entry = Tcl_FindHashEntry(&cdefn->functions, "constructor"); 2340 if (entry == NULL) { 2341 result = Itcl_ConstructBase(interp, contextObj, cdefn); 2342 if (result != TCL_OK) { 2343 return TCL_ERROR; 2344 } 2345 } 2346 } 2347 elem = Itcl_PrevListElem(elem); 2348 } 2349 return TCL_OK; 2350} 2351 2352 2353/* 2354 * ------------------------------------------------------------------------ 2355 * Itcl_InvokeMethodIfExists() 2356 * 2357 * Looks for a particular method in the specified class. If the 2358 * method is found, it is invoked with the given arguments. Any 2359 * protection level (protected/private) for the method is ignored. 2360 * If the method does not exist, this procedure does nothing. 2361 * 2362 * This procedure is used primarily to invoke the constructor/destructor 2363 * when an object is created/destroyed. 2364 * 2365 * Returns TCL_OK on success; otherwise, this procedure returns 2366 * TCL_ERROR along with an error message in the interpreter. 2367 * ------------------------------------------------------------------------ 2368 */ 2369int 2370Itcl_InvokeMethodIfExists(interp, name, contextClass, contextObj, objc, objv) 2371 Tcl_Interp *interp; /* interpreter */ 2372 CONST char *name; /* name of desired method */ 2373 ItclClass *contextClass; /* current class being constructed */ 2374 ItclObject *contextObj; /* object being constructed */ 2375 int objc; /* number of arguments */ 2376 Tcl_Obj *CONST objv[]; /* argument objects */ 2377{ 2378 int result = TCL_OK; 2379 2380 ItclMemberFunc *mfunc; 2381 ItclMember *member; 2382 Tcl_HashEntry *entry; 2383 Tcl_Obj *cmdlinePtr; 2384 int cmdlinec; 2385 Tcl_Obj **cmdlinev; 2386 2387 /* 2388 * Scan through the list of base classes and see if any of these 2389 * have not been constructed. Invoke base class constructors 2390 * implicitly, as needed. Go through the list of base classes 2391 * in reverse order, so that least-specific classes are constructed 2392 * first. 2393 */ 2394 entry = Tcl_FindHashEntry(&contextClass->functions, name); 2395 2396 if (entry) { 2397 mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); 2398 member = mfunc->member; 2399 2400 /* 2401 * Prepend the method name to the list of arguments. 2402 */ 2403 cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv); 2404 2405 (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, 2406 &cmdlinec, &cmdlinev); 2407 2408 /* 2409 * Execute the code for the method. Be careful to protect 2410 * the method in case it gets deleted during execution. 2411 */ 2412 Itcl_PreserveData((ClientData)mfunc); 2413 2414 result = Itcl_EvalMemberCode(interp, mfunc, member, 2415 contextObj, cmdlinec, cmdlinev); 2416 2417 result = Itcl_ReportFuncErrors(interp, mfunc, 2418 contextObj, result); 2419 2420 Itcl_ReleaseData((ClientData)mfunc); 2421 Tcl_DecrRefCount(cmdlinePtr); 2422 } 2423 return result; 2424} 2425 2426 2427/* 2428 * ------------------------------------------------------------------------ 2429 * Itcl_ReportFuncErrors() 2430 * 2431 * Used to interpret the status code returned when the body of a 2432 * Tcl-style proc is executed. Handles the "errorInfo" and "errorCode" 2433 * variables properly, and adds error information into the interpreter 2434 * if anything went wrong. Returns a new status code that should be 2435 * treated as the return status code for the command. 2436 * 2437 * This same operation is usually buried in the Tcl InterpProc() 2438 * procedure. It is defined here so that it can be reused more easily. 2439 * ------------------------------------------------------------------------ 2440 */ 2441int 2442Itcl_ReportFuncErrors(interp, mfunc, contextObj, result) 2443 Tcl_Interp* interp; /* interpreter being modified */ 2444 ItclMemberFunc *mfunc; /* command member that was invoked */ 2445 ItclObject *contextObj; /* object context for this command */ 2446 int result; /* integer status code from proc body */ 2447{ 2448 Interp* iPtr = (Interp*)interp; 2449 Tcl_Obj *objPtr; 2450 char num[20]; 2451 2452 if (result != TCL_OK) { 2453 if (result == TCL_RETURN) { 2454 result = TclUpdateReturnInfo(iPtr); 2455 } 2456 else if (result == TCL_ERROR) { 2457 objPtr = Tcl_NewStringObj("\n ", -1); 2458 Tcl_IncrRefCount(objPtr); 2459 2460 if (mfunc->member->flags & ITCL_CONSTRUCTOR) { 2461 Tcl_AppendToObj(objPtr, "while constructing object \"", -1); 2462 Tcl_GetCommandFullName(contextObj->classDefn->interp, 2463 contextObj->accessCmd, objPtr); 2464 Tcl_AppendToObj(objPtr, "\" in ", -1); 2465 Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); 2466 if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { 2467 Tcl_AppendToObj(objPtr, " (", -1); 2468 } 2469 } 2470 2471 else if (mfunc->member->flags & ITCL_DESTRUCTOR) { 2472 Tcl_AppendToObj(objPtr, "while deleting object \"", -1); 2473 Tcl_GetCommandFullName(contextObj->classDefn->interp, 2474 contextObj->accessCmd, objPtr); 2475 Tcl_AppendToObj(objPtr, "\" in ", -1); 2476 Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); 2477 if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { 2478 Tcl_AppendToObj(objPtr, " (", -1); 2479 } 2480 } 2481 2482 else { 2483 Tcl_AppendToObj(objPtr, "(", -1); 2484 2485 if (contextObj && contextObj->accessCmd) { 2486 Tcl_AppendToObj(objPtr, "object \"", -1); 2487 Tcl_GetCommandFullName(contextObj->classDefn->interp, 2488 contextObj->accessCmd, objPtr); 2489 Tcl_AppendToObj(objPtr, "\" ", -1); 2490 } 2491 2492 if ((mfunc->member->flags & ITCL_COMMON) != 0) { 2493 Tcl_AppendToObj(objPtr, "procedure", -1); 2494 } else { 2495 Tcl_AppendToObj(objPtr, "method", -1); 2496 } 2497 Tcl_AppendToObj(objPtr, " \"", -1); 2498 Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); 2499 Tcl_AppendToObj(objPtr, "\" ", -1); 2500 } 2501 2502 if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { 2503 Tcl_AppendToObj(objPtr, "body line ", -1); 2504 sprintf(num, "%d", ERRORLINE(iPtr)); 2505 Tcl_AppendToObj(objPtr, num, -1); 2506 Tcl_AppendToObj(objPtr, ")", -1); 2507 } else { 2508 Tcl_AppendToObj(objPtr, ")", -1); 2509 } 2510 2511 Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); 2512 Tcl_DecrRefCount(objPtr); 2513 } 2514 2515 else if (result == TCL_BREAK) { 2516 Tcl_ResetResult(interp); 2517 Tcl_AppendToObj(Tcl_GetObjResult(interp), 2518 "invoked \"break\" outside of a loop", -1); 2519 result = TCL_ERROR; 2520 } 2521 2522 else if (result == TCL_CONTINUE) { 2523 Tcl_ResetResult(interp); 2524 Tcl_AppendToObj(Tcl_GetObjResult(interp), 2525 "invoked \"continue\" outside of a loop", -1); 2526 result = TCL_ERROR; 2527 } 2528 } 2529 return result; 2530} 2531