summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog27
-rw-r--r--doc/bgerror.n15
-rw-r--r--generic/tcl.decls19
-rw-r--r--generic/tcl.h9
-rw-r--r--generic/tclBasic.c8
-rw-r--r--generic/tclCmdAH.c6
-rw-r--r--generic/tclDecls.h57
-rw-r--r--generic/tclDictObj.c26
-rw-r--r--generic/tclEvent.c357
-rw-r--r--generic/tclIOGT.c10
-rw-r--r--generic/tclInt.h20
-rw-r--r--generic/tclInterp.c99
-rw-r--r--generic/tclMain.c5
-rw-r--r--generic/tclResult.c46
-rw-r--r--generic/tclStubInit.c7
-rw-r--r--generic/tclTrace.c34
-rw-r--r--tests/interp.test10
17 files changed, 527 insertions, 228 deletions
diff --git a/ChangeLog b/ChangeLog
index 6a628d0..98c8896 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -9,6 +9,33 @@
2004-11-12 Don Porter <dgp@users.sourceforge.net>
+ TIP #221 IMPLEMENTATION
+ * generic/tclBasic.c: Define [::tcl::Bgerror] in new interps.
+ * generic/tclEvent.c: Update Tcl_BackgroundError to make use
+ of the registered [interp bgerror] command.
+ * generic/tclInterp.c: New [interp bgerror] subcommand.
+ * tests/interp.test: syntax tests updated.
+
+ TIP #226 IMPLEMENTATION
+ * generic/tcl.decls: Stubs for Tcl_(Save|Restore|Discard)InterpState
+ * generic/tcl.h: New public opaque type, Tcl_InterpState.
+ * generic/tclInt.h: Drop old private declarations. Add
+ Tcl(Get|Set)BgErrorHandler
+ * generic/tclResult.c: Tcl_*InterpState implementations.
+ * generic/tclDictObj.c: Update callers.
+ * generic/tclIOGT.c:
+ * generic/tclTrace.c:
+
+ TIP #227 IMPLEMENTATION
+ * generic/tcl.decls: Stubs for Tcl_(Get|Set)ReturnOptions.
+ * generic/tclInt.h: Drop old private declarations.
+ * generic/tclResult.c: Tcl_*ReturnOptions implementations.
+ * generic/tclCmdAH.c: Update callers.
+ * generic/tclMain.c:
+
+ * generic/tclDecls.h: make genstubs
+ * generic/tclStubInit.c:
+
* unix/tclAppInit.c: Removed tclConfig.h #include, now that tcl.h
takes care of it for us.
diff --git a/doc/bgerror.n b/doc/bgerror.n
index 648bbc3..c20e8a0 100644
--- a/doc/bgerror.n
+++ b/doc/bgerror.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: bgerror.n,v 1.7 2004/11/12 23:27:58 dkf Exp $
+'\" RCS: @(#) $Id: bgerror.n,v 1.8 2004/11/13 00:19:05 dgp Exp $
'\"
.so man.macros
.TH bgerror n 7.5 Tcl "Tcl Built-In Commands"
@@ -18,6 +18,19 @@ bgerror \- Command invoked to process background errors
.BE
.SH DESCRIPTION
+.VS 8.5
+Release 8.5 of Tcl supports the \fBinterp bgerror\fR command,
+which allows applications to register in an interpreter the command
+that will handle background errors in that interpreter. In older
+releases of Tcl, this level of control was not available, and applications
+could control the handling of background errors only by creating
+a command with the particular command name \fBbgerror\fR in the
+global namespace of an interpreter. The following documentation
+describes the interface requirements of the \fBbgerror\fR command
+an application might define to retain compatibility with pre-8.5
+releases of Tcl. Applications intending to support only
+Tcl releases 8.5 and later should simply make use of \fBinterp bgerror\fR.
+.VE 8.5
.PP
The \fBbgerror\fR command doesn't exist as built-in part of Tcl. Instead,
individual applications or users can define a \fBbgerror\fR
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 97550e3..af227bf 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.104 2004/05/13 12:59:20 dkf Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.105 2004/11/13 00:19:05 dgp Exp $
library tcl
@@ -1909,6 +1909,23 @@ declare 533 generic {
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)
+}
##############################################################################
diff --git a/generic/tcl.h b/generic/tcl.h
index 71ef242..ef9693a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.188 2004/11/12 20:27:28 das Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.189 2004/11/13 00:19:06 dgp Exp $
*/
#ifndef _TCL
@@ -461,11 +461,15 @@ typedef struct Tcl_Interp {
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;
@@ -474,9 +478,6 @@ typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
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.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 2375920..a37dff5 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.134 2004/10/29 15:39:04 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.135 2004/11/13 00:19:06 dgp Exp $
*/
#include "tclInt.h"
@@ -399,6 +399,12 @@ Tcl_CreateInterp()
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.
*/
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index e3c95bd..108ea72 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.56 2004/10/21 15:19:46 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.57 2004/11/13 00:19:07 dgp Exp $
*/
#include "tclInt.h"
@@ -269,7 +269,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
}
}
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_ErrorObjCmd(dummy, interp, objc, objv)
}
Tcl_SetObjResult(interp, objv[1]);
- return TclSetReturnOptions(interp, options);
+ return Tcl_SetReturnOptions(interp, options);
}
/*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index db70762..851e339 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.106 2004/11/03 19:13:34 davygrvy Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.107 2004/11/13 00:19:07 dgp Exp $
*/
#ifndef _TCLDECLS
@@ -3325,6 +3325,36 @@ EXTERN void Tcl_LimitGetTime _ANSI_ARGS_((Tcl_Interp * interp,
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 @@ typedef struct TclStubs {
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 @@ extern TclStubs *tclStubsPtr;
#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) */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 57576e4..2bbd292 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDictObj.c,v 1.26 2004/10/19 22:20:04 dkf Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.27 2004/11/13 00:19:09 dgp Exp $
*/
#include "tclInt.h"
@@ -2739,7 +2739,7 @@ DictUpdateCmd(interp, objc, objv)
{
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 @@ DictUpdateCmd(interp, objc, objv)
* 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 @@ DictUpdateCmd(interp, objc, objv)
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 @@ DictWithCmd(interp, objc, objv)
{
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 @@ DictWithCmd(interp, objc, objv)
* 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 @@ DictWithCmd(interp, objc, objv)
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
if (leafPtr == DICT_PATH_NON_EXISTENT) {
@@ -2975,7 +2975,7 @@ DictWithCmd(interp, objc, objv)
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- return TclRestoreInterpState(interp, state);
+ return Tcl_RestoreInterpState(interp, state);
}
} else {
leafPtr = dictPtr;
@@ -3014,10 +3014,10 @@ DictWithCmd(interp, objc, objv)
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- TclDiscardInterpState(state);
+ Tcl_DiscardInterpState(state);
return TCL_ERROR;
}
- return TclRestoreInterpState(interp, state);
+ return Tcl_RestoreInterpState(interp, state);
}
/*
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 108ecf3..5dce0fc 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEvent.c,v 1.50 2004/10/24 22:25:12 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.51 2004/11/13 00:19:09 dgp Exp $
*/
#include "tclInt.h"
@@ -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 BgError {
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 @@ static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
* 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 @@ Tcl_BackgroundError(interp)
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 @@ Tcl_BackgroundError(interp)
* 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 @@ HandleBgErrors(clientData)
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 @@ HandleBgErrors(clientData)
* 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;
+ int code, prefixObjc;
+ Tcl_Obj **prefixObjv, **tempObjv;
- /*
- * 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);
- }
-
- /*
- * 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 @@ HandleBgErrors(clientData)
*/
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 @@ HandleBgErrors(clientData)
}
assocPtr->lastBgPtr = NULL;
- Tcl_DecrRefCount(objv[0]);
-
Tcl_Release((ClientData) interp);
Tcl_Release((ClientData) assocPtr);
}
@@ -361,6 +285,198 @@ HandleBgErrors(clientData)
/*
*----------------------------------------------------------------------
*
+ * 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 @@ BgErrorDeleteProc(clientData, interp)
ckfree((char *) errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
}
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 37b57be..57f9ed2 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * CVS: $Id: tclIOGT.c,v 1.11 2004/10/19 21:54:07 dgp Exp $
+ * CVS: $Id: tclIOGT.c,v 1.12 2004/11/13 00:19:09 dgp Exp $
*/
#include "tclInt.h"
@@ -383,13 +383,13 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve)
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 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve)
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) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c2019a3..28284b2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.197 2004/11/12 20:27:28 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.198 2004/11/13 00:19:09 dgp Exp $
*/
#ifndef _TCLINT
@@ -1480,8 +1480,6 @@ typedef struct Interp {
#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).
@@ -1768,8 +1766,6 @@ MODULE_SCOPE int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
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,
@@ -1798,8 +1794,7 @@ MODULE_SCOPE void TclFinalizeAsync _ANSI_ARGS_((void));
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));
@@ -1947,12 +1942,8 @@ MODULE_SCOPE VOID TclRememberJoinableThread _ANSI_ARGS_((
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,
@@ -2038,6 +2029,9 @@ MODULE_SCOPE int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
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[]));
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 4ee52f6..e0e3582 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.48 2004/10/25 17:24:37 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.49 2004/11/13 00:19:09 dgp Exp $
*/
#include "tclInt.h"
@@ -287,6 +287,9 @@ static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
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 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv)
{
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 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv)
}
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 @@ GetInterp(interp, pathPtr)
/*
*----------------------------------------------------------------------
*
+ * 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 @@ SlaveObjCmd(clientData, interp, objc, objv)
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 @@ SlaveObjCmd(clientData, interp, objc, objv)
}
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 ...?");
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 7869cec..fc373bc 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.29 2004/10/25 17:24:39 dgp Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.30 2004/11/13 00:19:10 dgp Exp $
*/
#include "tclInt.h"
@@ -435,7 +435,7 @@ Tcl_Main(argc, argv, appInitProc)
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_Main(argc, argv, appInitProc)
Tcl_WriteObj(errChannel, valuePtr);
}
Tcl_WriteChars(errChannel, "\n", 1);
- Tcl_DecrRefCount(options);
}
exitCode = 1;
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 196f634..c549330 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclResult.c,v 1.21 2004/10/25 20:24:13 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.22 2004/11/13 00:19:10 dgp Exp $
*/
#include "tclInt.h"
@@ -31,7 +31,7 @@ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
/*
* 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 @@ typedef struct InterpState {
/*
*----------------------------------------------------------------------
*
- * 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 @@ typedef struct InterpState {
*----------------------------------------------------------------------
*/
-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 @@ TclSaveInterpState(interp, status)
}
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 @@ TclSaveInterpState(interp, status)
*/
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 @@ TclRestoreInterpState(interp, state)
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 @@ TclRestoreInterpState(interp, state)
*/
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 @@ error:
/*
*-------------------------------------------------------------------------
*
- * TclGetReturnOptions --
+ * Tcl_GetReturnOptions --
*
* Packs up the interp state into a dictionary of return options.
*
@@ -1380,7 +1380,7 @@ error:
*/
Tcl_Obj *
-TclGetReturnOptions(interp, result)
+Tcl_GetReturnOptions(interp, result)
Tcl_Interp *interp;
int result;
{
@@ -1423,7 +1423,7 @@ TclGetReturnOptions(interp, result)
/*
*-------------------------------------------------------------------------
*
- * 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 @@ TclGetReturnOptions(interp, result)
*/
int
-TclSetReturnOptions(interp, options)
+Tcl_SetReturnOptions(interp, options)
Tcl_Interp *interp;
Tcl_Obj *options;
{
@@ -1513,8 +1513,8 @@ TclTransferResult(sourceInterp, result, targetInterp)
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);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 36b7247..bfa7d86 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.106 2004/10/27 17:13:58 davygrvy Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.107 2004/11/13 00:19:10 dgp Exp $
*/
#include "tclInt.h"
@@ -941,6 +941,11 @@ TclStubs tclStubs = {
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. */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 24d9450..893f38e 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTrace.c,v 1.19 2004/11/03 17:16:05 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.20 2004/11/13 00:19:10 dgp Exp $
*/
#include "tclInt.h"
@@ -1422,7 +1422,7 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
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 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
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 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
}
iPtr->activeCmdTracePtr = active.nextPtr;
if (state) {
- (void) TclRestoreInterpState(interp, state);
+ (void) Tcl_RestoreInterpState(interp, state);
}
return(traceCode);
}
@@ -1514,7 +1514,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
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 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
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 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
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 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
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 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
}
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 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
}
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 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
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 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
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);
}
}
diff --git a/tests/interp.test b/tests/interp.test
index 3909ef1..53c64e5 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.41 2004/09/14 17:45:37 msofer Exp $
+# RCS: @(#) $Id: interp.test,v 1.42 2004/11/13 00:19:10 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -33,7 +33,7 @@ test interp-1.1 {options for interp command} {
} {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 @@ test interp-1.6 {options for interp command} {
} {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"}}
generated by cgit v0.12 at 2024-07-01 02:46:21 (GMT)