summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2003-02-15 20:24:09 (GMT)
committerKevin B Kenny <kennykb@acm.org>2003-02-15 20:24:09 (GMT)
commitc57a31dd4cb2115f456bd86670401d84cfece198 (patch)
treeb5e5798c6c88c51e872ae25e983a8b464b8a4373 /generic
parentd7fea62a694860b20556f09402fa119eb3bc4cdb (diff)
downloadtcl-c57a31dd4cb2115f456bd86670401d84cfece198.zip
tcl-c57a31dd4cb2115f456bd86670401d84cfece198.tar.gz
tcl-c57a31dd4cb2115f456bd86670401d84cfece198.tar.bz2
Fixed Tcl_DeleteEvents not to get a pointer smash when deleting the
last event in the queue. Added test code in 'tcltest' and a new file of test cases 'notify.test' to exercise this functionality; several of the new test cases fail for the original code and pass for the corrected code.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclNotify.c15
-rw-r--r--generic/tclTest.c220
2 files changed, 227 insertions, 8 deletions
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index a9bdebc..d312e6c 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -9,11 +9,12 @@
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 2003 by Kevin B. Kenny. 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: tclNotify.c,v 1.10 2002/12/17 21:35:56 hobbs Exp $
+ * RCS: @(#) $Id: tclNotify.c,v 1.11 2003/02/15 20:24:10 kennykb Exp $
*/
#include "tclInt.h"
@@ -509,15 +510,15 @@ Tcl_DeleteEvents(proc, clientData)
if ((*proc) (evPtr, clientData) == 1) {
if (tsdPtr->firstEventPtr == evPtr) {
tsdPtr->firstEventPtr = evPtr->nextPtr;
- if (evPtr->nextPtr == (Tcl_Event *) NULL) {
- tsdPtr->lastEventPtr = prevPtr;
- }
- if (tsdPtr->markerEventPtr == evPtr) {
- tsdPtr->markerEventPtr = prevPtr;
- }
} else {
prevPtr->nextPtr = evPtr->nextPtr;
}
+ if (evPtr->nextPtr == (Tcl_Event *) NULL) {
+ tsdPtr->lastEventPtr = prevPtr;
+ }
+ if (tsdPtr->markerEventPtr == evPtr) {
+ tsdPtr->markerEventPtr = prevPtr;
+ }
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree((char *) hold);
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 1acbcf0..fe84173 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -9,11 +9,12 @@
* Copyright (c) 1993-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Ajuba Solutions.
+ * Copyright (c) 2003 by Kevin B. Kenny. 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: tclTest.c,v 1.60 2003/02/10 12:50:31 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.61 2003/02/15 20:24:10 kennykb Exp $
*/
#define TCL_TEST
@@ -112,6 +113,16 @@ static int freeCount;
static int exitMainLoop = 0;
/*
+ * Event structure used in testing the event queue management procedures.
+ */
+typedef struct TestEvent {
+ Tcl_Event header; /* Header common to all events */
+ Tcl_Interp* interp; /* Interpreter that will handle the event */
+ Tcl_Obj* command; /* Command to evaluate when the event occurs */
+ Tcl_Obj* tag; /* Tag for this event used to delete it */
+} TestEvent;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
@@ -218,6 +229,15 @@ static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int TesteventObjCmd _ANSI_ARGS_((ClientData unused,
+ Tcl_Interp* interp,
+ int argc,
+ Tcl_Obj *CONST objv[]));
+static int TesteventProc _ANSI_ARGS_((Tcl_Event* event,
+ int flags));
+static int TesteventDeleteProc _ANSI_ARGS_((
+ Tcl_Event* event,
+ ClientData clientData));
static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
@@ -581,6 +601,8 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
@@ -1899,6 +1921,202 @@ TestevalobjvObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * TesteventObjCmd --
+ *
+ * This procedure implements a 'testevent' command. The command
+ * is used to test event queue management.
+ *
+ * The command takes two forms:
+ * - testevent queue name position script
+ * Queues an event at the given position in the queue, and
+ * associates a given name with it (the same name may be
+ * associated with multiple events). When the event comes
+ * to the head of the queue, executes the given script at
+ * global level in the current interp. The position may be
+ * one of 'head', 'tail' or 'mark'.
+ * - testevent delete name
+ * Deletes any events associated with the given name from
+ * the queue.
+ *
+ * Return value:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Manipulates the event queue as directed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TesteventObjCmd( ClientData unused, /* Not used */
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj *CONST objv[] ) /* Parameter vector */
+{
+
+ static CONST char* subcommands[] = { /* Possible subcommands */
+ "queue",
+ "delete",
+ NULL
+ };
+ int subCmdIndex; /* Index of the chosen subcommand */
+ static CONST char* positions[] = { /* Possible queue positions */
+ "head",
+ "tail",
+ "mark",
+ NULL
+ };
+ int posIndex; /* Index of the chosen position */
+ static CONST int posNum[] = { /* Interpretation of the chosen position */
+ TCL_QUEUE_HEAD,
+ TCL_QUEUE_TAIL,
+ TCL_QUEUE_MARK
+ };
+ TestEvent* ev; /* Event to be queued */
+
+ if ( objc < 2 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" );
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand",
+ TCL_EXACT, &subCmdIndex ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ switch ( subCmdIndex ) {
+ case 0: /* queue */
+ if ( objc != 5 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "name position script" );
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetIndexFromObj( interp, objv[3], positions,
+ "position specifier", TCL_EXACT,
+ &posIndex ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ ev = (TestEvent*) ckalloc( sizeof( TestEvent ) );
+ ev->header.proc = TesteventProc;
+ ev->header.nextPtr = NULL;
+ ev->interp = interp;
+ ev->command = objv[ 4 ];
+ Tcl_IncrRefCount( ev->command );
+ ev->tag = objv[ 2 ];
+ Tcl_IncrRefCount( ev->tag );
+ Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] );
+ break;
+
+ case 1: /* delete */
+ if ( objc != 3 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "name" );
+ return TCL_ERROR;
+ }
+ Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] );
+ break;
+ }
+
+ return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TesteventProc --
+ *
+ * Delivers a test event to the Tcl interpreter as part of event
+ * queue testing.
+ *
+ * Results:
+ * Returns 1 if the event has been serviced, 0 otherwise.
+ *
+ * Side effects:
+ * Evaluates the event's callback script, so has whatever
+ * side effects the callback has. The return value of the
+ * callback script becomes the return value of this function.
+ * If the callback script reports an error, it is reported as
+ * a background error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TesteventProc( Tcl_Event* event, /* Event to deliver */
+ int flags ) /* Current flags for Tcl_ServiceEvent */
+{
+ TestEvent * ev = (TestEvent *) event;
+ Tcl_Interp* interp = ev->interp;
+ Tcl_Obj* command = ev->command;
+ int result = Tcl_EvalObjEx( interp, command,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT );
+ int retval;
+ if ( result != TCL_OK ) {
+ Tcl_AddErrorInfo( interp,
+ " (command bound to \"testevent\" callback)" );
+ Tcl_BackgroundError( interp );
+ return 1; /* Avoid looping on errors */
+ }
+ if ( Tcl_GetBooleanFromObj( interp,
+ Tcl_GetObjResult( interp ),
+ &retval ) != TCL_OK ) {
+ Tcl_AddErrorInfo( interp,
+ " (return value from \"testevent\" callback)" );
+ Tcl_BackgroundError( interp );
+ return 1;
+ }
+ if ( retval ) {
+ Tcl_DecrRefCount( ev->tag );
+ Tcl_DecrRefCount( ev->command );
+ }
+
+ return retval;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TesteventDeleteProc --
+ *
+ * Removes some set of events from the queue.
+ *
+ * This procedure is used as part of testing event queue management.
+ *
+ * Results:
+ * Returns 1 if a given event should be deleted, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TesteventDeleteProc( Tcl_Event* event, /* Event to examine */
+ ClientData clientData ) /* Tcl_Obj containing the name
+ * of the event(s) to remove */
+{
+ TestEvent* ev; /* Event to examine */
+ char* evNameStr;
+ Tcl_Obj* targetName; /* Name of the event(s) to delete */
+ char* targetNameStr;
+
+ if ( event->proc != TesteventProc ) {
+ return 0;
+ }
+ targetName = (Tcl_Obj*) clientData;
+ targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL );
+ ev = (TestEvent*) event;
+ evNameStr = Tcl_GetStringFromObj( ev->tag, NULL );
+ if ( strcmp( evNameStr, targetNameStr ) == 0 ) {
+ Tcl_DecrRefCount( ev->tag );
+ Tcl_DecrRefCount( ev->command );
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestexithandlerCmd --
*
* This procedure implements the "testexithandler" command. It is