1/* 2 * tclResult.c -- 3 * 4 * This file contains code to manage the interpreter result. 5 * 6 * Copyright (c) 1997 by Sun Microsystems, Inc. 7 * 8 * See the file "license.terms" for information on usage and redistribution of 9 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 * 11 * RCS: @(#) $Id: tclResult.c,v 1.47.2.1 2010/03/24 15:31:48 dgp Exp $ 12 */ 13 14#include "tclInt.h" 15 16/* 17 * Indices of the standard return options dictionary keys. 18 */ 19 20enum returnKeys { 21 KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, 22 KEY_LEVEL, KEY_OPTIONS, KEY_LAST 23}; 24 25/* 26 * Function prototypes for local functions in this file: 27 */ 28 29static Tcl_Obj ** GetKeys(void); 30static void ReleaseKeys(ClientData clientData); 31static void ResetObjResult(Interp *iPtr); 32static void SetupAppendBuffer(Interp *iPtr, int newSpace); 33 34/* 35 * This structure is used to take a snapshot of the interpreter state in 36 * Tcl_SaveInterpState. You can snapshot the state, execute a command, and 37 * then back up to the result or the error that was previously in progress. 38 */ 39 40typedef struct InterpState { 41 int status; /* return code status */ 42 int flags; /* Each remaining field saves the */ 43 int returnLevel; /* corresponding field of the Interp */ 44 int returnCode; /* struct. These fields taken together are */ 45 Tcl_Obj *errorInfo; /* the "state" of the interp. */ 46 Tcl_Obj *errorCode; 47 Tcl_Obj *returnOpts; 48 Tcl_Obj *objResult; 49} InterpState; 50 51/* 52 *---------------------------------------------------------------------- 53 * 54 * Tcl_SaveInterpState -- 55 * 56 * Fills a token with a snapshot of the current state of the interpreter. 57 * The snapshot can be restored at any point by TclRestoreInterpState. 58 * 59 * The token returned must be eventally passed to one of the routines 60 * TclRestoreInterpState or TclDiscardInterpState, or there will be a 61 * memory leak. 62 * 63 * Results: 64 * Returns a token representing the interp state. 65 * 66 * Side effects: 67 * None. 68 * 69 *---------------------------------------------------------------------- 70 */ 71 72Tcl_InterpState 73Tcl_SaveInterpState( 74 Tcl_Interp *interp, /* Interpreter's state to be saved */ 75 int status) /* status code for current operation */ 76{ 77 Interp *iPtr = (Interp *)interp; 78 InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); 79 80 statePtr->status = status; 81 statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; 82 statePtr->returnLevel = iPtr->returnLevel; 83 statePtr->returnCode = iPtr->returnCode; 84 statePtr->errorInfo = iPtr->errorInfo; 85 if (statePtr->errorInfo) { 86 Tcl_IncrRefCount(statePtr->errorInfo); 87 } 88 statePtr->errorCode = iPtr->errorCode; 89 if (statePtr->errorCode) { 90 Tcl_IncrRefCount(statePtr->errorCode); 91 } 92 statePtr->returnOpts = iPtr->returnOpts; 93 if (statePtr->returnOpts) { 94 Tcl_IncrRefCount(statePtr->returnOpts); 95 } 96 statePtr->objResult = Tcl_GetObjResult(interp); 97 Tcl_IncrRefCount(statePtr->objResult); 98 return (Tcl_InterpState) statePtr; 99} 100 101/* 102 *---------------------------------------------------------------------- 103 * 104 * Tcl_RestoreInterpState -- 105 * 106 * Accepts an interp and a token previously returned by 107 * Tcl_SaveInterpState. Restore the state of the interp to what it was at 108 * the time of the Tcl_SaveInterpState call. 109 * 110 * Results: 111 * Returns the status value originally passed in to Tcl_SaveInterpState. 112 * 113 * Side effects: 114 * Restores the interp state and frees memory held by token. 115 * 116 *---------------------------------------------------------------------- 117 */ 118 119int 120Tcl_RestoreInterpState( 121 Tcl_Interp *interp, /* Interpreter's state to be restored. */ 122 Tcl_InterpState state) /* Saved interpreter state. */ 123{ 124 Interp *iPtr = (Interp *)interp; 125 InterpState *statePtr = (InterpState *)state; 126 int status = statePtr->status; 127 128 iPtr->flags &= ~ERR_ALREADY_LOGGED; 129 iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED); 130 131 iPtr->returnLevel = statePtr->returnLevel; 132 iPtr->returnCode = statePtr->returnCode; 133 if (iPtr->errorInfo) { 134 Tcl_DecrRefCount(iPtr->errorInfo); 135 } 136 iPtr->errorInfo = statePtr->errorInfo; 137 if (iPtr->errorInfo) { 138 Tcl_IncrRefCount(iPtr->errorInfo); 139 } 140 if (iPtr->errorCode) { 141 Tcl_DecrRefCount(iPtr->errorCode); 142 } 143 iPtr->errorCode = statePtr->errorCode; 144 if (iPtr->errorCode) { 145 Tcl_IncrRefCount(iPtr->errorCode); 146 } 147 if (iPtr->returnOpts) { 148 Tcl_DecrRefCount(iPtr->returnOpts); 149 } 150 iPtr->returnOpts = statePtr->returnOpts; 151 if (iPtr->returnOpts) { 152 Tcl_IncrRefCount(iPtr->returnOpts); 153 } 154 Tcl_SetObjResult(interp, statePtr->objResult); 155 Tcl_DiscardInterpState(state); 156 return status; 157} 158 159/* 160 *---------------------------------------------------------------------- 161 * 162 * Tcl_DiscardInterpState -- 163 * 164 * Accepts a token previously returned by Tcl_SaveInterpState. Frees the 165 * memory it uses. 166 * 167 * Results: 168 * None. 169 * 170 * Side effects: 171 * Frees memory. 172 * 173 *---------------------------------------------------------------------- 174 */ 175 176void 177Tcl_DiscardInterpState( 178 Tcl_InterpState state) /* saved interpreter state */ 179{ 180 InterpState *statePtr = (InterpState *)state; 181 182 if (statePtr->errorInfo) { 183 Tcl_DecrRefCount(statePtr->errorInfo); 184 } 185 if (statePtr->errorCode) { 186 Tcl_DecrRefCount(statePtr->errorCode); 187 } 188 if (statePtr->returnOpts) { 189 Tcl_DecrRefCount(statePtr->returnOpts); 190 } 191 Tcl_DecrRefCount(statePtr->objResult); 192 ckfree((char *) statePtr); 193} 194 195/* 196 *---------------------------------------------------------------------- 197 * 198 * Tcl_SaveResult -- 199 * 200 * Takes a snapshot of the current result state of the interpreter. The 201 * snapshot can be restored at any point by Tcl_RestoreResult. Note that 202 * this routine does not preserve the errorCode, errorInfo, or flags 203 * fields so it should not be used if an error is in progress. 204 * 205 * Once a snapshot is saved, it must be restored by calling 206 * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. 207 * 208 * Results: 209 * None. 210 * 211 * Side effects: 212 * Resets the interpreter result. 213 * 214 *---------------------------------------------------------------------- 215 */ 216 217void 218Tcl_SaveResult( 219 Tcl_Interp *interp, /* Interpreter to save. */ 220 Tcl_SavedResult *statePtr) /* Pointer to state structure. */ 221{ 222 Interp *iPtr = (Interp *) interp; 223 224 /* 225 * Move the result object into the save state. Note that we don't need to 226 * change its refcount because we're moving it, not adding a new 227 * reference. Put an empty object into the interpreter. 228 */ 229 230 statePtr->objResultPtr = iPtr->objResultPtr; 231 iPtr->objResultPtr = Tcl_NewObj(); 232 Tcl_IncrRefCount(iPtr->objResultPtr); 233 234 /* 235 * Save the string result. 236 */ 237 238 statePtr->freeProc = iPtr->freeProc; 239 if (iPtr->result == iPtr->resultSpace) { 240 /* 241 * Copy the static string data out of the interp buffer. 242 */ 243 244 statePtr->result = statePtr->resultSpace; 245 strcpy(statePtr->result, iPtr->result); 246 statePtr->appendResult = NULL; 247 } else if (iPtr->result == iPtr->appendResult) { 248 /* 249 * Move the append buffer out of the interp. 250 */ 251 252 statePtr->appendResult = iPtr->appendResult; 253 statePtr->appendAvl = iPtr->appendAvl; 254 statePtr->appendUsed = iPtr->appendUsed; 255 statePtr->result = statePtr->appendResult; 256 iPtr->appendResult = NULL; 257 iPtr->appendAvl = 0; 258 iPtr->appendUsed = 0; 259 } else { 260 /* 261 * Move the dynamic or static string out of the interpreter. 262 */ 263 264 statePtr->result = iPtr->result; 265 statePtr->appendResult = NULL; 266 } 267 268 iPtr->result = iPtr->resultSpace; 269 iPtr->resultSpace[0] = 0; 270 iPtr->freeProc = 0; 271} 272 273/* 274 *---------------------------------------------------------------------- 275 * 276 * Tcl_RestoreResult -- 277 * 278 * Restores the state of the interpreter to a snapshot taken by 279 * Tcl_SaveResult. After this call, the token for the interpreter state 280 * is no longer valid. 281 * 282 * Results: 283 * None. 284 * 285 * Side effects: 286 * Restores the interpreter result. 287 * 288 *---------------------------------------------------------------------- 289 */ 290 291void 292Tcl_RestoreResult( 293 Tcl_Interp *interp, /* Interpreter being restored. */ 294 Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ 295{ 296 Interp *iPtr = (Interp *) interp; 297 298 Tcl_ResetResult(interp); 299 300 /* 301 * Restore the string result. 302 */ 303 304 iPtr->freeProc = statePtr->freeProc; 305 if (statePtr->result == statePtr->resultSpace) { 306 /* 307 * Copy the static string data into the interp buffer. 308 */ 309 310 iPtr->result = iPtr->resultSpace; 311 strcpy(iPtr->result, statePtr->result); 312 } else if (statePtr->result == statePtr->appendResult) { 313 /* 314 * Move the append buffer back into the interp. 315 */ 316 317 if (iPtr->appendResult != NULL) { 318 ckfree((char *) iPtr->appendResult); 319 } 320 321 iPtr->appendResult = statePtr->appendResult; 322 iPtr->appendAvl = statePtr->appendAvl; 323 iPtr->appendUsed = statePtr->appendUsed; 324 iPtr->result = iPtr->appendResult; 325 } else { 326 /* 327 * Move the dynamic or static string back into the interpreter. 328 */ 329 330 iPtr->result = statePtr->result; 331 } 332 333 /* 334 * Restore the object result. 335 */ 336 337 Tcl_DecrRefCount(iPtr->objResultPtr); 338 iPtr->objResultPtr = statePtr->objResultPtr; 339} 340 341/* 342 *---------------------------------------------------------------------- 343 * 344 * Tcl_DiscardResult -- 345 * 346 * Frees the memory associated with an interpreter snapshot taken by 347 * Tcl_SaveResult. If the snapshot is not restored, this function must be 348 * called to discard it, or the memory will be lost. 349 * 350 * Results: 351 * None. 352 * 353 * Side effects: 354 * None. 355 * 356 *---------------------------------------------------------------------- 357 */ 358 359void 360Tcl_DiscardResult( 361 Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ 362{ 363 TclDecrRefCount(statePtr->objResultPtr); 364 365 if (statePtr->result == statePtr->appendResult) { 366 ckfree(statePtr->appendResult); 367 } else if (statePtr->freeProc) { 368 if (statePtr->freeProc == TCL_DYNAMIC) { 369 ckfree(statePtr->result); 370 } else { 371 (*statePtr->freeProc)(statePtr->result); 372 } 373 } 374} 375 376/* 377 *---------------------------------------------------------------------- 378 * 379 * Tcl_SetResult -- 380 * 381 * Arrange for "result" to be the Tcl return value. 382 * 383 * Results: 384 * None. 385 * 386 * Side effects: 387 * interp->result is left pointing either to "result" or to a copy of it. 388 * Also, the object result is reset. 389 * 390 *---------------------------------------------------------------------- 391 */ 392 393void 394Tcl_SetResult( 395 Tcl_Interp *interp, /* Interpreter with which to associate the 396 * return value. */ 397 register char *result, /* Value to be returned. If NULL, the result 398 * is set to an empty string. */ 399 Tcl_FreeProc *freeProc) /* Gives information about the string: 400 * TCL_STATIC, TCL_VOLATILE, or the address of 401 * a Tcl_FreeProc such as free. */ 402{ 403 Interp *iPtr = (Interp *) interp; 404 int length; 405 register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; 406 char *oldResult = iPtr->result; 407 408 if (result == NULL) { 409 iPtr->resultSpace[0] = 0; 410 iPtr->result = iPtr->resultSpace; 411 iPtr->freeProc = 0; 412 } else if (freeProc == TCL_VOLATILE) { 413 length = strlen(result); 414 if (length > TCL_RESULT_SIZE) { 415 iPtr->result = (char *) ckalloc((unsigned) length+1); 416 iPtr->freeProc = TCL_DYNAMIC; 417 } else { 418 iPtr->result = iPtr->resultSpace; 419 iPtr->freeProc = 0; 420 } 421 strcpy(iPtr->result, result); 422 } else { 423 iPtr->result = result; 424 iPtr->freeProc = freeProc; 425 } 426 427 /* 428 * If the old result was dynamically-allocated, free it up. Do it here, 429 * rather than at the beginning, in case the new result value was part of 430 * the old result value. 431 */ 432 433 if (oldFreeProc != 0) { 434 if (oldFreeProc == TCL_DYNAMIC) { 435 ckfree(oldResult); 436 } else { 437 (*oldFreeProc)(oldResult); 438 } 439 } 440 441 /* 442 * Reset the object result since we just set the string result. 443 */ 444 445 ResetObjResult(iPtr); 446} 447 448/* 449 *---------------------------------------------------------------------- 450 * 451 * Tcl_GetStringResult -- 452 * 453 * Returns an interpreter's result value as a string. 454 * 455 * Results: 456 * The interpreter's result as a string. 457 * 458 * Side effects: 459 * If the string result is empty, the object result is moved to the 460 * string result, then the object result is reset. 461 * 462 *---------------------------------------------------------------------- 463 */ 464 465CONST char * 466Tcl_GetStringResult( 467 register Tcl_Interp *interp)/* Interpreter whose result to return. */ 468{ 469 /* 470 * If the string result is empty, move the object result to the string 471 * result, then reset the object result. 472 */ 473 474 if (*(interp->result) == 0) { 475 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 476 TCL_VOLATILE); 477 } 478 return interp->result; 479} 480 481/* 482 *---------------------------------------------------------------------- 483 * 484 * Tcl_SetObjResult -- 485 * 486 * Arrange for objPtr to be an interpreter's result value. 487 * 488 * Results: 489 * None. 490 * 491 * Side effects: 492 * interp->objResultPtr is left pointing to the object referenced by 493 * objPtr. The object's reference count is incremented since there is now 494 * a new reference to it. The reference count for any old objResultPtr 495 * value is decremented. Also, the string result is reset. 496 * 497 *---------------------------------------------------------------------- 498 */ 499 500void 501Tcl_SetObjResult( 502 Tcl_Interp *interp, /* Interpreter with which to associate the 503 * return object value. */ 504 register Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj 505 * result is made an empty string object. */ 506{ 507 register Interp *iPtr = (Interp *) interp; 508 register Tcl_Obj *oldObjResult = iPtr->objResultPtr; 509 510 iPtr->objResultPtr = objPtr; 511 Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ 512 513 /* 514 * We wait until the end to release the old object result, in case we are 515 * setting the result to itself. 516 */ 517 518 TclDecrRefCount(oldObjResult); 519 520 /* 521 * Reset the string result since we just set the result object. 522 */ 523 524 if (iPtr->freeProc != NULL) { 525 if (iPtr->freeProc == TCL_DYNAMIC) { 526 ckfree(iPtr->result); 527 } else { 528 (*iPtr->freeProc)(iPtr->result); 529 } 530 iPtr->freeProc = 0; 531 } 532 iPtr->result = iPtr->resultSpace; 533 iPtr->resultSpace[0] = 0; 534} 535 536/* 537 *---------------------------------------------------------------------- 538 * 539 * Tcl_GetObjResult -- 540 * 541 * Returns an interpreter's result value as a Tcl object. The object's 542 * reference count is not modified; the caller must do that if it needs 543 * to hold on to a long-term reference to it. 544 * 545 * Results: 546 * The interpreter's result as an object. 547 * 548 * Side effects: 549 * If the interpreter has a non-empty string result, the result object is 550 * either empty or stale because some function set interp->result 551 * directly. If so, the string result is moved to the result object then 552 * the string result is reset. 553 * 554 *---------------------------------------------------------------------- 555 */ 556 557Tcl_Obj * 558Tcl_GetObjResult( 559 Tcl_Interp *interp) /* Interpreter whose result to return. */ 560{ 561 register Interp *iPtr = (Interp *) interp; 562 Tcl_Obj *objResultPtr; 563 int length; 564 565 /* 566 * If the string result is non-empty, move the string result to the object 567 * result, then reset the string result. 568 */ 569 570 if (*(iPtr->result) != 0) { 571 ResetObjResult(iPtr); 572 573 objResultPtr = iPtr->objResultPtr; 574 length = strlen(iPtr->result); 575 TclInitStringRep(objResultPtr, iPtr->result, length); 576 577 if (iPtr->freeProc != NULL) { 578 if (iPtr->freeProc == TCL_DYNAMIC) { 579 ckfree(iPtr->result); 580 } else { 581 (*iPtr->freeProc)(iPtr->result); 582 } 583 iPtr->freeProc = 0; 584 } 585 iPtr->result = iPtr->resultSpace; 586 iPtr->resultSpace[0] = 0; 587 } 588 return iPtr->objResultPtr; 589} 590 591/* 592 *---------------------------------------------------------------------- 593 * 594 * Tcl_AppendResultVA -- 595 * 596 * Append a variable number of strings onto the interpreter's result. 597 * 598 * Results: 599 * None. 600 * 601 * Side effects: 602 * The result of the interpreter given by the first argument is extended 603 * by the strings in the va_list (up to a terminating NULL argument). 604 * 605 * If the string result is non-empty, the object result forced to be a 606 * duplicate of it first. There will be a string result afterwards. 607 * 608 *---------------------------------------------------------------------- 609 */ 610 611void 612Tcl_AppendResultVA( 613 Tcl_Interp *interp, /* Interpreter with which to associate the 614 * return value. */ 615 va_list argList) /* Variable argument list. */ 616{ 617 Tcl_Obj *objPtr = Tcl_GetObjResult(interp); 618 619 if (Tcl_IsShared(objPtr)) { 620 objPtr = Tcl_DuplicateObj(objPtr); 621 } 622 Tcl_AppendStringsToObjVA(objPtr, argList); 623 Tcl_SetObjResult(interp, objPtr); 624 625 /* 626 * Strictly we should call Tcl_GetStringResult(interp) here to make sure 627 * that interp->result is correct according to the old contract, but that 628 * makes the performance of much code (e.g. in Tk) absolutely awful. So we 629 * leave it out; code that really wants interp->result can just insert the 630 * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] 631 */ 632 633#ifdef USE_DIRECT_INTERP_RESULT_ACCESS 634 /* 635 * Ensure that the interp->result is legal so old Tcl 7.* code still 636 * works. There's still embarrasingly much of it about... 637 */ 638 639 (void) Tcl_GetStringResult(interp); 640#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */ 641} 642 643/* 644 *---------------------------------------------------------------------- 645 * 646 * Tcl_AppendResult -- 647 * 648 * Append a variable number of strings onto the interpreter's result. 649 * 650 * Results: 651 * None. 652 * 653 * Side effects: 654 * The result of the interpreter given by the first argument is extended 655 * by the strings given by the second and following arguments (up to a 656 * terminating NULL argument). 657 * 658 * If the string result is non-empty, the object result forced to be a 659 * duplicate of it first. There will be a string result afterwards. 660 * 661 *---------------------------------------------------------------------- 662 */ 663 664void 665Tcl_AppendResult( 666 Tcl_Interp *interp, ...) 667{ 668 va_list argList; 669 670 va_start(argList, interp); 671 Tcl_AppendResultVA(interp, argList); 672 va_end(argList); 673} 674 675/* 676 *---------------------------------------------------------------------- 677 * 678 * Tcl_AppendElement -- 679 * 680 * Convert a string to a valid Tcl list element and append it to the 681 * result (which is ostensibly a list). 682 * 683 * Results: 684 * None. 685 * 686 * Side effects: 687 * The result in the interpreter given by the first argument is extended 688 * with a list element converted from string. A separator space is added 689 * before the converted list element unless the current result is empty, 690 * contains the single character "{", or ends in " {". 691 * 692 * If the string result is empty, the object result is moved to the 693 * string result, then the object result is reset. 694 * 695 *---------------------------------------------------------------------- 696 */ 697 698void 699Tcl_AppendElement( 700 Tcl_Interp *interp, /* Interpreter whose result is to be 701 * extended. */ 702 CONST char *element) /* String to convert to list element and add 703 * to result. */ 704{ 705 Interp *iPtr = (Interp *) interp; 706 char *dst; 707 int size; 708 int flags; 709 710 /* 711 * If the string result is empty, move the object result to the string 712 * result, then reset the object result. 713 */ 714 715 (void) Tcl_GetStringResult(interp); 716 717 /* 718 * See how much space is needed, and grow the append buffer if needed to 719 * accommodate the list element. 720 */ 721 722 size = Tcl_ScanElement(element, &flags) + 1; 723 if ((iPtr->result != iPtr->appendResult) 724 || (iPtr->appendResult[iPtr->appendUsed] != 0) 725 || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { 726 SetupAppendBuffer(iPtr, size+iPtr->appendUsed); 727 } 728 729 /* 730 * Convert the string into a list element and copy it to the buffer that's 731 * forming, with a space separator if needed. 732 */ 733 734 dst = iPtr->appendResult + iPtr->appendUsed; 735 if (TclNeedSpace(iPtr->appendResult, dst)) { 736 iPtr->appendUsed++; 737 *dst = ' '; 738 dst++; 739 740 /* 741 * If we need a space to separate this element from preceding stuff, 742 * then this element will not lead a list, and need not have it's 743 * leading '#' quoted. 744 */ 745 746 flags |= TCL_DONT_QUOTE_HASH; 747 } 748 iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); 749} 750 751/* 752 *---------------------------------------------------------------------- 753 * 754 * SetupAppendBuffer -- 755 * 756 * This function makes sure that there is an append buffer properly 757 * initialized, if necessary, from the interpreter's result, and that it 758 * has at least enough room to accommodate newSpace new bytes of 759 * information. 760 * 761 * Results: 762 * None. 763 * 764 * Side effects: 765 * None. 766 * 767 *---------------------------------------------------------------------- 768 */ 769 770static void 771SetupAppendBuffer( 772 Interp *iPtr, /* Interpreter whose result is being set up. */ 773 int newSpace) /* Make sure that at least this many bytes of 774 * new information may be added. */ 775{ 776 int totalSpace; 777 778 /* 779 * Make the append buffer larger, if that's necessary, then copy the 780 * result into the append buffer and make the append buffer the official 781 * Tcl result. 782 */ 783 784 if (iPtr->result != iPtr->appendResult) { 785 /* 786 * If an oversized buffer was used recently, then free it up so we go 787 * back to a smaller buffer. This avoids tying up memory forever after 788 * a large operation. 789 */ 790 791 if (iPtr->appendAvl > 500) { 792 ckfree(iPtr->appendResult); 793 iPtr->appendResult = NULL; 794 iPtr->appendAvl = 0; 795 } 796 iPtr->appendUsed = strlen(iPtr->result); 797 } else if (iPtr->result[iPtr->appendUsed] != 0) { 798 /* 799 * Most likely someone has modified a result created by 800 * Tcl_AppendResult et al. so that it has a different size. Just 801 * recompute the size. 802 */ 803 804 iPtr->appendUsed = strlen(iPtr->result); 805 } 806 807 totalSpace = newSpace + iPtr->appendUsed; 808 if (totalSpace >= iPtr->appendAvl) { 809 char *new; 810 811 if (totalSpace < 100) { 812 totalSpace = 200; 813 } else { 814 totalSpace *= 2; 815 } 816 new = (char *) ckalloc((unsigned) totalSpace); 817 strcpy(new, iPtr->result); 818 if (iPtr->appendResult != NULL) { 819 ckfree(iPtr->appendResult); 820 } 821 iPtr->appendResult = new; 822 iPtr->appendAvl = totalSpace; 823 } else if (iPtr->result != iPtr->appendResult) { 824 strcpy(iPtr->appendResult, iPtr->result); 825 } 826 827 Tcl_FreeResult((Tcl_Interp *) iPtr); 828 iPtr->result = iPtr->appendResult; 829} 830 831/* 832 *---------------------------------------------------------------------- 833 * 834 * Tcl_FreeResult -- 835 * 836 * This function frees up the memory associated with an interpreter's 837 * string result. It also resets the interpreter's result object. 838 * Tcl_FreeResult is most commonly used when a function is about to 839 * replace one result value with another. 840 * 841 * Results: 842 * None. 843 * 844 * Side effects: 845 * Frees the memory associated with interp's string result and sets 846 * interp->freeProc to zero, but does not change interp->result or clear 847 * error state. Resets interp's result object to an unshared empty 848 * object. 849 * 850 *---------------------------------------------------------------------- 851 */ 852 853void 854Tcl_FreeResult( 855 register Tcl_Interp *interp)/* Interpreter for which to free result. */ 856{ 857 register Interp *iPtr = (Interp *) interp; 858 859 if (iPtr->freeProc != NULL) { 860 if (iPtr->freeProc == TCL_DYNAMIC) { 861 ckfree(iPtr->result); 862 } else { 863 (*iPtr->freeProc)(iPtr->result); 864 } 865 iPtr->freeProc = 0; 866 } 867 868 ResetObjResult(iPtr); 869} 870 871/* 872 *---------------------------------------------------------------------- 873 * 874 * Tcl_ResetResult -- 875 * 876 * This function resets both the interpreter's string and object results. 877 * 878 * Results: 879 * None. 880 * 881 * Side effects: 882 * It resets the result object to an unshared empty object. It then 883 * restores the interpreter's string result area to its default 884 * initialized state, freeing up any memory that may have been allocated. 885 * It also clears any error information for the interpreter. 886 * 887 *---------------------------------------------------------------------- 888 */ 889 890void 891Tcl_ResetResult( 892 register Tcl_Interp *interp)/* Interpreter for which to clear result. */ 893{ 894 register Interp *iPtr = (Interp *) interp; 895 896 ResetObjResult(iPtr); 897 if (iPtr->freeProc != NULL) { 898 if (iPtr->freeProc == TCL_DYNAMIC) { 899 ckfree(iPtr->result); 900 } else { 901 (*iPtr->freeProc)(iPtr->result); 902 } 903 iPtr->freeProc = 0; 904 } 905 iPtr->result = iPtr->resultSpace; 906 iPtr->resultSpace[0] = 0; 907 if (iPtr->errorCode) { 908 /* Legacy support */ 909 if (iPtr->flags & ERR_LEGACY_COPY) { 910 Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, 911 iPtr->errorCode, TCL_GLOBAL_ONLY); 912 } 913 Tcl_DecrRefCount(iPtr->errorCode); 914 iPtr->errorCode = NULL; 915 } 916 if (iPtr->errorInfo) { 917 /* Legacy support */ 918 if (iPtr->flags & ERR_LEGACY_COPY) { 919 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, 920 iPtr->errorInfo, TCL_GLOBAL_ONLY); 921 } 922 Tcl_DecrRefCount(iPtr->errorInfo); 923 iPtr->errorInfo = NULL; 924 } 925 iPtr->returnLevel = 1; 926 iPtr->returnCode = TCL_OK; 927 if (iPtr->returnOpts) { 928 Tcl_DecrRefCount(iPtr->returnOpts); 929 iPtr->returnOpts = NULL; 930 } 931 iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY); 932} 933 934/* 935 *---------------------------------------------------------------------- 936 * 937 * ResetObjResult -- 938 * 939 * Function used to reset an interpreter's Tcl result object. 940 * 941 * Results: 942 * None. 943 * 944 * Side effects: 945 * Resets the interpreter's result object to an unshared empty string 946 * object with ref count one. It does not clear any error information in 947 * the interpreter. 948 * 949 *---------------------------------------------------------------------- 950 */ 951 952static void 953ResetObjResult( 954 register Interp *iPtr) /* Points to the interpreter whose result 955 * object should be reset. */ 956{ 957 register Tcl_Obj *objResultPtr = iPtr->objResultPtr; 958 959 if (Tcl_IsShared(objResultPtr)) { 960 TclDecrRefCount(objResultPtr); 961 TclNewObj(objResultPtr); 962 Tcl_IncrRefCount(objResultPtr); 963 iPtr->objResultPtr = objResultPtr; 964 } else if (objResultPtr->bytes != tclEmptyStringRep) { 965 if (objResultPtr->bytes != NULL) { 966 ckfree((char *) objResultPtr->bytes); 967 } 968 objResultPtr->bytes = tclEmptyStringRep; 969 objResultPtr->length = 0; 970 TclFreeIntRep(objResultPtr); 971 objResultPtr->typePtr = NULL; 972 } 973} 974 975/* 976 *---------------------------------------------------------------------- 977 * 978 * Tcl_SetErrorCodeVA -- 979 * 980 * This function is called to record machine-readable information about 981 * an error that is about to be returned. 982 * 983 * Results: 984 * None. 985 * 986 * Side effects: 987 * The errorCode field of the interp is modified to hold all of the 988 * arguments to this function, in a list form with each argument becoming 989 * one element of the list. 990 * 991 *---------------------------------------------------------------------- 992 */ 993 994void 995Tcl_SetErrorCodeVA( 996 Tcl_Interp *interp, /* Interpreter in which to set errorCode */ 997 va_list argList) /* Variable argument list. */ 998{ 999 Tcl_Obj *errorObj = Tcl_NewObj(); 1000 1001 /* 1002 * Scan through the arguments one at a time, appending them to the 1003 * errorCode field as list elements. 1004 */ 1005 1006 while (1) { 1007 char *elem = va_arg(argList, char *); 1008 if (elem == NULL) { 1009 break; 1010 } 1011 Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); 1012 } 1013 Tcl_SetObjErrorCode(interp, errorObj); 1014} 1015 1016/* 1017 *---------------------------------------------------------------------- 1018 * 1019 * Tcl_SetErrorCode -- 1020 * 1021 * This function is called to record machine-readable information about 1022 * an error that is about to be returned. 1023 * 1024 * Results: 1025 * None. 1026 * 1027 * Side effects: 1028 * The errorCode field of the interp is modified to hold all of the 1029 * arguments to this function, in a list form with each argument becoming 1030 * one element of the list. 1031 * 1032 *---------------------------------------------------------------------- 1033 */ 1034 1035void 1036Tcl_SetErrorCode( 1037 Tcl_Interp *interp, ...) 1038{ 1039 va_list argList; 1040 1041 /* 1042 * Scan through the arguments one at a time, appending them to the 1043 * errorCode field as list elements. 1044 */ 1045 1046 va_start(argList, interp); 1047 Tcl_SetErrorCodeVA(interp, argList); 1048 va_end(argList); 1049} 1050 1051/* 1052 *---------------------------------------------------------------------- 1053 * 1054 * Tcl_SetObjErrorCode -- 1055 * 1056 * This function is called to record machine-readable information about 1057 * an error that is about to be returned. The caller should build a list 1058 * object up and pass it to this routine. 1059 * 1060 * Results: 1061 * None. 1062 * 1063 * Side effects: 1064 * The errorCode field of the interp is set to the new value. 1065 * 1066 *---------------------------------------------------------------------- 1067 */ 1068 1069void 1070Tcl_SetObjErrorCode( 1071 Tcl_Interp *interp, 1072 Tcl_Obj *errorObjPtr) 1073{ 1074 Interp *iPtr = (Interp *) interp; 1075 1076 if (iPtr->errorCode) { 1077 Tcl_DecrRefCount(iPtr->errorCode); 1078 } 1079 iPtr->errorCode = errorObjPtr; 1080 Tcl_IncrRefCount(iPtr->errorCode); 1081} 1082 1083/* 1084 *---------------------------------------------------------------------- 1085 * 1086 * GetKeys -- 1087 * 1088 * Returns a Tcl_Obj * array of the standard keys used in the return 1089 * options dictionary. 1090 * 1091 * Broadly sharing one copy of these key values helps with both memory 1092 * efficiency and dictionary lookup times. 1093 * 1094 * Results: 1095 * A Tcl_Obj * array. 1096 * 1097 * Side effects: 1098 * First time called in a thread, creates the keys (allocating memory) 1099 * and arranges for their cleanup at thread exit. 1100 * 1101 *---------------------------------------------------------------------- 1102 */ 1103 1104static Tcl_Obj ** 1105GetKeys(void) 1106{ 1107 static Tcl_ThreadDataKey returnKeysKey; 1108 Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey, 1109 (int) (KEY_LAST * sizeof(Tcl_Obj *))); 1110 1111 if (keys[0] == NULL) { 1112 /* 1113 * First call in this thread, create the keys... 1114 */ 1115 1116 int i; 1117 1118 TclNewLiteralStringObj(keys[KEY_CODE], "-code"); 1119 TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode"); 1120 TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo"); 1121 TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline"); 1122 TclNewLiteralStringObj(keys[KEY_LEVEL], "-level"); 1123 TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options"); 1124 1125 for (i = KEY_CODE; i < KEY_LAST; i++) { 1126 Tcl_IncrRefCount(keys[i]); 1127 } 1128 1129 /* 1130 * ... and arrange for their clenaup. 1131 */ 1132 1133 Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys); 1134 } 1135 return keys; 1136} 1137 1138/* 1139 *---------------------------------------------------------------------- 1140 * 1141 * ReleaseKeys -- 1142 * 1143 * Called as a thread exit handler to cleanup return options dictionary 1144 * keys. 1145 * 1146 * Results: 1147 * None. 1148 * 1149 * Side effects: 1150 * Frees memory. 1151 * 1152 *---------------------------------------------------------------------- 1153 */ 1154 1155static void 1156ReleaseKeys( 1157 ClientData clientData) 1158{ 1159 Tcl_Obj **keys = (Tcl_Obj **)clientData; 1160 int i; 1161 1162 for (i = KEY_CODE; i < KEY_LAST; i++) { 1163 Tcl_DecrRefCount(keys[i]); 1164 keys[i] = NULL; 1165 } 1166} 1167 1168/* 1169 *---------------------------------------------------------------------- 1170 * 1171 * TclProcessReturn -- 1172 * 1173 * Does the work of the [return] command based on the code, level, and 1174 * returnOpts arguments. Note that the code argument must agree with the 1175 * -code entry in returnOpts and the level argument must agree with the 1176 * -level entry in returnOpts, as is the case for values returned from 1177 * TclMergeReturnOptions. 1178 * 1179 * Results: 1180 * Returns the return code the [return] command should return. 1181 * 1182 * Side effects: 1183 * None. 1184 * 1185 *---------------------------------------------------------------------- 1186 */ 1187 1188int 1189TclProcessReturn( 1190 Tcl_Interp *interp, 1191 int code, 1192 int level, 1193 Tcl_Obj *returnOpts) 1194{ 1195 Interp *iPtr = (Interp *) interp; 1196 Tcl_Obj *valuePtr; 1197 Tcl_Obj **keys = GetKeys(); 1198 1199 /* 1200 * Store the merged return options. 1201 */ 1202 1203 if (iPtr->returnOpts != returnOpts) { 1204 if (iPtr->returnOpts) { 1205 Tcl_DecrRefCount(iPtr->returnOpts); 1206 } 1207 iPtr->returnOpts = returnOpts; 1208 Tcl_IncrRefCount(iPtr->returnOpts); 1209 } 1210 1211 if (code == TCL_ERROR) { 1212 if (iPtr->errorInfo) { 1213 Tcl_DecrRefCount(iPtr->errorInfo); 1214 iPtr->errorInfo = NULL; 1215 } 1216 Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); 1217 if (valuePtr != NULL) { 1218 int infoLen; 1219 1220 (void) TclGetStringFromObj(valuePtr, &infoLen); 1221 if (infoLen) { 1222 iPtr->errorInfo = valuePtr; 1223 Tcl_IncrRefCount(iPtr->errorInfo); 1224 iPtr->flags |= ERR_ALREADY_LOGGED; 1225 } 1226 } 1227 Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); 1228 if (valuePtr != NULL) { 1229 Tcl_SetObjErrorCode(interp, valuePtr); 1230 } else { 1231 Tcl_SetErrorCode(interp, "NONE", NULL); 1232 } 1233 1234 Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); 1235 if (valuePtr != NULL) { 1236 TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); 1237 } 1238 } 1239 if (level != 0) { 1240 iPtr->returnLevel = level; 1241 iPtr->returnCode = code; 1242 return TCL_RETURN; 1243 } 1244 if (code == TCL_ERROR) { 1245 iPtr->flags |= ERR_LEGACY_COPY; 1246 } 1247 return code; 1248} 1249 1250/* 1251 *---------------------------------------------------------------------- 1252 * 1253 * TclMergeReturnOptions -- 1254 * 1255 * Parses, checks, and stores the options to the [return] command. 1256 * 1257 * Results: 1258 * Returns TCL_ERROR is any of the option values are invalid. Otherwise, 1259 * returns TCL_OK, and writes the returnOpts, code, and level values to 1260 * the pointers provided. 1261 * 1262 * Side effects: 1263 * None. 1264 * 1265 *---------------------------------------------------------------------- 1266 */ 1267 1268int 1269TclMergeReturnOptions( 1270 Tcl_Interp *interp, /* Current interpreter. */ 1271 int objc, /* Number of arguments. */ 1272 Tcl_Obj *CONST objv[], /* Argument objects. */ 1273 Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj 1274 * *) where the pointer to the merged return 1275 * options dictionary should be written */ 1276 int *codePtr, /* If not NULL, points to space where the 1277 * -code value should be written */ 1278 int *levelPtr) /* If not NULL, points to space where the 1279 * -level value should be written */ 1280{ 1281 int code=TCL_OK; 1282 int level = 1; 1283 Tcl_Obj *valuePtr; 1284 Tcl_Obj *returnOpts = Tcl_NewObj(); 1285 Tcl_Obj **keys = GetKeys(); 1286 1287 for (; objc > 1; objv += 2, objc -= 2) { 1288 int optLen; 1289 CONST char *opt = TclGetStringFromObj(objv[0], &optLen); 1290 int compareLen; 1291 CONST char *compare = 1292 TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); 1293 1294 if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { 1295 Tcl_DictSearch search; 1296 int done = 0; 1297 Tcl_Obj *keyPtr; 1298 Tcl_Obj *dict = objv[1]; 1299 1300 nestedOptions: 1301 if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, 1302 &keyPtr, &valuePtr, &done)) { 1303 /* 1304 * Value is not a legal dictionary. 1305 */ 1306 1307 Tcl_ResetResult(interp); 1308 Tcl_AppendResult(interp, "bad ", compare, 1309 " value: expected dictionary but got \"", 1310 TclGetString(objv[1]), "\"", NULL); 1311 goto error; 1312 } 1313 1314 while (!done) { 1315 Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); 1316 Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); 1317 } 1318 1319 Tcl_DictObjGet(NULL, returnOpts, keys[KEY_OPTIONS], &valuePtr); 1320 if (valuePtr != NULL) { 1321 dict = valuePtr; 1322 Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_OPTIONS]); 1323 goto nestedOptions; 1324 } 1325 1326 } else { 1327 Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); 1328 } 1329 } 1330 1331 /* 1332 * Check for bogus -code value. 1333 */ 1334 1335 Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); 1336 if ((valuePtr != NULL) 1337 && (TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &code))) { 1338 static CONST char *returnCodes[] = { 1339 "ok", "error", "return", "break", "continue", NULL 1340 }; 1341 1342 if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, 1343 NULL, TCL_EXACT, &code)) { 1344 /* 1345 * Value is not a legal return code. 1346 */ 1347 1348 Tcl_ResetResult(interp); 1349 Tcl_AppendResult(interp, "bad completion code \"", 1350 TclGetString(valuePtr), 1351 "\": must be ok, error, return, break, " 1352 "continue, or an integer", NULL); 1353 goto error; 1354 } 1355 } 1356 if (valuePtr != NULL) { 1357 Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); 1358 } 1359 1360 /* 1361 * Check for bogus -level value. 1362 */ 1363 1364 Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr); 1365 if (valuePtr != NULL) { 1366 if ((TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &level)) 1367 || (level < 0)) { 1368 /* 1369 * Value is not a legal level. 1370 */ 1371 1372 Tcl_ResetResult(interp); 1373 Tcl_AppendResult(interp, "bad -level value: " 1374 "expected non-negative integer but got \"", 1375 TclGetString(valuePtr), "\"", NULL); 1376 goto error; 1377 } 1378 Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); 1379 } 1380 1381 /* 1382 * Check for bogus -errorcode value. 1383 */ 1384 1385 Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr); 1386 if (valuePtr != NULL) { 1387 int length; 1388 1389 if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { 1390 /* 1391 * Value is not a list, which is illegal for -errorcode. 1392 */ 1393 Tcl_ResetResult(interp); 1394 Tcl_AppendResult(interp, "bad -errorcode value: " 1395 "expected a list but got \"", 1396 TclGetString(valuePtr), "\"", NULL); 1397 goto error; 1398 } 1399 } 1400 1401 /* 1402 * Convert [return -code return -level X] to [return -code ok -level X+1] 1403 */ 1404 1405 if (code == TCL_RETURN) { 1406 level++; 1407 code = TCL_OK; 1408 } 1409 1410 if (codePtr != NULL) { 1411 *codePtr = code; 1412 } 1413 if (levelPtr != NULL) { 1414 *levelPtr = level; 1415 } 1416 1417 if (optionsPtrPtr == NULL) { 1418 /* 1419 * Not passing back the options (?!), so clean them up. 1420 */ 1421 1422 Tcl_DecrRefCount(returnOpts); 1423 } else { 1424 *optionsPtrPtr = returnOpts; 1425 } 1426 return TCL_OK; 1427 1428 error: 1429 Tcl_DecrRefCount(returnOpts); 1430 return TCL_ERROR; 1431} 1432 1433/* 1434 *------------------------------------------------------------------------- 1435 * 1436 * Tcl_GetReturnOptions -- 1437 * 1438 * Packs up the interp state into a dictionary of return options. 1439 * 1440 * Results: 1441 * A dictionary of return options. 1442 * 1443 * Side effects: 1444 * None. 1445 * 1446 *------------------------------------------------------------------------- 1447 */ 1448 1449Tcl_Obj * 1450Tcl_GetReturnOptions( 1451 Tcl_Interp *interp, 1452 int result) 1453{ 1454 Interp *iPtr = (Interp *) interp; 1455 Tcl_Obj *options; 1456 Tcl_Obj **keys = GetKeys(); 1457 1458 if (iPtr->returnOpts) { 1459 options = Tcl_DuplicateObj(iPtr->returnOpts); 1460 } else { 1461 options = Tcl_NewObj(); 1462 } 1463 1464 if (result == TCL_RETURN) { 1465 Tcl_DictObjPut(NULL, options, keys[KEY_CODE], 1466 Tcl_NewIntObj(iPtr->returnCode)); 1467 Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], 1468 Tcl_NewIntObj(iPtr->returnLevel)); 1469 } else { 1470 Tcl_DictObjPut(NULL, options, keys[KEY_CODE], 1471 Tcl_NewIntObj(result)); 1472 Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], 1473 Tcl_NewIntObj(0)); 1474 } 1475 1476 if (result == TCL_ERROR) { 1477 Tcl_AddObjErrorInfo(interp, "", -1); 1478 } 1479 if (iPtr->errorCode) { 1480 Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); 1481 } 1482 if (iPtr->errorInfo) { 1483 Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); 1484 Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], 1485 Tcl_NewIntObj(iPtr->errorLine)); 1486 } 1487 return options; 1488} 1489 1490/* 1491 *------------------------------------------------------------------------- 1492 * 1493 * Tcl_SetReturnOptions -- 1494 * 1495 * Accepts an interp and a dictionary of return options, and sets the 1496 * return options of the interp to match the dictionary. 1497 * 1498 * Results: 1499 * A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid 1500 * option value was found in the dictionary. If a -level value of 0 is in 1501 * the dictionary, then the -code value in the dictionary will be 1502 * returned (TCL_OK default). 1503 * 1504 * Side effects: 1505 * Sets the state of the interp. 1506 * 1507 *------------------------------------------------------------------------- 1508 */ 1509 1510int 1511Tcl_SetReturnOptions( 1512 Tcl_Interp *interp, 1513 Tcl_Obj *options) 1514{ 1515 int objc, level, code; 1516 Tcl_Obj **objv, *mergedOpts; 1517 1518 Tcl_IncrRefCount(options); 1519 if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) 1520 || (objc % 2)) { 1521 Tcl_ResetResult(interp); 1522 Tcl_AppendResult(interp, "expected dict but got \"", 1523 TclGetString(options), "\"", NULL); 1524 code = TCL_ERROR; 1525 } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, 1526 &mergedOpts, &code, &level)) { 1527 code = TCL_ERROR; 1528 } else { 1529 code = TclProcessReturn(interp, code, level, mergedOpts); 1530 } 1531 1532 Tcl_DecrRefCount(options); 1533 return code; 1534} 1535 1536/* 1537 *------------------------------------------------------------------------- 1538 * 1539 * TclTransferResult -- 1540 * 1541 * Copy the result (and error information) from one interp to another. 1542 * Used when one interp has caused another interp to evaluate a script 1543 * and then wants to transfer the results back to itself. 1544 * 1545 * This routine copies the string reps of the result and error 1546 * information. It does not simply increment the refcounts of the result 1547 * and error information objects themselves. It is not legal to exchange 1548 * objects between interps, because an object may be kept alive by one 1549 * interp, but have an internal rep that is only valid while some other 1550 * interp is alive. 1551 * 1552 * Results: 1553 * The target interp's result is set to a copy of the source interp's 1554 * result. The source's errorInfo field may be transferred to the 1555 * target's errorInfo field, and the source's errorCode field may be 1556 * transferred to the target's errorCode field. 1557 * 1558 * Side effects: 1559 * None. 1560 * 1561 *------------------------------------------------------------------------- 1562 */ 1563 1564void 1565TclTransferResult( 1566 Tcl_Interp *sourceInterp, /* Interp whose result and error information 1567 * should be moved to the target interp. 1568 * After moving result, this interp's result 1569 * is reset. */ 1570 int result, /* TCL_OK if just the result should be copied, 1571 * TCL_ERROR if both the result and error 1572 * information should be copied. */ 1573 Tcl_Interp *targetInterp) /* Interp where result and error information 1574 * should be stored. If source and target are 1575 * the same, nothing is done. */ 1576{ 1577 Interp *tiPtr = (Interp *) targetInterp; 1578 Interp *siPtr = (Interp *) sourceInterp; 1579 1580 if (sourceInterp == targetInterp) { 1581 return; 1582 } 1583 1584 if (result == TCL_OK && siPtr->returnOpts == NULL) { 1585 /* 1586 * Special optimization for the common case of normal command return 1587 * code and no explicit return options. 1588 */ 1589 1590 if (tiPtr->returnOpts) { 1591 Tcl_DecrRefCount(tiPtr->returnOpts); 1592 tiPtr->returnOpts = NULL; 1593 } 1594 } else { 1595 Tcl_SetReturnOptions(targetInterp, 1596 Tcl_GetReturnOptions(sourceInterp, result)); 1597 tiPtr->flags &= ~(ERR_ALREADY_LOGGED); 1598 } 1599 Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); 1600 Tcl_ResetResult(sourceInterp); 1601} 1602 1603/* 1604 * Local Variables: 1605 * mode: c 1606 * c-basic-offset: 4 1607 * fill-column: 78 1608 * End: 1609 */ 1610