TIP 285 Implementation

1 files changed, 160 insertions, 9 deletions

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.