* 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.

12 files changed, 489 insertions, 47 deletions

diff --git a/ChangeLog b/ChangeLog
index d57b049..a97f5bc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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(&notifierMutex);
 
     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, &notifierMutex, timePtr);
+        Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, 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;
+    }
+}
+