aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSteve Bennett <steveb@workware.net.au>2010-09-16 10:01:27 +1000
committerSteve Bennett <steveb@workware.net.au>2010-10-15 11:02:54 +1000
commitb4a77b8c3c18870009b5a2c193a1772552b5e4b5 (patch)
tree10bc85e5e1a702f07547b6cd0ee8fc077d03cd99
parent1f3eccbfe50172710a1190bd1d13f03778d587a1 (diff)
downloadjimtcl-b4a77b8c3c18870009b5a2c193a1772552b5e4b5.zip
jimtcl-b4a77b8c3c18870009b5a2c193a1772552b5e4b5.tar.gz
jimtcl-b4a77b8c3c18870009b5a2c193a1772552b5e4b5.tar.bz2
eventloop improvements and enhancements
Move Jim_EvalObjBackground() out of the core to eventloop Time events are now kept and triggered in time order Time handlers are removed before execution Add 'update' Add 'after info' and 'after idle' Include time events in the return from Jim_ProcessEvents() Add Tcl eventloop tests Signed-off-by: Steve Bennett <steveb@workware.net.au>
-rw-r--r--jim-aio.c2
-rw-r--r--jim-eventloop.c312
-rw-r--r--jim-eventloop.h1
-rw-r--r--jim.c36
-rw-r--r--jim.h5
-rw-r--r--jim_tcl.txt156
-rw-r--r--tests/event.test117
-rw-r--r--tests/testing.tcl15
-rw-r--r--tests/timer.test455
9 files changed, 887 insertions, 212 deletions
diff --git a/jim-aio.c b/jim-aio.c
index 666cc1e..6f08993 100644
--- a/jim-aio.c
+++ b/jim-aio.c
@@ -4,7 +4,7 @@
* Copyright 2005 Salvatore Sanfilippo <antirez@invece.org>
* Copyright 2005 Clemens Hintze <c.hintze@gmx.net>
* Copyright 2005 patthoyts - Pat Thoyts <patthoyts@users.sf.net>
- * Copyright 2008 oharboe - o/yvind Harboe - oyvind.harboe@zylin.com
+ * Copyright 2008 oharboe - Øyvind Harboe - oyvind.harboe@zylin.com
* Copyright 2008 Andrew Lunn <andrew@lunn.ch>
* Copyright 2008 Duane Ellis <openocd@duaneellis.com>
* Copyright 2008 Uwe Klein <uklein@klein-messgeraete.de>
diff --git a/jim-eventloop.c b/jim-eventloop.c
index 0f34dd3..992b607 100644
--- a/jim-eventloop.c
+++ b/jim-eventloop.c
@@ -4,7 +4,7 @@
* Copyright 2005 Salvatore Sanfilippo <antirez@invece.org>
* Copyright 2005 Clemens Hintze <c.hintze@gmx.net>
* Copyright 2005 patthoyts - Pat Thoyts <patthoyts@users.sf.net>
- * Copyright 2008 oharboe - Øyvind Harboe - oyvind.harboe@zylin.com
+ * Copyright 2008 oharboe - Øyvind Harboe - oyvind.harboe@zylin.com
* Copyright 2008 Andrew Lunn <andrew@lunn.ch>
* Copyright 2008 Duane Ellis <openocd@duaneellis.com>
* Copyright 2008 Uwe Klein <uklein@klein-messgeraete.de>
@@ -91,8 +91,49 @@ typedef struct Jim_EventLoop
jim_wide timeEventNextId;
Jim_FileEvent *fileEventHead;
Jim_TimeEvent *timeEventHead;
+ int suppress_bgerror; /* bgerror returned break, so don't call it again */
} Jim_EventLoop;
+static void JimAfterTimeHandler(Jim_Interp *interp, void *clientData);
+static void JimAfterTimeEventFinalizer(Jim_Interp *interp, void *clientData);
+
+int Jim_EvalObjBackground(Jim_Interp *interp, Jim_Obj *scriptObjPtr)
+{
+ Jim_EventLoop *eventLoop = Jim_GetAssocData(interp, "eventloop");
+ Jim_CallFrame *savedFramePtr;
+ int retval;
+
+ savedFramePtr = interp->framePtr;
+ interp->framePtr = interp->topFramePtr;
+ retval = Jim_EvalObj(interp, scriptObjPtr);
+ interp->framePtr = savedFramePtr;
+ /* Try to report the error (if any) via the bgerror proc */
+ if (retval != JIM_OK && !eventLoop->suppress_bgerror) {
+ Jim_Obj *objv[2];
+ int rc = JIM_ERR;
+
+ objv[0] = Jim_NewStringObj(interp, "bgerror", -1);
+ objv[1] = Jim_GetResult(interp);
+ Jim_IncrRefCount(objv[0]);
+ Jim_IncrRefCount(objv[1]);
+ if (Jim_GetCommand(interp, objv[0], JIM_NONE) == NULL || (rc = Jim_EvalObjVector(interp, 2, objv)) != JIM_OK) {
+ if (rc == JIM_BREAK) {
+ /* No more bgerror calls */
+ eventLoop->suppress_bgerror++;
+ }
+ else {
+ /* Report the error to stderr. */
+ fprintf(stderr, "Background error:" JIM_NL);
+ Jim_PrintErrorMessage(interp);
+ }
+ }
+ Jim_DecrRefCount(interp, objv[0]);
+ Jim_DecrRefCount(interp, objv[1]);
+ }
+ return retval;
+}
+
+
void Jim_CreateFileHandler(Jim_Interp *interp, FILE * handle, int mask,
Jim_FileProc * proc, void *clientData, Jim_EventFinalizerProc * finalizerProc)
{
@@ -147,7 +188,7 @@ jim_wide Jim_CreateTimeHandler(Jim_Interp *interp, jim_wide milliseconds,
{
Jim_EventLoop *eventLoop = Jim_GetAssocData(interp, "eventloop");
jim_wide id = eventLoop->timeEventNextId++;
- Jim_TimeEvent *te;
+ Jim_TimeEvent *te, *e, *prev;
long cur_sec, cur_ms;
JimGetTime(&cur_sec, &cur_ms);
@@ -165,61 +206,117 @@ jim_wide Jim_CreateTimeHandler(Jim_Interp *interp, jim_wide milliseconds,
te->timeProc = proc;
te->finalizerProc = finalizerProc;
te->clientData = clientData;
+
+ /* Add to the appropriate place in the list */
+ if (eventLoop->timeEventHead) {
+ prev = NULL;
+ for (e = eventLoop->timeEventHead; e; e = e->next) {
+ if (te->when_sec < e->when_sec || (te->when_sec == e->when_sec && te->when_ms < e->when_ms)) {
+ break;
+ }
+ prev = e;
+ }
+ if (prev) {
+ te->next = prev->next;
+ prev->next = te;
+ return id;
+ }
+ }
+
te->next = eventLoop->timeEventHead;
eventLoop->timeEventHead = te;
+
return id;
}
-jim_wide Jim_DeleteTimeHandler(Jim_Interp *interp, jim_wide id)
+static jim_wide JimParseAfterId(Jim_Obj *idObj)
{
- Jim_TimeEvent *te, *prev = NULL;
- Jim_EventLoop *eventLoop = Jim_GetAssocData(interp, "eventloop");
- long cur_sec, cur_ms;
- jim_wide remain;
+ int len;
+ const char *tok = Jim_GetString(idObj, &len);
+ jim_wide id;
- JimGetTime(&cur_sec, &cur_ms);
+ if (strncmp(tok, "after#", 6) == 0 && Jim_StringToWide(tok + 6, &id, 10) == JIM_OK) {
+ /* Got an event by id */
+ return id;
+ }
+ return -1;
+}
- te = eventLoop->timeEventHead;
- if (id >= eventLoop->timeEventNextId) {
- return -2; /* wrong event ID */
+static jim_wide JimFindAfterByScript(Jim_EventLoop *eventLoop, Jim_Obj *scriptObj)
+{
+ Jim_TimeEvent *te;
+
+ for (te = eventLoop->timeEventHead; te; te = te->next) {
+ /* Is this an 'after' event? */
+ if (te->timeProc == JimAfterTimeHandler) {
+ if (Jim_StringCompareObj(scriptObj, te->clientData, 0) == 0) {
+ return te->id;
+ }
+ }
}
- while (te) {
+ return -1; /* NO event with the specified ID found */
+}
+
+static Jim_TimeEvent *JimFindTimeHandlerById(Jim_EventLoop *eventLoop, jim_wide id)
+{
+ Jim_TimeEvent *te;
+
+ for (te = eventLoop->timeEventHead; te; te = te->next) {
if (te->id == id) {
- remain = (te->when_sec - cur_sec) * 1000;
- remain += (te->when_ms - cur_ms);
- remain = (remain < 0) ? 0 : remain;
+ return te;
+ }
+ }
+ return NULL;
+}
+
+static Jim_TimeEvent *Jim_RemoveTimeHandler(Jim_EventLoop *eventLoop, jim_wide id)
+{
+ Jim_TimeEvent *te, *prev = NULL;
+ for (te = eventLoop->timeEventHead; te; te = te->next) {
+ if (te->id == id) {
if (prev == NULL)
eventLoop->timeEventHead = te->next;
else
prev->next = te->next;
- if (te->finalizerProc)
- te->finalizerProc(interp, te->clientData);
- Jim_Free(te);
- return remain;
+ return te;
}
prev = te;
- te = te->next;
}
- return -1; /* NO event with the specified ID found */
+ return NULL;
}
-/* Search the first timer to fire.
- * This operation is useful to know how many time the select can be
- * put in sleep without to delay any event.
- * If there are no timers NULL is returned. */
-static Jim_TimeEvent *JimSearchNearestTimer(Jim_EventLoop * eventLoop)
+static void Jim_FreeTimeHandler(Jim_Interp *interp, Jim_TimeEvent *te)
{
- Jim_TimeEvent *te = eventLoop->timeEventHead;
- Jim_TimeEvent *nearest = NULL;
+ if (te->finalizerProc)
+ te->finalizerProc(interp, te->clientData);
+ Jim_Free(te);
+}
- while (te) {
- if (!nearest || te->when_sec < nearest->when_sec ||
- (te->when_sec == nearest->when_sec && te->when_ms < nearest->when_ms))
- nearest = te;
- te = te->next;
+jim_wide Jim_DeleteTimeHandler(Jim_Interp *interp, jim_wide id)
+{
+ Jim_TimeEvent *te;
+ Jim_EventLoop *eventLoop = Jim_GetAssocData(interp, "eventloop");
+
+ if (id >= eventLoop->timeEventNextId) {
+ return -2; /* wrong event ID */
}
- return nearest;
+
+ te = Jim_RemoveTimeHandler(eventLoop, id);
+ if (te) {
+ jim_wide remain;
+ long cur_sec, cur_ms;
+
+ JimGetTime(&cur_sec, &cur_ms);
+
+ remain = (te->when_sec - cur_sec) * 1000;
+ remain += (te->when_ms - cur_ms);
+ remain = (remain < 0) ? 0 : remain;
+
+ Jim_FreeTimeHandler(interp, te);
+ return remain;
+ }
+ return -1; /* NO event with the specified ID found */
}
/* --- POSIX version of Jim_ProcessEvents, for now the only available --- */
@@ -282,12 +379,18 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags)
* to fire. */
if (numfd || ((flags & JIM_TIME_EVENTS) && !(flags & JIM_DONT_WAIT))) {
int retval;
- Jim_TimeEvent *shortest;
struct timeval tv, *tvp;
jim_wide dt;
- shortest = JimSearchNearestTimer(eventLoop);
- if (shortest) {
+ if (flags & JIM_DONT_WAIT) {
+ /* Wait no time */
+ tvp = &tv;
+ tvp->tv_sec = 0;
+ tvp->tv_usec = 0;
+ }
+ /* The nearest timer is always at the head of the list */
+ else if (eventLoop->timeEventHead) {
+ Jim_TimeEvent *shortest = eventLoop->timeEventHead;
long now_sec, now_ms;
/* Calculate the time missing for the nearest
@@ -364,6 +467,8 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags)
JimGetTime(&now_sec, &now_ms);
if (now_sec > te->when_sec || (now_sec == te->when_sec && now_ms >= te->when_ms)) {
id = te->id;
+ /* Remove from the list before executing */
+ Jim_RemoveTimeHandler(eventLoop, id);
te->timeProc(interp, te->clientData);
/* After an event is processed our time event list may
* no longer be the same, so we restart from head.
@@ -371,8 +476,10 @@ int Jim_ProcessEvents(Jim_Interp *interp, int flags)
* by event handlers itself in order to don't loop forever
* even in case an [after 0] that continuously register
* itself. To do so we saved the max ID we want to handle. */
- Jim_DeleteTimeHandler(interp, id);
+ Jim_FreeTimeHandler(interp, te);
+
te = eventLoop->timeEventHead;
+ processed++;
}
else {
te = te->next;
@@ -413,6 +520,7 @@ void JimELAssocDataDeleProc(Jim_Interp *interp, void *data)
static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
{
+ Jim_EventLoop *eventLoop = Jim_CmdPrivData(interp);
Jim_Obj *oldValue;
if (argc != 2) {
@@ -420,8 +528,6 @@ static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
return JIM_ERR;
}
- interp->suppress_bgerror = 0;
-
oldValue = Jim_GetGlobalVariable(interp, argv[1], JIM_NONE);
if (oldValue) {
Jim_IncrRefCount(oldValue);
@@ -434,6 +540,9 @@ static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
return JIM_ERR;
}
}
+
+ eventLoop->suppress_bgerror = 0;
+
while (1) {
Jim_Obj *currValue;
@@ -456,14 +565,40 @@ static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
return JIM_OK;
}
-void JimAfterTimeHandler(Jim_Interp *interp, void *clientData)
+static int JimELUpdateCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+ Jim_EventLoop *eventLoop = Jim_CmdPrivData(interp);
+ static const char *options[] = {
+ "idletasks", NULL
+ };
+ enum { UPDATE_IDLE, UPDATE_NONE };
+ int option = UPDATE_NONE;
+ int flags = JIM_TIME_EVENTS;
+
+ if (argc == 1) {
+ flags = JIM_ALL_EVENTS;
+ }
+ else if (argc > 2 || Jim_GetEnum(interp, argv[1], options, &option, NULL, JIM_ERRMSG | JIM_ENUM_ABBREV) != JIM_OK) {
+ Jim_WrongNumArgs(interp, 1, argv, "?idletasks?");
+ return JIM_ERR;
+ }
+
+ eventLoop->suppress_bgerror = 0;
+
+ while (Jim_ProcessEvents(interp, flags | JIM_DONT_WAIT) > 0) {
+ }
+
+ return JIM_OK;
+}
+
+static void JimAfterTimeHandler(Jim_Interp *interp, void *clientData)
{
Jim_Obj *objPtr = clientData;
Jim_EvalObjBackground(interp, objPtr);
}
-void JimAfterTimeEventFinalizer(Jim_Interp *interp, void *clientData)
+static void JimAfterTimeEventFinalizer(Jim_Interp *interp, void *clientData)
{
Jim_Obj *objPtr = clientData;
@@ -472,23 +607,25 @@ void JimAfterTimeEventFinalizer(Jim_Interp *interp, void *clientData)
static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
{
- jim_wide ms, id;
+ Jim_EventLoop *eventLoop = Jim_CmdPrivData(interp);
+ jim_wide ms = 0, id;
Jim_Obj *objPtr, *idObjPtr;
const char *options[] = {
- "cancel", NULL
+ "cancel", "info", "idle", NULL
};
enum
- { AFTER_CANCEL, AFTER_INFO, AFTER_RESTART, AFTER_EXPIRE, AFTER_CREATE };
+ { AFTER_CANCEL, AFTER_INFO, AFTER_IDLE, AFTER_RESTART, AFTER_EXPIRE, AFTER_CREATE };
int option = AFTER_CREATE;
if (argc < 2) {
- Jim_WrongNumArgs(interp, 1, argv, "<after milliseconds> ?script|cancel <id>?");
+ Jim_WrongNumArgs(interp, 1, argv, "option ?arg ...?");
return JIM_ERR;
}
if (Jim_GetWide(interp, argv[1], &ms) != JIM_OK) {
- if (Jim_GetEnum(interp, argv[1], options, &option, NULL, JIM_ERRMSG) != JIM_OK) {
+ if (Jim_GetEnum(interp, argv[1], options, &option, "argument", JIM_ERRMSG) != JIM_OK) {
return JIM_ERR;
}
+ Jim_SetEmptyResult(interp);
}
else if (argc == 2) {
/* Simply a sleep */
@@ -496,10 +633,18 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
usleep((ms % 1000) * 1000);
return JIM_OK;
}
+
switch (option) {
- case AFTER_CREATE:
- Jim_IncrRefCount(argv[2]);
- id = Jim_CreateTimeHandler(interp, ms, JimAfterTimeHandler, argv[2],
+ case AFTER_IDLE:
+ if (argc < 3) {
+ Jim_WrongNumArgs(interp, 2, argv, "script ?script ...?");
+ return JIM_ERR;
+ }
+ /* fall through */
+ case AFTER_CREATE: {
+ Jim_Obj *scriptObj = Jim_ConcatObj(interp, argc - 2, argv + 2);
+ Jim_IncrRefCount(scriptObj);
+ id = Jim_CreateTimeHandler(interp, ms, JimAfterTimeHandler, scriptObj,
JimAfterTimeEventFinalizer);
objPtr = Jim_NewStringObj(interp, NULL, 0);
Jim_AppendString(interp, objPtr, "after#", -1);
@@ -509,21 +654,66 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
Jim_DecrRefCount(interp, idObjPtr);
Jim_SetResult(interp, objPtr);
return JIM_OK;
- case AFTER_CANCEL:{
- int tlen;
+ }
+ case AFTER_CANCEL:
+ if (argc < 3) {
+ Jim_WrongNumArgs(interp, 2, argv, "id|command");
+ return JIM_ERR;
+ }
+ else {
jim_wide remain = 0;
- const char *tok = Jim_GetString(argv[2], &tlen);
- if (strncmp(tok, "after#", 6) == 0 && Jim_StringToWide(tok + 6, &id, 10) == JIM_OK) {
- remain = Jim_DeleteTimeHandler(interp, id);
- if (remain > -2) {
- Jim_SetResult(interp, Jim_NewIntObj(interp, remain));
+ id = JimParseAfterId(argv[2]);
+ if (id < 0) {
+ /* Not an event id, so search by script */
+ Jim_Obj *scriptObj = Jim_ConcatObj(interp, argc - 2, argv + 2);
+ id = JimFindAfterByScript(eventLoop, scriptObj);
+ Jim_FreeNewObj(interp, scriptObj);
+ if (id < 0) {
+ /* Not found */
+ break;
+ }
+ }
+ remain = Jim_DeleteTimeHandler(interp, id);
+ if (remain >= 0) {
+ Jim_SetResultInt(interp, remain);
+ }
+ }
+ break;
+
+ case AFTER_INFO:
+ if (argc == 2) {
+ Jim_TimeEvent *te = eventLoop->timeEventHead;
+ Jim_Obj *listObj = Jim_NewListObj(interp, NULL, 0);
+ char buf[30];
+
+ while (te) {
+ snprintf(buf, sizeof(buf), "after#%" JIM_WIDE_MODIFIER, te->id);
+ Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, buf, -1));
+ te = te->next;
+ }
+ Jim_SetResult(interp, listObj);
+ }
+ else if (argc == 3) {
+ jim_wide id = JimParseAfterId(argv[2]);
+ if (id >= 0) {
+ Jim_TimeEvent *e = JimFindTimeHandlerById(eventLoop, id);
+ if (e && e->timeProc == JimAfterTimeHandler) {
+ Jim_Obj *listObj = Jim_NewListObj(interp, NULL, 0);
+ Jim_ListAppendElement(interp, listObj, e->clientData);
+ Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, e->initialms ? "timer" : "idle", -1));
+ Jim_SetResult(interp, listObj);
return JIM_OK;
}
}
- Jim_SetResultString(interp, "invalid event", -1);
+ Jim_SetResultFormatted(interp, "event \"%#s\" doesn't exist", argv[2]);
return JIM_ERR;
}
+ else {
+ Jim_WrongNumArgs(interp, 2, argv, "?id?");
+ return JIM_ERR;
+ }
+ break;
}
return JIM_OK;
}
@@ -536,10 +726,12 @@ int Jim_eventloopInit(Jim_Interp *interp)
eventLoop->fileEventHead = NULL;
eventLoop->timeEventHead = NULL;
eventLoop->timeEventNextId = 1;
+ eventLoop->suppress_bgerror = 0;
Jim_SetAssocData(interp, "eventloop", JimELAssocDataDeleProc, eventLoop);
- Jim_CreateCommand(interp, "vwait", JimELVwaitCommand, NULL, NULL);
- Jim_CreateCommand(interp, "after", JimELAfterCommand, NULL, NULL);
+ Jim_CreateCommand(interp, "vwait", JimELVwaitCommand, eventLoop, NULL);
+ Jim_CreateCommand(interp, "update", JimELUpdateCommand, eventLoop, NULL);
+ Jim_CreateCommand(interp, "after", JimELAfterCommand, eventLoop, NULL);
return JIM_OK;
}
diff --git a/jim-eventloop.h b/jim-eventloop.h
index 0b81627..42f20c9 100644
--- a/jim-eventloop.h
+++ b/jim-eventloop.h
@@ -83,6 +83,7 @@ JIM_EXPORT jim_wide Jim_DeleteTimeHandler (Jim_Interp *interp, jim_wide id);
#define JIM_DONT_WAIT 4
JIM_EXPORT int Jim_ProcessEvents (Jim_Interp *interp, int flags);
+JIM_EXPORT int Jim_EvalObjBackground (Jim_Interp *interp, Jim_Obj *scriptObjPtr);
int Jim_eventloopInit(Jim_Interp *interp);
diff --git a/jim.c b/jim.c
index 732253f..b083473 100644
--- a/jim.c
+++ b/jim.c
@@ -4670,7 +4670,6 @@ Jim_Interp *Jim_CreateInterp(void)
i->unknown = Jim_NewStringObj(i, "unknown", -1);
i->unknown_called = 0;
i->errorProc = i->emptyObj;
- i->suppress_bgerror = 0;
i->currentScriptObj = Jim_NewEmptyStringObj(i);
Jim_IncrRefCount(i->emptyObj);
Jim_IncrRefCount(i->result);
@@ -9877,41 +9876,6 @@ int Jim_EvalGlobal(Jim_Interp *interp, const char *script)
return retval;
}
-int Jim_EvalObjBackground(Jim_Interp *interp, Jim_Obj *scriptObjPtr)
-{
- Jim_CallFrame *savedFramePtr;
- int retval;
-
- savedFramePtr = interp->framePtr;
- interp->framePtr = interp->topFramePtr;
- retval = Jim_EvalObj(interp, scriptObjPtr);
- interp->framePtr = savedFramePtr;
- /* Try to report the error (if any) via the bgerror proc */
- if (retval != JIM_OK && !interp->suppress_bgerror) {
- Jim_Obj *objv[2];
- int rc = JIM_ERR;
-
- objv[0] = Jim_NewStringObj(interp, "bgerror", -1);
- objv[1] = Jim_GetResult(interp);
- Jim_IncrRefCount(objv[0]);
- Jim_IncrRefCount(objv[1]);
- if (Jim_GetCommand(interp, objv[0], JIM_NONE) == NULL || (rc = Jim_EvalObjVector(interp, 2, objv)) != JIM_OK) {
- if (rc == JIM_BREAK) {
- /* No more bgerror calls */
- interp->suppress_bgerror++;
- }
- else {
- /* Report the error to stderr. */
- fprintf(stderr, "Background error:" JIM_NL);
- Jim_PrintErrorMessage(interp);
- }
- }
- Jim_DecrRefCount(interp, objv[0]);
- Jim_DecrRefCount(interp, objv[1]);
- }
- return retval;
-}
-
#include <sys/stat.h>
int Jim_EvalFile(Jim_Interp *interp, const char *filename)
diff --git a/jim.h b/jim.h
index b8d5d1d..038d62f 100644
--- a/jim.h
+++ b/jim.h
@@ -541,7 +541,6 @@ typedef struct Jim_Interp {
Jim_Obj *unknown; /* Unknown command cache */
int unknown_called; /* The unknown command has been invoked */
int errorFlag; /* Set if an error occurred during execution. */
- int suppress_bgerror; /* bgerror returned break, so don't call it again */
void *cmdPrivData; /* Used to pass the private data pointer to
a command. It is set to what the user specified
via Jim_CreateCommand(). */
@@ -623,8 +622,6 @@ JIM_EXPORT int Jim_Eval_Named(Jim_Interp *interp, const char *script,const char
JIM_EXPORT int Jim_EvalGlobal(Jim_Interp *interp, const char *script);
JIM_EXPORT int Jim_EvalFile(Jim_Interp *interp, const char *filename);
JIM_EXPORT int Jim_EvalObj (Jim_Interp *interp, Jim_Obj *scriptObjPtr);
-JIM_EXPORT int Jim_EvalObjBackground (Jim_Interp *interp,
- Jim_Obj *scriptObjPtr);
JIM_EXPORT int Jim_EvalObjVector (Jim_Interp *interp, int objc,
Jim_Obj *const *objv);
JIM_EXPORT int Jim_SubstObj (Jim_Interp *interp, Jim_Obj *substObjPtr,
@@ -695,6 +692,8 @@ JIM_EXPORT Jim_Obj * Jim_ScanString (Jim_Interp *interp, Jim_Obj *strObjPtr,
Jim_Obj *fmtObjPtr, int flags);
JIM_EXPORT int Jim_CompareStringImmediate (Jim_Interp *interp,
Jim_Obj *objPtr, const char *str);
+JIM_EXPORT int Jim_StringCompareObj(Jim_Obj *firstObjPtr, Jim_Obj *secondObjPtr,
+ int nocase);
/* reference object */
JIM_EXPORT Jim_Obj * Jim_NewReference (Jim_Interp *interp,
diff --git a/jim_tcl.txt b/jim_tcl.txt
index 9deb38a..d76b6c9 100644
--- a/jim_tcl.txt
+++ b/jim_tcl.txt
@@ -53,8 +53,8 @@ The major differences are:
16. Support for "static" variables in procedures
17. Significantly faster for many scripts/operations
18. Support for tail-call optimisation, 'tailcall'
-20. Variable traces are not supported
-21. The history command is not supported
+19. Variable traces are not supported
+20. The history command is not supported
CHANGES
-------
@@ -79,7 +79,7 @@ Since v0.62:
17. 'exec' now sets $::errorCode, and catch sets opts(-errorcode) for exit status
18. Command pipelines via open "|..." are now supported
19. Add 'info references'
-20. Add support for 'after *ms*'
+20. Add support for 'after *ms*', 'after idle', 'after info', 'update'
Since v0.61:
@@ -1552,7 +1552,7 @@ the key +-level+ will be the current return level (see 'return
if {[catch {...} msg opts]} {
...maybe do something with the error...
- incr opts(-level)
+ incr opts(-level)
return {*}$opts $msg
}
@@ -1892,30 +1892,30 @@ If the command fails, the global $::errorCode (and the -errorcode
option in 'catch') will be set to a list, as follows:
+*CHILDKILLED* 'pid sigName msg'+::
- This format is used when a child process has been killed
- because of a signal. The pid element will be the process's
- identifier (in decimal). The sigName element will be the
- symbolic name of the signal that caused the process to
- terminate; it will be one of the names from the include
- file signal.h, such as SIGPIPE. The msg element will be a
- short human-readable message describing the signal, such
- as "write on pipe with no readers" for SIGPIPE.
+ This format is used when a child process has been killed
+ because of a signal. The pid element will be the process's
+ identifier (in decimal). The sigName element will be the
+ symbolic name of the signal that caused the process to
+ terminate; it will be one of the names from the include
+ file signal.h, such as SIGPIPE. The msg element will be a
+ short human-readable message describing the signal, such
+ as "write on pipe with no readers" for SIGPIPE.
+*CHILDSUSP* 'pid sigName msg'+::
- This format is used when a child process has been suspended
- because of a signal. The pid element will be the process's
- identifier, in decimal. The sigName element will be the
- symbolic name of the signal that caused the process to
- suspend; this will be one of the names from the include
- file signal.h, such as SIGTTIN. The msg element will be a
- short human-readable message describing the signal, such
- as "background tty read" for SIGTTIN.
+ This format is used when a child process has been suspended
+ because of a signal. The pid element will be the process's
+ identifier, in decimal. The sigName element will be the
+ symbolic name of the signal that caused the process to
+ suspend; this will be one of the names from the include
+ file signal.h, such as SIGTTIN. The msg element will be a
+ short human-readable message describing the signal, such
+ as "background tty read" for SIGTTIN.
+*CHILDSTATUS* 'pid code'+::
- This format is used when a child process has exited with a
- non-zero exit status. The pid element will be the process's
- identifier (in decimal) and the code element will be the
- exit code returned by the process (also in decimal).
+ This format is used when a child process has exited with a
+ non-zero exit status. The pid element will be the process's
+ identifier (in decimal) and the code element will be the
+ exit code returned by the process (also in decimal).
exit
~~~~
@@ -2400,8 +2400,8 @@ The legal *option*'s (which may be abbreviated) are:
'string match'.
+*info references*+::
- Returns a list of all references which have not yet been garbage
- collected.
+ Returns a list of all references which have not yet been garbage
+ collected.
+*info returncodes* ?'code'?+::
Returns a list representing the mapping of standard return codes
@@ -2523,28 +2523,28 @@ In this example, a local procedure is created. Note that the procedure
continues to have global scope while it is active.
proc outer {} {
- # proc ... returns "inner" which is marked local
+ # proc ... returns "inner" which is marked local
local proc inner {} {
- # will be deleted when 'outer' exits
- }
+ # will be deleted when 'outer' exits
+ }
- inner
- ...
- }
+ inner
+ ...
+ }
In this example, the lambda is deleted at the end of the procedure rather
than waiting until garbage collection.
proc outer {} {
set x [lambda inner {args} {
- # will be deleted when 'outer' exits
- }]
- # Use 'function' here which simply returns $x
- local function $x
+ # will be deleted when 'outer' exits
+ }]
+ # Use 'function' here which simply returns $x
+ local function $x
- $x ...
- ...
- }
+ $x ...
+ ...
+ }
lindex
~~~~~~
@@ -4041,8 +4041,8 @@ aio
If *addrvar* is specified, the sending address of the message is stored in
the named variable in the form 'addr:port'. See 'socket' for details.
-eventloop: after, vwait
-~~~~~~~~~~~~~~~~~~~~~~~
+eventloop: after, vwait, update
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following commands allow a script to be invoked when the given condition occurs.
If no script is given, returns the current script. If the given script is the empty, the
@@ -4057,22 +4057,49 @@ handler is removed.
+$handle *onexception* '?exception-script?'+::
Sets or returns the script for when when oob data received.
-Time-based execution is also available via the eventloop API.
+For compatibility with 'Tcl', these may be prefixed with 'fileevent'. e.g.
-+*after* 'time'+::
- Sleeps for the given number of milliseconds. No events are processed during this time.
+ ::
+ +fileevent $handle *readable* '...'+
-+*after* 'time script'+::
- The script is executed after the given number of milliseconds have elapsed.
- Returns an event id.
+Time-based execution is also available via the eventloop API.
-+*after cancel* 'id'+::
- Cancels an 'after' event with the given event id.
++*after* 'ms'+::
+ Sleeps for the given number of milliseconds. No events are
+ processed during this time.
+
++*after* 'ms|*idle* script ?script ...?'+::
+ The scripts are concatenated and executed after the given
+ number of milliseconds have elapsed. If 'idle' is specified,
+ the script will run the next time the event loop is processed
+ with 'vwait' or 'update'. The script is only run once and
+ then removed. Returns an event id.
+
++*after cancel* 'id|command'+::
+ Cancels an 'after' event with the given event id or matching
+ command (script). Returns the number of milliseconds
+ remaining until the event would have fired. Returns the
+ empty string if no matching event is found.
+
++*after info* '?id?'+::
+ If *id* is not given, returns a list of current 'after'
+ events. If *id* is given, returns a list containing the
+ associated script and either 'timer' or 'idle' to indicated
+ the type of the event. An error occurs if *id* does not
+ match an event.
+*vwait* 'variable'+::
- A call to 'vwait' is required to enter the eventloop. 'vwait' processes events until
- the named (global) variable changes. The variable need not exist beforehand.
- If there are no event handlers defined, 'vwait' returns immediately.
+ A call to 'vwait' is enters the eventloop. 'vwait' processes
+ events until the named (global) variable changes or all
+ event handlers are removed. The variable need not exist
+ beforehand. If there are no event handlers defined, 'vwait'
+ returns immediately.
+
++*update ?idletasks?*+::
+ A call to 'update' enters the eventloop to process expired events, but
+ no new events. If 'idletasks' is specified, only expired time events are handled,
+ not file events.
+ Returns once handlers have been run for all expired events.
Scripts are executed at the global scope. If an error occurs during a handler script,
an attempt is made to call (the user-defined command) 'bgerror' with the details of the error.
@@ -4082,8 +4109,7 @@ If a file event handler script generates an error, the handler is automatically
to prevent infinite errors. (A time event handler is always removed after execution).
+*bgerror* 'error'+::
- Called when an event handler script generates an error.
-
+ Called when an event handler script generates an error.
socket
~~~~~~
@@ -4188,7 +4214,7 @@ may be specified before priority to control these parameters:
Use given string instead of argv0 variable for ident string.
+*-options* 'integer'+::
- Set syslog options such as LOG_CONS, LOG_NDELAY You should
+ Set syslog options such as +LOG_CONS+, +LOG_NDELAY+. You should
use numeric values of those from your system syslog.h file,
because I haven't got time to implement yet another hash
table.
@@ -4212,16 +4238,16 @@ by the Tcl library.
It contains {. /lib/jim} by default.
+*errorCode*+::
- This variable holds the value of the -errorcode return
- option set by the most recent error that occurred in this
- interpreter. This list value represents additional information
- about the error in a form that is easy to process with
- programs. The first element of the list identifies a general
- class of errors, and determines the format of the rest of
- the list. The following formats for -errorcode return options
- are used by the Tcl core; individual applications may define
- additional formats. Currently only 'exec' sets this variable.
- Otherwise it will be *NONE*.
+ This variable holds the value of the -errorcode return
+ option set by the most recent error that occurred in this
+ interpreter. This list value represents additional information
+ about the error in a form that is easy to process with
+ programs. The first element of the list identifies a general
+ class of errors, and determines the format of the rest of
+ the list. The following formats for -errorcode return options
+ are used by the Tcl core; individual applications may define
+ additional formats. Currently only 'exec' sets this variable.
+ Otherwise it will be *NONE*.
The following global variables are set by jimsh.
diff --git a/tests/event.test b/tests/event.test
index 9f14f6d..0374539 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -1,35 +1,35 @@
+# This file contains a collection of tests for the procedures in the file
+# tclEvent.c, which includes the "update", and "vwait" Tcl
+# commands. Sourcing this file into Tcl runs the tests and generates
+# output for errors. No output means no errors were found.
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
source testing.tcl
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
catch {rename bgerror {}}
proc bgerror msg {
- lappend ::x $msg
+ lappend ::x $msg
}
- after 100 {error "a simple error"}
- after 200 {open non_existent}
+ after idle {error "a simple error"}
+ after idle {open non_existent}
+ after idle {set errorInfo foobar; set errorCode xyzzy}
set x {}
- vwait dummy
+ update idletasks
rename bgerror {}
set x
} {{a simple error} {non_existent: No such file or directory}}
-test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
- proc bgerror msg {
- lappend ::x $msg
- return -code break
- }
- after 100 {error "a simple error"}
- after 200 {open non_existent}
- set x {}
- vwait dummy
- rename bgerror {}
- set x
-} {{a simple error}}
-
test event-7.1 {bgerror / regular} {
set errRes {}
proc bgerror {err} {
- set ::errRes $err;
+ global errRes;
+ set errRes $err;
}
after 0 {error err1}
vwait errRes;
@@ -39,31 +39,40 @@ test event-7.1 {bgerror / regular} {
test event-7.2 {bgerror / accumulation} {
set errRes {}
proc bgerror {err} {
- lappend ::errRes $err;
+ global errRes;
+ lappend errRes $err;
}
after 0 {error err1}
- after 1 {error err2}
- after 2 {error err3}
- vwait dummy
+ after 0 {error err2}
+ after 0 {error err3}
+ update
set errRes;
} {err1 err2 err3}
test event-7.3 {bgerror / accumulation / break} {
set errRes {}
proc bgerror {err} {
- lappend ::errRes $err;
- return -code break "skip!";
+ global errRes;
+ lappend errRes $err;
+ return -code break "skip!";
}
after 0 {error err1}
- after 1 {error err2}
- after 2 {error err3}
- vwait dummy
- set errRes
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ set errRes;
} err1
# end of bgerror tests
catch {rename bgerror {}}
+
+test event-10.1 {Tcl_Exit procedure} {
+ set cmd [list exec [info nameofexecutable] "<<exit 3"]
+ list [catch $cmd msg] [lindex $errorCode 0] \
+ [lindex $errorCode 2]
+} {1 CHILDSTATUS 3}
+
test event-11.1 {Tcl_VwaitCmd procedure} {
list [catch {vwait} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
@@ -75,20 +84,23 @@ test event-11.3 {Tcl_VwaitCmd procedure} {
set x 1
list [catch {vwait x(1)} msg] $msg
} {1 {can't read "x(1)": variable isn't array}}
-
test event-11.4 {Tcl_VwaitCmd procedure} {
- vwait dummy
- lappend ids [after 100 {set x x-done}]
- lappend ids [after 200 {set y y-done}]
- lappend ids [after 300 {set z z-done}]
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 10; update; # On Mac make sure update won't take long
+ after 100 {set x x-done}
+ after 200 {set y y-done}
+ after 300 {set z z-done}
+ after idle {set q q-done}
set x before
set y before
set z before
set q before
list [vwait y] $x $y $z $q
-} {{} x-done y-done before before}
+} {{} x-done y-done before q-done}
-foreach i $ids {
+foreach i [after info] {
after cancel $i
}
@@ -115,7 +127,6 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
file delete test1 test2
list $x $y $z
} {3 3 done}
-
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
file delete test1 test2
set f1 [open test1 w]
@@ -123,7 +134,7 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
set x 0
set y 0
set z 0
- vwait dummy
+ update
$f1 writable { incr x; if { $y == 3 } { set z done } }
$f2 writable { incr y; if { $x == 3 } { set z done } }
vwait z
@@ -134,17 +145,41 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
} {3 3 done}
+test event-12.1 {Tcl_UpdateCmd procedure} {
+ list [catch {update a b} msg] $msg
+} {1 {wrong # args: should be "update ?idletasks?"}}
test event-12.3 {Tcl_UpdateCmd procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
after 500 {set x after}
- after 1 {set y after}
- after 2 {set z "after, y = $y"}
+ after idle {set y after}
+ after idle {set z "after, y = $y"}
set x before
set y before
set z before
- vwait z
+ update idletasks
list $x $y $z
} {before after {after, y = after}}
+test event-12.4 {Tcl_UpdateCmd procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 10; update; # On Mac make sure update won't take long
+ after 200 {set x x-done}
+ after 600 {set y y-done}
+ after idle {set z z-done}
+ set x before
+ set y before
+ set z before
+ after 300
+ update
+ list $x $y $z
+} {x-done before z-done}
-vwait dummy
+# cleanup
+foreach i [after info] {
+ after cancel $i
+}
testreport
diff --git a/tests/testing.tcl b/tests/testing.tcl
index 9c0b4ec..5e6b395 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -4,8 +4,11 @@ proc makeFile {contents name} {
close $f
}
-proc info_source {script} {
- join [info source $script] :
+proc error_source {} {
+ lassign [info stacktrace] p f l
+ if {$f ne ""} {
+ puts "At : $f:$l"
+ }
}
catch {
@@ -14,8 +17,7 @@ catch {
proc errorInfo {msg} {
return $::errorInfo
}
- proc info_source {script} {
- return ""
+ proc error_source {} {
}
}
@@ -33,7 +35,8 @@ proc test {id descr script expected} {
if {!$::testquiet} {
puts -nonewline "$id "
}
- set rc [catch {uplevel 1 $script} result]
+ set rc [catch {uplevel 1 $script} result opts]
+
# Note that rc=2 is return
if {($rc == 0 || $rc == 2) && $result eq $expected} {
if {!$::testquiet} {
@@ -45,7 +48,7 @@ proc test {id descr script expected} {
puts -nonewline "$id "
}
puts "ERR $descr"
- puts "At : [info_source $script]"
+ error_source
puts "Expected: '$expected'"
puts "Got : '$result'"
incr ::testresults(numfail)
diff --git a/tests/timer.test b/tests/timer.test
new file mode 100644
index 0000000..d1c7e1f
--- /dev/null
+++ b/tests/timer.test
@@ -0,0 +1,455 @@
+# This file contains a collection of tests for the procedures in the
+# file tclTimer.c, which includes the "after" Tcl command. Sourcing
+# this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# 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) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: timer.test,v 1.7.2.1 2001/10/13 01:14:19 hobbs Exp $
+
+source testing.tcl
+
+test timer-1.1 {Tcl_CreateTimerHandler procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x ""
+ foreach i {100 200 1000 50 150} {
+ after $i lappend x $i
+ }
+ after 210
+ update
+ set x
+} {50 100 150 200}
+
+test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x ""
+ foreach i {100 200 300 50 150} {
+ after $i lappend x $i
+ }
+ after cancel lappend x 150
+ after cancel lappend x 50
+ after 210
+ update
+ set x
+} {100 200}
+
+# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
+# above.
+
+test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
+ set x start
+ after 100 { set x fired }
+ update idletasks
+ set result $x
+ after 200
+ update
+ lappend result $x
+} {start fired}
+test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ foreach i {200 600 1000} {
+ after $i lappend x $i
+ }
+ after 210
+ set result ""
+ set x ""
+ update
+ lappend result $x
+ after 400
+ update
+ lappend result $x
+ after 400
+ update
+ lappend result $x
+} {200 {200 600} {200 600 1000}}
+test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x {}
+ after 100 lappend x 100
+ set i [after 300 lappend x 300]
+ after 200 after cancel $i
+ after 400
+ update
+ set x
+} 100
+test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x {}
+ after 100 lappend x a
+ after 200 lappend x b
+ after 300 lappend x c
+ after 310
+ vwait x
+ set x
+} {a b c}
+test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x {}
+ after 100 {lappend x a; after 0 lappend x b}
+ after 100
+ vwait x
+ set x
+} a
+test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x {}
+ after 100 {lappend x a; after 100 lappend x b; after 100}
+ after 100
+ vwait x
+ set result $x
+ vwait x
+ lappend result $x
+} {a {a b}}
+
+# No tests for Tcl_DoWhenIdle: it's already tested by other tests
+# below.
+
+test timer-4.1 {Tcl_CancelIdleCall procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x before
+ set y before
+ set z before
+ after idle set x after1
+ after idle set y after2
+ after idle set z after3
+ after cancel set y after2
+ update idletasks
+ concat $x $y $z
+} {after1 before after3}
+test timer-4.2 {Tcl_CancelIdleCall procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x before
+ set y before
+ set z before
+ after idle set x after1
+ after idle set y after2
+ after idle set z after3
+ after cancel set x after1
+ update idletasks
+ concat $x $y $z
+} {before after2 after3}
+
+test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x 1
+ set y 23
+ after idle {incr x; after idle {incr x; after idle {incr x}}}
+ after idle {incr y}
+ vwait x
+ set result "$x $y"
+ update idletasks
+ lappend result $x
+} {2 24 4}
+
+test timer-6.1 {Tcl_AfterCmd procedure, basics} {
+ list [catch {after} msg] $msg
+} {1 {wrong # args: should be "after option ?arg ...?"}}
+test timer-6.2 {Tcl_AfterCmd procedure, basics} {
+ list [catch {after 2x} msg] $msg
+} {1 {bad argument "2x": must be cancel, idle, or info}}
+test timer-6.3 {Tcl_AfterCmd procedure, basics} {
+ list [catch {after gorp} msg] $msg
+} {1 {bad argument "gorp": must be cancel, idle, or info}}
+test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
+ set x before
+ after 400 {set x after}
+ after 200
+ update
+ set y $x
+ after 400
+ update
+ list $y $x
+} {before after}
+test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
+ set x before
+ after 300 {set x after}
+ after 200
+ update
+ set y $x
+ after 200
+ update
+ list $y $x
+} {before after}
+test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
+ list [catch {after cancel} msg] $msg
+} {1 {wrong # args: should be "after cancel id|command"}}
+test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
+ after cancel after#1
+} {}
+test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
+ after cancel {foo bar}
+} {}
+test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x before
+ set y [after 100 set x after]
+ after cancel $y
+ after 200
+ update
+ set x
+} {before}
+test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x before
+ after 100 set x after
+ after cancel set x after
+ after 200
+ update
+ set x
+} {before}
+test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x before
+ after 100 set x after
+ set id [after 300 set x after]
+ after cancel $id
+ after 200
+ update
+ set y $x
+ set x cleared
+ after 200
+ update
+ list $y $x
+} {after cleared}
+test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x first
+ after idle lappend x second
+ after idle lappend x third
+ set i [after idle lappend x fourth]
+ after cancel {lappend x second}
+ after cancel $i
+ update idletasks
+ set x
+} {first third}
+test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x first
+ after idle lappend x second
+ after idle lappend x third
+ set i [after idle lappend x fourth]
+ after cancel lappend x second
+ after cancel $i
+ update idletasks
+ set x
+} {first third}
+test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set id [
+ after 100 {
+ set x done
+ after cancel $id
+ }
+ ]
+ vwait x
+} {}
+test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
+ list [catch {after idle} msg] $msg
+} {1 {wrong # args: should be "after idle script ?script ...?"}}
+test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
+ set x before
+ after idle {set x after}
+ set y $x
+ update idletasks
+ list $y $x
+} {before after}
+test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
+ set x before
+ after idle set x after
+ set y $x
+ update idletasks
+ list $y $x
+} {before after}
+set event1 [after idle event 1]
+set event2 [after 1000 event 2]
+
+test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after 1 "set x ab\0cd"
+ after 10
+ update
+ string length $x
+} {5}
+test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after 1 set x ab\0cd
+ after 10
+ update
+ string length $x
+} {5}
+test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after 1 set x ab\0cd
+ after cancel "set x ab\0ef"
+ set x [llength [after info]]
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x
+} {1}
+test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after 1 set x ab\0cd
+ after cancel set x ab\0ef
+ set y [llength [after info]]
+ foreach i [after info] {
+ after cancel $i
+ }
+ set y
+} {1}
+test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after idle "set x ab\0cd"
+ update
+ string length $x
+} {5}
+test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ after idle set x ab\0cd
+ update
+ string length $x
+} {5}
+test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ set x "hello world"
+ set id junk
+ set id [after 10 set x ab\0cd]
+ update
+ set y [string length [lindex [lindex [after info $id] 0] 2]]
+ foreach i [after info] {
+ after cancel $i
+ }
+ set y
+} {5}
+
+set event [after idle foo bar]
+scan $event after#%d id
+
+test timer-7.1 {GetAfterEvent procedure} {
+ list [catch {after info xfter#$id} msg] $msg
+} "1 {event \"xfter#$id\" doesn't exist}"
+test timer-7.2 {GetAfterEvent procedure} {
+ list [catch {after info afterx$id} msg] $msg
+} "1 {event \"afterx$id\" doesn't exist}"
+test timer-7.3 {GetAfterEvent procedure} {
+ list [catch {after info after#ab} msg] $msg
+} {1 {event "after#ab" doesn't exist}}
+test timer-7.4 {GetAfterEvent procedure} {
+ list [catch {after info after#} msg] $msg
+} {1 {event "after#" doesn't exist}}
+test timer-7.5 {GetAfterEvent procedure} {
+ list [catch {after info after#${id}x} msg] $msg
+} "1 {event \"after#${id}x\" doesn't exist}"
+test timer-7.6 {GetAfterEvent procedure} {
+ list [catch {after info afterx[expr $id+1]} msg] $msg
+} "1 {event \"afterx[expr $id+1]\" doesn't exist}"
+after cancel $event
+
+test timer-8.1 {AfterProc procedure} {
+ set x before
+ proc foo {} {
+ set x untouched
+ after 100 {set x after}
+ after 200
+ update
+ return $x
+ }
+ list [foo] $x
+} {untouched after}
+test timer-8.2 {AfterProc procedure} {
+ catch {rename bgerror {}}
+ proc bgerror msg {
+ set ::x $msg
+ }
+ set x empty
+ after 100 {error "After error"}
+ after 200
+ set y $x
+ update
+ catch {rename bgerror {}}
+ list $y $x
+} {empty {After error}}
+
+test timer-8.4 {AfterProc procedure, deleting handler from itself} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ proc foo {} {
+ global x
+ set x {}
+ foreach i [after info] {
+ lappend x [after info $i]
+ }
+ after cancel foo
+ }
+ after 1000 {error "I shouldn't ever have executed"}
+ after idle foo
+ update idletasks
+ set x
+} {{{error "I shouldn't ever have executed"} timer}}
+
+foreach i [after info] {
+ after cancel $i
+}
+
+testreport