Attachment "tips.patch" to
ticket [1060579fff]
added by
dgp
2004-11-05 05:37:23.
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.104
diff -u -r1.104 tcl.decls
--- generic/tcl.decls 13 May 2004 12:59:20 -0000 1.104
+++ generic/tcl.decls 4 Nov 2004 22:31:56 -0000
@@ -1909,6 +1909,23 @@
declare 534 generic {
int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type)
}
+# TIP#226 API
+declare 535 generic {
+ Tcl_InterpState Tcl_SaveInterpState(Tcl_Interp *interp, int status)
+}
+declare 536 generic {
+ int Tcl_RestoreInterpState(Tcl_Interp *interp, Tcl_InterpState state)
+}
+declare 537 generic {
+ void Tcl_DiscardInterpState(Tcl_InterpState state)
+}
+# TIP#227 API
+declare 538 generic {
+ int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options)
+}
+declare 539 generic {
+ Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result)
+}
##############################################################################
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.187
diff -u -r1.187 tcl.h
--- generic/tcl.h 3 Nov 2004 19:13:33 -0000 1.187
+++ generic/tcl.h 4 Nov 2004 22:31:56 -0000
@@ -457,11 +457,15 @@
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
+typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
+typedef struct Tcl_Dict_ *Tcl_Dict;
typedef struct Tcl_EncodingState_ *Tcl_EncodingState;
typedef struct Tcl_Encoding_ *Tcl_Encoding;
typedef struct Tcl_Event Tcl_Event;
+typedef struct Tcl_InterpState_ *Tcl_InterpState;
+typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
typedef struct Tcl_Mutex_ *Tcl_Mutex;
typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
@@ -470,9 +474,6 @@
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
-typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
-typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
-typedef struct Tcl_Dict_ *Tcl_Dict;
/*
* Definition of the interface to procedures implementing threads.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.134
diff -u -r1.134 tclBasic.c
--- generic/tclBasic.c 29 Oct 2004 15:39:04 -0000 1.134
+++ generic/tclBasic.c 4 Nov 2004 22:31:57 -0000
@@ -399,6 +399,12 @@
TclClockOldscanObjCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL );
+ /* Register the default [interp bgerror] handler. */
+
+ Tcl_CreateObjCommand( interp, "::tcl::Bgerror",
+ TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL );
+
/*
* Register the builtin math functions.
*/
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.56
diff -u -r1.56 tclCmdAH.c
--- generic/tclCmdAH.c 21 Oct 2004 15:19:46 -0000 1.56
+++ generic/tclCmdAH.c 4 Nov 2004 22:31:57 -0000
@@ -269,7 +269,7 @@
}
}
if (objc == 4) {
- Tcl_Obj *options = TclGetReturnOptions(interp, result);
+ Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
options, 0)) {
Tcl_DecrRefCount(options);
@@ -577,7 +577,7 @@
}
Tcl_SetObjResult(interp, objv[1]);
- return TclSetReturnOptions(interp, options);
+ return Tcl_SetReturnOptions(interp, options);
}
/*
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.106
diff -u -r1.106 tclDecls.h
--- generic/tclDecls.h 3 Nov 2004 19:13:34 -0000 1.106
+++ generic/tclDecls.h 4 Nov 2004 22:31:58 -0000
@@ -3325,6 +3325,36 @@
EXTERN int Tcl_LimitGetGranularity _ANSI_ARGS_((
Tcl_Interp * interp, int type));
#endif
+#ifndef Tcl_SaveInterpState_TCL_DECLARED
+#define Tcl_SaveInterpState_TCL_DECLARED
+/* 535 */
+EXTERN Tcl_InterpState Tcl_SaveInterpState _ANSI_ARGS_((Tcl_Interp * interp,
+ int status));
+#endif
+#ifndef Tcl_RestoreInterpState_TCL_DECLARED
+#define Tcl_RestoreInterpState_TCL_DECLARED
+/* 536 */
+EXTERN int Tcl_RestoreInterpState _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_InterpState state));
+#endif
+#ifndef Tcl_DiscardInterpState_TCL_DECLARED
+#define Tcl_DiscardInterpState_TCL_DECLARED
+/* 537 */
+EXTERN void Tcl_DiscardInterpState _ANSI_ARGS_((
+ Tcl_InterpState state));
+#endif
+#ifndef Tcl_SetReturnOptions_TCL_DECLARED
+#define Tcl_SetReturnOptions_TCL_DECLARED
+/* 538 */
+EXTERN int Tcl_SetReturnOptions _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * options));
+#endif
+#ifndef Tcl_GetReturnOptions_TCL_DECLARED
+#define Tcl_GetReturnOptions_TCL_DECLARED
+/* 539 */
+EXTERN Tcl_Obj * Tcl_GetReturnOptions _ANSI_ARGS_((
+ Tcl_Interp * interp, int result));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -3901,6 +3931,11 @@
int (*tcl_LimitGetCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 532 */
void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */
int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */
+ Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */
+ int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */
+ void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */
+ int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */
+ Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */
} TclStubs;
#ifdef __cplusplus
@@ -6081,6 +6116,26 @@
#define Tcl_LimitGetGranularity \
(tclStubsPtr->tcl_LimitGetGranularity) /* 534 */
#endif
+#ifndef Tcl_SaveInterpState
+#define Tcl_SaveInterpState \
+ (tclStubsPtr->tcl_SaveInterpState) /* 535 */
+#endif
+#ifndef Tcl_RestoreInterpState
+#define Tcl_RestoreInterpState \
+ (tclStubsPtr->tcl_RestoreInterpState) /* 536 */
+#endif
+#ifndef Tcl_DiscardInterpState
+#define Tcl_DiscardInterpState \
+ (tclStubsPtr->tcl_DiscardInterpState) /* 537 */
+#endif
+#ifndef Tcl_SetReturnOptions
+#define Tcl_SetReturnOptions \
+ (tclStubsPtr->tcl_SetReturnOptions) /* 538 */
+#endif
+#ifndef Tcl_GetReturnOptions
+#define Tcl_GetReturnOptions \
+ (tclStubsPtr->tcl_GetReturnOptions) /* 539 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclDictObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDictObj.c,v
retrieving revision 1.26
diff -u -r1.26 tclDictObj.c
--- generic/tclDictObj.c 19 Oct 2004 22:20:04 -0000 1.26
+++ generic/tclDictObj.c 4 Nov 2004 22:31:58 -0000
@@ -2739,7 +2739,7 @@
{
Tcl_Obj *dictPtr, *objPtr;
int i, result, dummy, allocdict = 0;
- TclInterpState state;
+ Tcl_InterpState state;
if (objc < 6 || objc & 1) {
Tcl_WrongNumArgs(interp, 2, objv,
@@ -2794,9 +2794,9 @@
* Double-check that it is still a dictionary.
*/
- state = TclSaveInterpState(interp, result);
+ state = Tcl_SaveInterpState(interp, result);
if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
@@ -2826,14 +2826,14 @@
if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
if (allocdict) {
TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
- return TclRestoreInterpState(interp, state);
+ return Tcl_RestoreInterpState(interp, state);
}
/*
@@ -2862,7 +2862,7 @@
{
Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr;
Tcl_DictSearch s;
- TclInterpState state;
+ Tcl_InterpState state;
int done, result, keyc, i, allocdict=0;
if (objc < 4) {
@@ -2938,10 +2938,10 @@
* Double-check that it is still a dictionary.
*/
- state = TclSaveInterpState(interp, result);
+ state = Tcl_SaveInterpState(interp, result);
if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
TclDecrRefCount(keysPtr);
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
@@ -2967,7 +2967,7 @@
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
if (leafPtr == DICT_PATH_NON_EXISTENT) {
@@ -2975,7 +2975,7 @@
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- return TclRestoreInterpState(interp, state);
+ return Tcl_RestoreInterpState(interp, state);
}
} else {
leafPtr = dictPtr;
@@ -3014,10 +3014,10 @@
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
- return TclRestoreInterpState(interp, state);
+ return Tcl_RestoreInterpState(interp, state);
}
/*
Index: generic/tclEvent.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v
retrieving revision 1.50
diff -u -r1.50 tclEvent.c
--- generic/tclEvent.c 24 Oct 2004 22:25:12 -0000 1.50
+++ generic/tclEvent.c 4 Nov 2004 22:31:58 -0000
@@ -20,8 +20,8 @@
/*
* The data structure below is used to report background errors. One
* such structure is allocated for each error; it holds information
- * about the interpreter and the error until bgerror can be invoked
- * later as an idle handler.
+ * about the interpreter and the error until an idle handler command
+ * can be invoked.
*/
typedef struct BgError {
@@ -42,6 +42,7 @@
typedef struct ErrAssocData {
Tcl_Interp *interp; /* Interpreter in which error occurred. */
+ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */
BgError *firstBgPtr; /* First in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
@@ -142,9 +143,9 @@
* None.
*
* Side effects:
- * The command "bgerror" is invoked later as an idle handler to
- * process the error, passing it the error message. If that fails,
- * then an error message is output on stderr.
+ * A handler command is invoked later as an idle handler to
+ * process the error, passing it the interp result and return
+ * options.
*
*----------------------------------------------------------------------
*/
@@ -160,27 +161,13 @@
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
- errPtr->returnOpts = TclGetReturnOptions(interp, TCL_ERROR);
+ errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
+ (void) TclGetBgErrorHandler(interp);
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
(Tcl_InterpDeleteProc **) NULL);
- if (assocPtr == NULL) {
-
- /*
- * This is the first time a background error has occurred in
- * this interpreter. Create associated data to keep track of
- * pending error reports.
- */
-
- assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
- assocPtr->interp = interp;
- assocPtr->firstBgPtr = NULL;
- assocPtr->lastBgPtr = NULL;
- Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
- (ClientData) assocPtr);
- }
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
@@ -203,7 +190,7 @@
* None.
*
* Side effects:
- * Depends on what actions "bgerror" takes for the errors.
+ * Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
@@ -215,7 +202,6 @@
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
- Tcl_Obj *objv[2];
/*
* Not bothering to save/restore the interp state. Assume that
@@ -224,109 +210,29 @@
* Tcl_DoOneEvent() that could lead us here.
*/
- objv[0] = Tcl_NewStringObj("bgerror", -1);
- Tcl_IncrRefCount(objv[0]);
-
Tcl_Preserve((ClientData) assocPtr);
Tcl_Preserve((ClientData) interp);
while (assocPtr->firstBgPtr != NULL) {
- int code;
- Tcl_Obj *keyPtr, *valuePtr;
- errPtr = assocPtr->firstBgPtr;
-
- /*
- * Restore important state variables to what they were at
- * the time the error occurred.
- *
- * Need to set the variables, not the interp fields, because
- * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
- * anything we write to the interp fields.
- */
-
- keyPtr = Tcl_NewStringObj("-errorcode", -1);
- Tcl_IncrRefCount(keyPtr);
- Tcl_DictObjGet(NULL, errPtr->returnOpts, keyPtr, &valuePtr);
- Tcl_DecrRefCount(keyPtr);
- if (valuePtr) {
- Tcl_SetVar2Ex(interp, "errorCode", NULL,
- valuePtr, TCL_GLOBAL_ONLY);
- }
- keyPtr = Tcl_NewStringObj("-errorinfo", -1);
- Tcl_IncrRefCount(keyPtr);
- Tcl_DictObjGet(NULL, errPtr->returnOpts, keyPtr, &valuePtr);
- Tcl_DecrRefCount(keyPtr);
- if (valuePtr) {
- Tcl_SetVar2Ex(interp, "errorInfo", NULL,
- valuePtr, TCL_GLOBAL_ONLY);
- }
+ int code, prefixObjc;
+ Tcl_Obj **prefixObjv, **tempObjv;
- /*
- * Create and invoke the bgerror command.
- */
+ errPtr = assocPtr->firstBgPtr;
- objv[1] = errPtr->errorMsg;
- Tcl_IncrRefCount(objv[1]);
-
+ Tcl_IncrRefCount(assocPtr->cmdPrefix);
+ Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix,
+ &prefixObjc, &prefixObjv);
+ tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
+ memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
+ tempObjv[prefixObjc] = errPtr->errorMsg;
+ tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
- code = Tcl_EvalObjv(interp, 2, objv, TCL_EVAL_GLOBAL);
- if (code == TCL_ERROR) {
-
- /*
- * If the interpreter is safe, we look for a hidden command
- * named "bgerror" and call that with the error information.
- * Otherwise, simply ignore the error. The rationale is that
- * this could be an error caused by a malicious applet trying
- * to cause an infinite barrage of error messages. The hidden
- * "bgerror" command can be used by a security policy to
- * interpose on such attacks and e.g. kill the applet after a
- * few attempts.
- */
-
- if (Tcl_IsSafe(interp)) {
- Tcl_ResetResult(interp);
- TclObjInvoke(interp, 2, objv, TCL_INVOKE_HIDDEN);
- } else {
-
- /*
- * We have to get the error output channel at the latest
- * possible time, because the eval (above) might have
- * changed the channel.
- */
-
- Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
-
- Tcl_IncrRefCount(resultPtr);
- if (Tcl_FindCommand(interp, "bgerror",
- NULL, TCL_GLOBAL_ONLY) == NULL) {
- if (valuePtr) {
- Tcl_WriteObj(errChannel, valuePtr);
- }
- Tcl_WriteChars(errChannel, "\n", -1);
- } else {
- Tcl_WriteChars(errChannel,
- "bgerror failed to handle background error.\n",
- -1);
- Tcl_WriteChars(errChannel, " Original error: ", -1);
- Tcl_WriteObj(errChannel, errPtr->errorMsg);
- Tcl_WriteChars(errChannel, "\n", -1);
- Tcl_WriteChars(errChannel,
- " Error in bgerror: ", -1);
- Tcl_WriteObj(errChannel, resultPtr);
- Tcl_WriteChars(errChannel, "\n", -1);
- }
- Tcl_DecrRefCount(resultPtr);
- Tcl_Flush(errChannel);
- }
- }
- }
+ code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
/*
* Discard the command and the information about the error report.
*/
- Tcl_DecrRefCount(objv[1]);
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
@@ -339,9 +245,29 @@
*/
break;
}
-
+ if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
+ Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1);
+ Tcl_Obj *valuePtr;
+
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+
+ Tcl_WriteChars(errChannel,
+ "error in background error handler:\n", -1);
+ if (valuePtr) {
+ Tcl_WriteObj(errChannel, valuePtr);
+ } else {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ }
+ Tcl_WriteChars(errChannel, "\n", 1);
+ Tcl_Flush(errChannel);
+ }
+ }
}
-
/* Cleanup any error reports we didn't do (due to a TCL_BREAK) */
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
@@ -352,8 +278,6 @@
}
assocPtr->lastBgPtr = NULL;
- Tcl_DecrRefCount(objv[0]);
-
Tcl_Release((ClientData) interp);
Tcl_Release((ClientData) assocPtr);
}
@@ -361,6 +285,198 @@
/*
*----------------------------------------------------------------------
*
+ * TclDefaultBgErrorHandlerObjCmd --
+ *
+ * This procedure is invoked to process the "::tcl::Bgerror" Tcl
+ * command. It is the default handler command registered with
+ * [interp bgerror] for the sake of compatibility with older Tcl
+ * releases.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * Depends on what actions the "bgerror" command takes for the errors.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Tcl_Obj *keyPtr, *valuePtr;
+ Tcl_Obj *tempObjv[2];
+ int code;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "msg options");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Restore important state variables to what they were at
+ * the time the error occurred.
+ *
+ * Need to set the variables, not the interp fields, because
+ * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
+ * anything we write to the interp fields.
+ */
+
+ keyPtr = Tcl_NewStringObj("-errorcode", -1);
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (valuePtr) {
+ Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
+ }
+
+ keyPtr = Tcl_NewStringObj("-errorinfo", -1);
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (valuePtr) {
+ Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
+ }
+
+ /* Create and invoke the bgerror command. */
+
+ tempObjv[0] = Tcl_NewStringObj("bgerror", -1);
+ Tcl_IncrRefCount(tempObjv[0]);
+ tempObjv[1] = objv[1];
+ Tcl_AllowExceptions(interp);
+ code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
+ if (code == TCL_ERROR) {
+ /*
+ * If the interpreter is safe, we look for a hidden command
+ * named "bgerror" and call that with the error information.
+ * Otherwise, simply ignore the error. The rationale is that
+ * this could be an error caused by a malicious applet trying
+ * to cause an infinite barrage of error messages. The hidden
+ * "bgerror" command can be used by a security policy to
+ * interpose on such attacks and e.g. kill the applet after a
+ * few attempts.
+ */
+ if (Tcl_IsSafe(interp)) {
+ Tcl_ResetResult(interp);
+ TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
+ } else {
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+
+ Tcl_IncrRefCount(resultPtr);
+ if (Tcl_FindCommand(interp, "bgerror",
+ NULL, TCL_GLOBAL_ONLY) == NULL) {
+ if (valuePtr) {
+ Tcl_WriteObj(errChannel, valuePtr);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ }
+ } else {
+ Tcl_WriteChars(errChannel,
+ "bgerror failed to handle background error.\n", -1);
+ Tcl_WriteChars(errChannel, " Original error: ", -1);
+ Tcl_WriteObj(errChannel, objv[1]);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel,
+ " Error in bgerror: ", -1);
+ Tcl_WriteObj(errChannel, resultPtr);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ }
+ Tcl_DecrRefCount(resultPtr);
+ Tcl_Flush(errChannel);
+ }
+ }
+ code = TCL_OK;
+ }
+ Tcl_DecrRefCount(tempObjv[0]);
+ Tcl_ResetResult(interp);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetBgErrorHandler --
+ *
+ * This procedure sets the command prefix to be used to handle
+ * background errors in interp.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Error handler is registered.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetBgErrorHandler(interp, cmdPrefix)
+ Tcl_Interp *interp;
+ Tcl_Obj *cmdPrefix;
+{
+ ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
+ "tclBgError", (Tcl_InterpDeleteProc **) NULL);
+
+ if (cmdPrefix == NULL) {
+ Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
+ }
+ if (assocPtr == NULL) {
+ /* First access: initialize */
+ assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr->interp = interp;
+ assocPtr->cmdPrefix = NULL;
+ assocPtr->firstBgPtr = NULL;
+ assocPtr->lastBgPtr = NULL;
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
+ (ClientData) assocPtr);
+ }
+ if (assocPtr->cmdPrefix) {
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
+ }
+ assocPtr->cmdPrefix = cmdPrefix;
+ Tcl_IncrRefCount(assocPtr->cmdPrefix);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetBgErrorHandler --
+ *
+ * This procedure retrieves the command prefix currently used
+ * to handle background errors in interp.
+ *
+ * Results:
+ * A (Tcl_Obj *) to a list of words (command prefix).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetBgErrorHandler(interp)
+ Tcl_Interp *interp;
+{
+ ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
+ "tclBgError", (Tcl_InterpDeleteProc **) NULL);
+
+ if (assocPtr == NULL) {
+ TclSetBgErrorHandler(interp, Tcl_NewStringObj("::tcl::Bgerror", -1));
+ assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
+ "tclBgError", (Tcl_InterpDeleteProc **) NULL);
+ }
+ return assocPtr->cmdPrefix;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* BgErrorDeleteProc --
*
* This procedure is associated with the "tclBgError" assoc data
@@ -394,6 +510,7 @@
ckfree((char *) errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
}
Index: generic/tclIOGT.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOGT.c,v
retrieving revision 1.11
diff -u -r1.11 tclIOGT.c
--- generic/tclIOGT.c 19 Oct 2004 21:54:07 -0000 1.11
+++ generic/tclIOGT.c 4 Nov 2004 22:31:58 -0000
@@ -383,13 +383,13 @@
Tcl_Obj* resObj; /* See below, switch (transmit) */
int resLen;
unsigned char* resBuf;
- TclInterpState state = NULL;
+ Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command);
Tcl_Obj* temp;
if (preserve) {
- state = TclSaveInterpState(dataPtr->interp, res);
+ state = Tcl_SaveInterpState(dataPtr->interp, res);
}
if (command == (Tcl_Obj*) NULL) {
@@ -488,14 +488,14 @@
Tcl_ResetResult(dataPtr->interp);
if (preserve) {
- (void) TclRestoreInterpState(dataPtr->interp, state);
+ (void) Tcl_RestoreInterpState(dataPtr->interp, state);
}
return res;
cleanup:
if (preserve) {
- (void) TclRestoreInterpState(dataPtr->interp, state);
+ (void) Tcl_RestoreInterpState(dataPtr->interp, state);
}
if (command != (Tcl_Obj*) NULL) {
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.193
diff -u -r1.193 tclInt.h
--- generic/tclInt.h 3 Nov 2004 19:13:38 -0000 1.193
+++ generic/tclInt.h 4 Nov 2004 22:31:59 -0000
@@ -1475,8 +1475,6 @@
#define SAFE_INTERP 0x80
#define INTERP_TRACE_IN_PROGRESS 0x200
-typedef struct TclInterpState_ *TclInterpState;
-
/*
* Maximum number of levels of nesting permitted in Tcl commands (used
* to catch infinite recursion).
@@ -1763,8 +1761,6 @@
CONST char *value));
MODULE_SCOPE void TclCleanupLiteralTable _ANSI_ARGS_((
Tcl_Interp* interp, LiteralTable* tablePtr));
-MODULE_SCOPE void TclDiscardInterpState _ANSI_ARGS_ ((
- TclInterpState state));
MODULE_SCOPE void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
MODULE_SCOPE int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1793,8 +1789,7 @@
MODULE_SCOPE void TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeThreadData _ANSI_ARGS_((void));
-MODULE_SCOPE Tcl_Obj * TclGetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
- int result));
+MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *pattern, Tcl_Obj *unquotedPrefix,
int globFlags, Tcl_GlobTypeData* types));
@@ -1942,12 +1937,8 @@
MODULE_SCOPE void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
MODULE_SCOPE void TclRemoveScriptLimitCallbacks _ANSI_ARGS_((
Tcl_Interp *interp));
-MODULE_SCOPE int TclRestoreInterpState _ANSI_ARGS_ ((
- Tcl_Interp *interp, TclInterpState state));
-MODULE_SCOPE TclInterpState TclSaveInterpState _ANSI_ARGS_ ((
- Tcl_Interp *interp, int status));
-MODULE_SCOPE int TclSetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *options));
+MODULE_SCOPE void TclSetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *cmdPrefix));
MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
int result));
MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
@@ -2033,6 +2024,9 @@
MODULE_SCOPE int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int Tcl_DictObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
Index: generic/tclInterp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInterp.c,v
retrieving revision 1.48
diff -u -r1.48 tclInterp.c
--- generic/tclInterp.c 25 Oct 2004 17:24:37 -0000 1.48
+++ generic/tclInterp.c 4 Nov 2004 22:31:59 -0000
@@ -287,6 +287,9 @@
Tcl_Obj *CONST objv[]));
static void InterpInfoDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
+static int SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int objc,
+ Tcl_Obj *CONST objv[]));
static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int safe));
static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
@@ -548,19 +551,19 @@
{
int index;
static CONST char *options[] = {
- "alias", "aliases", "create", "delete",
- "eval", "exists", "expose", "hide",
- "hidden", "issafe", "invokehidden", "limit",
- "marktrusted", "recursionlimit","slaves", "share",
- "target", "transfer",
+ "alias", "aliases", "bgerror", "create",
+ "delete", "eval", "exists", "expose",
+ "hide", "hidden", "issafe", "invokehidden",
+ "limit", "marktrusted", "recursionlimit","slaves",
+ "share", "target", "transfer",
NULL
};
enum option {
- OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
- OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
- OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT,
- OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE,
- OPT_TARGET, OPT_TRANSFER
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE,
+ OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
+ OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
+ OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES,
+ OPT_SHARE, OPT_TARGET, OPT_TRANSFER
};
@@ -617,6 +620,19 @@
}
return AliasList(interp, slaveInterp);
}
+ case OPT_BGERROR: {
+ Tcl_Interp *slaveInterp;
+
+ if (objc != 3 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
+ }
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *slavePtr;
@@ -1988,6 +2004,48 @@
/*
*----------------------------------------------------------------------
*
+ * SlaveBgerror --
+ *
+ * Helper function to set/query the background error handling
+ * command prefix of an interp
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * When (objc == 1), slaveInterp will be set to a new background
+ * handler of objv[0].
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SlaveBgerror(interp, slaveInterp, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */
+ int objc; /* Set or Query. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
+{
+ if (objc) {
+ int length;
+
+ if (TCL_ERROR == Tcl_ListObjLength(interp, objv[0], &length)) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ TclSetBgErrorHandler(interp, objv[0]);
+ }
+ Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* SlaveCreate --
*
* Helper function to do the actual work of creating a slave interp
@@ -2135,14 +2193,14 @@
Tcl_Interp *slaveInterp;
int index;
static CONST char *options[] = {
- "alias", "aliases", "eval", "expose",
- "hide", "hidden", "issafe", "invokehidden",
- "limit", "marktrusted", "recursionlimit", NULL
+ "alias", "aliases", "bgerror", "eval",
+ "expose", "hide", "hidden", "issafe",
+ "invokehidden", "limit", "marktrusted", "recursionlimit", NULL
};
enum options {
- OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
- OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
- OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL,
+ OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
+ OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT
};
slaveInterp = (Tcl_Interp *) clientData;
@@ -2185,6 +2243,13 @@
}
return AliasList(interp, slaveInterp);
}
+ case OPT_BGERROR: {
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
+ return TCL_ERROR;
+ }
+ return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
+ }
case OPT_EVAL: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
Index: generic/tclMain.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclMain.c,v
retrieving revision 1.29
diff -u -r1.29 tclMain.c
--- generic/tclMain.c 25 Oct 2004 17:24:39 -0000 1.29
+++ generic/tclMain.c 4 Nov 2004 22:31:59 -0000
@@ -435,7 +435,7 @@
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
- Tcl_Obj *options = TclGetReturnOptions(interp, code);
+ Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1);
Tcl_Obj *valuePtr;
@@ -447,7 +447,6 @@
Tcl_WriteObj(errChannel, valuePtr);
}
Tcl_WriteChars(errChannel, "\n", 1);
- Tcl_DecrRefCount(options);
}
exitCode = 1;
}
Index: generic/tclResult.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclResult.c,v
retrieving revision 1.21
diff -u -r1.21 tclResult.c
--- generic/tclResult.c 25 Oct 2004 20:24:13 -0000 1.21
+++ generic/tclResult.c 4 Nov 2004 22:31:59 -0000
@@ -31,7 +31,7 @@
/*
* This structure is used to take a snapshot of the interpreter
- * state in TclSaveInterpState. You can snapshot the state,
+ * state in Tcl_SaveInterpState. You can snapshot the state,
* execute a command, and then back up to the result or the
* error that was previously in progress.
*/
@@ -50,7 +50,7 @@
/*
*----------------------------------------------------------------------
*
- * TclSaveInterpState --
+ * Tcl_SaveInterpState --
*
* Fills a token with a snapshot of the current state of the
* interpreter. The snapshot can be restored at any point by
@@ -69,8 +69,8 @@
*----------------------------------------------------------------------
*/
-TclInterpState
-TclSaveInterpState(interp, status)
+Tcl_InterpState
+Tcl_SaveInterpState(interp, status)
Tcl_Interp* interp; /* Interpreter's state to be saved */
int status; /* status code for current operation */
{
@@ -95,20 +95,20 @@
}
statePtr->objResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(statePtr->objResult);
- return (TclInterpState) statePtr;
+ return (Tcl_InterpState) statePtr;
}
/*
*----------------------------------------------------------------------
*
- * TclRestoreInterpState --
+ * Tcl_RestoreInterpState --
*
* Accepts an interp and a token previously returned by
- * TclSaveInterpState. Restore the state of the interp
- * to what it was at the time of the TclSaveInterpState call.
+ * Tcl_SaveInterpState. Restore the state of the interp
+ * to what it was at the time of the Tcl_SaveInterpState call.
*
* Results:
- * Returns the status value originally passed in to TclSaveInterpState.
+ * Returns the status value originally passed in to Tcl_SaveInterpState.
*
* Side effects:
* Restores the interp state and frees memory held by token.
@@ -117,9 +117,9 @@
*/
int
-TclRestoreInterpState(interp, state)
+Tcl_RestoreInterpState(interp, state)
Tcl_Interp* interp; /* Interpreter's state to be restored*/
- TclInterpState state; /* saved interpreter state */
+ Tcl_InterpState state; /* saved interpreter state */
{
Interp *iPtr = (Interp *)interp;
InterpState *statePtr = (InterpState *)state;
@@ -152,16 +152,16 @@
Tcl_IncrRefCount(iPtr->returnOpts);
}
Tcl_SetObjResult(interp, statePtr->objResult);
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return status;
}
/*
*----------------------------------------------------------------------
*
- * TclDiscardInterpState --
+ * Tcl_DiscardInterpState --
*
- * Accepts a token previously returned by TclSaveInterpState.
+ * Accepts a token previously returned by Tcl_SaveInterpState.
* Frees the memory it uses.
*
* Results:
@@ -174,8 +174,8 @@
*/
void
-TclDiscardInterpState(state)
- TclInterpState state; /* saved interpreter state */
+Tcl_DiscardInterpState(state)
+ Tcl_InterpState state; /* saved interpreter state */
{
InterpState *statePtr = (InterpState *)state;
@@ -1366,7 +1366,7 @@
/*
*-------------------------------------------------------------------------
*
- * TclGetReturnOptions --
+ * Tcl_GetReturnOptions --
*
* Packs up the interp state into a dictionary of return options.
*
@@ -1380,7 +1380,7 @@
*/
Tcl_Obj *
-TclGetReturnOptions(interp, result)
+Tcl_GetReturnOptions(interp, result)
Tcl_Interp *interp;
int result;
{
@@ -1423,7 +1423,7 @@
/*
*-------------------------------------------------------------------------
*
- * TclSetReturnOptions --
+ * Tcl_SetReturnOptions --
*
* Accepts an interp and a dictionary of return options, and sets
* the return options of the interp to match the dictionary.
@@ -1441,7 +1441,7 @@
*/
int
-TclSetReturnOptions(interp, options)
+Tcl_SetReturnOptions(interp, options)
Tcl_Interp *interp;
Tcl_Obj *options;
{
@@ -1513,8 +1513,8 @@
return;
}
- TclSetReturnOptions(targetInterp,
- TclGetReturnOptions(sourceInterp, result));
+ Tcl_SetReturnOptions(targetInterp,
+ Tcl_GetReturnOptions(sourceInterp, result));
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.106
diff -u -r1.106 tclStubInit.c
--- generic/tclStubInit.c 27 Oct 2004 17:13:58 -0000 1.106
+++ generic/tclStubInit.c 4 Nov 2004 22:31:59 -0000
@@ -941,6 +941,11 @@
Tcl_LimitGetCommands, /* 532 */
Tcl_LimitGetTime, /* 533 */
Tcl_LimitGetGranularity, /* 534 */
+ Tcl_SaveInterpState, /* 535 */
+ Tcl_RestoreInterpState, /* 536 */
+ Tcl_DiscardInterpState, /* 537 */
+ Tcl_SetReturnOptions, /* 538 */
+ Tcl_GetReturnOptions, /* 539 */
};
/* !END!: Do not edit above this line. */
Index: generic/tclTrace.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTrace.c,v
retrieving revision 1.19
diff -u -r1.19 tclTrace.c
--- generic/tclTrace.c 3 Nov 2004 17:16:05 -0000 1.19
+++ generic/tclTrace.c 4 Nov 2004 22:32:00 -0000
@@ -1422,7 +1422,7 @@
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
- TclInterpState state = NULL;
+ Tcl_InterpState state = NULL;
if (command == NULL || cmdPtr->tracePtr == NULL) {
return traceCode;
@@ -1455,7 +1455,7 @@
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
if (state == NULL) {
- state = TclSaveInterpState(interp, code);
+ state = Tcl_SaveInterpState(interp, code);
}
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
@@ -1467,7 +1467,7 @@
}
iPtr->activeCmdTracePtr = active.nextPtr;
if (state) {
- (void) TclRestoreInterpState(interp, state);
+ (void) Tcl_RestoreInterpState(interp, state);
}
return(traceCode);
}
@@ -1514,7 +1514,7 @@
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
- TclInterpState state = NULL;
+ Tcl_InterpState state = NULL;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
@@ -1562,7 +1562,7 @@
Tcl_Preserve((ClientData) tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if (state == NULL) {
- state = TclSaveInterpState(interp, code);
+ state = Tcl_SaveInterpState(interp, code);
}
if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
@@ -1598,9 +1598,9 @@
iPtr->activeInterpTracePtr = active.nextPtr;
if (state) {
if (traceCode == TCL_OK) {
- (void) TclRestoreInterpState(interp, state);
+ (void) Tcl_RestoreInterpState(interp, state);
} else {
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
}
}
return(traceCode);
@@ -2422,7 +2422,7 @@
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
- TclInterpState state = NULL;
+ Tcl_InterpState state = NULL;
/*
* If there are already similar trace procedures active for the
@@ -2490,7 +2490,7 @@
}
Tcl_Preserve((ClientData) tracePtr);
if (state == NULL) {
- state = TclSaveInterpState((Tcl_Interp *)iPtr, code);
+ state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
@@ -2526,7 +2526,7 @@
}
Tcl_Preserve((ClientData) tracePtr);
if (state == NULL) {
- state = TclSaveInterpState((Tcl_Interp *)iPtr, code);
+ state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
@@ -2554,7 +2554,7 @@
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
- Tcl_Obj *options = TclGetReturnOptions((Tcl_Interp *)iPtr, code);
+ Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code);
Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1);
Tcl_Obj *errorInfo;
@@ -2599,18 +2599,18 @@
Tcl_DictObjPut(NULL, options, errorInfoKey, errorInfo);
Tcl_DecrRefCount(errorInfoKey);
Tcl_DecrRefCount(errorInfo);
- code = TclSetReturnOptions((Tcl_Interp *)iPtr, options);
+ code = Tcl_SetReturnOptions((Tcl_Interp *)iPtr, options);
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
} else {
- (void) TclRestoreInterpState((Tcl_Interp *)iPtr, state);
+ (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
}
DisposeTraceResult(disposeFlags,result);
} else if (state) {
if (code == TCL_OK) {
- code = TclRestoreInterpState((Tcl_Interp *)iPtr, state);
+ code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
} else {
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
}
}
Index: tests/interp.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/interp.test,v
retrieving revision 1.41
diff -u -r1.41 interp.test
--- tests/interp.test 14 Sep 2004 17:45:37 -0000 1.41
+++ tests/interp.test 4 Nov 2004 22:32:02 -0000
@@ -33,7 +33,7 @@
} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
test interp-1.2 {options for interp command} {
list [catch {interp frobox} msg] $msg
-} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "frobox": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.3 {options for interp command} {
interp delete
} ""
@@ -51,13 +51,13 @@
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-1.7 {options for interp command} {
list [catch {interp hello} msg] $msg
-} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "hello": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.8 {options for interp command} {
list [catch {interp -froboz} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.9 {options for interp command} {
list [catch {interp -froboz -safe} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.10 {options for interp command} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
