Tcl Source Code

'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
'\" Copyright (c) 2018 Nathan Coulter.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState,
Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the
state of an an interpreter.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_InterpState
\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
.sp
int
\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
.sp
\fBTcl_DiscardInterpState\fR(\fIstate\fR)
.sp
\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR)
.sp
\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR)
.sp
\fBTcl_DiscardResult\fR(\fIsavedPtr\fR)
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
The interpreter for the operation.
.AP int status in
The return code for the state.
.AP Tcl_InterpState state in
A token for saved state.
.AP Tcl_SavedResult *savedPtr in
A pointer to storage for saved state.
.BE
.SH DESCRIPTION
.PP
These routines save the state of an interpreter before a call to a routine such
as \fBTcl_Eval\fR, and restore the state afterwards.
.PP
\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the
result of a script, including the resulting value, the return code passed as
\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR.
It returns a token for the saved state.  The interpreter result is not reset
and no interpreter state is changed.
.PP
\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and
returns the \fIstatus\fR originally passed in the corresponding call to
\fBTcl_SaveInterpState\fR.
.PP
If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called
to release it.  A token used to discard or restore state must not be used
again.
.PP
\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are
deprecated.  Instead use \fBTcl_SaveInterpState\fR,
\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more
capable.
.PP
\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location
\fIstatePtr\fR points to and returns the interpreter result to its initial
state.  It does not save options such as \fB\-errorcode\fR or
\fB\-errorinfo\fR.
.PP
\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and
moves the result from \fIstatePtr\fR back to \fIinterp\fR.  \fIstatePtr\fR is
then in an undefined state and must not be used until passed again to
\fBTcl_SaveResult\fR.
.PP
\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is
then in an undefined state and must not be used until passed again to
\fBTcl_SaveResult\fR.
.PP
If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to
release it.
.SH KEYWORDS
result, state, interp

				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object has
				 * no internal rep (has no type). */
    Tcl_ObjInternalRep internalRep;	/* The internal representation: */
} Tcl_Obj;


/*
 *----------------------------------------------------------------------------
 * The following type contains the state needed by Tcl_SaveResult. It
 * is typically allocated on the stack.
 */

typedef Tcl_Obj *Tcl_SavedResult;

/*
 *----------------------------------------------------------------------------
 * The following definitions support Tcl's namespace facility. Note: the first
 * five fields must match exactly the fields in a Namespace structure (see
 * tclInt.h).
 */

#define Tcl_AddObjErrorInfo(interp, message, length) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
#define Tcl_GlobalEval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
inline TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {}
#define Tcl_SaveResult(interp, statePtr) \
	do { \
	    Tcl_SaveResult_(); \
	    *(statePtr) = Tcl_GetObjResult(interp); \
	    Tcl_IncrRefCount(*(statePtr)); \
	    Tcl_SetObjResult(interp, Tcl_NewObj()); \
	} while(0)
inline TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {}
#define Tcl_RestoreResult(interp, statePtr) \
	do { \
	    Tcl_RestoreResult_(); \
	    Tcl_ResetResult(interp); \
   	    Tcl_SetObjResult(interp, *(statePtr)); \
   	    Tcl_DecrRefCount(*(statePtr)); \
	} while(0)
inline TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {}
#define Tcl_DiscardResult(statePtr) \
	do { \
	    Tcl_DiscardResult_(); \
	    Tcl_DecrRefCount(*(statePtr)); \
	} while(0)
