os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclResult.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclResult.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1050 @@
1.4 +/*
1.5 + * tclResult.c --
1.6 + *
1.7 + * This file contains code to manage the interpreter result.
1.8 + *
1.9 + * Copyright (c) 1997 by Sun Microsystems, Inc.
1.10 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.11 + *
1.12 + * See the file "license.terms" for information on usage and redistribution
1.13 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.14 + *
1.15 + * RCS: @(#) $Id: tclResult.c,v 1.5.2.2 2004/09/30 22:45:15 dgp Exp $
1.16 + */
1.17 +
1.18 +#include "tclInt.h"
1.19 +
1.20 +/*
1.21 + * Function prototypes for local procedures in this file:
1.22 + */
1.23 +
1.24 +static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
1.25 +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
1.26 + int newSpace));
1.27 +
1.28 +
1.29 +/*
1.30 + *----------------------------------------------------------------------
1.31 + *
1.32 + * Tcl_SaveResult --
1.33 + *
1.34 + * Takes a snapshot of the current result state of the interpreter.
1.35 + * The snapshot can be restored at any point by
1.36 + * Tcl_RestoreResult. Note that this routine does not
1.37 + * preserve the errorCode, errorInfo, or flags fields so it
1.38 + * should not be used if an error is in progress.
1.39 + *
1.40 + * Once a snapshot is saved, it must be restored by calling
1.41 + * Tcl_RestoreResult, or discarded by calling
1.42 + * Tcl_DiscardResult.
1.43 + *
1.44 + * Results:
1.45 + * None.
1.46 + *
1.47 + * Side effects:
1.48 + * Resets the interpreter result.
1.49 + *
1.50 + *----------------------------------------------------------------------
1.51 + */
1.52 +
1.53 +EXPORT_C void
1.54 +Tcl_SaveResult(interp, statePtr)
1.55 + Tcl_Interp *interp; /* Interpreter to save. */
1.56 + Tcl_SavedResult *statePtr; /* Pointer to state structure. */
1.57 +{
1.58 + Interp *iPtr = (Interp *) interp;
1.59 +
1.60 + /*
1.61 + * Move the result object into the save state. Note that we don't need
1.62 + * to change its refcount because we're moving it, not adding a new
1.63 + * reference. Put an empty object into the interpreter.
1.64 + */
1.65 +
1.66 + statePtr->objResultPtr = iPtr->objResultPtr;
1.67 + iPtr->objResultPtr = Tcl_NewObj();
1.68 + Tcl_IncrRefCount(iPtr->objResultPtr);
1.69 +
1.70 + /*
1.71 + * Save the string result.
1.72 + */
1.73 +
1.74 + statePtr->freeProc = iPtr->freeProc;
1.75 + if (iPtr->result == iPtr->resultSpace) {
1.76 + /*
1.77 + * Copy the static string data out of the interp buffer.
1.78 + */
1.79 +
1.80 + statePtr->result = statePtr->resultSpace;
1.81 + strcpy(statePtr->result, iPtr->result);
1.82 + statePtr->appendResult = NULL;
1.83 + } else if (iPtr->result == iPtr->appendResult) {
1.84 + /*
1.85 + * Move the append buffer out of the interp.
1.86 + */
1.87 +
1.88 + statePtr->appendResult = iPtr->appendResult;
1.89 + statePtr->appendAvl = iPtr->appendAvl;
1.90 + statePtr->appendUsed = iPtr->appendUsed;
1.91 + statePtr->result = statePtr->appendResult;
1.92 + iPtr->appendResult = NULL;
1.93 + iPtr->appendAvl = 0;
1.94 + iPtr->appendUsed = 0;
1.95 + } else {
1.96 + /*
1.97 + * Move the dynamic or static string out of the interpreter.
1.98 + */
1.99 +
1.100 + statePtr->result = iPtr->result;
1.101 + statePtr->appendResult = NULL;
1.102 + }
1.103 +
1.104 + iPtr->result = iPtr->resultSpace;
1.105 + iPtr->resultSpace[0] = 0;
1.106 + iPtr->freeProc = 0;
1.107 +}
1.108 +
1.109 +/*
1.110 + *----------------------------------------------------------------------
1.111 + *
1.112 + * Tcl_RestoreResult --
1.113 + *
1.114 + * Restores the state of the interpreter to a snapshot taken
1.115 + * by Tcl_SaveResult. After this call, the token for
1.116 + * the interpreter state is no longer valid.
1.117 + *
1.118 + * Results:
1.119 + * None.
1.120 + *
1.121 + * Side effects:
1.122 + * Restores the interpreter result.
1.123 + *
1.124 + *----------------------------------------------------------------------
1.125 + */
1.126 +
1.127 +EXPORT_C void
1.128 +Tcl_RestoreResult(interp, statePtr)
1.129 + Tcl_Interp* interp; /* Interpreter being restored. */
1.130 + Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
1.131 +{
1.132 + Interp *iPtr = (Interp *) interp;
1.133 +
1.134 + Tcl_ResetResult(interp);
1.135 +
1.136 + /*
1.137 + * Restore the string result.
1.138 + */
1.139 +
1.140 + iPtr->freeProc = statePtr->freeProc;
1.141 + if (statePtr->result == statePtr->resultSpace) {
1.142 + /*
1.143 + * Copy the static string data into the interp buffer.
1.144 + */
1.145 +
1.146 + iPtr->result = iPtr->resultSpace;
1.147 + strcpy(iPtr->result, statePtr->result);
1.148 + } else if (statePtr->result == statePtr->appendResult) {
1.149 + /*
1.150 + * Move the append buffer back into the interp.
1.151 + */
1.152 +
1.153 + if (iPtr->appendResult != NULL) {
1.154 + ckfree((char *)iPtr->appendResult);
1.155 + }
1.156 +
1.157 + iPtr->appendResult = statePtr->appendResult;
1.158 + iPtr->appendAvl = statePtr->appendAvl;
1.159 + iPtr->appendUsed = statePtr->appendUsed;
1.160 + iPtr->result = iPtr->appendResult;
1.161 + } else {
1.162 + /*
1.163 + * Move the dynamic or static string back into the interpreter.
1.164 + */
1.165 +
1.166 + iPtr->result = statePtr->result;
1.167 + }
1.168 +
1.169 + /*
1.170 + * Restore the object result.
1.171 + */
1.172 +
1.173 + Tcl_DecrRefCount(iPtr->objResultPtr);
1.174 + iPtr->objResultPtr = statePtr->objResultPtr;
1.175 +}
1.176 +
1.177 +/*
1.178 + *----------------------------------------------------------------------
1.179 + *
1.180 + * Tcl_DiscardResult --
1.181 + *
1.182 + * Frees the memory associated with an interpreter snapshot
1.183 + * taken by Tcl_SaveResult. If the snapshot is not
1.184 + * restored, this procedure must be called to discard it,
1.185 + * or the memory will be lost.
1.186 + *
1.187 + * Results:
1.188 + * None.
1.189 + *
1.190 + * Side effects:
1.191 + * None.
1.192 + *
1.193 + *----------------------------------------------------------------------
1.194 + */
1.195 +
1.196 +EXPORT_C void
1.197 +Tcl_DiscardResult(statePtr)
1.198 + Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
1.199 +{
1.200 + TclDecrRefCount(statePtr->objResultPtr);
1.201 +
1.202 + if (statePtr->result == statePtr->appendResult) {
1.203 + ckfree(statePtr->appendResult);
1.204 + } else if (statePtr->freeProc) {
1.205 + if (statePtr->freeProc == TCL_DYNAMIC) {
1.206 + ckfree(statePtr->result);
1.207 + } else {
1.208 + (*statePtr->freeProc)(statePtr->result);
1.209 + }
1.210 + }
1.211 +}
1.212 +
1.213 +/*
1.214 + *----------------------------------------------------------------------
1.215 + *
1.216 + * Tcl_SetResult --
1.217 + *
1.218 + * Arrange for "string" to be the Tcl return value.
1.219 + *
1.220 + * Results:
1.221 + * None.
1.222 + *
1.223 + * Side effects:
1.224 + * interp->result is left pointing either to "string" (if "copy" is 0)
1.225 + * or to a copy of string. Also, the object result is reset.
1.226 + *
1.227 + *----------------------------------------------------------------------
1.228 + */
1.229 +
1.230 +EXPORT_C void
1.231 +Tcl_SetResult(interp, string, freeProc)
1.232 + Tcl_Interp *interp; /* Interpreter with which to associate the
1.233 + * return value. */
1.234 + register char *string; /* Value to be returned. If NULL, the
1.235 + * result is set to an empty string. */
1.236 + Tcl_FreeProc *freeProc; /* Gives information about the string:
1.237 + * TCL_STATIC, TCL_VOLATILE, or the address
1.238 + * of a Tcl_FreeProc such as free. */
1.239 +{
1.240 + Interp *iPtr = (Interp *) interp;
1.241 + int length;
1.242 + register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
1.243 + char *oldResult = iPtr->result;
1.244 +
1.245 + if (string == NULL) {
1.246 + iPtr->resultSpace[0] = 0;
1.247 + iPtr->result = iPtr->resultSpace;
1.248 + iPtr->freeProc = 0;
1.249 + } else if (freeProc == TCL_VOLATILE) {
1.250 + length = strlen(string);
1.251 + if (length > TCL_RESULT_SIZE) {
1.252 + iPtr->result = (char *) ckalloc((unsigned) length+1);
1.253 + iPtr->freeProc = TCL_DYNAMIC;
1.254 + } else {
1.255 + iPtr->result = iPtr->resultSpace;
1.256 + iPtr->freeProc = 0;
1.257 + }
1.258 + strcpy(iPtr->result, string);
1.259 + } else {
1.260 + iPtr->result = string;
1.261 + iPtr->freeProc = freeProc;
1.262 + }
1.263 +
1.264 + /*
1.265 + * If the old result was dynamically-allocated, free it up. Do it
1.266 + * here, rather than at the beginning, in case the new result value
1.267 + * was part of the old result value.
1.268 + */
1.269 +
1.270 + if (oldFreeProc != 0) {
1.271 + if (oldFreeProc == TCL_DYNAMIC) {
1.272 + ckfree(oldResult);
1.273 + } else {
1.274 + (*oldFreeProc)(oldResult);
1.275 + }
1.276 + }
1.277 +
1.278 + /*
1.279 + * Reset the object result since we just set the string result.
1.280 + */
1.281 +
1.282 + ResetObjResult(iPtr);
1.283 +}
1.284 +
1.285 +/*
1.286 + *----------------------------------------------------------------------
1.287 + *
1.288 + * Tcl_GetStringResult --
1.289 + *
1.290 + * Returns an interpreter's result value as a string.
1.291 + *
1.292 + * Results:
1.293 + * The interpreter's result as a string.
1.294 + *
1.295 + * Side effects:
1.296 + * If the string result is empty, the object result is moved to the
1.297 + * string result, then the object result is reset.
1.298 + *
1.299 + *----------------------------------------------------------------------
1.300 + */
1.301 +
1.302 +EXPORT_C CONST char *
1.303 +Tcl_GetStringResult(interp)
1.304 + register Tcl_Interp *interp; /* Interpreter whose result to return. */
1.305 +{
1.306 + /*
1.307 + * If the string result is empty, move the object result to the
1.308 + * string result, then reset the object result.
1.309 + */
1.310 +
1.311 + if (*(interp->result) == 0) {
1.312 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.313 + TCL_VOLATILE);
1.314 + }
1.315 + return interp->result;
1.316 +}
1.317 +
1.318 +/*
1.319 + *----------------------------------------------------------------------
1.320 + *
1.321 + * Tcl_SetObjResult --
1.322 + *
1.323 + * Arrange for objPtr to be an interpreter's result value.
1.324 + *
1.325 + * Results:
1.326 + * None.
1.327 + *
1.328 + * Side effects:
1.329 + * interp->objResultPtr is left pointing to the object referenced
1.330 + * by objPtr. The object's reference count is incremented since
1.331 + * there is now a new reference to it. The reference count for any
1.332 + * old objResultPtr value is decremented. Also, the string result
1.333 + * is reset.
1.334 + *
1.335 + *----------------------------------------------------------------------
1.336 + */
1.337 +
1.338 +EXPORT_C void
1.339 +Tcl_SetObjResult(interp, objPtr)
1.340 + Tcl_Interp *interp; /* Interpreter with which to associate the
1.341 + * return object value. */
1.342 + register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
1.343 + * obj result is made an empty string
1.344 + * object. */
1.345 +{
1.346 + register Interp *iPtr = (Interp *) interp;
1.347 + register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
1.348 +
1.349 + iPtr->objResultPtr = objPtr;
1.350 + Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
1.351 +
1.352 + /*
1.353 + * We wait until the end to release the old object result, in case
1.354 + * we are setting the result to itself.
1.355 + */
1.356 +
1.357 + TclDecrRefCount(oldObjResult);
1.358 +
1.359 + /*
1.360 + * Reset the string result since we just set the result object.
1.361 + */
1.362 +
1.363 + if (iPtr->freeProc != NULL) {
1.364 + if (iPtr->freeProc == TCL_DYNAMIC) {
1.365 + ckfree(iPtr->result);
1.366 + } else {
1.367 + (*iPtr->freeProc)(iPtr->result);
1.368 + }
1.369 + iPtr->freeProc = 0;
1.370 + }
1.371 + iPtr->result = iPtr->resultSpace;
1.372 + iPtr->resultSpace[0] = 0;
1.373 +}
1.374 +
1.375 +/*
1.376 + *----------------------------------------------------------------------
1.377 + *
1.378 + * Tcl_GetObjResult --
1.379 + *
1.380 + * Returns an interpreter's result value as a Tcl object. The object's
1.381 + * reference count is not modified; the caller must do that if it
1.382 + * needs to hold on to a long-term reference to it.
1.383 + *
1.384 + * Results:
1.385 + * The interpreter's result as an object.
1.386 + *
1.387 + * Side effects:
1.388 + * If the interpreter has a non-empty string result, the result object
1.389 + * is either empty or stale because some procedure set interp->result
1.390 + * directly. If so, the string result is moved to the result object
1.391 + * then the string result is reset.
1.392 + *
1.393 + *----------------------------------------------------------------------
1.394 + */
1.395 +
1.396 +EXPORT_C Tcl_Obj *
1.397 +Tcl_GetObjResult(interp)
1.398 + Tcl_Interp *interp; /* Interpreter whose result to return. */
1.399 +{
1.400 + register Interp *iPtr = (Interp *) interp;
1.401 + Tcl_Obj *objResultPtr;
1.402 + int length;
1.403 +
1.404 + /*
1.405 + * If the string result is non-empty, move the string result to the
1.406 + * object result, then reset the string result.
1.407 + */
1.408 +
1.409 + if (*(iPtr->result) != 0) {
1.410 + ResetObjResult(iPtr);
1.411 +
1.412 + objResultPtr = iPtr->objResultPtr;
1.413 + length = strlen(iPtr->result);
1.414 + TclInitStringRep(objResultPtr, iPtr->result, length);
1.415 +
1.416 + if (iPtr->freeProc != NULL) {
1.417 + if (iPtr->freeProc == TCL_DYNAMIC) {
1.418 + ckfree(iPtr->result);
1.419 + } else {
1.420 + (*iPtr->freeProc)(iPtr->result);
1.421 + }
1.422 + iPtr->freeProc = 0;
1.423 + }
1.424 + iPtr->result = iPtr->resultSpace;
1.425 + iPtr->resultSpace[0] = 0;
1.426 + }
1.427 + return iPtr->objResultPtr;
1.428 +}
1.429 +
1.430 +/*
1.431 + *----------------------------------------------------------------------
1.432 + *
1.433 + * Tcl_AppendResultVA --
1.434 + *
1.435 + * Append a variable number of strings onto the interpreter's string
1.436 + * result.
1.437 + *
1.438 + * Results:
1.439 + * None.
1.440 + *
1.441 + * Side effects:
1.442 + * The result of the interpreter given by the first argument is
1.443 + * extended by the strings in the va_list (up to a terminating NULL
1.444 + * argument).
1.445 + *
1.446 + * If the string result is empty, the object result is moved to the
1.447 + * string result, then the object result is reset.
1.448 + *
1.449 + *----------------------------------------------------------------------
1.450 + */
1.451 +
1.452 +EXPORT_C void
1.453 +Tcl_AppendResultVA (interp, argList)
1.454 + Tcl_Interp *interp; /* Interpreter with which to associate the
1.455 + * return value. */
1.456 + va_list argList; /* Variable argument list. */
1.457 +{
1.458 +#define STATIC_LIST_SIZE 16
1.459 + Interp *iPtr = (Interp *) interp;
1.460 + char *string, *static_list[STATIC_LIST_SIZE];
1.461 + char **args = static_list;
1.462 + int nargs_space = STATIC_LIST_SIZE;
1.463 + int nargs, newSpace, i;
1.464 +
1.465 + /*
1.466 + * If the string result is empty, move the object result to the
1.467 + * string result, then reset the object result.
1.468 + */
1.469 +
1.470 + if (*(iPtr->result) == 0) {
1.471 + Tcl_SetResult((Tcl_Interp *) iPtr,
1.472 + TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
1.473 + TCL_VOLATILE);
1.474 + }
1.475 +
1.476 + /*
1.477 + * Scan through all the arguments to see how much space is needed
1.478 + * and save pointers to the arguments in the args array,
1.479 + * reallocating as necessary.
1.480 + */
1.481 +
1.482 + nargs = 0;
1.483 + newSpace = 0;
1.484 + while (1) {
1.485 + string = va_arg(argList, char *);
1.486 + if (string == NULL) {
1.487 + break;
1.488 + }
1.489 + if (nargs >= nargs_space) {
1.490 + /*
1.491 + * Expand the args buffer
1.492 + */
1.493 + nargs_space += STATIC_LIST_SIZE;
1.494 + if (args == static_list) {
1.495 + args = (void *)ckalloc(nargs_space * sizeof(char *));
1.496 + for (i = 0; i < nargs; ++i) {
1.497 + args[i] = static_list[i];
1.498 + }
1.499 + } else {
1.500 + args = (void *)ckrealloc((void *)args,
1.501 + nargs_space * sizeof(char *));
1.502 + }
1.503 + }
1.504 + newSpace += strlen(string);
1.505 + args[nargs++] = string;
1.506 + }
1.507 +
1.508 + /*
1.509 + * If the append buffer isn't already setup and large enough to hold
1.510 + * the new data, set it up.
1.511 + */
1.512 +
1.513 + if ((iPtr->result != iPtr->appendResult)
1.514 + || (iPtr->appendResult[iPtr->appendUsed] != 0)
1.515 + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
1.516 + SetupAppendBuffer(iPtr, newSpace);
1.517 + }
1.518 +
1.519 + /*
1.520 + * Now go through all the argument strings again, copying them into the
1.521 + * buffer.
1.522 + */
1.523 +
1.524 + for (i = 0; i < nargs; ++i) {
1.525 + string = args[i];
1.526 + strcpy(iPtr->appendResult + iPtr->appendUsed, string);
1.527 + iPtr->appendUsed += strlen(string);
1.528 + }
1.529 +
1.530 + /*
1.531 + * If we had to allocate a buffer from the heap,
1.532 + * free it now.
1.533 + */
1.534 +
1.535 + if (args != static_list) {
1.536 + ckfree((void *)args);
1.537 + }
1.538 +#undef STATIC_LIST_SIZE
1.539 +}
1.540 +
1.541 +/*
1.542 + *----------------------------------------------------------------------
1.543 + *
1.544 + * Tcl_AppendResult --
1.545 + *
1.546 + * Append a variable number of strings onto the interpreter's string
1.547 + * result.
1.548 + *
1.549 + * Results:
1.550 + * None.
1.551 + *
1.552 + * Side effects:
1.553 + * The result of the interpreter given by the first argument is
1.554 + * extended by the strings given by the second and following arguments
1.555 + * (up to a terminating NULL argument).
1.556 + *
1.557 + * If the string result is empty, the object result is moved to the
1.558 + * string result, then the object result is reset.
1.559 + *
1.560 + *----------------------------------------------------------------------
1.561 + */
1.562 +
1.563 +EXPORT_C void
1.564 +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1.565 +{
1.566 + Tcl_Interp *interp;
1.567 + va_list argList;
1.568 +
1.569 + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1.570 + Tcl_AppendResultVA(interp, argList);
1.571 + va_end(argList);
1.572 +}
1.573 +
1.574 +/*
1.575 + *----------------------------------------------------------------------
1.576 + *
1.577 + * Tcl_AppendElement --
1.578 + *
1.579 + * Convert a string to a valid Tcl list element and append it to the
1.580 + * result (which is ostensibly a list).
1.581 + *
1.582 + * Results:
1.583 + * None.
1.584 + *
1.585 + * Side effects:
1.586 + * The result in the interpreter given by the first argument is
1.587 + * extended with a list element converted from string. A separator
1.588 + * space is added before the converted list element unless the current
1.589 + * result is empty, contains the single character "{", or ends in " {".
1.590 + *
1.591 + * If the string result is empty, the object result is moved to the
1.592 + * string result, then the object result is reset.
1.593 + *
1.594 + *----------------------------------------------------------------------
1.595 + */
1.596 +
1.597 +EXPORT_C void
1.598 +Tcl_AppendElement(interp, string)
1.599 + Tcl_Interp *interp; /* Interpreter whose result is to be
1.600 + * extended. */
1.601 + CONST char *string; /* String to convert to list element and
1.602 + * add to result. */
1.603 +{
1.604 + Interp *iPtr = (Interp *) interp;
1.605 + char *dst;
1.606 + int size;
1.607 + int flags;
1.608 +
1.609 + /*
1.610 + * If the string result is empty, move the object result to the
1.611 + * string result, then reset the object result.
1.612 + */
1.613 +
1.614 + if (*(iPtr->result) == 0) {
1.615 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.616 + TCL_VOLATILE);
1.617 + }
1.618 +
1.619 + /*
1.620 + * See how much space is needed, and grow the append buffer if
1.621 + * needed to accommodate the list element.
1.622 + */
1.623 +
1.624 + size = Tcl_ScanElement(string, &flags) + 1;
1.625 + if ((iPtr->result != iPtr->appendResult)
1.626 + || (iPtr->appendResult[iPtr->appendUsed] != 0)
1.627 + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
1.628 + SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
1.629 + }
1.630 +
1.631 + /*
1.632 + * Convert the string into a list element and copy it to the
1.633 + * buffer that's forming, with a space separator if needed.
1.634 + */
1.635 +
1.636 + dst = iPtr->appendResult + iPtr->appendUsed;
1.637 + if (TclNeedSpace(iPtr->appendResult, dst)) {
1.638 + iPtr->appendUsed++;
1.639 + *dst = ' ';
1.640 + dst++;
1.641 + }
1.642 + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
1.643 +}
1.644 +
1.645 +/*
1.646 + *----------------------------------------------------------------------
1.647 + *
1.648 + * SetupAppendBuffer --
1.649 + *
1.650 + * This procedure makes sure that there is an append buffer properly
1.651 + * initialized, if necessary, from the interpreter's result, and
1.652 + * that it has at least enough room to accommodate newSpace new
1.653 + * bytes of information.
1.654 + *
1.655 + * Results:
1.656 + * None.
1.657 + *
1.658 + * Side effects:
1.659 + * None.
1.660 + *
1.661 + *----------------------------------------------------------------------
1.662 + */
1.663 +
1.664 +static void
1.665 +SetupAppendBuffer(iPtr, newSpace)
1.666 + Interp *iPtr; /* Interpreter whose result is being set up. */
1.667 + int newSpace; /* Make sure that at least this many bytes
1.668 + * of new information may be added. */
1.669 +{
1.670 + int totalSpace;
1.671 +
1.672 + /*
1.673 + * Make the append buffer larger, if that's necessary, then copy the
1.674 + * result into the append buffer and make the append buffer the official
1.675 + * Tcl result.
1.676 + */
1.677 +
1.678 + if (iPtr->result != iPtr->appendResult) {
1.679 + /*
1.680 + * If an oversized buffer was used recently, then free it up
1.681 + * so we go back to a smaller buffer. This avoids tying up
1.682 + * memory forever after a large operation.
1.683 + */
1.684 +
1.685 + if (iPtr->appendAvl > 500) {
1.686 + ckfree(iPtr->appendResult);
1.687 + iPtr->appendResult = NULL;
1.688 + iPtr->appendAvl = 0;
1.689 + }
1.690 + iPtr->appendUsed = strlen(iPtr->result);
1.691 + } else if (iPtr->result[iPtr->appendUsed] != 0) {
1.692 + /*
1.693 + * Most likely someone has modified a result created by
1.694 + * Tcl_AppendResult et al. so that it has a different size.
1.695 + * Just recompute the size.
1.696 + */
1.697 +
1.698 + iPtr->appendUsed = strlen(iPtr->result);
1.699 + }
1.700 +
1.701 + totalSpace = newSpace + iPtr->appendUsed;
1.702 + if (totalSpace >= iPtr->appendAvl) {
1.703 + char *new;
1.704 +
1.705 + if (totalSpace < 100) {
1.706 + totalSpace = 200;
1.707 + } else {
1.708 + totalSpace *= 2;
1.709 + }
1.710 + new = (char *) ckalloc((unsigned) totalSpace);
1.711 + strcpy(new, iPtr->result);
1.712 + if (iPtr->appendResult != NULL) {
1.713 + ckfree(iPtr->appendResult);
1.714 + }
1.715 + iPtr->appendResult = new;
1.716 + iPtr->appendAvl = totalSpace;
1.717 + } else if (iPtr->result != iPtr->appendResult) {
1.718 + strcpy(iPtr->appendResult, iPtr->result);
1.719 + }
1.720 +
1.721 + Tcl_FreeResult((Tcl_Interp *) iPtr);
1.722 + iPtr->result = iPtr->appendResult;
1.723 +}
1.724 +
1.725 +/*
1.726 + *----------------------------------------------------------------------
1.727 + *
1.728 + * Tcl_FreeResult --
1.729 + *
1.730 + * This procedure frees up the memory associated with an interpreter's
1.731 + * string result. It also resets the interpreter's result object.
1.732 + * Tcl_FreeResult is most commonly used when a procedure is about to
1.733 + * replace one result value with another.
1.734 + *
1.735 + * Results:
1.736 + * None.
1.737 + *
1.738 + * Side effects:
1.739 + * Frees the memory associated with interp's string result and sets
1.740 + * interp->freeProc to zero, but does not change interp->result or
1.741 + * clear error state. Resets interp's result object to an unshared
1.742 + * empty object.
1.743 + *
1.744 + *----------------------------------------------------------------------
1.745 + */
1.746 +
1.747 +EXPORT_C void
1.748 +Tcl_FreeResult(interp)
1.749 + register Tcl_Interp *interp; /* Interpreter for which to free result. */
1.750 +{
1.751 + register Interp *iPtr = (Interp *) interp;
1.752 +
1.753 + if (iPtr->freeProc != NULL) {
1.754 + if (iPtr->freeProc == TCL_DYNAMIC) {
1.755 + ckfree(iPtr->result);
1.756 + } else {
1.757 + (*iPtr->freeProc)(iPtr->result);
1.758 + }
1.759 + iPtr->freeProc = 0;
1.760 + }
1.761 +
1.762 + ResetObjResult(iPtr);
1.763 +}
1.764 +
1.765 +/*
1.766 + *----------------------------------------------------------------------
1.767 + *
1.768 + * Tcl_ResetResult --
1.769 + *
1.770 + * This procedure resets both the interpreter's string and object
1.771 + * results.
1.772 + *
1.773 + * Results:
1.774 + * None.
1.775 + *
1.776 + * Side effects:
1.777 + * It resets the result object to an unshared empty object. It
1.778 + * then restores the interpreter's string result area to its default
1.779 + * initialized state, freeing up any memory that may have been
1.780 + * allocated. It also clears any error information for the interpreter.
1.781 + *
1.782 + *----------------------------------------------------------------------
1.783 + */
1.784 +
1.785 +EXPORT_C void
1.786 +Tcl_ResetResult(interp)
1.787 + register Tcl_Interp *interp; /* Interpreter for which to clear result. */
1.788 +{
1.789 + register Interp *iPtr = (Interp *) interp;
1.790 +
1.791 + ResetObjResult(iPtr);
1.792 + if (iPtr->freeProc != NULL) {
1.793 + if (iPtr->freeProc == TCL_DYNAMIC) {
1.794 + ckfree(iPtr->result);
1.795 + } else {
1.796 + (*iPtr->freeProc)(iPtr->result);
1.797 + }
1.798 + iPtr->freeProc = 0;
1.799 + }
1.800 + iPtr->result = iPtr->resultSpace;
1.801 + iPtr->resultSpace[0] = 0;
1.802 + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
1.803 +}
1.804 +
1.805 +/*
1.806 + *----------------------------------------------------------------------
1.807 + *
1.808 + * ResetObjResult --
1.809 + *
1.810 + * Procedure used to reset an interpreter's Tcl result object.
1.811 + *
1.812 + * Results:
1.813 + * None.
1.814 + *
1.815 + * Side effects:
1.816 + * Resets the interpreter's result object to an unshared empty string
1.817 + * object with ref count one. It does not clear any error information
1.818 + * in the interpreter.
1.819 + *
1.820 + *----------------------------------------------------------------------
1.821 + */
1.822 +
1.823 +static void
1.824 +ResetObjResult(iPtr)
1.825 + register Interp *iPtr; /* Points to the interpreter whose result
1.826 + * object should be reset. */
1.827 +{
1.828 + register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
1.829 +
1.830 + if (Tcl_IsShared(objResultPtr)) {
1.831 + TclDecrRefCount(objResultPtr);
1.832 + TclNewObj(objResultPtr);
1.833 + Tcl_IncrRefCount(objResultPtr);
1.834 + iPtr->objResultPtr = objResultPtr;
1.835 + } else {
1.836 + if ((objResultPtr->bytes != NULL)
1.837 + && (objResultPtr->bytes != tclEmptyStringRep)) {
1.838 + ckfree((char *) objResultPtr->bytes);
1.839 + }
1.840 + objResultPtr->bytes = tclEmptyStringRep;
1.841 + objResultPtr->length = 0;
1.842 + if ((objResultPtr->typePtr != NULL)
1.843 + && (objResultPtr->typePtr->freeIntRepProc != NULL)) {
1.844 + objResultPtr->typePtr->freeIntRepProc(objResultPtr);
1.845 + }
1.846 + objResultPtr->typePtr = (Tcl_ObjType *) NULL;
1.847 + }
1.848 +}
1.849 +
1.850 +/*
1.851 + *----------------------------------------------------------------------
1.852 + *
1.853 + * Tcl_SetErrorCodeVA --
1.854 + *
1.855 + * This procedure is called to record machine-readable information
1.856 + * about an error that is about to be returned.
1.857 + *
1.858 + * Results:
1.859 + * None.
1.860 + *
1.861 + * Side effects:
1.862 + * The errorCode global variable is modified to hold all of the
1.863 + * arguments to this procedure, in a list form with each argument
1.864 + * becoming one element of the list. A flag is set internally
1.865 + * to remember that errorCode has been set, so the variable doesn't
1.866 + * get set automatically when the error is returned.
1.867 + *
1.868 + *----------------------------------------------------------------------
1.869 + */
1.870 +
1.871 +EXPORT_C void
1.872 +Tcl_SetErrorCodeVA (interp, argList)
1.873 + Tcl_Interp *interp; /* Interpreter in which to access the errorCode
1.874 + * variable. */
1.875 + va_list argList; /* Variable argument list. */
1.876 +{
1.877 + char *string;
1.878 + int flags;
1.879 + Interp *iPtr = (Interp *) interp;
1.880 +
1.881 + /*
1.882 + * Scan through the arguments one at a time, appending them to
1.883 + * $errorCode as list elements.
1.884 + */
1.885 +
1.886 + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
1.887 + while (1) {
1.888 + string = va_arg(argList, char *);
1.889 + if (string == NULL) {
1.890 + break;
1.891 + }
1.892 + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
1.893 + (char *) NULL, string, flags);
1.894 + flags |= TCL_APPEND_VALUE;
1.895 + }
1.896 + iPtr->flags |= ERROR_CODE_SET;
1.897 +}
1.898 +
1.899 +/*
1.900 + *----------------------------------------------------------------------
1.901 + *
1.902 + * Tcl_SetErrorCode --
1.903 + *
1.904 + * This procedure is called to record machine-readable information
1.905 + * about an error that is about to be returned.
1.906 + *
1.907 + * Results:
1.908 + * None.
1.909 + *
1.910 + * Side effects:
1.911 + * The errorCode global variable is modified to hold all of the
1.912 + * arguments to this procedure, in a list form with each argument
1.913 + * becoming one element of the list. A flag is set internally
1.914 + * to remember that errorCode has been set, so the variable doesn't
1.915 + * get set automatically when the error is returned.
1.916 + *
1.917 + *----------------------------------------------------------------------
1.918 + */
1.919 + /* VARARGS2 */
1.920 +EXPORT_C void
1.921 +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1.922 +{
1.923 + Tcl_Interp *interp;
1.924 + va_list argList;
1.925 +
1.926 + /*
1.927 + * Scan through the arguments one at a time, appending them to
1.928 + * $errorCode as list elements.
1.929 + */
1.930 +
1.931 + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1.932 + Tcl_SetErrorCodeVA(interp, argList);
1.933 + va_end(argList);
1.934 +}
1.935 +
1.936 +/*
1.937 + *----------------------------------------------------------------------
1.938 + *
1.939 + * Tcl_SetObjErrorCode --
1.940 + *
1.941 + * This procedure is called to record machine-readable information
1.942 + * about an error that is about to be returned. The caller should
1.943 + * build a list object up and pass it to this routine.
1.944 + *
1.945 + * Results:
1.946 + * None.
1.947 + *
1.948 + * Side effects:
1.949 + * The errorCode global variable is modified to be the new value.
1.950 + * A flag is set internally to remember that errorCode has been
1.951 + * set, so the variable doesn't get set automatically when the
1.952 + * error is returned.
1.953 + *
1.954 + *----------------------------------------------------------------------
1.955 + */
1.956 +
1.957 +EXPORT_C void
1.958 +Tcl_SetObjErrorCode(interp, errorObjPtr)
1.959 + Tcl_Interp *interp;
1.960 + Tcl_Obj *errorObjPtr;
1.961 +{
1.962 + Interp *iPtr;
1.963 +
1.964 + iPtr = (Interp *) interp;
1.965 + Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
1.966 + iPtr->flags |= ERROR_CODE_SET;
1.967 +}
1.968 +
1.969 +/*
1.970 + *-------------------------------------------------------------------------
1.971 + *
1.972 + * TclTransferResult --
1.973 + *
1.974 + * Copy the result (and error information) from one interp to
1.975 + * another. Used when one interp has caused another interp to
1.976 + * evaluate a script and then wants to transfer the results back
1.977 + * to itself.
1.978 + *
1.979 + * This routine copies the string reps of the result and error
1.980 + * information. It does not simply increment the refcounts of the
1.981 + * result and error information objects themselves.
1.982 + * It is not legal to exchange objects between interps, because an
1.983 + * object may be kept alive by one interp, but have an internal rep
1.984 + * that is only valid while some other interp is alive.
1.985 + *
1.986 + * Results:
1.987 + * The target interp's result is set to a copy of the source interp's
1.988 + * result. The source's error information "$errorInfo" may be
1.989 + * appended to the target's error information and the source's error
1.990 + * code "$errorCode" may be stored in the target's error code.
1.991 + *
1.992 + * Side effects:
1.993 + * None.
1.994 + *
1.995 + *-------------------------------------------------------------------------
1.996 + */
1.997 +
1.998 +void
1.999 +TclTransferResult(sourceInterp, result, targetInterp)
1.1000 + Tcl_Interp *sourceInterp; /* Interp whose result and error information
1.1001 + * should be moved to the target interp.
1.1002 + * After moving result, this interp's result
1.1003 + * is reset. */
1.1004 + int result; /* TCL_OK if just the result should be copied,
1.1005 + * TCL_ERROR if both the result and error
1.1006 + * information should be copied. */
1.1007 + Tcl_Interp *targetInterp; /* Interp where result and error information
1.1008 + * should be stored. If source and target
1.1009 + * are the same, nothing is done. */
1.1010 +{
1.1011 + Interp *iPtr;
1.1012 + Tcl_Obj *objPtr;
1.1013 +
1.1014 + if (sourceInterp == targetInterp) {
1.1015 + return;
1.1016 + }
1.1017 +
1.1018 + if (result == TCL_ERROR) {
1.1019 + /*
1.1020 + * An error occurred, so transfer error information from the source
1.1021 + * interpreter to the target interpreter. Setting the flags tells
1.1022 + * the target interp that it has inherited a partial traceback
1.1023 + * chain, not just a simple error message.
1.1024 + */
1.1025 +
1.1026 + iPtr = (Interp *) sourceInterp;
1.1027 + if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
1.1028 + Tcl_AddErrorInfo(sourceInterp, "");
1.1029 + }
1.1030 + iPtr->flags &= ~(ERR_ALREADY_LOGGED);
1.1031 +
1.1032 + Tcl_ResetResult(targetInterp);
1.1033 +
1.1034 + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
1.1035 + TCL_GLOBAL_ONLY);
1.1036 + if (objPtr) {
1.1037 + Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
1.1038 + TCL_GLOBAL_ONLY);
1.1039 + ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
1.1040 + }
1.1041 +
1.1042 + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
1.1043 + TCL_GLOBAL_ONLY);
1.1044 + if (objPtr) {
1.1045 + Tcl_SetObjErrorCode(targetInterp, objPtr);
1.1046 + }
1.1047 +
1.1048 + }
1.1049 +
1.1050 + ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
1.1051 + Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
1.1052 + Tcl_ResetResult(sourceInterp);
1.1053 +}