diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclNotify.c | 15 | ||||
| -rw-r--r-- | generic/tclTest.c | 220 | ||||
| -rwxr-xr-x | tests/notify.test | 326 |
4 files changed, 565 insertions, 8 deletions
@@ -1,3 +1,15 @@ +2003-02-15 Kevin Kenny <kennykb@users.sourceforge.net> + + * tests/notify.test (new-file): + * generic/tclTest.c (TclTest_Init, EventtestObjCmd, EventtestProc, + EventTestDeleteProc): + * generic/tclNotify.c (Tcl_DeleteEvents): 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. + 2003-02-14 Jeff Hobbs <jeffh@ActiveState.com> * README: Bumped to version 8.4.2. 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 diff --git a/tests/notify.test b/tests/notify.test new file mode 100755 index 0000000..dcf4e09 --- /dev/null +++ b/tests/notify.test @@ -0,0 +1,326 @@ +# -*- tcl -*-
+#
+# notify.test --
+#
+# This file tests several functions in the file, 'generic/tclNotify.c'.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# 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: notify.test,v 1.1 2003/02/15 20:24:11 kennykb Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+testConstraint testevent [llength [info commands testevent]]
+
+test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {one}
+
+test notify-1.2 {Tcl_QueueEvent and delivery of events in order} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent queue three tail {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {one two three}
+
+test notify-1.3 {Tcl_QueueEvent at head} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one head {lappend delivered one; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result one
+
+test notify-1.4 {Tcl_QueueEvent multiple events at head} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one head {lappend delivered one; expr 1}
+ testevent queue two head {lappend delivered two; expr 1}
+ testevent queue three head {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {three two one}
+
+test notify-1.5 {Tcl_QueueEvent marker event into an empty queue} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result one
+
+test notify-1.6 {Tcl_QueueEvent first marker event in a nonempty queue} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent queue three head {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {three two one}
+
+test notify-1.7 {Tcl_QueueEvent second marker event} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {one two}
+
+test notify-1.8 {Tcl_QueueEvent preexisting event following second marker} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent queue three mark {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {one three two}
+
+test notify-2.1 {remove sole element, don't replace } \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent delete one
+ vwait done
+ set delivered
+ } \
+ -result {}
+
+test notify-2.2 {remove and replace sole element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent delete one
+ testevent queue two tail {lappend delivered two; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result two
+
+test notify-2.3 {remove first element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent delete one
+ vwait done
+ set delivered
+ } \
+ -result {two}
+
+test notify-2.4 {remove and replace first element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent delete one
+ testevent queue three head {lappend delivered three; expr 1};
+ vwait done
+ set delivered
+ } \
+ -result {three two}
+
+test notify-2.5 {remove last element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent delete two
+ vwait done
+ set delivered
+ } \
+ -result {one}
+
+
+test notify-2.6 {remove and replace last element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent delete two
+ testevent queue three tail {lappend delivered three; expr 1};
+ vwait done
+ set delivered
+ } \
+ -result {one three}
+
+test notify-2.7 {remove a middle element} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one tail {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent queue three tail {lappend delivered three; expr 1}
+ testevent delete two
+ vwait done
+ set delivered
+ } \
+ -result {one three}
+
+test notify-2.8 {remove a marker event that's the sole event in the queue} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent delete one
+ vwait done
+ set delivered
+ } \
+ -result {}
+
+test notify-2.9 {remove and replace a marker event that's the sole event} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent delete one
+ testevent queue two mark {lappend delivered two; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result two
+
+test notify-2.10 {remove marker event from head} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent delete one
+ vwait done
+ set delivered
+ } \
+ -result two
+
+test notify-2.11 {remove and replace marker event at head} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two tail {lappend delivered two; expr 1}
+ testevent delete one
+ testevent queue three mark {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {three two}
+
+test notify-2.12 {remove marker event at tail} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent delete two
+ vwait done
+ set delivered
+ } \
+ -result {one}
+
+test notify-2.13 {remove and replace marker event at tail} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent delete two
+ testevent queue three mark {lappend delivered three; expr 1}
+ vwait done
+ set delivered
+ } \
+ -result {one three}
+
+test notify-2.14 {remove marker event from middle} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent queue three mark {lappend delivered three; expr 1}
+ testevent delete two
+ vwait done
+ set delivered
+ } \
+ -result {one three}
+
+test notify-2.15 {remove and replace marker event at middle} \
+ -constraints {testevent} \
+ -body {
+ set delivered {}
+ after 10 set done 1
+ testevent queue one mark {lappend delivered one; expr 1}
+ testevent queue two mark {lappend delivered two; expr 1}
+ testevent queue three tail {lappend delivered three; expr 1}
+ testevent delete two
+ testevent queue four mark {lappend delivered four; expr 1};
+ vwait done
+ set delivered
+ } \
+ -result {one four three}
+
+# cleanup
+::tcltest::cleanupTests
+return
|