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 9 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 * 11 * RCS: @(#) $Id: tclResult.c,v 1.5.2.2 2004/09/30 22:45:15 dgp Exp $ 12 */ 13 14#include "tclInt.h" 15 16/* 17 * Function prototypes for local procedures in this file: 18 */ 19 20static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); 21static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, 22 int newSpace)); 23 24 25/* 26 *---------------------------------------------------------------------- 27 * 28 * Tcl_SaveResult -- 29 * 30 * Takes a snapshot of the current result state of the interpreter. 31 * The snapshot can be restored at any point by 32 * Tcl_RestoreResult. Note that this routine does not 33 * preserve the errorCode, errorInfo, or flags fields so it 34 * should not be used if an error is in progress. 35 * 36 * Once a snapshot is saved, it must be restored by calling 37 * Tcl_RestoreResult, or discarded by calling 38 * Tcl_DiscardResult. 39 * 40 * Results: 41 * None. 42 * 43 * Side effects: 44 * Resets the interpreter result. 45 * 46 *---------------------------------------------------------------------- 47 */ 48 49void 50Tcl_SaveResult(interp, statePtr) 51 Tcl_Interp *interp; /* Interpreter to save. */ 52 Tcl_SavedResult *statePtr; /* Pointer to state structure. */ 53{ 54 Interp *iPtr = (Interp *) interp; 55 56 /* 57 * Move the result object into the save state. Note that we don't need 58 * to change its refcount because we're moving it, not adding a new 59 * reference. Put an empty object into the interpreter. 60 */ 61 62 statePtr->objResultPtr = iPtr->objResultPtr; 63 iPtr->objResultPtr = Tcl_NewObj(); 64 Tcl_IncrRefCount(iPtr->objResultPtr); 65 66 /* 67 * Save the string result. 68 */ 69 70 statePtr->freeProc = iPtr->freeProc; 71 if (iPtr->result == iPtr->resultSpace) { 72 /* 73 * Copy the static string data out of the interp buffer. 74 */ 75 76 statePtr->result = statePtr->resultSpace; 77 strcpy(statePtr->result, iPtr->result); 78 statePtr->appendResult = NULL; 79 } else if (iPtr->result == iPtr->appendResult) { 80 /* 81 * Move the append buffer out of the interp. 82 */ 83 84 statePtr->appendResult = iPtr->appendResult; 85 statePtr->appendAvl = iPtr->appendAvl; 86 statePtr->appendUsed = iPtr->appendUsed; 87 statePtr->result = statePtr->appendResult; 88 iPtr->appendResult = NULL; 89 iPtr->appendAvl = 0; 90 iPtr->appendUsed = 0; 91 } else { 92 /* 93 * Move the dynamic or static string out of the interpreter. 94 */ 95 96 statePtr->result = iPtr->result; 97 statePtr->appendResult = NULL; 98 } 99 100 iPtr->result = iPtr->resultSpace; 101 iPtr->resultSpace[0] = 0; 102 iPtr->freeProc = 0; 103} 104 105/* 106 *---------------------------------------------------------------------- 107 * 108 * Tcl_RestoreResult -- 109 * 110 * Restores the state of the interpreter to a snapshot taken 111 * by Tcl_SaveResult. After this call, the token for 112 * the interpreter state is no longer valid. 113 * 114 * Results: 115 * None. 116 * 117 * Side effects: 118 * Restores the interpreter result. 119 * 120 *---------------------------------------------------------------------- 121 */ 122 123void 124Tcl_RestoreResult(interp, statePtr) 125 Tcl_Interp* interp; /* Interpreter being restored. */ 126 Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ 127{ 128 Interp *iPtr = (Interp *) interp; 129 130 Tcl_ResetResult(interp); 131 132 /* 133 * Restore the string result. 134 */ 135 136 iPtr->freeProc = statePtr->freeProc; 137 if (statePtr->result == statePtr->resultSpace) { 138 /* 139 * Copy the static string data into the interp buffer. 140 */ 141 142 iPtr->result = iPtr->resultSpace; 143 strcpy(iPtr->result, statePtr->result); 144 } else if (statePtr->result == statePtr->appendResult) { 145 /* 146 * Move the append buffer back into the interp. 147 */ 148 149 if (iPtr->appendResult != NULL) { 150 ckfree((char *)iPtr->appendResult); 151 } 152 153 iPtr->appendResult = statePtr->appendResult; 154 iPtr->appendAvl = statePtr->appendAvl; 155 iPtr->appendUsed = statePtr->appendUsed; 156 iPtr->result = iPtr->appendResult; 157 } else { 158 /* 159 * Move the dynamic or static string back into the interpreter. 160 */ 161 162 iPtr->result = statePtr->result; 163 } 164 165 /* 166 * Restore the object result. 167 */ 168 169 Tcl_DecrRefCount(iPtr->objResultPtr); 170 iPtr->objResultPtr = statePtr->objResultPtr; 171} 172 173/* 174 *---------------------------------------------------------------------- 175 * 176 * Tcl_DiscardResult -- 177 * 178 * Frees the memory associated with an interpreter snapshot 179 * taken by Tcl_SaveResult. If the snapshot is not 180 * restored, this procedure must be called to discard it, 181 * or the memory will be lost. 182 * 183 * Results: 184 * None. 185 * 186 * Side effects: 187 * None. 188 * 189 *---------------------------------------------------------------------- 190 */ 191 192void 193Tcl_DiscardResult(statePtr) 194 Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ 195{ 196 TclDecrRefCount(statePtr->objResultPtr); 197 198 if (statePtr->result == statePtr->appendResult) { 199 ckfree(statePtr->appendResult); 200 } else if (statePtr->freeProc) { 201 if (statePtr->freeProc == TCL_DYNAMIC) { 202 ckfree(statePtr->result); 203 } else { 204 (*statePtr->freeProc)(statePtr->result); 205 } 206 } 207} 208 209/* 210 *---------------------------------------------------------------------- 211 * 212 * Tcl_SetResult -- 213 * 214 * Arrange for "string" to be the Tcl return value. 215 * 216 * Results: 217 * None. 218 * 219 * Side effects: 220 * interp->result is left pointing either to "string" (if "copy" is 0) 221 * or to a copy of string. Also, the object result is reset. 222 * 223 *---------------------------------------------------------------------- 224 */ 225 226void 227Tcl_SetResult(interp, string, freeProc) 228 Tcl_Interp *interp; /* Interpreter with which to associate the 229 * return value. */ 230 register char *string; /* Value to be returned. If NULL, the 231 * result is set to an empty string. */ 232 Tcl_FreeProc *freeProc; /* Gives information about the string: 233 * TCL_STATIC, TCL_VOLATILE, or the address 234 * of a Tcl_FreeProc such as free. */ 235{ 236 Interp *iPtr = (Interp *) interp; 237 int length; 238 register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; 239 char *oldResult = iPtr->result; 240 241 if (string == NULL) { 242 iPtr->resultSpace[0] = 0; 243 iPtr->result = iPtr->resultSpace; 244 iPtr->freeProc = 0; 245 } else if (freeProc == TCL_VOLATILE) { 246 length = strlen(string); 247 if (length > TCL_RESULT_SIZE) { 248 iPtr->result = (char *) ckalloc((unsigned) length+1); 249 iPtr->freeProc = TCL_DYNAMIC; 250 } else { 251 iPtr->result = iPtr->resultSpace; 252 iPtr->freeProc = 0; 253 } 254 strcpy(iPtr->result, string); 255 } else { 256 iPtr->result = string; 257 iPtr->freeProc = freeProc; 258 } 259 260 /* 261 * If the old result was dynamically-allocated, free it up. Do it 262 * here, rather than at the beginning, in case the new result value 263 * was part of the old result value. 264 */ 265 266 if (oldFreeProc != 0) { 267 if (oldFreeProc == TCL_DYNAMIC) { 268 ckfree(oldResult); 269 } else { 270 (*oldFreeProc)(oldResult); 271 } 272 } 273 274 /* 275 * Reset the object result since we just set the string result. 276 */ 277 278 ResetObjResult(iPtr); 279} 280 281/* 282 *---------------------------------------------------------------------- 283 * 284 * Tcl_GetStringResult -- 285 * 286 * Returns an interpreter's result value as a string. 287 * 288 * Results: 289 * The interpreter's result as a string. 290 * 291 * Side effects: 292 * If the string result is empty, the object result is moved to the 293 * string result, then the object result is reset. 294 * 295 *---------------------------------------------------------------------- 296 */ 297 298CONST char * 299Tcl_GetStringResult(interp) 300 register Tcl_Interp *interp; /* Interpreter whose result to return. */ 301{ 302 /* 303 * If the string result is empty, move the object result to the 304 * string result, then reset the object result. 305 */ 306 307 if (*(interp->result) == 0) { 308 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 309 TCL_VOLATILE); 310 } 311 return interp->result; 312} 313 314/* 315 *---------------------------------------------------------------------- 316 * 317 * Tcl_SetObjResult -- 318 * 319 * Arrange for objPtr to be an interpreter's result value. 320 * 321 * Results: 322 * None. 323 * 324 * Side effects: 325 * interp->objResultPtr is left pointing to the object referenced 326 * by objPtr. The object's reference count is incremented since 327 * there is now a new reference to it. The reference count for any 328 * old objResultPtr value is decremented. Also, the string result 329 * is reset. 330 * 331 *---------------------------------------------------------------------- 332 */ 333 334void 335Tcl_SetObjResult(interp, objPtr) 336 Tcl_Interp *interp; /* Interpreter with which to associate the 337 * return object value. */ 338 register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the 339 * obj result is made an empty string 340 * object. */ 341{ 342 register Interp *iPtr = (Interp *) interp; 343 register Tcl_Obj *oldObjResult = iPtr->objResultPtr; 344 345 iPtr->objResultPtr = objPtr; 346 Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ 347 348 /* 349 * We wait until the end to release the old object result, in case 350 * we are setting the result to itself. 351 */ 352 353 TclDecrRefCount(oldObjResult); 354 355 /* 356 * Reset the string result since we just set the result object. 357 */ 358 359 if (iPtr->freeProc != NULL) { 360 if (iPtr->freeProc == TCL_DYNAMIC) { 361 ckfree(iPtr->result); 362 } else { 363 (*iPtr->freeProc)(iPtr->result); 364 } 365 iPtr->freeProc = 0; 366 } 367 iPtr->result = iPtr->resultSpace; 368 iPtr->resultSpace[0] = 0; 369} 370 371/* 372 *---------------------------------------------------------------------- 373 * 374 * Tcl_GetObjResult -- 375 * 376 * Returns an interpreter's result value as a Tcl object. The object's 377 * reference count is not modified; the caller must do that if it 378 * needs to hold on to a long-term reference to it. 379 * 380 * Results: 381 * The interpreter's result as an object. 382 * 383 * Side effects: 384 * If the interpreter has a non-empty string result, the result object 385 * is either empty or stale because some procedure set interp->result 386 * directly. If so, the string result is moved to the result object 387 * then the string result is reset. 388 * 389 *---------------------------------------------------------------------- 390 */ 391 392Tcl_Obj * 393Tcl_GetObjResult(interp) 394 Tcl_Interp *interp; /* Interpreter whose result to return. */ 395{ 396 register Interp *iPtr = (Interp *) interp; 397 Tcl_Obj *objResultPtr; 398 int length; 399 400 /* 401 * If the string result is non-empty, move the string result to the 402 * object result, then reset the string result. 403 */ 404 405 if (*(iPtr->result) != 0) { 406 ResetObjResult(iPtr); 407 408 objResultPtr = iPtr->objResultPtr; 409 length = strlen(iPtr->result); 410 TclInitStringRep(objResultPtr, iPtr->result, length); 411 412 if (iPtr->freeProc != NULL) { 413 if (iPtr->freeProc == TCL_DYNAMIC) { 414 ckfree(iPtr->result); 415 } else { 416 (*iPtr->freeProc)(iPtr->result); 417 } 418 iPtr->freeProc = 0; 419 } 420 iPtr->result = iPtr->resultSpace; 421 iPtr->resultSpace[0] = 0; 422 } 423 return iPtr->objResultPtr; 424} 425 426/* 427 *---------------------------------------------------------------------- 428 * 429 * Tcl_AppendResultVA -- 430 * 431 * Append a variable number of strings onto the interpreter's string 432 * result. 433 * 434 * Results: 435 * None. 436 * 437 * Side effects: 438 * The result of the interpreter given by the first argument is 439 * extended by the strings in the va_list (up to a terminating NULL 440 * argument). 441 * 442 * If the string result is empty, the object result is moved to the 443 * string result, then the object result is reset. 444 * 445 *---------------------------------------------------------------------- 446 */ 447 448void 449Tcl_AppendResultVA (interp, argList) 450 Tcl_Interp *interp; /* Interpreter with which to associate the 451 * return value. */ 452 va_list argList; /* Variable argument list. */ 453{ 454#define STATIC_LIST_SIZE 16 455 Interp *iPtr = (Interp *) interp; 456 char *string, *static_list[STATIC_LIST_SIZE]; 457 char **args = static_list; 458 int nargs_space = STATIC_LIST_SIZE; 459 int nargs, newSpace, i; 460 461 /* 462 * If the string result is empty, move the object result to the 463 * string result, then reset the object result. 464 */ 465 466 if (*(iPtr->result) == 0) { 467 Tcl_SetResult((Tcl_Interp *) iPtr, 468 TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)), 469 TCL_VOLATILE); 470 } 471 472 /* 473 * Scan through all the arguments to see how much space is needed 474 * and save pointers to the arguments in the args array, 475 * reallocating as necessary. 476 */ 477 478 nargs = 0; 479 newSpace = 0; 480 while (1) { 481 string = va_arg(argList, char *); 482 if (string == NULL) { 483 break; 484 } 485 if (nargs >= nargs_space) { 486 /* 487 * Expand the args buffer 488 */ 489 nargs_space += STATIC_LIST_SIZE; 490 if (args == static_list) { 491 args = (void *)ckalloc(nargs_space * sizeof(char *)); 492 for (i = 0; i < nargs; ++i) { 493 args[i] = static_list[i]; 494 } 495 } else { 496 args = (void *)ckrealloc((void *)args, 497 nargs_space * sizeof(char *)); 498 } 499 } 500 newSpace += strlen(string); 501 args[nargs++] = string; 502 } 503 504 /* 505 * If the append buffer isn't already setup and large enough to hold 506 * the new data, set it up. 507 */ 508 509 if ((iPtr->result != iPtr->appendResult) 510 || (iPtr->appendResult[iPtr->appendUsed] != 0) 511 || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { 512 SetupAppendBuffer(iPtr, newSpace); 513 } 514 515 /* 516 * Now go through all the argument strings again, copying them into the 517 * buffer. 518 */ 519 520 for (i = 0; i < nargs; ++i) { 521 string = args[i]; 522 strcpy(iPtr->appendResult + iPtr->appendUsed, string); 523 iPtr->appendUsed += strlen(string); 524 } 525 526 /* 527 * If we had to allocate a buffer from the heap, 528 * free it now. 529 */ 530 531 if (args != static_list) { 532 ckfree((void *)args); 533 } 534#undef STATIC_LIST_SIZE 535} 536 537/* 538 *---------------------------------------------------------------------- 539 * 540 * Tcl_AppendResult -- 541 * 542 * Append a variable number of strings onto the interpreter's string 543 * result. 544 * 545 * Results: 546 * None. 547 * 548 * Side effects: 549 * The result of the interpreter given by the first argument is 550 * extended by the strings given by the second and following arguments 551 * (up to a terminating NULL argument). 552 * 553 * If the string result is empty, the object result is moved to the 554 * string result, then the object result is reset. 555 * 556 *---------------------------------------------------------------------- 557 */ 558 559void 560Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) 561{ 562 Tcl_Interp *interp; 563 va_list argList; 564 565 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 566 Tcl_AppendResultVA(interp, argList); 567 va_end(argList); 568} 569 570/* 571 *---------------------------------------------------------------------- 572 * 573 * Tcl_AppendElement -- 574 * 575 * Convert a string to a valid Tcl list element and append it to the 576 * result (which is ostensibly a list). 577 * 578 * Results: 579 * None. 580 * 581 * Side effects: 582 * The result in the interpreter given by the first argument is 583 * extended with a list element converted from string. A separator 584 * space is added before the converted list element unless the current 585 * result is empty, contains the single character "{", or ends in " {". 586 * 587 * If the string result is empty, the object result is moved to the 588 * string result, then the object result is reset. 589 * 590 *---------------------------------------------------------------------- 591 */ 592 593void 594Tcl_AppendElement(interp, string) 595 Tcl_Interp *interp; /* Interpreter whose result is to be 596 * extended. */ 597 CONST char *string; /* String to convert to list element and 598 * add to result. */ 599{ 600 Interp *iPtr = (Interp *) interp; 601 char *dst; 602 int size; 603 int flags; 604 605 /* 606 * If the string result is empty, move the object result to the 607 * string result, then reset the object result. 608 */ 609 610 if (*(iPtr->result) == 0) { 611 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 612 TCL_VOLATILE); 613 } 614 615 /* 616 * See how much space is needed, and grow the append buffer if 617 * needed to accommodate the list element. 618 */ 619 620 size = Tcl_ScanElement(string, &flags) + 1; 621 if ((iPtr->result != iPtr->appendResult) 622 || (iPtr->appendResult[iPtr->appendUsed] != 0) 623 || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { 624 SetupAppendBuffer(iPtr, size+iPtr->appendUsed); 625 } 626 627 /* 628 * Convert the string into a list element and copy it to the 629 * buffer that's forming, with a space separator if needed. 630 */ 631 632 dst = iPtr->appendResult + iPtr->appendUsed; 633 if (TclNeedSpace(iPtr->appendResult, dst)) { 634 iPtr->appendUsed++; 635 *dst = ' '; 636 dst++; 637 } 638 iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); 639} 640 641/* 642 *---------------------------------------------------------------------- 643 * 644 * SetupAppendBuffer -- 645 * 646 * This procedure makes sure that there is an append buffer properly 647 * initialized, if necessary, from the interpreter's result, and 648 * that it has at least enough room to accommodate newSpace new 649 * bytes of information. 650 * 651 * Results: 652 * None. 653 * 654 * Side effects: 655 * None. 656 * 657 *---------------------------------------------------------------------- 658 */ 659 660static void 661SetupAppendBuffer(iPtr, newSpace) 662 Interp *iPtr; /* Interpreter whose result is being set up. */ 663 int newSpace; /* Make sure that at least this many bytes 664 * of new information may be added. */ 665{ 666 int totalSpace; 667 668 /* 669 * Make the append buffer larger, if that's necessary, then copy the 670 * result into the append buffer and make the append buffer the official 671 * Tcl result. 672 */ 673 674 if (iPtr->result != iPtr->appendResult) { 675 /* 676 * If an oversized buffer was used recently, then free it up 677 * so we go back to a smaller buffer. This avoids tying up 678 * memory forever after a large operation. 679 */ 680 681 if (iPtr->appendAvl > 500) { 682 ckfree(iPtr->appendResult); 683 iPtr->appendResult = NULL; 684 iPtr->appendAvl = 0; 685 } 686 iPtr->appendUsed = strlen(iPtr->result); 687 } else if (iPtr->result[iPtr->appendUsed] != 0) { 688 /* 689 * Most likely someone has modified a result created by 690 * Tcl_AppendResult et al. so that it has a different size. 691 * Just recompute the size. 692 */ 693 694 iPtr->appendUsed = strlen(iPtr->result); 695 } 696 697 totalSpace = newSpace + iPtr->appendUsed; 698 if (totalSpace >= iPtr->appendAvl) { 699 char *new; 700 701 if (totalSpace < 100) { 702 totalSpace = 200; 703 } else { 704 totalSpace *= 2; 705 } 706 new = (char *) ckalloc((unsigned) totalSpace); 707 strcpy(new, iPtr->result); 708 if (iPtr->appendResult != NULL) { 709 ckfree(iPtr->appendResult); 710 } 711 iPtr->appendResult = new; 712 iPtr->appendAvl = totalSpace; 713 } else if (iPtr->result != iPtr->appendResult) { 714 strcpy(iPtr->appendResult, iPtr->result); 715 } 716 717 Tcl_FreeResult((Tcl_Interp *) iPtr); 718 iPtr->result = iPtr->appendResult; 719} 720 721/* 722 *---------------------------------------------------------------------- 723 * 724 * Tcl_FreeResult -- 725 * 726 * This procedure frees up the memory associated with an interpreter's 727 * string result. It also resets the interpreter's result object. 728 * Tcl_FreeResult is most commonly used when a procedure is about to 729 * replace one result value with another. 730 * 731 * Results: 732 * None. 733 * 734 * Side effects: 735 * Frees the memory associated with interp's string result and sets 736 * interp->freeProc to zero, but does not change interp->result or 737 * clear error state. Resets interp's result object to an unshared 738 * empty object. 739 * 740 *---------------------------------------------------------------------- 741 */ 742 743void 744Tcl_FreeResult(interp) 745 register Tcl_Interp *interp; /* Interpreter for which to free result. */ 746{ 747 register Interp *iPtr = (Interp *) interp; 748 749 if (iPtr->freeProc != NULL) { 750 if (iPtr->freeProc == TCL_DYNAMIC) { 751 ckfree(iPtr->result); 752 } else { 753 (*iPtr->freeProc)(iPtr->result); 754 } 755 iPtr->freeProc = 0; 756 } 757 758 ResetObjResult(iPtr); 759} 760 761/* 762 *---------------------------------------------------------------------- 763 * 764 * Tcl_ResetResult -- 765 * 766 * This procedure resets both the interpreter's string and object 767 * results. 768 * 769 * Results: 770 * None. 771 * 772 * Side effects: 773 * It resets the result object to an unshared empty object. It 774 * then restores the interpreter's string result area to its default 775 * initialized state, freeing up any memory that may have been 776 * allocated. It also clears any error information for the interpreter. 777 * 778 *---------------------------------------------------------------------- 779 */ 780 781void 782Tcl_ResetResult(interp) 783 register Tcl_Interp *interp; /* Interpreter for which to clear result. */ 784{ 785 register Interp *iPtr = (Interp *) interp; 786 787 ResetObjResult(iPtr); 788 if (iPtr->freeProc != NULL) { 789 if (iPtr->freeProc == TCL_DYNAMIC) { 790 ckfree(iPtr->result); 791 } else { 792 (*iPtr->freeProc)(iPtr->result); 793 } 794 iPtr->freeProc = 0; 795 } 796 iPtr->result = iPtr->resultSpace; 797 iPtr->resultSpace[0] = 0; 798 iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); 799} 800 801/* 802 *---------------------------------------------------------------------- 803 * 804 * ResetObjResult -- 805 * 806 * Procedure used to reset an interpreter's Tcl result object. 807 * 808 * Results: 809 * None. 810 * 811 * Side effects: 812 * Resets the interpreter's result object to an unshared empty string 813 * object with ref count one. It does not clear any error information 814 * in the interpreter. 815 * 816 *---------------------------------------------------------------------- 817 */ 818 819static void 820ResetObjResult(iPtr) 821 register Interp *iPtr; /* Points to the interpreter whose result 822 * object should be reset. */ 823{ 824 register Tcl_Obj *objResultPtr = iPtr->objResultPtr; 825 826 if (Tcl_IsShared(objResultPtr)) { 827 TclDecrRefCount(objResultPtr); 828 TclNewObj(objResultPtr); 829 Tcl_IncrRefCount(objResultPtr); 830 iPtr->objResultPtr = objResultPtr; 831 } else { 832 if ((objResultPtr->bytes != NULL) 833 && (objResultPtr->bytes != tclEmptyStringRep)) { 834 ckfree((char *) objResultPtr->bytes); 835 } 836 objResultPtr->bytes = tclEmptyStringRep; 837 objResultPtr->length = 0; 838 if ((objResultPtr->typePtr != NULL) 839 && (objResultPtr->typePtr->freeIntRepProc != NULL)) { 840 objResultPtr->typePtr->freeIntRepProc(objResultPtr); 841 } 842 objResultPtr->typePtr = (Tcl_ObjType *) NULL; 843 } 844} 845 846/* 847 *---------------------------------------------------------------------- 848 * 849 * Tcl_SetErrorCodeVA -- 850 * 851 * This procedure is called to record machine-readable information 852 * about an error that is about to be returned. 853 * 854 * Results: 855 * None. 856 * 857 * Side effects: 858 * The errorCode global variable is modified to hold all of the 859 * arguments to this procedure, in a list form with each argument 860 * becoming one element of the list. A flag is set internally 861 * to remember that errorCode has been set, so the variable doesn't 862 * get set automatically when the error is returned. 863 * 864 *---------------------------------------------------------------------- 865 */ 866 867void 868Tcl_SetErrorCodeVA (interp, argList) 869 Tcl_Interp *interp; /* Interpreter in which to access the errorCode 870 * variable. */ 871 va_list argList; /* Variable argument list. */ 872{ 873 char *string; 874 int flags; 875 Interp *iPtr = (Interp *) interp; 876 877 /* 878 * Scan through the arguments one at a time, appending them to 879 * $errorCode as list elements. 880 */ 881 882 flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; 883 while (1) { 884 string = va_arg(argList, char *); 885 if (string == NULL) { 886 break; 887 } 888 (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", 889 (char *) NULL, string, flags); 890 flags |= TCL_APPEND_VALUE; 891 } 892 iPtr->flags |= ERROR_CODE_SET; 893} 894 895/* 896 *---------------------------------------------------------------------- 897 * 898 * Tcl_SetErrorCode -- 899 * 900 * This procedure is called to record machine-readable information 901 * about an error that is about to be returned. 902 * 903 * Results: 904 * None. 905 * 906 * Side effects: 907 * The errorCode global variable is modified to hold all of the 908 * arguments to this procedure, in a list form with each argument 909 * becoming one element of the list. A flag is set internally 910 * to remember that errorCode has been set, so the variable doesn't 911 * get set automatically when the error is returned. 912 * 913 *---------------------------------------------------------------------- 914 */ 915 /* VARARGS2 */ 916void 917Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) 918{ 919 Tcl_Interp *interp; 920 va_list argList; 921 922 /* 923 * Scan through the arguments one at a time, appending them to 924 * $errorCode as list elements. 925 */ 926 927 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 928 Tcl_SetErrorCodeVA(interp, argList); 929 va_end(argList); 930} 931 932/* 933 *---------------------------------------------------------------------- 934 * 935 * Tcl_SetObjErrorCode -- 936 * 937 * This procedure is called to record machine-readable information 938 * about an error that is about to be returned. The caller should 939 * build a list object up and pass it to this routine. 940 * 941 * Results: 942 * None. 943 * 944 * Side effects: 945 * The errorCode global variable is modified to be the new value. 946 * A flag is set internally to remember that errorCode has been 947 * set, so the variable doesn't get set automatically when the 948 * error is returned. 949 * 950 *---------------------------------------------------------------------- 951 */ 952 953void 954Tcl_SetObjErrorCode(interp, errorObjPtr) 955 Tcl_Interp *interp; 956 Tcl_Obj *errorObjPtr; 957{ 958 Interp *iPtr; 959 960 iPtr = (Interp *) interp; 961 Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); 962 iPtr->flags |= ERROR_CODE_SET; 963} 964 965/* 966 *------------------------------------------------------------------------- 967 * 968 * TclTransferResult -- 969 * 970 * Copy the result (and error information) from one interp to 971 * another. Used when one interp has caused another interp to 972 * evaluate a script and then wants to transfer the results back 973 * to itself. 974 * 975 * This routine copies the string reps of the result and error 976 * information. It does not simply increment the refcounts of the 977 * result and error information objects themselves. 978 * It is not legal to exchange objects between interps, because an 979 * object may be kept alive by one interp, but have an internal rep 980 * that is only valid while some other interp is alive. 981 * 982 * Results: 983 * The target interp's result is set to a copy of the source interp's 984 * result. The source's error information "$errorInfo" may be 985 * appended to the target's error information and the source's error 986 * code "$errorCode" may be stored in the target's error code. 987 * 988 * Side effects: 989 * None. 990 * 991 *------------------------------------------------------------------------- 992 */ 993 994void 995TclTransferResult(sourceInterp, result, targetInterp) 996 Tcl_Interp *sourceInterp; /* Interp whose result and error information 997 * should be moved to the target interp. 998 * After moving result, this interp's result 999 * is reset. */ 1000 int result; /* TCL_OK if just the result should be copied, 1001 * TCL_ERROR if both the result and error 1002 * information should be copied. */ 1003 Tcl_Interp *targetInterp; /* Interp where result and error information 1004 * should be stored. If source and target 1005 * are the same, nothing is done. */ 1006{ 1007 Interp *iPtr; 1008 Tcl_Obj *objPtr; 1009 1010 if (sourceInterp == targetInterp) { 1011 return; 1012 } 1013 1014 if (result == TCL_ERROR) { 1015 /* 1016 * An error occurred, so transfer error information from the source 1017 * interpreter to the target interpreter. Setting the flags tells 1018 * the target interp that it has inherited a partial traceback 1019 * chain, not just a simple error message. 1020 */ 1021 1022 iPtr = (Interp *) sourceInterp; 1023 if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) { 1024 Tcl_AddErrorInfo(sourceInterp, ""); 1025 } 1026 iPtr->flags &= ~(ERR_ALREADY_LOGGED); 1027 1028 Tcl_ResetResult(targetInterp); 1029 1030 objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, 1031 TCL_GLOBAL_ONLY); 1032 if (objPtr) { 1033 Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, 1034 TCL_GLOBAL_ONLY); 1035 ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS; 1036 } 1037 1038 objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, 1039 TCL_GLOBAL_ONLY); 1040 if (objPtr) { 1041 Tcl_SetObjErrorCode(targetInterp, objPtr); 1042 } 1043 1044 } 1045 1046 ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; 1047 Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); 1048 Tcl_ResetResult(sourceInterp); 1049} 1050