TIP 285 Implementation

16 files changed, 876 insertions, 54 deletions

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;
 	    }