summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog64
-rw-r--r--doc/Eval.352
-rw-r--r--doc/after.n6
-rw-r--r--doc/interp.n23
-rw-r--r--generic/tcl.decls11
-rw-r--r--generic/tcl.h8
-rw-r--r--generic/tclBasic.c450
-rw-r--r--generic/tclDecls.h24
-rw-r--r--generic/tclEvent.c35
-rw-r--r--generic/tclExecute.c43
-rw-r--r--generic/tclInt.decls7
-rw-r--r--generic/tclInt.h26
-rw-r--r--generic/tclIntDecls.h12
-rw-r--r--generic/tclInterp.c91
-rw-r--r--generic/tclNotify.c4
-rw-r--r--generic/tclParse.c7
-rw-r--r--generic/tclProc.c4
-rw-r--r--generic/tclStubInit.c5
-rw-r--r--generic/tclThreadTest.c169
-rw-r--r--generic/tclTimer.c34
-rw-r--r--tests/cmdAH.test4
-rw-r--r--tests/interp.test10
-rw-r--r--tests/thread.test1194
-rw-r--r--tools/man2help2.tcl4
-rw-r--r--tools/man2tcl.c12
-rw-r--r--win/makefile.vc80
-rw-r--r--win/rules.vc8
-rw-r--r--win/tcl.hpj.in4
-rw-r--r--win/tclWinNotify.c4
-rw-r--r--win/tclWinThrd.c4
30 files changed, 2308 insertions, 91 deletions
diff --git a/ChangeLog b/ChangeLog
index 42e44a3..13abc3b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,67 @@
+2008-06-13 Joe Mistachkin <joe@mistachkin.com>
+
+ TIP #285 IMPLEMENTATION
+
+ * doc/Eval.3: Added documentation for the Tcl_CancelEval and Tcl_Canceled
+ functions and the TCL_CANCEL_UNWIND flag bit.
+ * doc/after.n: Corrected the spelling of 'canceled' in the documentation.
+ * doc/interp.n: Added documentation for [interp cancel].
+ * generic/tcl.decls: Added the Tcl_CancelEval and Tcl_Canceled functions
+ to the stubs table.
+ * generic/tcl.h: Added the TCL_CANCEL_UNWIND flag bit.
+ * generic/tclBasic.c: The bulk of the script cancellation functionality
+ is defined here. Added code to initialize and manage the script
+ cancellation hash table in a thread-safe manner. Reset script
+ cancellation flags prior to increasing the nesting level (if the nesting
+ level is currently zero) and always cooperatively check for script
+ cancellation near the start of TclEvalObjvInternal and after invoking
+ async handlers.
+ * generic/tclDecls.h: Regenerated.
+ * generic/tclEvent.c: Call TclFinalizeEvaluation during finalization to
+ cleanup the script cancellation hash table. During [vwait], always
+ cooperatively check for script cancellation. Corrected the spelling of
+ 'canceled' in comments to be consistent with the documentation.
+ * generic/tclExecute.c: Reset script cancellation flags prior to
+ increasing the nesting level (if the nesting level is currently zero) and
+ always cooperatively check for script cancellation after invoking async
+ handlers. Prevent [catch] from catching script cancellation when the
+ TCL_CANCEL_UNWIND flag is set (similar to the manner used by TIP 143 when
+ a limit has been exceeded).
+ * generic/tclInt.decls: Added TclResetCancellation to the internal stubs
+ table.
+ * generic/tclInt.h: Added asyncCancel and asyncCancelMsg fields to the
+ private Interp structure. Added private interp flag value CANCELED to
+ help control script cancellation.
+ * generic/tclIntDecls.h: Regenerated.
+ * generic/tclInterp.c (Tcl_InterpObjCmd): Added [interp cancel]
+ subcommand.
+ * generic/tclNotify.c (Tcl_DeleteEventSource): Corrected the spelling of
+ 'canceled' in comments to be consistent with the documentation.
+ * generic/tclParse.c: Reset script cancellation flags prior to increasing
+ * generic/tclProc.c: the nesting level (if the nesting level is currently
+ zero) and cooperatively check for script cancellation prior to evaluating
+ commands.
+ * generic/tclStubInit.c: Regenerated.
+ * generic/tclThreadTest.c (Tcl_ThreadObjCmd): Added script cancellation
+ support ([testthread cancel]).
+ Modified [testthread id] to allow querying of the 'main' thread ID.
+ Corrected comments to reflect the actual command syntax. Made [testthread
+ wait] cooperatively check for script cancellation. Added [testthread
+ event] to allow for processing one pending event without blocking.
+ * generic/tclTimer.c: Delay for a maximum of 500 milliseconds prior
+ to checking for async handlers and script cancellation.
+ * tests/cmdAH.test: Changed [interp c] to [interp create].
+ * tests/interp.test: Added and fixed tests for [interp cancel].
+ * tests/thread.test: Added tests for script cancellation via [testthread
+ cancel].
+ * tools/man2help2.tcl: Fixed problems with WinHelp target (see
+ * tools/man2tcl.c: [Bug 1934200], [Bug 1934265], and [Bug 1934272]).
+ * win/makefile.vc: Added 'pdbs' option for Windows build rules to allow
+ * win/rules.vc: for non-debug builds with full symbols.
+ * win/tcl.hpj.in: Corrected version for WinHelp target.
+ * win/tclWinNotify.c: Used SleepEx and WaitForSingleObjectEx on
+ * win/tclWinThrd.c: Windows because they are alertable.
+
2008-06-12 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in: add complete deps on tclDTrace.h.
diff --git a/doc/Eval.3 b/doc/Eval.3
index 79392fc..313406c 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -2,17 +2,18 @@
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
+'\" Copyright (c) 2006-2008 Joe Mistachkin.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: Eval.3,v 1.27 2007/12/13 15:22:31 dgp Exp $
+'\" RCS: @(#) $Id: Eval.3,v 1.28 2008/06/13 05:45:07 mistachkin Exp $
'\"
.so man.macros
-.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
+.TH Tcl_Eval 3 8.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
+Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA, Tcl_CancelEval, Tcl_Canceled \- execute and cancel Tcl scripts
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -43,16 +44,25 @@ int
.sp
int
\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR)
+.sp
+int
+\fBTcl_CancelEval\fR(\fIinterp, clientData, flags\fR)
+.sp
+int
+\fBTcl_Canceled\fR(\fIinterp, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp **termPtr
.AP Tcl_Interp *interp in
-Interpreter in which to execute the script. The interpreter's result is
-modified to hold the result or error message from the script.
+Interpreter in which to execute or cancel the script. The interpreter's
+result is modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in
A Tcl object containing the script to execute.
.AP int flags in
ORed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
+For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently
+supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and
+\fBTCL_CANCEL_UNWIND\fR are currently supported.
.AP "const char" *fileName in
Name of a file containing a Tcl script.
.AP int objc in
@@ -72,6 +82,9 @@ String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
+.AP ClientData clientData in
+Currently, reserved for future use.
+It should be set to NULL.
.BE
.SH DESCRIPTION
@@ -159,6 +172,17 @@ of arguments. \fBTcl_VarEval\fR is now deprecated.
\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that
instead of taking a variable number of arguments it takes an argument
list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated.
+.PP
+\fBTcl_CancelEval\fR cancels or unwinds the script in progress soon after
+the next invocation of asynchronous handlers, causing \fBTCL_ERROR\fR to be
+the return code for that script. This function is thread-safe and may be
+called from any thread in the process.
+.PP
+\fBTcl_Canceled\fR checks if the script in progress has been canceled and
+returns \fBTCL_ERROR\fR if it has. Otherwise, \fBTCL_OK\fR is returned.
+Extensions can use this function to check to see if they should abort a long
+running command. This function is thread sensitive and may only be called
+from the thread the interpreter was created in.
.SH "FLAG BITS"
Any ORed combination of the following values may be used for the
@@ -179,6 +203,22 @@ If this flag is set, the script is processed at global level. This
means that it is evaluated in the global namespace and its variable
context consists of global variables only (it ignores any Tcl
procedures at are active).
+.TP 23
+\fBTCL_CANCEL_UNWIND\fR
+This flag is only used by \fBTcl_CancelEval\fR and \fBTcl_Canceled\fR;
+it is ignored by other procedures. For \fBTcl_CancelEval\fR, if this
+flag is set, the script in progress is canceled and the evaluation
+stack for the interpreter is unwound. For \fBTcl_Canceled\fR, if this
+flag is set, the script in progress is considered to be canceled only
+if the evaluation stack for the interpreter is being unwound.
+.TP 23
+\fBTCL_LEAVE_ERR_MSG\fR
+This flag is only used by \fBTcl_Canceled\fR; it is ignored by
+other procedures. If an error is returned and this bit is set in
+\fIflags\fR, then an error message will be left in the interpreter's
+result, where it can be retrieved with \fBTcl_GetObjResult\fR or
+\fBTcl_GetStringResult\fR. If this flag bit is not set then no error
+message is left and the interpreter's result will not be modified.
.SH "MISCELLANEOUS DETAILS"
.PP
@@ -207,4 +247,4 @@ This means that top-level applications should never see a return code
from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR.
.SH KEYWORDS
-execute, file, global, object, result, script
+cancel, execute, file, global, object, result, script, unwind
diff --git a/doc/after.n b/doc/after.n
index e79cbb9..4e5dfdd 100644
--- a/doc/after.n
+++ b/doc/after.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: after.n,v 1.10 2007/12/13 15:22:32 dgp Exp $
+'\" RCS: @(#) $Id: after.n,v 1.11 2008/06/13 05:45:07 mistachkin Exp $
'\"
.so man.macros
.TH after n 7.5 Tcl "Tcl Built-In Commands"
@@ -67,7 +67,7 @@ This command also cancels the execution of a delayed command.
The \fIscript\fR arguments are concatenated together with space
separators (just as in the \fBconcat\fR command).
If there is a pending command that matches the string, it is
-cancelled and will never be executed; if no such command is
+canceled and will never be executed; if no such command is
currently pending then the \fBafter cancel\fR command has no effect.
.TP
\fBafter idle \fIscript \fR?\fIscript script ...\fR?
@@ -90,7 +90,7 @@ event handlers created by the \fBafter\fR command for this
interpreter.
If \fIid\fR is supplied, it specifies an existing handler;
\fIid\fR must have been the return value from some previous call
-to \fBafter\fR and it must not have triggered yet or been cancelled.
+to \fBafter\fR and it must not have triggered yet or been canceled.
In this case the command returns a list with two elements.
The first element of the list is the script associated
with \fIid\fR, and the second element is either
diff --git a/doc/interp.n b/doc/interp.n
index 5612226..f89594c 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -1,14 +1,15 @@
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2004 Donal K. Fellows
+'\" Copyright (c) 2006-2008 Joe Mistachkin.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: interp.n,v 1.38 2007/12/13 15:22:32 dgp Exp $
+'\" RCS: @(#) $Id: interp.n,v 1.39 2008/06/13 05:45:07 mistachkin Exp $
'\"
.so man.macros
-.TH interp n 7.6 Tcl "Tcl Built-In Commands"
+.TH interp n 8.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
@@ -144,6 +145,22 @@ what to set the interpreter's background error to. See the
\fBBACKGROUND ERROR HANDLING\fR section for more details.
.VE 8.5
.TP
+\fBinterp\fR \fBcancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\fR?
+.VS 8.6
+Cancels the script being evaluated in the interpreter identified by
+\fIpath\fR. Without the \fB\-unwind\fR switch the evaluation stack for
+the interpreter is unwound until an enclosing catch command is found or
+there are no further invocations of the interpreter left on the call
+stack. With the \fB\-unwind\fR switch the evaluation stack for the
+interpreter is unwound without regard to any intervening catch command
+until there are no further invocations of the interpreter left on the
+call stack. The \fB\-\|\-\fR switch can be used to mark the end of
+switches; it may be needed if \fIpath\fR is an unusual value such
+as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the
+error message string; otherwise, a default error message string will be
+used.
+.VE 8.6
+.TP
\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
Creates a slave interpreter identified by \fIpath\fR and a new command,
called a \fIslave command\fR. The name of the slave command is the last
@@ -811,6 +828,6 @@ set i [\fBinterp create\fR]
.CE
.VE 8.5
.SH "SEE ALSO"
-bgerror(n), load(n), safe(n), Tcl_CreateSlave(3)
+bgerror(n), load(n), safe(n), Tcl_CreateSlave(3), Tcl_Eval(3)
.SH KEYWORDS
alias, master interpreter, safe interpreter, slave interpreter
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 3616299..6c9b09a 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -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: tcl.decls,v 1.132 2008/04/02 21:27:44 das Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.133 2008/06/13 05:45:07 mistachkin Exp $
library tcl
@@ -2099,6 +2099,15 @@ declare 579 generic {
void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, CONST char *format, ...)
}
+# TIP #285: Script cancellation support.
+declare 580 generic {
+ int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
+ ClientData clientData, int flags)
+}
+declare 581 generic {
+ int Tcl_Canceled(Tcl_Interp *interp, int flags)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tcl.h b/generic/tcl.h
index a1a61d6..dbf4c52 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.257 2008/05/09 04:58:53 georgeps Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.258 2008/06/13 05:45:07 mistachkin Exp $
*/
#ifndef _TCL
@@ -983,11 +983,15 @@ typedef struct Tcl_DString {
* o Cut out of error traces
* o Don't reset the flags controlling ensemble
* error message rewriting.
+ * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the
+ * stack for the script in progress to be
+ * completely unwound.
*/
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
#define TCL_EVAL_DIRECT 0x40000
#define TCL_EVAL_INVOKE 0x80000
+#define TCL_CANCEL_UNWIND 0x100000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see the man
@@ -1000,6 +1004,8 @@ typedef struct Tcl_DString {
/*
* Flag values passed to variable-related functions.
+ * WARNING: these bit choices must not conflict with the bit choice for
+ * TCL_CANCEL_UNWIND, above.
*/
#define TCL_GLOBAL_ONLY 1
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9210fd7..d0aa8e2 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -10,11 +10,12 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* 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.301 2008/06/08 03:21:31 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.302 2008/06/13 05:45:08 mistachkin Exp $
*/
#include "tclInt.h"
@@ -53,6 +54,8 @@ typedef struct OldMathFuncData {
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName, int flags);
+static int CancelEvalProc(ClientData clientData,
+ Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
static void DeleteInterpProc(Tcl_Interp *interp);
static void DeleteOpCmdClientData(ClientData clientData);
@@ -362,6 +365,56 @@ static int stackGrowsDown = 1;
#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */
/*
+ * This is the script cancellation struct and hash table. The hash table
+ * is used to keep track of the information necessary to process script
+ * cancellation requests, including the original interp, asynchronous handler
+ * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments
+ * passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is
+ * used for protecting calls to Tcl_CancelEval as well as protecting access
+ * to the hash table below.
+ */
+typedef struct {
+ Tcl_Interp *interp; /* Interp this struct belongs to */
+ Tcl_AsyncHandler async; /* Async handler token for script
+ * cancellation */
+ char *result; /* The script cancellation result or
+ * NULL for a default result */
+ int length; /* Length of the above error message */
+ ClientData clientData; /* Ignored */
+ int flags; /* Additional flags */
+} CancelInfo;
+static Tcl_HashTable cancelTable;
+static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(cancelLock)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEvaluation --
+ *
+ * Finalizes the script cancellation hash table.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeEvaluation(void)
+{
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized == 1) {
+ Tcl_DeleteHashTable(&cancelTable);
+ cancelTableInitialized = 0;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
@@ -389,6 +442,9 @@ Tcl_CreateInterp(void)
const OpCmdInfo *opcmdInfoPtr;
const CmdInfo *cmdInfoPtr;
Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+ CancelInfo *cancelInfo;
union {
char c[sizeof(short)];
short s;
@@ -412,6 +468,15 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size");
}
+ if (cancelTableInitialized == 0) {
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized == 0) {
+ Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
+ cancelTableInitialized = 1;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -546,6 +611,25 @@ Tcl_CreateInterp(void)
iPtr->chanMsg = NULL;
/*
+ * TIP #285, Script cancellation support.
+ */
+
+ iPtr->asyncCancelMsg = Tcl_NewObj();
+
+ cancelInfo = (CancelInfo *) ckalloc(sizeof(CancelInfo));
+ cancelInfo->interp = interp;
+
+ iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
+ cancelInfo->async = iPtr->asyncCancel;
+ cancelInfo->result = NULL;
+ cancelInfo->length = 0;
+
+ Tcl_MutexLock(&cancelLock);
+ hPtr = Tcl_CreateHashEntry(&cancelTable, (char *) iPtr, &isNew);
+ Tcl_SetHashValue(hPtr, cancelInfo);
+ Tcl_MutexUnlock(&cancelLock);
+
+ /*
* Initialize the compilation and execution statistics kept for this
* interpreter.
*/
@@ -629,9 +713,6 @@ Tcl_CreateInterp(void)
*/
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
- int isNew;
- Tcl_HashEntry *hPtr;
-
if ((cmdInfoPtr->objProc == NULL)
&& (cmdInfoPtr->compileProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
@@ -1202,6 +1283,7 @@ DeleteInterpProc(
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
+ CancelInfo *cancelInfo;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
@@ -1230,6 +1312,39 @@ DeleteInterpProc(
}
/*
+ * TIP #285, Script cancellation support. Delete this interp from the
+ * global hash table of CancelInfo structs.
+ */
+
+ Tcl_MutexLock(&cancelLock);
+ hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ if (hPtr != NULL) {
+ cancelInfo = (CancelInfo *) Tcl_GetHashValue(hPtr);
+
+ if (cancelInfo != NULL) {
+ if (cancelInfo->result != NULL) {
+ ckfree((char *) cancelInfo->result);
+ cancelInfo->result = NULL;
+ }
+ ckfree((char *) cancelInfo);
+ cancelInfo = NULL;
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ if (iPtr->asyncCancel != NULL) {
+ Tcl_AsyncDelete(iPtr->asyncCancel);
+ iPtr->asyncCancel = NULL;
+ }
+
+ if (iPtr->asyncCancelMsg != NULL) {
+ Tcl_DecrRefCount(iPtr->asyncCancelMsg);
+ iPtr->asyncCancelMsg = NULL;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+
+ /*
* Shut down all limit handler callback scripts that call back into this
* interpreter. Then eliminate all limit handlers for this interpreter.
*/
@@ -2948,6 +3063,59 @@ CallCommandTraces(
return result;
}
+static int
+CancelEvalProc(clientData, interp, code)
+ ClientData clientData; /* Interp to cancel the script in progress. */
+ Tcl_Interp *interp; /* Ignored */
+ int code; /* Current return code from command. */
+{
+ CancelInfo *cancelInfo = (CancelInfo *) clientData;
+ Interp *iPtr;
+
+ if (cancelInfo != NULL) {
+ Tcl_MutexLock(&cancelLock);
+ iPtr = (Interp *) cancelInfo->interp;
+
+ if (iPtr != NULL) {
+ /*
+ * Setting this flag will cause the script in progress to be
+ * canceled as soon as possible. The core honors this flag
+ * at all the necessary places to ensure script cancellation
+ * is responsive. Extensions can check for this flag by
+ * calling Tcl_Canceled and checking if TCL_ERROR is returned
+ * or they can choose to ignore the script cancellation
+ * flag and the associated functionality altogether.
+ */
+ iPtr->flags |= CANCELED;
+
+ /*
+ * Currently, we only care about the TCL_CANCEL_UNWIND flag
+ * from Tcl_CancelEval. We do not want to simply combine all
+ * the flags from original Tcl_CancelEval call with the interp
+ * flags here just in case the caller passed flags that might
+ * cause behaviour unrelated to script cancellation.
+ */
+ if (cancelInfo->flags & TCL_CANCEL_UNWIND) {
+ iPtr->flags |= TCL_CANCEL_UNWIND;
+ }
+
+ /*
+ * Create the result object now so that Tcl_Canceled can avoid
+ * locking the cancelLock mutex.
+ */
+ if (cancelInfo->result != NULL) {
+ Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result,
+ cancelInfo->length);
+ } else {
+ Tcl_SetObjLength(iPtr->asyncCancelMsg, 0);
+ }
+ }
+ Tcl_MutexUnlock(&cancelLock);
+ }
+
+ return code;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -3418,7 +3586,7 @@ TclInterpReady(
*/
if (iPtr->flags & DELETED) {
- Tcl_ResetResult(interp);
+ /* JJM - Superfluous Tcl_ResetResult call removed. */
Tcl_AppendResult(interp,
"attempt to call eval in deleted interpreter", NULL);
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
@@ -3449,6 +3617,260 @@ TclInterpReady(
/*
*----------------------------------------------------------------------
*
+ * TclResetCancellation --
+ *
+ * Reset the script cancellation flags if the nesting level
+ * (iPtr->numLevels) for the interp is zero or argument force is
+ * non-zero.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The script cancellation flags for the interp may be reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclResetCancellation(
+ Tcl_Interp *interp, int force)
+{
+ register Interp *iPtr = (Interp *) interp;
+
+ if (iPtr != NULL) {
+ if (force || (iPtr->numLevels == 0)) {
+ iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND));
+ }
+
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Canceled --
+ *
+ * Check if the script in progress has been canceled, i.e.,
+ * Tcl_CancelEval was called for this interpreter or any of its
+ * master interpreters.
+ *
+ * Results:
+ * The return value is TCL_OK if the script evaluation has not been
+ * canceled, TCL_ERROR otherwise.
+ *
+ * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned
+ * in the interpreter's result object. Otherwise, the interpreter's
+ * result object is left unchanged. If "flags" contains
+ * TCL_CANCEL_UNWIND, TCL_ERROR will only be returned if the script
+ * evaluation is being completely unwound.
+ *
+ * Side effects:
+ * The CANCELED flag for the interp will be reset if it is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Canceled(
+ Tcl_Interp *interp,
+ int flags)
+{
+ register Interp *iPtr = (Interp *) interp;
+ const char *id, *message;
+ int length;
+
+ /*
+ * Traverse up the to the top-level interp, checking for the
+ * CANCELED flag along the way. If any of the intervening
+ * interps have the CANCELED flag set, the current script in
+ * progress is considered to be canceled and we stop checking.
+ * Otherwise, if any interp has the DELETED flag set we stop
+ * checking.
+ */
+ for (; iPtr != NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *)iPtr)) {
+ /*
+ * Has the current script in progress for this interpreter been
+ * canceled or is the stack being unwound due to the previous
+ * script cancellation?
+ */
+ if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) {
+ /*
+ * The CANCELED flag is a one-shot flag that is reset immediately
+ * upon being detected; however, if the TCL_CANCEL_UNWIND flag is
+ * set we will continue to report that the script in progress has
+ * been canceled thereby allowing the evaluation stack for the
+ * interp to be fully unwound.
+ */
+ iPtr->flags &= ~CANCELED;
+
+ /*
+ * The CANCELED flag was detected and reset; however, if the caller
+ * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
+ * (indicating that the script in progress has been canceled) if the
+ * evaluation stack for the interp is being fully unwound.
+ */
+ if (!(flags & TCL_CANCEL_UNWIND) || (iPtr->flags & TCL_CANCEL_UNWIND)) {
+ /*
+ * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
+ * interp's result; otherwise, we leave it alone.
+ */
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ /*
+ * Setup errorCode variables so that we can differentiate between
+ * being canceled and unwound.
+ */
+ if (iPtr->asyncCancelMsg != NULL) {
+ message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ } else {
+ length = 0;
+ }
+
+ if (iPtr->flags & TCL_CANCEL_UNWIND) {
+ id = "IUNWIND";
+ if (length == 0) {
+ message = "eval unwound";
+ }
+ } else {
+ id = "ICANCEL";
+ if (length == 0) {
+ message = "eval canceled";
+ }
+ }
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, NULL);
+ Tcl_SetErrorCode(interp, "TCL", id, message, NULL);
+ }
+
+ /*
+ * Return TCL_ERROR to the caller (not necessarily just the Tcl core
+ * itself) that indicates further processing of the script or command
+ * in progress should halt gracefully and as soon as possible.
+ */
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * FIXME: If this interpreter is being deleted we cannot continue to
+ * traverse up the interp chain due to an issue with
+ * Tcl_GetMaster (really the slave interp bookkeeping) that
+ * causes us to run off into a freed interp struct. Ideally,
+ * this check would not be necessary because Tcl_GetMaster
+ * would return NULL instead of a pointer to invalid (freed)
+ * memory.
+ */
+ if (iPtr->flags & DELETED) {
+ break;
+ }
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CancelEval --
+ *
+ * This function schedules the cancellation of the current script in
+ * the given interpreter.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as TCL_OK or
+ * TCL_ERROR. Since the interp may belong to a different thread, no
+ * error message can be left in the interp's result.
+ *
+ * Side effects:
+ * The script in progress in the specified interpreter will be
+ * canceled with TCL_ERROR after asynchronous handlers are invoked at
+ * the next Tcl_Canceled check.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_CancelEval(
+ Tcl_Interp *interp, /* Interpreter in which to cancel the
+ * script. */
+ Tcl_Obj *resultObjPtr, /* The script cancellation error message
+ * or NULL for a default error message. */
+ ClientData clientData, /* Passed to CancelEvalProc. */
+ int flags) /* Collection of OR-ed bits that control
+ * the cancellation of the script. Only
+ * TCL_CANCEL_UNWIND is currently
+ * supported. */
+{
+ Tcl_HashEntry *hPtr;
+ CancelInfo *cancelInfo;
+ int code;
+ const char *result;
+
+ Tcl_MutexLock(&cancelLock);
+ if (cancelTableInitialized == 1) {
+ if (interp != NULL) {
+ hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+
+ if (hPtr != NULL) {
+ cancelInfo = (CancelInfo *) Tcl_GetHashValue(hPtr);
+
+ if (cancelInfo != NULL) {
+ /*
+ * Populate information needed by the interpreter thread
+ * to fulfill the cancellation request. Currently,
+ * clientData is ignored. If the TCL_CANCEL_UNWIND flags
+ * bit is set, the script in progress is not allowed to
+ * catch the script cancellation because the evaluation
+ * stack for the interp is completely unwound.
+ */
+ if (resultObjPtr != NULL) {
+ result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
+ cancelInfo->result = ckrealloc(cancelInfo->result,
+ cancelInfo->length);
+ memcpy((void *) cancelInfo->result, (void *) result,
+ (size_t) cancelInfo->length);
+ Tcl_DecrRefCount(resultObjPtr); /* discard their result object. */
+ } else {
+ cancelInfo->result = NULL;
+ cancelInfo->length = 0;
+ }
+
+ cancelInfo->clientData = clientData;
+ cancelInfo->flags = flags;
+
+ Tcl_AsyncMark(cancelInfo->async);
+ code = TCL_OK;
+ } else {
+ /* the CancelInfo for this interp is invalid */
+ code = TCL_ERROR;
+ }
+ } else {
+ /* no CancelInfo for this interp */
+ code = TCL_ERROR;
+ }
+ } else {
+ /* a valid interp must be supplied */
+ code = TCL_ERROR;
+ }
+ } else {
+ /*
+ * No CancelInfo hash table (Tcl_CreateInterp
+ * has never been called?)
+ */
+ code = TCL_ERROR;
+ }
+ Tcl_MutexUnlock(&cancelLock);
+
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclEvalObjvInternal
*
* This function evaluates a Tcl command that has already been parsed
@@ -3509,6 +3931,10 @@ TclEvalObjvInternal(
return TCL_ERROR;
}
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
if (objc == 0) {
return TCL_OK;
}
@@ -3656,6 +4082,9 @@ TclEvalObjvInternal(
if (TclAsyncReady(iPtr)) {
code = Tcl_AsyncInvoke(interp, code);
}
+ if (code == TCL_OK && Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ code = TCL_ERROR;
+ }
if (code == TCL_OK && TclLimitReady(iPtr->limit)) {
code = Tcl_LimitCheck(interp);
}
@@ -3786,6 +4215,8 @@ TclEvalObjvInternal(
TclGetString(objv[0]), "\"", NULL);
code = TCL_ERROR;
} else {
+ TclResetCancellation(interp, 0);
+
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, newObjc, newObjv, command,
length, 0);
@@ -3841,6 +4272,8 @@ Tcl_EvalObjv(
Interp *iPtr = (Interp *) interp;
int code = TCL_OK;
+ TclResetCancellation(interp, 0);
+
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags);
iPtr->numLevels--;
@@ -4293,6 +4726,9 @@ TclEvalEx(
eeFramePtr->line = lines;
iPtr->cmdFramePtr = eeFramePtr;
+
+ TclResetCancellation(interp, 0);
+
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objectsUsed, objv,
parsePtr->commandStart, parsePtr->commandSize, 0);
@@ -5165,6 +5601,10 @@ TclObjInvoke(
return TCL_ERROR;
}
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index aee0e79..a09429a 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.133 2008/04/08 14:54:52 das Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.134 2008/06/13 05:45:09 mistachkin Exp $
*/
#ifndef _TCLDECLS
@@ -3501,6 +3501,18 @@ EXTERN Tcl_Obj * Tcl_ObjPrintf (CONST char * format, ...);
EXTERN void Tcl_AppendPrintfToObj (Tcl_Obj * objPtr,
CONST char * format, ...);
#endif
+#ifndef Tcl_CancelEval_TCL_DECLARED
+#define Tcl_CancelEval_TCL_DECLARED
+/* 580 */
+EXTERN int Tcl_CancelEval (Tcl_Interp * interp,
+ Tcl_Obj * resultObjPtr,
+ ClientData clientData, int flags);
+#endif
+#ifndef Tcl_Canceled_TCL_DECLARED
+#define Tcl_Canceled_TCL_DECLARED
+/* 581 */
+EXTERN int Tcl_Canceled (Tcl_Interp * interp, int flags);
+#endif
typedef struct TclStubHooks {
CONST struct TclPlatStubs *tclPlatStubs;
@@ -4140,6 +4152,8 @@ typedef struct TclStubs {
int (*tcl_AppendFormatToObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST char * format, int objc, Tcl_Obj * CONST objv[]); /* 577 */
Tcl_Obj * (*tcl_ObjPrintf) (CONST char * format, ...); /* 578 */
void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */
+ int (*tcl_CancelEval) (Tcl_Interp * interp, Tcl_Obj * resultObjPtr, ClientData clientData, int flags); /* 580 */
+ int (*tcl_Canceled) (Tcl_Interp * interp, int flags); /* 581 */
} TclStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6532,6 +6546,14 @@ extern CONST TclStubs *tclStubsPtr;
#define Tcl_AppendPrintfToObj \
(tclStubsPtr->tcl_AppendPrintfToObj) /* 579 */
#endif
+#ifndef Tcl_CancelEval
+#define Tcl_CancelEval \
+ (tclStubsPtr->tcl_CancelEval) /* 580 */
+#endif
+#ifndef Tcl_Canceled
+#define Tcl_Canceled \
+ (tclStubsPtr->tcl_Canceled) /* 581 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 7a7dbd8..836d958 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.81 2008/04/27 22:21:29 dkf Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.82 2008/06/13 05:45:10 mistachkin Exp $
*/
#include "tclInt.h"
@@ -571,7 +571,7 @@ TclGetBgErrorHandler(
*
* Side effects:
* Background error information is freed: if there were any pending error
- * reports, they are cancelled.
+ * reports, they are canceled.
*
*----------------------------------------------------------------------
*/
@@ -643,7 +643,7 @@ Tcl_CreateExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -719,7 +719,7 @@ Tcl_CreateThreadExitHandler(
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
- * it is cancelled; if no such handler exists then nothing happens.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -980,6 +980,7 @@ Tcl_Finalize(void)
* after the exit handlers, because there are order dependencies.
*/
+ TclFinalizeEvaluation();
TclFinalizeExecution();
TclFinalizeEnvironment();
@@ -1246,7 +1247,12 @@ Tcl_VwaitObjCmd(
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ break;
+ }
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "limit exceeded", NULL);
break;
}
}
@@ -1254,20 +1260,24 @@ Tcl_VwaitObjCmd(
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
- /*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
- */
-
- Tcl_ResetResult(interp);
if (!foundEvent) {
+ Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", NULL);
return TCL_ERROR;
}
if (!done) {
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ /*
+ * The interpreter's result was already set to the right error
+ * message prior to exiting the loop above.
+ */
return TCL_ERROR;
+ } else {
+ /*
+ * Clear out the interpreter's result, since it may have been
+ * set by event handlers.
+ */
+ Tcl_ResetResult(interp);
}
return TCL_OK;
}
@@ -1337,6 +1347,9 @@ Tcl_UpdateObjCmd(
}
while (Tcl_DoOneEvent(flags) != 0) {
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "limit exceeded", NULL);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5bbc366..6e0d0d3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -9,11 +9,12 @@
* Copyright (c) 2002-2005 by Miguel Sofer.
* Copyright (c) 2005-2007 by Donal K. Fellows.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.372 2008/06/08 03:21:33 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.373 2008/06/13 05:45:10 mistachkin Exp $
*/
#include "tclInt.h"
@@ -1411,12 +1412,19 @@ TclCompEvalObj(
* performance is noticeable.
*/
+ TclResetCancellation(interp, 0);
+
iPtr->numLevels++;
if (TclInterpReady(interp) == TCL_ERROR) {
result = TCL_ERROR;
goto done;
}
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
namespacePtr = iPtr->varFramePtr->nsPtr;
/*
@@ -1880,10 +1888,9 @@ TclExecuteByteCode(
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
*/
-
- if (TclAsyncReady(iPtr)) {
int localResult;
+ if (TclAsyncReady(iPtr)) {
DECACHE_STACK_INFO();
localResult = Tcl_AsyncInvoke(interp, result);
CACHE_STACK_INFO();
@@ -1892,10 +1899,18 @@ TclExecuteByteCode(
goto checkForCatch;
}
}
- if (TclLimitReady(iPtr->limit)) {
- int localResult;
DECACHE_STACK_INFO();
+ localResult = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+
+ if (localResult == TCL_ERROR) {
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ if (TclLimitReady(iPtr->limit)) {
+ DECACHE_STACK_INFO();
localResult = Tcl_LimitCheck(interp);
CACHE_STACK_INFO();
if (localResult == TCL_ERROR) {
@@ -7302,6 +7317,24 @@ TclExecuteByteCode(
}
/*
+ * We must not catch if the script in progress has been canceled with
+ * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we
+ * either hit another interpreter (presumably where the script in
+ * progress has not been canceled) or we get to the top-level. We
+ * do NOT modify the interpreter result here because we know it will
+ * already be set prior to vectoring down to this point in the code.
+ */
+ if (Tcl_Canceled(interp, 0) == TCL_ERROR) {
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... cancel with unwind, returning %s\n",
+ StringForResultCode(result));
+ }
+#endif
+ goto abnormalReturn;
+ }
+
+ /*
* We must not catch an exceeded limit. Instead, it blows outwards
* until we either hit another interpreter (presumably where the limit
* is not exceeded) or we get to the top-level.
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index ccc568f..95354ac 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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: tclInt.decls,v 1.121 2008/01/23 17:31:42 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.122 2008/06/13 05:45:12 mistachkin Exp $
library tcl
@@ -934,6 +934,11 @@ declare 236 generic {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
+# TIP #285: Script cancellation support.
+declare 237 generic {
+ int TclResetCancellation(Tcl_Interp *interp, int force)
+}
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3fe993d..112421d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -9,11 +9,12 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* 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.370 2008/06/06 19:46:37 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.371 2008/06/13 05:45:12 mistachkin Exp $
*/
#ifndef _TCLINT
@@ -1827,6 +1828,18 @@ typedef struct Interp {
* NULL), takes precedence over a POSIX error
* code returned by a channel operation. */
+ /*
+ * TIP #285, Script cancellation support.
+ */
+
+ Tcl_AsyncHandler asyncCancel; /* Async handler token for Tcl_CancelEval. */
+ Tcl_Obj* asyncCancelMsg; /* Error message set by async cancel handler
+ * for the propagation of arbitrary Tcl
+ * errors. This information, if present
+ * (asyncCancelMsg not NULL), takes precedence
+ * over the default error messages returned by
+ * a script cancellation operation. */
+
/* TIP #280 */
CmdFrame *cmdFramePtr; /* Points to the command frame containing
* the location information for the current
@@ -1993,6 +2006,15 @@ typedef struct InterpList {
* of the wrong-num-args string in Tcl_WrongNumArgs.
* Makes it append instead of replacing and uses
* different intermediate text.
+ * CANCELED: Non-zero means that the script in progress should be
+ * canceled as soon as possible. This can be checked by
+ * extensions (and the core itself) by calling
+ * Tcl_Canceled and checking if TCL_ERROR is returned.
+ * This is a one-shot flag that is reset immediately upon
+ * being detected; however, if the TCL_CANCEL_UNWIND flag
+ * is set Tcl_Canceled will continue to report that the
+ * script in progress has been canceled thereby allowing
+ * the evaluation stack for the interp to be fully unwound.
*
* WARNING: For the sake of some extensions that have made use of former
* internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
@@ -2007,6 +2029,7 @@ typedef struct InterpList {
#define INTERP_TRACE_IN_PROGRESS 0x200
#define INTERP_ALTERNATE_WRONG_ARGS 0x400
#define ERR_LEGACY_COPY 0x800
+#define CANCELED 0x1000
/*
* Maximum number of levels of nesting permitted in Tcl commands (used to
@@ -2480,6 +2503,7 @@ MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
MODULE_SCOPE void TclFinalizeEncodingSubsystem(void);
MODULE_SCOPE void TclFinalizeEnvironment(void);
+MODULE_SCOPE void TclFinalizeEvaluation(void);
MODULE_SCOPE void TclFinalizeExecution(void);
MODULE_SCOPE void TclFinalizeIOSubsystem(void);
MODULE_SCOPE void TclFinalizeFilesystem(void);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index c6f8055..c8f788c 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -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: tclIntDecls.h,v 1.115 2008/04/08 14:54:52 das Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.116 2008/06/13 05:45:13 mistachkin Exp $
*/
#ifndef _TCLINTDECLS
@@ -1076,6 +1076,11 @@ EXTERN void TclInitVarHashTable (TclVarHashTable * tablePtr,
EXTERN void TclBackgroundException (Tcl_Interp * interp,
int code);
#endif
+#ifndef TclResetCancellation_TCL_DECLARED
+#define TclResetCancellation_TCL_DECLARED
+/* 237 */
+EXTERN int TclResetCancellation (Tcl_Interp * interp, int force);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1342,6 +1347,7 @@ typedef struct TclIntStubs {
Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
+ int (*tclResetCancellation) (Tcl_Interp * interp, int force); /* 237 */
} TclIntStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -2086,6 +2092,10 @@ extern CONST TclIntStubs *tclIntStubsPtr;
#define TclBackgroundException \
(tclIntStubsPtr->tclBackgroundException) /* 236 */
#endif
+#ifndef TclResetCancellation
+#define TclResetCancellation \
+ (tclIntStubsPtr->tclResetCancellation) /* 237 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 8de5983..05a2609 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.84 2008/05/30 22:54:29 dkf Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.85 2008/06/13 05:45:13 mistachkin Exp $
*/
#include "tclInt.h"
@@ -557,19 +557,19 @@ Tcl_InterpObjCmd(
{
int index;
static const char *options[] = {
- "alias", "aliases", "bgerror", "create",
- "delete", "eval", "exists", "expose",
- "hide", "hidden", "issafe", "invokehidden",
- "limit", "marktrusted", "recursionlimit","slaves",
- "share", "target", "transfer",
+ "alias", "aliases", "bgerror", "cancel",
+ "create", "delete", "eval", "exists",
+ "expose", "hide", "hidden", "issafe",
+ "invokehidden", "limit", "marktrusted", "recursionlimit",
+ "slaves", "share", "target", "transfer",
NULL
};
enum option {
- 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
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
+ 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
};
if (objc < 2) {
@@ -638,6 +638,75 @@ Tcl_InterpObjCmd(
}
return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
}
+ case OPT_CANCEL: {
+ int i, flags;
+ Tcl_Interp *slaveInterp;
+ Tcl_Obj *resultObjPtr;
+ static CONST char *options[] = {
+ "-unwind", "--", NULL
+ };
+ enum option {
+ OPT_UNWIND, OPT_LAST
+ };
+
+ if (objc > 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?");
+ return TCL_ERROR;
+ }
+
+ flags = 0;
+
+ for (i = 2; i < objc; i++) {
+ if (TclGetString(objv[i])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum option) index) {
+ case OPT_UNWIND:
+ /*
+ * The evaluation stack in the target interp is to be
+ * unwound.
+ */
+ flags |= TCL_CANCEL_UNWIND;
+ break;
+ case OPT_LAST:
+ i++;
+ goto endOfForLoop;
+ }
+ }
+
+ endOfForLoop:
+
+ /*
+ * Did they specify a slave interp to cancel the script in
+ * progress in? If not, use the current interp.
+ */
+
+ if (i < objc) {
+ slaveInterp = GetInterp(interp, objv[i]);
+ i++;
+ } else {
+ slaveInterp = interp;
+ }
+
+ if (slaveInterp != NULL) {
+ if (i < objc) {
+ resultObjPtr = objv[i];
+ Tcl_IncrRefCount(resultObjPtr); /* Tcl_CancelEval removes this ref. */
+ i++;
+ } else {
+ resultObjPtr = NULL;
+ }
+
+ return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
+ } else {
+ return TCL_ERROR;
+ }
+ }
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *slavePtr;
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 805845b..0e13379 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNotify.c,v 1.26 2008/04/16 14:29:26 das Exp $
+ * RCS: @(#) $Id: tclNotify.c,v 1.27 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -299,7 +299,7 @@ Tcl_CreateEventSource(
* None.
*
* Side effects:
- * The given event source is cancelled, so its function will never again
+ * The given event source is canceled, so its function will never again
* be called. If no such source exists, nothing happens.
*
*----------------------------------------------------------------------
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 620f54e..126ea4f 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.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: tclParse.c,v 1.64 2008/05/21 20:28:14 dgp Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.65 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -2167,9 +2167,14 @@ TclSubstTokens(
case TCL_TOKEN_COMMAND: {
Interp *iPtr = (Interp *) interp;
+ TclResetCancellation(interp, 0);
+
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
+ code = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
+ }
+ if (code == TCL_OK) {
/* TIP #280: Transfer line information to nested command */
code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
0, line);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 85f49f9..42f65ba 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.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: tclProc.c,v 1.141 2008/06/08 03:21:33 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.142 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -1700,6 +1700,8 @@ TclObjInterpProcCore(
* Invoke the commands in the procedure's body.
*/
+ TclResetCancellation(interp, 0);
+
procPtr->refCount++;
iPtr->numLevels++;
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 463eb55..2765182 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.153 2008/04/16 14:49:29 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.154 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -306,6 +306,7 @@ static const TclIntStubs tclIntStubs = {
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
+ TclResetCancellation, /* 237 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -1099,6 +1100,8 @@ static const TclStubs tclStubs = {
Tcl_AppendFormatToObj, /* 577 */
Tcl_ObjPrintf, /* 578 */
Tcl_AppendPrintfToObj, /* 579 */
+ Tcl_CancelEval, /* 580 */
+ Tcl_Canceled, /* 581 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index e8363da..cbc48de 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -7,11 +7,12 @@
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadTest.c,v 1.24 2006/09/22 14:45:48 dkf Exp $
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.25 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -50,7 +51,7 @@ static struct ThreadSpecificData *threadList;
* The following bit-values are legal for the "flags" field of the
* ThreadSpecificData structure.
*/
-#define TP_Dying 0x001 /* This thread is being cancelled */
+#define TP_Dying 0x001 /* This thread is being canceled */
/*
* An instance of the following structure contains all information that is
@@ -105,6 +106,7 @@ static ThreadEventResult *resultList;
* This is for simple error handling when a thread script exits badly.
*/
+static Tcl_ThreadId mainThreadId;
static Tcl_ThreadId errorThreadId;
static char *errorProcString;
@@ -127,6 +129,8 @@ EXTERN int TclCreateThread(Tcl_Interp *interp, char *script,
EXTERN int TclThreadList(Tcl_Interp *interp);
EXTERN int TclThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
char *script, int wait);
+EXTERN int TclThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
+ char *result, int flags);
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
@@ -161,6 +165,15 @@ int
TclThread_Init(
Tcl_Interp *interp) /* The current Tcl interpreter */
{
+ /*
+ * If the main thread Id has not been set, do it now.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ if ((long) mainThreadId == 0) {
+ mainThreadId = Tcl_GetCurrentThread();
+ }
+ Tcl_MutexUnlock(&threadMutex);
Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd,
(ClientData) NULL, NULL);
@@ -176,10 +189,12 @@ TclThread_Init(
* This procedure is invoked to process the "testthread" Tcl command. See
* the user documentation for details on what it does.
*
+ * thread cancel ?-unwind? id ?result?
* thread create ?-joinable? ?script?
- * thread send id ?-async? script
+ * thread send ?-async? id script
+ * thread event
* thread exit
- * thread info id
+ * thread id ?-main?
* thread names
* thread wait
* thread errorproc proc
@@ -205,12 +220,14 @@ Tcl_ThreadObjCmd(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static const char *threadOptions[] = {
- "create", "exit", "id", "join", "names",
- "send", "wait", "errorproc", NULL
+ "cancel", "create", "event", "exit", "id",
+ "join", "names", "send", "wait", "errorproc",
+ NULL
};
enum options {
- THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
- THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
+ THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
+ THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
+ THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
@@ -235,6 +252,34 @@ Tcl_ThreadObjCmd(
}
switch ((enum options)option) {
+ case THREAD_CANCEL: {
+ long id;
+ char *result;
+ int flags, arg;
+
+ if ((objc < 3) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
+ return TCL_ERROR;
+ }
+ flags = 0;
+ arg = 2;
+ if ((objc == 4) || (objc == 5)) {
+ if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
+ flags = TCL_CANCEL_UNWIND;
+ arg++;
+ }
+ }
+ if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
+ if (arg < objc) {
+ result = Tcl_GetString(objv[arg]);
+ } else {
+ result = NULL;
+ }
+ return TclThreadCancel(interp, (Tcl_ThreadId) id, result, flags);
+ }
case THREAD_CREATE: {
char *script;
int joinable, len;
@@ -293,8 +338,25 @@ Tcl_ThreadObjCmd(
Tcl_ExitThread(0);
return TCL_OK;
case THREAD_ID:
+ if (objc == 2 || objc == 3) {
+ Tcl_Obj *idObj;
+
+ /*
+ * Check if they want the main thread id or the current thread id.
+ */
+
if (objc == 2) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
+ idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
+ } else {
+ if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) {
+ Tcl_MutexLock(&threadMutex);
+ idObj = Tcl_NewLongObj((long) mainThreadId);
+ Tcl_MutexUnlock(&threadMutex);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ }
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
@@ -358,6 +420,14 @@ Tcl_ThreadObjCmd(
script = Tcl_GetString(objv[arg]);
return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
}
+ case THREAD_EVENT: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
+ return TCL_OK;
+ }
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
@@ -381,9 +451,35 @@ Tcl_ThreadObjCmd(
return TCL_OK;
}
case THREAD_WAIT:
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ return TCL_ERROR;
+ }
while (1) {
+
+ /*
+ * If the script has been unwound, bail out immediately. This
+ * does not follow the recommended guidelines for how extensions
+ * should handle the script cancellation functionality because
+ * this is not a "normal" extension. Most extensions do not have
+ * a command that simply enters an infinite Tcl event loop.
+ * Normal extensions should not specify the TCL_CANCEL_UNWIND when
+ * calling Tcl_Canceled to check if the command has been canceled.
+ */
+
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
+ break;
+ }
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
+
+ /*
+ * If we get to this point, we have been canceled by another thread,
+ * which is considered to be an "error".
+ */
+
+ ThreadErrorProc(interp);
+ return TCL_OK;
}
return TCL_OK;
}
@@ -845,6 +941,61 @@ TclThreadSend(
/*
*------------------------------------------------------------------------
*
+ * TclThreadCancel --
+ *
+ * Cancels a script in another thread.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+
+int
+TclThreadCancel(
+ Tcl_Interp *interp, /* The current interpreter. */
+ Tcl_ThreadId id, /* Thread Id of other interpreter. */
+ char *result, /* The result or NULL for default. */
+ int flags) /* Flags for Tcl_CancelEval. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int found;
+ Tcl_ThreadId threadId = (Tcl_ThreadId) id;
+
+ /*
+ * Verify the thread exists.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ found = 0;
+ for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
+ if (tsdPtr->threadId == threadId) {
+ found = 1;
+ break;
+ }
+ }
+ if (!found) {
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_AppendResult(interp, "invalid thread id", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Since Tcl_CancelEval can be safely called from any thread,
+ * we do it now.
+ */
+
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_ResetResult(interp);
+ return Tcl_CancelEval(tsdPtr->interp, Tcl_NewStringObj(result, -1), 0, flags);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
* ThreadEventProc --
*
* Handle the event in the target thread.
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index f7da3c4..db9f6a8 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.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: tclTimer.c,v 1.32 2008/04/27 22:21:32 dkf Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.33 2008/06/13 05:45:14 mistachkin Exp $
*/
#include "tclInt.h"
@@ -130,6 +130,14 @@ static Tcl_ThreadDataKey dataKey;
((long)(t1).usec - (long)(t2).usec)/1000)
/*
+ * The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay.
+ * This is used to limit the maximum lag between interp limit and script
+ * cancellation checks.
+ */
+
+#define TCL_TIME_MAXIMUM_SLICE 500
+
+/*
* Prototypes for functions referenced only in this file:
*/
@@ -980,7 +988,7 @@ Tcl_AfterObjCmd(
*
* Results:
* Standard Tcl result code (with error set if an error occurred due to a
- * time limit being exceeded).
+ * time limit being exceeded or being canceled).
*
* Side effects:
* May adjust the time limit granularity marker.
@@ -1008,6 +1016,14 @@ AfterDelay(
do {
Tcl_GetTime(&now);
+ if (Tcl_AsyncReady()) {
+ if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (iPtr->limit.timeEvent != NULL
&& TCL_TIME_BEFORE(iPtr->limit.time, now)) {
iPtr->limit.granularityTicker = 0;
@@ -1023,6 +1039,9 @@ AfterDelay(
diff = LONG_MAX;
}
#endif
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
+ }
if (diff > 0) {
Tcl_Sleep((long)diff);
}
@@ -1033,9 +1052,20 @@ AfterDelay(
diff = LONG_MAX;
}
#endif
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
+ }
if (diff > 0) {
Tcl_Sleep((long)diff);
}
+ if (Tcl_AsyncReady()) {
+ if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (Tcl_LimitCheck(interp) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 79d7b4f..98b09e9 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.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: cmdAH.test,v 1.58 2008/04/23 15:44:37 dkf Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.59 2008/06/13 05:45:14 mistachkin Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -1472,7 +1472,7 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
interp create simpleInterp
interp create -safe safeInterp
-interp c
+interp create
safeInterp expose file file
test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} {
diff --git a/tests/interp.test b/tests/interp.test
index 2bbd7a3..57a2020 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.55 2008/05/31 11:42:20 dkf Exp $
+# RCS: @(#) $Id: interp.test,v 1.56 2008/06/13 05:45:15 mistachkin Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -31,7 +31,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, bgerror, 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, cancel, 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
} ""
@@ -49,13 +49,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, bgerror, 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, cancel, 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, bgerror, 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, cancel, 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, bgerror, 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, cancel, 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"}}
diff --git a/tests/thread.test b/tests/thread.test
index 9f5562e..97de497 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -6,11 +6,12 @@
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: thread.test,v 1.18 2007/12/13 15:26:07 dgp Exp $
+# RCS: @(#) $Id: thread.test,v 1.19 2008/06/13 05:45:15 mistachkin Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -25,7 +26,8 @@ if {[testConstraint testthread]} {
testthread errorproc ThreadError
proc ThreadError {id info} {
- global threadError
+ global threadId threadError
+ set threadId $id
set threadError $info
}
@@ -40,7 +42,7 @@ test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
} {1 {wrong # args: should be "testthread option ?args?"}}
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
-} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
+} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}}
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
list [threadReap] [llength [testthread names]]
} {1 1}
@@ -253,6 +255,1192 @@ test thread-6.1 {freeing very large object trees in a thread} testthread {
set res
} {0}
+# TIP #285: Script cancellation support
+test thread-7.1 {cancel: args} {testthread} {
+ set x [catch {testthread cancel} msg]
+ list $x $msg
+} {1 {wrong # args: should be "testthread cancel ?-unwind? id ?result?"}}
+test thread-7.2 {cancel: nonint} {testthread} {
+ set x [catch {testthread cancel abc} msg]
+ list $x $msg
+} {1 {expected integer but got "abc"}}
+test thread-7.3 {cancel: bad id} {testthread} {
+ set tid [expr $::tcltest::mainThread + 10]
+ set x [catch {testthread cancel $tid} msg]
+ list $x $msg
+} {1 {invalid thread id}}
+test thread-7.4 {cancel: pure bytecode loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.5 {cancel: pure inside-command loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ set while while
+ $while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ set while while
+ $while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread "the eval was canceled"]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {the eval was canceled}}
+test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ set while while
+ $while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread "the eval was canceled"]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {the eval was canceled}}
+test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread "the eval was unwound"]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {the eval was unwound}}
+test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ set while while
+ $while {1} {
+ # No bytecode at all here...
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread "the eval was unwound"]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {the eval was unwound}}
+test thread-7.12 {cancel: after} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ after 30000
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.13 {cancel: after -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ after 30000
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.14 {cancel: vwait} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ vwait forever
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.15 {cancel: vwait -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ vwait forever
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.16 {cancel: expr} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ expr {[while {1} {incr x}]}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.17 {cancel: expr -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ expr {[while {1} {incr x}]}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.18 {cancel: expr bignum} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ #
+ # TODO: This will not cancel because libtommath
+ # does not check Tcl_Canceled.
+ #
+ expr {2**99999}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.19 {cancel: expr bignum -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ #
+ # TODO: This will not cancel because libtommath
+ # does not check Tcl_Canceled.
+ #
+ expr {2**99999}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.20 {cancel: subst} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ subst {[while {1} {incr x}]}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.21 {cancel: subst -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ subst {[while {1} {incr x}]}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.22 {cancel: slave interp} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ while {1} {}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.23 {cancel: slave interp -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ set i [interp create]
+ interp alias $i testthread {} testthread
+ $i eval {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ set while while; $while {1} {}
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.24 {cancel: nested catch inside pure bytecode loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel $serverthread]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.26 {cancel: send async cancel bad interp path} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ update
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ catch {testthread send $serverthread {interp cancel -- bad}} msg
+ threadReap
+ list [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ $msg
+} {1 {could not find interpreter "bad"}}
+test thread-7.27 {cancel: send async cancel -- switch} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ interp create -- -unwind
+ interp alias -unwind testthread {} testthread
+ interp eval -unwind {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ update
+ }
+ }
+ foobar
+ }
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {interp cancel -- -unwind}]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval canceled}}
+test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {interp cancel}]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {interp cancel}]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.30 {cancel: send async testthread cancel nested catch inside pure bytecode loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {testthread cancel [testthread id]}]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-command loop} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {testthread cancel [testthread id]}]
+ after 1000; # wait for ThreadErrorProc to be called.
+ while {[testthread event]} {}; # force events to service
+ catch {testthread send $serverthread {testthread exit}}
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # No bytecode at all here...
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # No bytecode at all here...
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread cancel -unwind $serverthread]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {interp cancel -unwind}]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {interp cancel -unwind}]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.36 {cancel: send async testthread cancel nested catch inside pure bytecode loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ catch {
+ while {1} {
+ catch {
+ while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+test thread-7.37 {cancel: send async testthread cancel nested catch inside pure inside-command loop -unwind} {testthread} {
+ threadReap
+ unset -nocomplain ::threadError ::threadId ::threadIdStarted
+ set serverthread [testthread create -joinable {
+ proc foobar {} {
+ set catch catch
+ set while while
+ $while {1} {
+ if {![info exists foo]} then {
+ # signal the primary thread that we are ready
+ # to be canceled now (we are running).
+ testthread send [testthread id -main] \
+ [list set ::threadIdStarted [testthread id]]
+ set foo 1
+ }
+ $catch {
+ $while {1} {
+ $catch {
+ $while {1} {
+ # we must call update here because otherwise
+ # the thread cannot even be forced to exit.
+ update
+ }
+ }
+ }
+ }
+ }
+ }
+ foobar
+ }]
+ # wait for other thread to signal "ready to cancel"
+ vwait ::threadIdStarted; after 1000
+ set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}]
+ testthread join $serverthread
+ while {[testthread event]} {}; # force events to service
+ threadReap
+ list $res [expr {[info exists ::threadIdStarted] ? \
+ $::threadIdStarted == $serverthread : 0}] \
+ [expr {[info exists ::threadId] ? \
+ $::threadId == $serverthread : 0}] \
+ [expr {[info exists ::threadError] ? \
+ [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 1 {eval unwound}}
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl
index ff8a520..7791add 100644
--- a/tools/man2help2.tcl
+++ b/tools/man2help2.tcl
@@ -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: man2help2.tcl,v 1.17 2007/12/13 15:28:40 dgp Exp $
+# RCS: @(#) $Id: man2help2.tcl,v 1.18 2008/06/13 05:45:15 mistachkin Exp $
#
# Global variables used by these scripts:
@@ -985,7 +985,7 @@ proc getTwips {arg} {
}
default {
puts stderr "bad units in distance \"$arg\""
- continue
+ return 0
}
}
return $distance
diff --git a/tools/man2tcl.c b/tools/man2tcl.c
index 5743a73..6622a5b 100644
--- a/tools/man2tcl.c
+++ b/tools/man2tcl.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: man2tcl.c,v 1.13 2007/12/13 15:28:40 dgp Exp $
+ * RCS: @(#) $Id: man2tcl.c,v 1.14 2008/06/13 05:45:15 mistachkin Exp $
*/
static char sccsid[] = "@(#) man2tcl.c 1.3 95/08/12 17:34:08";
@@ -197,6 +197,7 @@ DoMacro(
* invocation. */
{
char *p, *end;
+ int quote;
/*
* If there is no macro name, then just skip the whole line.
@@ -234,8 +235,11 @@ DoMacro(
}
QuoteText(p+1, (end-(p+1)));
} else {
- for (end = p+1; (*end != 0) && !isspace(*end); end++) {
- /* Empty loop body. */
+ quote = 0;
+ for (end = p+1; (*end != 0) && (quote || !isspace(*end)); end++) {
+ if (*end == '\'') {
+ quote = !quote;
+ }
}
QuoteText(p, end-p);
}
@@ -346,7 +350,7 @@ DoText(
p += 2;
sscanf(p,"%d",&ch);
- PRINT(("text \\u%04x", ch));
+ PRINT(("text \\u%04x\n", ch));
while(*p&&*p!='\'') p++;
} else if (*p != 0) {
PRINT(("char {\\%c}\n", *p));
diff --git a/win/makefile.vc b/win/makefile.vc
index 27dc974..2ed2e8b 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -13,7 +13,7 @@
# Copyright (c) 2003-2008 Pat Thoyts.
#
#------------------------------------------------------------------------------
-# RCS: @(#) $Id: makefile.vc,v 1.183 2008/06/06 19:46:42 andreas_kupries Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.184 2008/06/13 05:45:15 mistachkin Exp $
#------------------------------------------------------------------------------
# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
@@ -62,10 +62,14 @@ the build instructions.
# makefile. Helpful to avoid problems when the sources are
# refreshed and you rebuild, but can "overbuild" when common
# headers like tclInt.h just get small changes.
-# htmlhtml -- Builds a Windows .chm help file for Tcl and Tk from the
+# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the
# troff manual pages found in $(ROOT)\doc. You need to
# have installed the HTML Help Compiler package from Microsoft
# to produce the .chm file.
+# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from
+# the troff man files found in $(ROOT)\doc. This type of
+# help file is deprecated by Microsoft in favour of html
+# help files (.chm)
#
# 4) Macros usable on the commandline:
# INSTALLDIR=<path>
@@ -423,6 +427,9 @@ cdebug = -O2 $(OPTIMIZATIONS)
!else
cdebug =
!endif
+!if $(SYMBOLS)
+cdebug = $(cdebug) -Zi
+!endif
!else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64"
### Warnings are too many, can't support warnings into errors.
cdebug = -Zi -Od $(DEBUGFLAGS)
@@ -464,6 +471,9 @@ STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES)
ldebug = -debug:full -debugtype:cv
!else
ldebug = -release -opt:ref -opt:icf,3
+!if $(SYMBOLS)
+ldebug = $(ldebug) -debug:full -debugtype:cv
+!endif
!endif
### Declarations common to all linker options
@@ -682,10 +692,76 @@ TkLib
UserCmd
<<
+#-------------------------------------------------------------------------
+# Build the old-style Windows .hlp file
+#-------------------------------------------------------------------------
+
+TCLHLPBASE = $(PROJECT)$(VERSION)
+HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp
+HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt
+DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs
+HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf
+MAN2HELP = $(DOCTMP_DIR)\man2help.tcl
+MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl
+INDEX = $(DOCTMP_DIR)\index.tcl
+BMP = $(DOCTMP_DIR)\feather.bmp
+BMP_NOPATH = feather.bmp
+MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe
+
+winhelp: docsetup $(HELPFILE)
+
+docsetup:
+ @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR)
+
+$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F)
+ @$(CPY) $(TOOLSDIR)\$(@F) $(@D)
+
+$(HELPFILE): $(HELPRTF) $(BMP)
+ cd $(DOCTMP_DIR)
+ start /wait hcrtf.exe -x <<$(PROJECT).hpj
+[OPTIONS]
+COMPRESS=12 Hall Zeck
+LCID=0x409 0x0 0x0 ; English (United States)
+TITLE=Tcl/Tk Reference Manual
+BMROOT=.
+CNT=$(@B).cnt
+HLP=$(@B).hlp
+
+[FILES]
+$(PROJECT).rtf
+
+[WINDOWS]
+main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535)
+
+[CONFIG]
+BrowseButtons()
+CreateButton(1, "Web", ExecFile("http://www.tcl.tk"))
+CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl"))
+CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk"))
+CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/"))
+<<
+ cd $(MAKEDIR)
+ @$(CPY) "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)"
+ @$(CPY) "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)"
+
+$(MAN2TCL): $(TOOLSDIR)\$$(@B).c
+ $(cc32) $(TCL_CFLAGS) -Fo$(@D)\ $(TOOLSDIR)\$(@B).c
+ $(link32) $(conlflags) -out:$@ -stack:16384 $(@D)\man2tcl.obj
+ $(_VC_MANIFEST_EMBED_EXE)
+
+$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\*
+ $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/)
+
install-docs:
!if exist($(CHMFILE))
@echo Installing compiled html help
@$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\"
+!else
+!if exist($(HELPFILE))
+ @echo Installing Windows help
+ @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"
+ @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
+!endif
!endif
#"
diff --git a/win/rules.vc b/win/rules.vc
index 5b5bc71..7017793 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -11,7 +11,7 @@
# Copyright (c) 2003-2007 Patrick Thoyts
#
#------------------------------------------------------------------------------
-# RCS: @(#) $Id: rules.vc,v 1.36 2008/05/15 00:04:11 patthoyts Exp $
+# RCS: @(#) $Id: rules.vc,v 1.37 2008/06/13 05:45:15 mistachkin Exp $
#------------------------------------------------------------------------------
!ifndef _RULES_VC
@@ -252,6 +252,12 @@ DEBUG = 1
!else
DEBUG = 0
!endif
+!if [nmakehlp -f $(OPTS) "pdbs"]
+!message *** Doing pdbs
+SYMBOLS = 1
+!else
+SYMBOLS = 0
+!endif
!if [nmakehlp -f $(OPTS) "profile"]
!message *** Doing profile
PROFILE = 1
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in
index 2a8c94a..3bdccbe 100644
--- a/win/tcl.hpj.in
+++ b/win/tcl.hpj.in
@@ -5,9 +5,9 @@ HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl84.cnt
+CNT=tcl86.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl84.hlp
+HLP=tcl86.hlp
[FILES]
tcl.rtf
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 5f2365d..8d19ba2 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.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: tclWinNotify.c,v 1.22 2008/04/16 14:29:26 das Exp $
+ * RCS: @(#) $Id: tclWinNotify.c,v 1.23 2008/06/13 05:45:15 mistachkin Exp $
*/
#include "tclInt.h"
@@ -584,7 +584,7 @@ Tcl_Sleep(
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
for (;;) {
- Sleep(sleepTime);
+ SleepEx(sleepTime, TRUE);
Tcl_GetTime(&now);
if (now.sec > desired.sec) {
break;
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index f6732b8..6ee0a5e 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.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: tclWinThrd.c,v 1.45 2008/05/09 04:58:55 georgeps Exp $
+ * RCS: @(#) $Id: tclWinThrd.c,v 1.46 2008/06/13 05:45:15 mistachkin Exp $
*/
#include "tclWinInt.h"
@@ -691,7 +691,7 @@ Tcl_ConditionWait(
while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
ResetEvent(tsdPtr->condEvent);
LeaveCriticalSection(&winCondPtr->condLock);
- if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
+ if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, TRUE) == WAIT_TIMEOUT) {
timeout = 1;
}
EnterCriticalSection(&winCondPtr->condLock);
generated by cgit v0.12 at 2024-11-05 01:52:30 (GMT)