diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | doc/GetTime.3 | 49 | ||||
| -rw-r--r-- | generic/tcl.decls | 14 | ||||
| -rw-r--r-- | generic/tcl.h | 7 | ||||
| -rw-r--r-- | generic/tclDecls.h | 28 | ||||
| -rw-r--r-- | generic/tclInt.h | 10 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | unix/tclUnixEvent.c | 26 | ||||
| -rw-r--r-- | unix/tclUnixNotfy.c | 40 | ||||
| -rw-r--r-- | unix/tclUnixTime.c | 164 | ||||
| -rw-r--r-- | win/tclWinNotify.c | 37 | ||||
| -rw-r--r-- | win/tclWinTime.c | 142 |
12 files changed, 489 insertions, 47 deletions
@@ -1,5 +1,20 @@ 2005-01-21 Andreas Kupries <andreask@activestate.com> + * generic/tclStubInit.c: Regenerated the stubs support code from + * generic/tclDecls.h: the modified tcl.decls (TIP #233, see below). + + * doc/GetTime.3: Implemented TIP #233, i.e. the + * generic/tcl.decls: 'Virtualization of Tcl's Sense of Time'. + * generic/tcl.h: Declared, implemented, and documented the + * generic/tclInt.h: specified new API functions. Moved the + * unix/tclUnixEvent.c: native (OS) access to time information + * unix/tclUnixNotfy.c: into standard handler functions. Inserted + * unix/tclUnixTime.c: hooks calling on the handlers where native + * win/tclWinNotify.c: access was done before, and where scaling + * win/tclWinTime.c: between domains (real/virtual) is required. + +2005-01-21 Andreas Kupries <andreask@activestate.com> + * generic/tclThread.c: Typo police. Fixed some nits * generic/tclCmdAH.c: in header comments of functions. * generic/tclBasic.c: (Missing --). diff --git a/doc/GetTime.3 b/doc/GetTime.3 index 7941379..22ffc53 100644 --- a/doc/GetTime.3 +++ b/doc/GetTime.3 @@ -16,10 +16,33 @@ Tcl_GetTime \- get date and time \fB#include <tcl.h>\fR .sp \fBTcl_GetTime\fR(\fItimePtr\fR) +.sp +\fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR) +.sp +\fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR) .SH ARGUMENTS .AS "Tcl_Time *" timePtr out .AP "Tcl_Time *" timePtr out Points to memory in which to store the date and time information. +.AS "Tcl_GetTimeProc *" getProc in +.AP "Tcl_GetTimeProc *" getProc in +Pointer to handler function replacing Tcl_GetTime's access to the OS. +.AS "Tcl_ScaleTimeProc *" scaleProc in +.AP "Tcl_ScaleTimeProc *" scaleProc in +Pointer to handler function for the conversion of time delays in the +virtual domain to real-time. +.AS "ClientData *" clientData in +.AP "ClientData *" clientData in +Value passed through to the two handler functions. +.AS "Tcl_GetTimeProc **" getProcPtr inout +.AP "Tcl_GetTimeProc **" getProcPtr inout +Pointer to place the currently registered get handler function into. +.AS "Tcl_ScaleTimeProc **" scaleProcPtr inout +.AP "Tcl_ScaleTimeProc **" scaleProcPtr inout +Pointer to place the currently registered scale handler function into. +.AS "ClientData **" clientDataPtr inout +.AP "ClientData **" clientDataPtr inout +Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP @@ -47,6 +70,32 @@ computer system. On multiprocessor variants of Windows, this number may be limited to the 10- or 20-ms granularity of the system clock. (On single-processor Windows systems, the \fIusec\fR field is derived from a performance counter and is highly precise.) +.PP +The \fBTcl_SetTime\fR function registers two related handler functions +with the core. The first handler function is a replacement for +\fBTcl_GetTime\fR, or rather the OS access made by +\fBTcl_GetTime\fR. The other handler function is used by the Tcl +notifier to convert wait/block times from the virtual domain into real +time. +.PP +The \fBTcl_QueryTime\fR function returns the currently registered +handler functions. If no external handlers were set then this will +return the standard handlers accessing and processing the native time +of the OS. The arguments to the function are allowed to be NULL; and +any argument which is NULL is ignored and not set. +.PP +Any handler pair specified has to return data which is consistent +between them. In other words, setting one handler of the pair to +something assuming a 10-times slowdown, and the other handler of the +pair to something assuming a two-times slowdown is wrong and not +allowed. +.PP +The set handler functions are allowed to run the delivered time +backwards, however this should be avoided. We have to allow it as the +native time can run backwards as the user can fiddle with the system +time one way or other. Note that the insertion of the hooks will not +change the behaviour of the Tcl core with regard to this situation, +i.e. the existing behaviour is retained. .SH "SEE ALSO" clock .SH KEYWORDS diff --git a/generic/tcl.decls b/generic/tcl.decls index cb0ad5b..4f20a56 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.106 2005/01/19 23:15:12 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.107 2005/01/21 22:25:08 andreas_kupries Exp $ library tcl @@ -1973,6 +1973,18 @@ declare 551 generic { int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr) } +# TIP#233 (Virtualized Time) +declare 552 generic { + void Tcl_SetTimeProc (Tcl_GetTimeProc* getProc, + Tcl_ScaleTimeProc* scaleProc, + ClientData clientData) +} +declare 553 generic { + void Tcl_QueryTimeProc (Tcl_GetTimeProc** getProc, + Tcl_ScaleTimeProc** scaleProc, + ClientData* clientData) +} + ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 2a74307..d1638bc 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.194 2005/01/19 23:15:14 dkf Exp $ + * RCS: @(#) $Id: tcl.h,v 1.195 2005/01/21 22:25:09 andreas_kupries Exp $ */ #ifndef _TCL @@ -1417,6 +1417,11 @@ typedef struct Tcl_Time { typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); +/* TIP #233 (Virtualized Time) + */ +typedef void (Tcl_GetTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); +typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); + /* * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4be829a..800f53d 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.108 2005/01/19 23:16:14 dkf Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.109 2005/01/21 22:25:11 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -3436,6 +3436,22 @@ EXTERN int Tcl_GetEnsembleNamespace _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); #endif +#ifndef Tcl_SetTimeProc_TCL_DECLARED +#define Tcl_SetTimeProc_TCL_DECLARED +/* 552 */ +EXTERN void Tcl_SetTimeProc _ANSI_ARGS_(( + Tcl_GetTimeProc* getProc, + Tcl_ScaleTimeProc* scaleProc, + ClientData clientData)); +#endif +#ifndef Tcl_QueryTimeProc_TCL_DECLARED +#define Tcl_QueryTimeProc_TCL_DECLARED +/* 553 */ +EXTERN void Tcl_QueryTimeProc _ANSI_ARGS_(( + Tcl_GetTimeProc** getProc, + Tcl_ScaleTimeProc** scaleProc, + ClientData* clientData)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -4029,6 +4045,8 @@ typedef struct TclStubs { int (*tcl_GetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** unknownListPtr)); /* 549 */ int (*tcl_GetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int * flagsPtr)); /* 550 */ int (*tcl_GetEnsembleNamespace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); /* 551 */ + void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */ + void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */ } TclStubs; #ifdef __cplusplus @@ -6277,6 +6295,14 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetEnsembleNamespace \ (tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */ #endif +#ifndef Tcl_SetTimeProc +#define Tcl_SetTimeProc \ + (tclStubsPtr->tcl_SetTimeProc) /* 552 */ +#endif +#ifndef Tcl_QueryTimeProc +#define Tcl_QueryTimeProc \ + (tclStubsPtr->tcl_QueryTimeProc) /* 553 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index a0d1c4a..df48d31 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.212 2005/01/19 23:15:16 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.213 2005/01/21 22:25:18 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1742,6 +1742,14 @@ MODULE_SCOPE char * tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; +/* TIP #233 (Virtualized Time) + * Data for the time hooks, if any. + */ + +MODULE_SCOPE Tcl_GetTimeProc* tclGetTimeProcPtr; +MODULE_SCOPE Tcl_ScaleTimeProc* tclScaleTimeProcPtr; +MODULE_SCOPE ClientData tclTimeClientData; + /* * Variables denoting the Tcl object types defined in the core. */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ba55856..fe406e6 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.111 2005/01/19 23:16:22 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.112 2005/01/21 22:25:19 andreas_kupries Exp $ */ #include "tclInt.h" @@ -968,6 +968,8 @@ TclStubs tclStubs = { Tcl_GetEnsembleUnknownHandler, /* 549 */ Tcl_GetEnsembleFlags, /* 550 */ Tcl_GetEnsembleNamespace, /* 551 */ + Tcl_SetTimeProc, /* 552 */ + Tcl_QueryTimeProc, /* 553 */ }; /* !END!: Do not edit above this line. */ diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c index 98ab452..036c898 100644 --- a/unix/tclUnixEvent.c +++ b/unix/tclUnixEvent.c @@ -8,10 +8,10 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixEvent.c,v 1.5 2004/04/06 22:25:56 dgp Exp $ + * RCS: @(#) $Id: tclUnixEvent.c,v 1.6 2005/01/21 22:25:35 andreas_kupries Exp $ */ -#include "tclPort.h" +#include "tclInt.h" /* *---------------------------------------------------------------------- @@ -34,7 +34,7 @@ Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { struct timeval delay; - Tcl_Time before, after; + Tcl_Time before, after, vdelay; /* * The only trick here is that select appears to return early @@ -52,13 +52,23 @@ Tcl_Sleep(ms) after.sec += 1; } while (1) { - delay.tv_sec = after.sec - before.sec; - delay.tv_usec = after.usec - before.usec; - if (delay.tv_usec < 0) { - delay.tv_usec += 1000000; - delay.tv_sec -= 1; + /* TIP #233: Scale from virtual time to real-time for select */ + + vdelay.sec = after.sec - before.sec; + vdelay.usec = after.usec - before.usec; + + if (vdelay.usec < 0) { + vdelay.usec += 1000000; + vdelay.sec -= 1; } + if ((vdelay.sec != 0) || (vdelay.usec != 0)) { + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + } + + delay.tv_sec = vdelay.sec; + delay.tv_usec = vdelay.usec; + /* * Special note: must convert delay.tv_sec to int before comparing * to zero, since delay.tv_usec is unsigned on some platforms. diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index b6ea35a..c02b89d 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -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: tclUnixNotfy.c,v 1.19 2004/12/07 00:01:48 hobbs Exp $ + * RCS: @(#) $Id: tclUnixNotfy.c,v 1.20 2005/01/21 22:25:35 andreas_kupries Exp $ */ #include "tclInt.h" @@ -652,11 +652,17 @@ Tcl_WaitForEvent(timePtr) { FileHandler *filePtr; FileHandlerEvent *fileEvPtr; - struct timeval timeout, *timeoutPtr; int mask; + Tcl_Time myTime; #ifdef TCL_THREADS int waitForFiles; + Tcl_Time *myTimePtr; #else + /* Impl. notes: timeout & timeoutPtr are used if, and only if + * threads are not enabled. They are the arguments for the regular + * select() used when the core is not thread-enabled. */ + + struct timeval timeout, *timeoutPtr; int numFound; #endif ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -672,9 +678,23 @@ Tcl_WaitForEvent(timePtr) */ if (timePtr) { - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; + /* TIP #233 (Virtualized Time). Is virtual time in effect ? + * And do we actually have something to scale ? If yes to both + * then we call the handler to do this scaling */ + + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + +#ifdef TCL_THREADS + myTimePtr = &myTime; +#else + timeout.tv_sec = myTime.sec; + timeout.tv_usec = myTime.usec; + timeoutPtr = &timeout; +#endif + #ifndef TCL_THREADS } else if (tsdPtr->numFdBits == 0) { /* @@ -688,7 +708,11 @@ Tcl_WaitForEvent(timePtr) return -1; #endif } else { +#ifdef TCL_THREADS + myTimePtr = NULL; +#else timeoutPtr = NULL; +#endif } #ifdef TCL_THREADS @@ -700,7 +724,7 @@ Tcl_WaitForEvent(timePtr) Tcl_MutexLock(¬ifierMutex); waitForFiles = (tsdPtr->numFdBits > 0); - if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) { + if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { /* * Cannot emulate a polling select with a polling condition variable. * Instead, pretend to wait for files and tell the notifier @@ -711,7 +735,7 @@ Tcl_WaitForEvent(timePtr) waitForFiles = 1; tsdPtr->pollState = POLL_WANT; - timePtr = NULL; + myTimePtr = NULL; } else { tsdPtr->pollState = 0; } @@ -740,7 +764,7 @@ Tcl_WaitForEvent(timePtr) FD_ZERO( &(tsdPtr->readyMasks.exceptional) ); if (!tsdPtr->eventReady) { - Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); + Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, myTimePtr); } tsdPtr->eventReady = 0; diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 32cea2d..9c043ee 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.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: tclUnixTime.c,v 1.22 2004/09/27 14:31:20 kennykb Exp $ + * RCS: @(#) $Id: tclUnixTime.c,v 1.23 2005/01/21 22:25:35 andreas_kupries Exp $ */ #include "tclInt.h" @@ -45,6 +45,17 @@ static char* lastTZ = NULL; /* Holds the last setting of the static void SetTZIfNecessary _ANSI_ARGS_((void)); static void CleanupMemory _ANSI_ARGS_((ClientData)); + +static void NativeScaleTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); +static void NativeGetTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); + +/* TIP #233 (Virtualized Time) + * Data for the time hooks, if any. + */ + +Tcl_GetTimeProc* tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc* tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; /* *----------------------------------------------------------------------------- @@ -92,18 +103,22 @@ unsigned long TclpGetClicks() { unsigned long now; -#ifdef NO_GETTOD - struct tms dummy; -#else - struct timeval date; - struct timezone tz; -#endif #ifdef NO_GETTOD - now = (unsigned long) times(&dummy); + if (tclGetTimeProcPtr != NativeGetTime) { + Tcl_Time time; + (*tclGetTimeProcPtr) (&time, tclTimeClientData); + now = time.sec*1000000 + time.usec; + } else { + /* A semi-NativeGetTime, specialized to clicks */ + struct tms dummy; + now = (unsigned long) times(&dummy); + } #else - gettimeofday(&date, &tz); - now = date.tv_sec*1000000 + date.tv_usec; + Tcl_Time time; + + (*tclGetTimeProcPtr) (&time, tclTimeClientData); + now = time.sec*1000000 + time.usec; #endif return now; @@ -235,6 +250,9 @@ TclpGetTimeZone (currentTime) * Gets the current system time in seconds and microseconds * since the beginning of the epoch: 00:00 UCT, January 1, 1970. * + * This function is hooked, allowing users to specify their + * own virtual system time. + * * Results: * Returns the current time in timePtr. * @@ -248,12 +266,7 @@ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { - struct timeval tv; - struct timezone tz; - - (void) gettimeofday(&tv, &tz); - timePtr->sec = tv.tv_sec; - timePtr->usec = tv.tv_usec; + (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); } /* @@ -384,7 +397,126 @@ TclpLocaltime_unix( timePtr ) { return TclpLocaltime( timePtr ); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimeProc -- + * + * TIP #233 (Virtualized Time) + * Registers two handlers for the virtualization of Tcl's + * access to time information. + * + * Results: + * None. + * + * Side effects: + * Remembers the handlers, alters core behaviour. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimeProc (getProc, scaleProc, clientData) + Tcl_GetTimeProc* getProc; + Tcl_ScaleTimeProc* scaleProc; + ClientData clientData; +{ + tclGetTimeProcPtr = getProc; + tclScaleTimeProcPtr = scaleProc; + tclTimeClientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueryTimeProc -- + * + * TIP #233 (Virtualized Time) + * Query which time handlers are registered. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +void +Tcl_QueryTimeProc (getProc, scaleProc, clientData) + Tcl_GetTimeProc** getProc; + Tcl_ScaleTimeProc** scaleProc; + ClientData* clientData; +{ + if (getProc) { + *getProc = tclGetTimeProcPtr; + } + if (scaleProc) { + *scaleProc = tclScaleTimeProcPtr; + } + if (clientData) { + *clientData = tclTimeClientData; + } +} + +/* + *---------------------------------------------------------------------- + * + * NativeScaleTime -- + * + * TIP #233 + * Scale from virtual time to the real-time. For native scaling the + * relationship is 1:1 and nothing has to be done. + * + * Results: + * Scales the time in timePtr. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static void +NativeScaleTime (timePtr, clientData) + Tcl_Time* timePtr; + ClientData clientData; +{ + /* Native scale is 1:1. Nothing is done */ +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233 + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime (timePtr, clientData) + Tcl_Time* timePtr; + ClientData clientData; +{ + struct timeval tv; + struct timezone tz; + + (void) gettimeofday(&tv, &tz); + timePtr->sec = tv.tv_sec; + timePtr->usec = tv.tv_usec; +} /* *---------------------------------------------------------------------- * diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 3bcfd2b..5c02108 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.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: tclWinNotify.c,v 1.16 2004/04/06 22:25:58 dgp Exp $ + * RCS: @(#) $Id: tclWinNotify.c,v 1.17 2005/01/21 22:25:35 andreas_kupries Exp $ */ #include "tclInt.h" @@ -444,7 +444,17 @@ Tcl_WaitForEvent( */ if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + /* TIP #233 (Virtualized Time). Convert virtual domain delay + * to real-time. + */ + + Tcl_Time myTime; + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + + timeout = myTime.sec * 1000 + myTime.usec / 1000; } else { timeout = INFINITE; } @@ -544,15 +554,24 @@ Tcl_Sleep(ms) Tcl_Time now; /* Current wall clock time */ Tcl_Time desired; /* Desired wakeup time */ - DWORD sleepTime = ms; /* Time to sleep */ + Tcl_Time vdelay; /* Time to sleep, for scaling virtual -> real */ + DWORD sleepTime; /* Time to sleep, real-time */ + + vdelay.sec = ms / 1000; + vdelay.usec = (ms % 1000) * 1000; Tcl_GetTime( &now ); - desired.sec = now.sec + ( ms / 1000 ); - desired.usec = now.usec + 1000 * ( ms % 1000 ); + desired.sec = now.sec + vdelay.sec; + desired.usec = now.usec + vdelay.usec; if ( desired.usec > 1000000 ) { ++desired.sec; desired.usec -= 1000000; } + + /* TIP #233: Scale delay from virtual to real-time */ + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; for ( ; ; ) { Sleep( sleepTime ); @@ -563,8 +582,12 @@ Tcl_Sleep(ms) && ( now.usec >= desired.usec ) ) { break; } - sleepTime = ( ( 1000 * ( desired.sec - now.sec ) ) - + ( ( desired.usec - now.usec ) / 1000 ) ); + + vdelay.sec = desired.sec - now.sec; + vdelay.usec = desired.usec - now.usec; + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; } } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 48460bb..47294df 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.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: tclWinTime.c,v 1.28 2004/09/07 17:39:00 kennykb Exp $ + * RCS: @(#) $Id: tclWinTime.c,v 1.29 2005/01/21 22:25:35 andreas_kupries Exp $ */ #include "tclInt.h" @@ -138,6 +138,17 @@ static Tcl_WideInt AccumulateSample _ANSI_ARGS_(( Tcl_WideInt perfCounter, Tcl_WideUInt fileTime )); + +static void NativeScaleTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); +static void NativeGetTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); + +/* TIP #233 (Virtualized Time) + * Data for the time hooks, if any. + */ + +Tcl_GetTimeProc* tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc* tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; /* *---------------------------------------------------------------------- @@ -160,7 +171,8 @@ unsigned long TclpGetSeconds() { Tcl_Time t; - Tcl_GetTime( &t ); + /* Tcl_GetTime inlined */ + (*tclGetTimeProcPtr) (&t, tclTimeClientData); return t.sec; } @@ -195,7 +207,9 @@ TclpGetClicks() Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ - Tcl_GetTime( &now ); + /* Tcl_GetTime inlined */ + (*tclGetTimeProcPtr) (&now, tclTimeClientData); + retval = ( now.sec * 1000000 ) + now.usec; return retval; @@ -258,6 +272,64 @@ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { + (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); +} + +/* + *---------------------------------------------------------------------- + * + * NativeScaleTime -- + * + * TIP #233 + * Scale from virtual time to the real-time. For native scaling the + * relationship is 1:1 and nothing has to be done. + * + * Results: + * Scales the time in timePtr. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static void +NativeScaleTime (timePtr, clientData) + Tcl_Time* timePtr; + ClientData clientData; +{ + /* Native scale is 1:1. Nothing is done */ +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233 + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * On the first call, initializes a set of static variables to + * keep track of the base value of the performance counter, the + * corresponding wall clock (obtained through ftime) and the + * frequency of the performance counter. Also spins a thread + * whose function is to wake up periodically and monitor these + * values, adjusting them as necessary to correct for drift + * in the performance counter's oscillator. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime (timePtr, clientData) + Tcl_Time* timePtr; + ClientData clientData; +{ struct timeb t; @@ -1182,3 +1254,67 @@ TclpLocaltime( timePtr ) */ return localtime( timePtr ); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimeProc -- + * + * TIP #233 (Virtualized Time) + * Registers two handlers for the virtualization of Tcl's + * access to time information. + * + * Results: + * None. + * + * Side effects: + * Remembers the handlers, alters core behaviour. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimeProc (getProc, scaleProc, clientData) + Tcl_GetTimeProc* getProc; + Tcl_ScaleTimeProc* scaleProc; + ClientData clientData; +{ + tclGetTimeProcPtr = getProc; + tclScaleTimeProcPtr = scaleProc; + tclTimeClientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueryTimeProc -- + * + * TIP #233 (Virtualized Time) + * Query which time handlers are registered. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueryTimeProc (getProc, scaleProc, clientData) + Tcl_GetTimeProc** getProc; + Tcl_ScaleTimeProc** scaleProc; + ClientData* clientData; +{ + if (getProc) { + *getProc = tclGetTimeProcPtr; + } + if (scaleProc) { + *scaleProc = tclScaleTimeProcPtr; + } + if (clientData) { + *clientData = tclTimeClientData; + } +} + |