#define Tcl_SetResult(interp, result, freeProc) \
	do { \
	    const char *__result = result; \
	    Tcl_FreeProc *__freeProc = freeProc; \
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \
	    if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
		if (__freeProc == TCL_DYNAMIC) { \

typedef struct {
    Tcl_Interp *interp;
    char *toUtfCmd;
    char *fromUtfCmd;
} TclEncoding;

/*
 * The counter below is used to determine if the TestsaveresultFree routine
 * was called for a result.
 */

static int freeCount;

/*
 * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
 */

static int exitMainLoop = 0;

/*

typedef struct TestChannel {
    Tcl_Channel chan;		/* Detached channel */
    struct TestChannel *nextPtr;/* Next in detached channel pool */
} TestChannel;

static TestChannel *firstDetached;

#ifdef __GNUC__
/*
 * The rest of this file shouldn't warn about deprecated functions; they're
 * there because we intend them to be so and know that this file is OK to
 * touch those fields.
 */
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif

/*
 * Forward declarations for procedures defined later in this file:
 */

static int		AsyncHandlerProc(void *clientData,
			    Tcl_Interp *interp, int code);
static Tcl_ThreadCreateType AsyncThreadProc(void *);

static Tcl_ObjCmdProc	TestparsevarnameObjCmd;
static Tcl_ObjCmdProc	TestpreferstableObjCmd;
static Tcl_ObjCmdProc	TestprintObjCmd;
static Tcl_ObjCmdProc	TestregexpObjCmd;
static Tcl_ObjCmdProc	TestreturnObjCmd;
static void		TestregexpXflags(const char *string,
			    size_t length, int *cflagsPtr, int *eflagsPtr);
static Tcl_ObjCmdProc	TestsaveresultCmd;
static void		TestsaveresultFree(void *blockPtr);
static Tcl_CmdProc	TestsetassocdataCmd;
static Tcl_CmdProc	TestsetCmd;
static Tcl_CmdProc	Testset2Cmd;
static Tcl_CmdProc	TestseterrorcodeCmd;
static Tcl_ObjCmdProc	TestsetobjerrorcodeCmd;
static Tcl_CmdProc	TestsetplatformCmd;
static Tcl_CmdProc	TeststaticlibraryCmd;

	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testseterr", TestsetCmd,

	return TCL_OK;
    } else {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " varName elemName ?newValue?\"", NULL);
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TestsaveresultCmd --
 *
 *	Implements the "testsaveresult" cmd that is used when testing the
 *	Tcl_SaveResult, Tcl_RestoreResult, and Tcl_DiscardResult interfaces.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsaveresultCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int discard, result;
    Tcl_SavedResult state;
    Tcl_Obj *objPtr;
    static const char *const optionStrings[] = {
	"append", "dynamic", "free", "object", "small", NULL
    };
    enum options {
	RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
    } index;

    /*
     * Parse arguments
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
	return TCL_ERROR;
    }

    freeCount = 0;
    objPtr = NULL;
    switch (index) {
    case RESULT_SMALL:
	Tcl_AppendResult(interp, "small result", NULL);
	break;
    case RESULT_APPEND:
	Tcl_AppendResult(interp, "append result", NULL);
	break;
    case RESULT_FREE: {
	char *buf = (char *)Tcl_Alloc(200);

	strcpy(buf, "free result");
	Tcl_SetResult(interp, buf, TCL_DYNAMIC);
	break;
    }
    case RESULT_DYNAMIC:
	Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
	break;
    case RESULT_OBJECT:
	objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE);
	Tcl_SetObjResult(interp, objPtr);
	break;
    }

    Tcl_SaveResult(interp, &state);

    if (index == RESULT_OBJECT) {
	result = Tcl_EvalObjEx(interp, objv[2], 0);
    } else {
	result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
    }

    if (discard) {
	Tcl_DiscardResult(&state);
    } else {
	Tcl_RestoreResult(interp, &state);
	result = TCL_OK;
    }

    switch (index) {
    case RESULT_DYNAMIC:
	Tcl_AppendElement(interp, freeCount ? "freed" : "leak");
	break;
    case RESULT_OBJECT:
	Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
		? "same" : "different");
	break;
    default:
	break;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TestsaveresultFree --
 *
 *	Special purpose freeProc used by TestsaveresultCmd.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Increments the freeCount.
 *
 *----------------------------------------------------------------------
 */

static void
TestsaveresultFree(
    TCL_UNUSED(void *))
{
    freeCount++;
}

/*
 *----------------------------------------------------------------------
 *
 * TestmainthreadCmd  --
 *
 *	Implements the "testmainthread" cmd that is used to test the