summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
committerKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
commitfab56e2415bbbc5e2355f500b28d26c5e907ef29 (patch)
tree0bfbd9e68acb81b08b317b956ce8ac4cca0824cd /generic
parentdcdb6368302f0bb38e0d11e8c2d346b684507b07 (diff)
downloadtcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.zip
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.gz
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.bz2
TIP #173 and #209 implementation - see ChangeLog for details
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c55
-rw-r--r--generic/tclClock.c823
-rw-r--r--generic/tclInt.h16
-rw-r--r--generic/tclInterp.c19
4 files changed, 612 insertions, 301 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 004e34c..63b709a 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -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: tclBasic.c,v 1.111 2004/08/02 20:55:36 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.112 2004/08/18 19:58:58 kennykb Exp $
*/
#include "tclInt.h"
@@ -71,8 +71,6 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
TclCompileCatchCmd, 1},
- {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
- (CompileProc *) NULL, 1},
{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
(CompileProc *) NULL, 1},
{"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
@@ -231,6 +229,30 @@ static CmdInfo builtInCmds[] = {
{NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0}
};
+
+static const CmdInfo clockCmds [] = {
+ /*
+ * Commands in the '::tcl::clock' namespace that support the
+ * 'clock' ensemble
+ */
+
+ { "::tcl::clock::clicks", (Tcl_CmdProc*) NULL,
+ TclClockClicksObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::microseconds", (Tcl_CmdProc*) NULL,
+ TclClockMicrosecondsObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::milliseconds", (Tcl_CmdProc*) NULL,
+ TclClockMillisecondsObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::seconds", (Tcl_CmdProc*) NULL,
+ TclClockSecondsObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::Localtime", (Tcl_CmdProc*) NULL,
+ TclClockLocaltimeObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::Mktime", (Tcl_CmdProc*) NULL,
+ TclClockMktimeObjCmd, (CompileProc*) NULL, 0 },
+ { "::tcl::clock::Oldscan", (Tcl_CmdProc*) NULL,
+ TclClockOldscanObjCmd, (CompileProc*) NULL, 0 },
+ { NULL, (Tcl_CmdProc *) NULL,
+ (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0 }
+};
/*
*----------------------------------------------------------------------
@@ -260,7 +282,7 @@ Tcl_CreateInterp()
BuiltinFunc *builtinFuncPtr;
MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
- CmdInfo *cmdInfoPtr;
+ const CmdInfo *cmdInfoPtr;
int i;
union {
char c[sizeof(short)];
@@ -472,6 +494,24 @@ Tcl_CreateInterp()
}
/*
+ * Register the clock commands. These *do* go through
+ * Tcl_CreateObjCommand, since they aren't in the global namespace.
+ */
+
+ for ( cmdInfoPtr = clockCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
+ if ( cmdInfoPtr->objProc == NULL ) {
+ Tcl_CreateCommand( interp, cmdInfoPtr->name,
+ cmdInfoPtr->proc, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL );
+ } else {
+ Tcl_CreateObjCommand( interp, cmdInfoPtr->name,
+ cmdInfoPtr->objProc, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL );
+ }
+ }
+
+
+ /*
* Register the builtin math functions.
*/
@@ -605,7 +645,7 @@ int
TclHideUnsafeCommands(interp)
Tcl_Interp *interp; /* Hide commands in this interpreter. */
{
- register CmdInfo *cmdInfoPtr;
+ register const CmdInfo *cmdInfoPtr;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
@@ -615,6 +655,11 @@ TclHideUnsafeCommands(interp)
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
+ for (cmdInfoPtr = clockCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
+ if (!cmdInfoPtr->isSafe) {
+ Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
+ }
+ }
return TCL_OK;
}
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 67570df..91f204b 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -7,17 +7,34 @@
*
* Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclClock.c,v 1.28 2004/05/14 21:43:28 kennykb Exp $
+ * RCS: @(#) $Id: tclClock.c,v 1.29 2004/08/18 19:58:59 kennykb Exp $
*/
#include "tclInt.h"
/*
- * The date parsing stuff uses lexx and has tons o statics.
+ * Windows has mktime. The configurators do not check.
+ */
+
+#ifdef WIN32
+#define HAVE_MKTIME
+#endif
+
+/*
+ * Thread specific data block holding a 'struct tm' for the 'gmtime'
+ * and 'localtime' library calls.
+ */
+
+static Tcl_ThreadDataKey tmKey;
+
+/*
+ * Mutex protecting 'gmtime', 'localtime' and 'mktime' calls
+ * and the statics in the date parsing code.
*/
TCL_DECLARE_MUTEX(clockMutex)
@@ -26,358 +43,580 @@ TCL_DECLARE_MUTEX(clockMutex)
* Function prototypes for local procedures in this file:
*/
-static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
- unsigned long clockVal, int useGMT,
- char *format));
+static struct tm* ThreadSafeLocalTime _ANSI_ARGS_(( CONST time_t* ));
+static void TzsetIfNecessary _ANSI_ARGS_(( void ));
/*
*-------------------------------------------------------------------------
*
- * Tcl_ClockObjCmd --
+ * TclClockLocaltimeObjCmd --
+ *
+ * Tcl command that extracts local time using the C library to do
+ * it.
*
- * This procedure is invoked to process the "clock" Tcl command.
- * See the user documentation for details on what it does.
+ * Usage:
+ * ::tcl::clock::Localtime <tick>
+ *
+ * Parameters:
+ * <tick> -- A count of seconds from the Posix epoch.
*
* Results:
- * A standard Tcl result.
+ * Returns a standard Tcl result. The object result is a Tcl
+ * list containing the year, month, day, hour, minute, and second
+ * fields of the local time. It may return an error if the
+ * argument exceeds the arithmetic range representable by
+ * 'time_t'.
*
* Side effects:
- * See the user documentation.
+ * None.
+ *
+ * This function is used as a call of last resort if the current time
+ * zone cannot be determined from environment variables TZ or TCL_TZ.
+ * It attempts to use the 'localtime' library function to extract the
+ * time and return it that way. This method suffers from Y2038 problems
+ * on most platforms. It also provides no portable way to get the
+ * name of the time zone.
*
*-------------------------------------------------------------------------
*/
int
-Tcl_ClockObjCmd (client, interp, objc, objv)
- ClientData client; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument values. */
+TclClockLocaltimeObjCmd( ClientData clientData,
+ /* Unused */
+ Tcl_Interp* interp,
+ /* Tcl interpreter */
+ int objc,
+ /* Parameter count */
+ Tcl_Obj* CONST* objv )
+ /* Parameter vector */
{
- Tcl_Obj *resultPtr;
- int index;
- Tcl_Obj *CONST *objPtr;
- int useGMT = 0;
- char *format = "%a %b %d %X %Z %Y";
- int clickType = 2;
- int dummy;
- unsigned long baseClock, clockVal;
- long zone;
- Tcl_Obj *baseObjPtr = NULL;
- char *scanStr;
- Tcl_Time now; /* Current time */
+ Tcl_WideInt tick; /* Time to convert */
+ time_t tock;
+ struct tm* timeVal; /* Time after conversion */
- static CONST char *switches[] = {
- "clicks", "format", "scan", "seconds", (char *) NULL
- };
- enum command {
- COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN, COMMAND_SECONDS
- };
- static CONST char *clicksSwitches[] = {
- "-milliseconds", "-microseconds", (char*) NULL
- };
- static CONST char *formatSwitches[] = {
- "-format", "-gmt", (char *) NULL
- };
- static CONST char *scanSwitches[] = {
- "-base", "-gmt", (char *) NULL
- };
+ Tcl_Obj* returnVec[ 6 ];
+
+ /* Check args */
- resultPtr = Tcl_GetObjResult(interp);
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ if ( objc != 2 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "seconds" );
return TCL_ERROR;
}
-
- if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
- != TCL_OK) {
+ if ( Tcl_GetWideIntFromObj( interp, objv[1], &tick ) != TCL_OK ) {
return TCL_ERROR;
}
- switch ((enum command) index) {
- case COMMAND_CLICKS: { /* clicks */
- if (objc == 3) {
- if (Tcl_GetIndexFromObj(interp, objv[2], clicksSwitches,
- "option", 0, &clickType) != TCL_OK) {
- return TCL_ERROR;
- }
- } else if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "?option?");
- return TCL_ERROR;
- }
- switch (clickType) {
- case 0: /* milliseconds */
- Tcl_GetTime(&now);
- Tcl_SetWideIntObj(resultPtr,
- ((Tcl_WideInt) now.sec * 1000 + now.usec / 1000));
- break;
- case 1: /* microseconds */
- Tcl_GetTime(&now);
- Tcl_SetWideIntObj(resultPtr,
- ((Tcl_WideInt) now.sec * 1000000 + now.usec));
- break;
- case 2: /* native clicks */
- Tcl_SetWideIntObj(resultPtr, (Tcl_WideInt) TclpGetClicks());
- break;
- }
- return TCL_OK;
- }
+ /* Convert the time, checking for overflow */
- case COMMAND_FORMAT: /* format */
- if ((objc < 3) || (objc > 7)) {
- wrongFmtArgs:
- Tcl_WrongNumArgs(interp, 2, objv,
- "clockval ?-format string? ?-gmt boolean?");
- return TCL_ERROR;
- }
+ tock = (time_t) tick;
+ if ( (Tcl_WideInt) tock != tick ) {
+ Tcl_SetObjResult
+ ( interp,
+ Tcl_NewStringObj("number too large to represent as a Posix time",
+ -1) );
+ Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL );
+ return TCL_ERROR;
+ }
+ TzsetIfNecessary();
+ timeVal = ThreadSafeLocalTime( &tock );
+
+ /* Package the results */
+
+ returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 );
+ returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1);
+ returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday );
+ returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour );
+ returnVec[4] = Tcl_NewIntObj( timeVal->tm_min );
+ returnVec[5] = Tcl_NewIntObj( timeVal->tm_sec );
+ Tcl_SetObjResult( interp, Tcl_NewListObj( 6, returnVec ) );
+ return TCL_OK;
- if (Tcl_GetLongFromObj(interp, objv[2], (long*) &clockVal)
- != TCL_OK) {
- return TCL_ERROR;
- }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ThreadSafeLocalTime --
+ *
+ * Wrapper around the 'localtime' library function to make it thread
+ * safe.
+ *
+ * Results:
+ * Returns a pointer to a 'struct tm' in thread-specific data.
+ *
+ * Side effects:
+ * Invokes localtime or localtime_r as appropriate.
+ *
+ *----------------------------------------------------------------------
+ */
- objPtr = objv+3;
- objc -= 3;
- while (objc > 1) {
- if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches,
- "switch", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch (index) {
- case 0: /* -format */
- format = Tcl_GetStringFromObj(objPtr[1], &dummy);
- break;
- case 1: /* -gmt */
- if (Tcl_GetBooleanFromObj(interp, objPtr[1],
- &useGMT) != TCL_OK) {
- return TCL_ERROR;
- }
- break;
- }
- objPtr += 2;
- objc -= 2;
- }
- if (objc != 0) {
- goto wrongFmtArgs;
- }
- return FormatClock(interp, (unsigned long) clockVal, useGMT,
- format);
-
- case COMMAND_SCAN: /* scan */
- if ((objc < 3) || (objc > 7)) {
- wrongScanArgs:
- Tcl_WrongNumArgs(interp, 2, objv,
- "dateString ?-base clockValue? ?-gmt boolean?");
- return TCL_ERROR;
- }
+static struct tm *
+ThreadSafeLocalTime(timePtr)
+ CONST time_t *timePtr; /* Pointer to the number of seconds
+ * since the local system's epoch
+ */
- objPtr = objv+3;
- objc -= 3;
- while (objc > 1) {
- if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
- "switch", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch (index) {
- case 0: /* -base */
- baseObjPtr = objPtr[1];
- break;
- case 1: /* -gmt */
- if (Tcl_GetBooleanFromObj(interp, objPtr[1],
- &useGMT) != TCL_OK) {
- return TCL_ERROR;
- }
- break;
- }
- objPtr += 2;
- objc -= 2;
- }
- if (objc != 0) {
- goto wrongScanArgs;
- }
+{
+ /*
+ * Get a thread-local buffer to hold the returned time.
+ */
- if (baseObjPtr != NULL) {
- if (Tcl_GetLongFromObj(interp, baseObjPtr,
- (long*) &baseClock) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
- baseClock = TclpGetSeconds();
- }
+ struct tm *tmPtr = (struct tm *)
+ Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
+#ifdef HAVE_LOCALTIME_R
+ localtime_r(timePtr, tmPtr);
+#else
+ Tcl_MutexLock(&clockMutex);
+ memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));
+ Tcl_MutexUnlock(&clockMutex);
+#endif
+ return tmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclClockMktimeObjCmd --
+ *
+ * Determine seconds from the epoch, given the fields of a local
+ * time.
+ *
+ * Usage:
+ * mktime <year> <month> <day> <hour> <minute> <second>
+ *
+ * Parameters:
+ * year -- Calendar year
+ * month -- Calendar month
+ * day -- Calendar day
+ * hour -- Hour of day (00-23)
+ * minute -- Minute of hour
+ * second -- Second of minute
+ *
+ * Results:
+ * Returns the given local time.
+ *
+ * Errors:
+ * Returns an error if the 'mktime' function does not exist in the
+ * C library, or if the given time cannot be converted.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if (useGMT) {
- zone = -50000; /* Force GMT */
- } else {
- zone = TclpGetTimeZone((unsigned long) baseClock);
- }
+int
+TclClockMktimeObjCmd( ClientData clientData,
+ /* Unused */
+ Tcl_Interp* interp,
+ /* Tcl interpreter */
+ int objc,
+ /* Parameter count */
+ Tcl_Obj* CONST* objv )
+ /* Parameter vector */
+{
+ int i;
+ struct tm toConvert; /* Time to be converted */
+ time_t convertedTime; /* Time converted from mktime */
- scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
- Tcl_MutexLock(&clockMutex);
- if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
- (unsigned long *) &clockVal) < 0) {
- Tcl_MutexUnlock(&clockMutex);
- Tcl_AppendStringsToObj(resultPtr,
- "unable to convert date-time string \"",
- scanStr, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_MutexUnlock(&clockMutex);
+#ifndef HAVE_MKTIME
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "cannot determine local time", -1 ) );
+ return TCL_ERROR;
+#else
- Tcl_SetLongObj(resultPtr, (long) clockVal);
- return TCL_OK;
+ /* Convert parameters */
- case COMMAND_SECONDS: /* seconds */
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
- return TCL_OK;
- default:
- return TCL_ERROR; /* Should never be reached. */
+ if ( objc != 7 ) {
+ Tcl_WrongNumArgs( interp, 1, objv,
+ "year month day hour minute second" );
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetIntFromObj( interp, objv[1], &i ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ toConvert.tm_year = i - 1900;
+ if ( Tcl_GetIntFromObj( interp, objv[2], &i ) != TCL_OK ) {
+ return TCL_ERROR;
}
+ toConvert.tm_mon = i;
+ if ( Tcl_GetIntFromObj( interp, objv[3], &i ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ toConvert.tm_mday = i;
+ if ( Tcl_GetIntFromObj( interp, objv[4], &i ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ toConvert.tm_hour = i;
+ if ( Tcl_GetIntFromObj( interp, objv[5], &i ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ toConvert.tm_min = i;
+ if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ toConvert.tm_sec = i;
+ toConvert.tm_isdst = -1;
+ toConvert.tm_wday = 0;
+ toConvert.tm_yday = 0;
+
+ /* Convert the time. It is rumored that mktime is not thread
+ * safe on some platforms. */
+
+ TzsetIfNecessary();
+ Tcl_MutexLock( &clockMutex );
+ convertedTime = mktime( &toConvert );
+ Tcl_MutexUnlock( &clockMutex );
+
+ /* Return the converted time, or an error if conversion fails */
+
+ if ( convertedTime == -1 ) {
+ Tcl_SetObjResult
+ ( interp,
+ Tcl_NewStringObj( "time value too large/small to represent",
+ -1 ) );
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( (Tcl_WideInt) convertedTime ) );
+ return TCL_OK;
+ }
+
+#endif
+
}
-/*
- *-----------------------------------------------------------------------------
+
+/*----------------------------------------------------------------------
*
- * FormatClock --
+ * TclClockClicksObjCmd --
*
- * Formats a time value based on seconds into a human readable
- * string.
+ * Returns a high-resolution counter.
*
* Results:
- * Standard Tcl result.
+ * Returns a standard Tcl result.
*
* Side effects:
- * None.
+ * None.
+ *
+ * This function implements the 'clock clicks' Tcl command. Refer
+ * to the user documentation for details on what it does.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-static int
-FormatClock(interp, clockVal, useGMT, format)
- Tcl_Interp *interp; /* Current interpreter. */
- unsigned long clockVal; /* Time in seconds. */
- int useGMT; /* Boolean */
- char *format; /* Format string */
+int
+TclClockClicksObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Client data is unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Parameter count */
+ Tcl_Obj* CONST* objv; /* Parameter values */
{
- struct tm *timeDataPtr;
- Tcl_DString buffer;
- int bufSize;
- char *p;
- int result;
- time_t tclockVal;
-#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
- int savedTimeZone = 0; /* lint. */
- char *savedTZEnv = NULL; /* lint. */
+ static CONST char *clicksSwitches[] = {
+ "-milliseconds", "-microseconds", (char*) NULL
+ };
+ enum ClicksSwitch {
+ CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
+ };
+ int index = CLICKS_NATIVE;
+ Tcl_Time now;
+
+ switch ( objc ) {
+ case 1:
+ break;
+ case 2:
+ if ( Tcl_GetIndexFromObj( interp, objv[1], clicksSwitches,
+ "option", 0, &index) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ break;
+ default:
+ Tcl_WrongNumArgs( interp, 1, objv, "?option?" );
+ return TCL_ERROR;
+ }
+
+ switch ( index ) {
+ case CLICKS_MILLIS:
+ Tcl_GetTime( &now );
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( (Tcl_WideInt) now.sec * 1000
+ + now.usec / 1000 ) );
+ break;
+ case CLICKS_NATIVE:
+#if 0
+ /*
+ * The following code will be used once this is incorporated
+ * into Tcl. But TEA bugs prevent it for right now. :(
+ * So we fall through this case and return the microseconds
+ * instead.
+ */
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( (Tcl_WideInt) TclpGetClicks() ) );
+ break;
#endif
+ case CLICKS_MICROS:
+ Tcl_GetTime( &now );
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( ( (Tcl_WideInt) now.sec
+ * 1000000 )
+ + now.usec ) );
+ break;
+ }
-#ifdef HAVE_TZSET
- /*
- * Some systems forgot to call tzset in localtime, make sure its done.
- */
- static int calledTzset = 0;
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * TclClockMillisecondsObjCmd -
+ *
+ * Returns a count of milliseconds since the epoch.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ * This function implements the 'clock milliseconds' Tcl command. Refer
+ * to the user documentation for details on what it does.
+ *
+ *----------------------------------------------------------------------
+ */
- Tcl_MutexLock(&clockMutex);
- if (!calledTzset) {
- tzset();
- calledTzset = 1;
+int
+TclClockMillisecondsObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Client data is unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Parameter count */
+ Tcl_Obj* CONST* objv; /* Parameter values */
+{
+ Tcl_Time now;
+ if ( objc != 1 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "" );
+ return TCL_ERROR;
}
- Tcl_MutexUnlock(&clockMutex);
-#endif
+ Tcl_GetTime( &now );
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( (Tcl_WideInt) now.sec * 1000
+ + now.usec / 1000 ) );
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * TclClockMicrosecondsObjCmd -
+ *
+ * Returns a count of microseconds since the epoch.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ * This function implements the 'clock microseconds' Tcl command. Refer
+ * to the user documentation for details on what it does.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * If the user gave us -format "", just return now
- */
- if (*format == '\0') {
- return TCL_OK;
+int
+TclClockMicrosecondsObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Client data is unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Parameter count */
+ Tcl_Obj* CONST* objv; /* Parameter values */
+{
+ Tcl_Time now;
+ if ( objc != 1 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "" );
+ return TCL_ERROR;
}
+ Tcl_GetTime( &now );
+ Tcl_SetObjResult( interp,
+ Tcl_NewWideIntObj( ( (Tcl_WideInt) now.sec * 1000000 )
+ + now.usec ) );
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * TclClockSecondsObjCmd -
+ *
+ * Returns a count of microseconds since the epoch.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ * This function implements the 'clock seconds' Tcl command. Refer
+ * to the user documentation for details on what it does.
+ *
+ *----------------------------------------------------------------------
+ */
-#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
- /*
- * This is a kludge for systems not having the timezone string in
- * struct tm. No matter what was specified, they use the local
- * timezone string. Since this kludge requires fiddling with the
- * TZ environment variable, it will mess up if done on multiple
- * threads at once. Protect it with a the clock mutex.
- */
-
- Tcl_MutexLock(&clockMutex);
- if (useGMT) {
- CONST char *varValue;
+int
+TclClockSecondsObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Client data is unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Parameter count */
+ Tcl_Obj* CONST* objv; /* Parameter values */
+{
+ Tcl_Time now;
+ if ( objc != 1 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "" );
+ return TCL_ERROR;
+ }
+ Tcl_GetTime( &now );
+ Tcl_SetObjResult( interp, Tcl_NewWideIntObj( (Tcl_WideInt) now.sec ) );
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TzsetIfNecessary --
+ *
+ * Calls the tzset() library function if the contents of the TZ
+ * environment variable has changed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls tzset.
+ *
+ *----------------------------------------------------------------------
+ */
- varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
- if (varValue != NULL) {
- savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
- } else {
- savedTZEnv = NULL;
+static void
+TzsetIfNecessary()
+{
+ static char* tzWas = NULL; /* Previous value of TZ, protected by
+ * clockMutex. */
+ CONST char* tzIsNow; /* Current value of TZ */
+
+ Tcl_MutexLock( &clockMutex );
+ tzIsNow = getenv( "TZ" );
+ if ( tzIsNow != NULL
+ && ( tzWas == NULL || strcmp( tzIsNow, tzWas ) != 0 ) ) {
+ tzset();
+ if ( tzWas != NULL ) {
+ ckfree( tzWas );
}
- Tcl_SetVar2(interp, "env", "TZ", "GMT0", TCL_GLOBAL_ONLY);
- savedTimeZone = timezone;
- timezone = 0;
- tzset();
+ tzWas = ckalloc( strlen( tzIsNow ) + 1 );
+ strcpy( tzWas, tzIsNow );
+ } else if ( tzIsNow == NULL && tzWas != NULL ) {
+ tzset();
+ ckfree( tzWas );
+ tzWas = NULL;
}
-#endif
+ Tcl_MutexUnlock( &clockMutex );
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclClockOldscanObjCmd --
+ *
+ * Implements the legacy 'clock scan' Tcl command when no '-format'
+ * option is supplied.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * This function implements the 'clock scan' Tcl command when no
+ * -format group is present. Refer to the user documentation to see
+ * what it does.
+ *
+ *-------------------------------------------------------------------------
+ */
- tclockVal = clockVal;
- timeDataPtr = TclpGetDate(&tclockVal, useGMT);
+int
+TclClockOldscanObjCmd( ClientData clientData, /* unused */
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj *CONST * objv /* Parameter vector */
+ )
+{
+ int index;
+ Tcl_Obj *CONST *objPtr;
+ char *scanStr;
+ Tcl_Obj *baseObjPtr = NULL;
+ int useGMT = 0;
+ unsigned long baseClock;
+ long clockVal;
+ long zone;
+ Tcl_Obj *resultPtr;
+ int dummy;
- /*
- * Make a guess at the upper limit on the substituted string size
- * based on the number of percents in the string.
- */
+ static CONST char *scanSwitches[] = {
+ "-base", "-gmt", (char *) NULL
+ };
- for (bufSize = 1, p = format; *p != '\0'; p++) {
- if (*p == '%') {
- bufSize += 40;
- } else {
- bufSize++;
+ if ((objc < 2) || (objc > 6)) {
+ wrongScanArgs:
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "dateString ?-base clockValue? ?-gmt boolean?");
+ return TCL_ERROR;
+ }
+ objPtr = objv+2;
+ objc -= 2;
+ while (objc > 1) {
+ if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
+ "switch", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
}
+ switch (index) {
+ case 0: /* -base */
+ baseObjPtr = objPtr[1];
+ break;
+ case 1: /* -gmt */
+ if (Tcl_GetBooleanFromObj(interp, objPtr[1],
+ &useGMT) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ objPtr += 2;
+ objc -= 2;
}
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer, bufSize);
-
- /* If we haven't locked the clock mutex up above, lock it now. */
-
-#if defined(HAVE_TM_ZONE) || defined(WIN32)
- Tcl_MutexLock(&clockMutex);
-#endif
- result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
- timeDataPtr, useGMT);
-#if defined(HAVE_TM_ZONE) || defined(WIN32)
- Tcl_MutexUnlock(&clockMutex);
-#endif
-
-#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
+ if (objc != 0) {
+ goto wrongScanArgs;
+ }
+
+ if (baseObjPtr != NULL) {
+ if (Tcl_GetLongFromObj(interp, baseObjPtr,
+ (long*) &baseClock) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ baseClock = TclpGetSeconds();
+ }
+
if (useGMT) {
- if (savedTZEnv != NULL) {
- Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
- ckfree(savedTZEnv);
- } else {
- Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
- }
- timezone = savedTimeZone;
- tzset();
+ zone = -50000; /* Force GMT */
+ } else {
+ zone = TclpGetTimeZone((unsigned long) baseClock);
}
- Tcl_MutexUnlock(&clockMutex);
-#endif
-
- if (result == 0) {
- /*
- * A zero return is the error case (can also mean the strftime
- * didn't get enough space to write into). We know it doesn't
- * mean that we wrote zero chars because the check for an empty
- * format string is above.
- */
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad format string \"", format, "\"", (char *) NULL);
+
+ scanStr = Tcl_GetStringFromObj(objv[1], &dummy);
+ Tcl_MutexLock(&clockMutex);
+ if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
+ &clockVal) < 0) {
+ Tcl_MutexUnlock(&clockMutex);
+ resultPtr = Tcl_NewObj();
+ Tcl_AppendStringsToObj(resultPtr,
+ "unable to convert date-time string \"",
+ scanStr, "\"", (char *) NULL);
+ Tcl_SetObjResult( interp, resultPtr );
return TCL_ERROR;
}
-
- Tcl_SetStringObj(Tcl_GetObjResult(interp), buffer.string, -1);
-
- Tcl_DStringFree(&buffer);
+ Tcl_MutexUnlock(&clockMutex);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) clockVal ) );
return TCL_OK;
+
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 620af26..8633e6e 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.171 2004/08/02 20:55:37 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.172 2004/08/18 19:58:59 kennykb Exp $
*/
#ifndef _TCLINT
@@ -1958,7 +1958,19 @@ EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData,
+EXTERN int TclClockClicksObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockMicrosecondsObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockMillisecondsObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockSecondsObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockLocaltimeObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockMktimeObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclClockOldscanObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 12a2a8b..70c3356 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.43 2004/08/02 20:55:37 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.44 2004/08/18 19:59:00 kennykb Exp $
*/
#include "tclInt.h"
@@ -2003,6 +2003,8 @@ SlaveCreate(interp, pathPtr, safe)
char *path;
int new, objc;
Tcl_Obj **objv;
+ Tcl_Obj* clockObj;
+ int status;
if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
@@ -2071,10 +2073,23 @@ SlaveCreate(interp, pathPtr, safe)
*/
InheritLimitsFromMaster(slaveInterp, masterInterp);
+ if ( safe ) {
+ clockObj = Tcl_NewStringObj( "clock", -1 );
+ Tcl_IncrRefCount( clockObj );
+ status = AliasCreate( interp, slaveInterp, masterInterp,
+ clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL );
+ Tcl_DecrRefCount( clockObj );
+ if ( status != TCL_OK ) {
+ goto error2;
+ }
+ }
+
+
return slaveInterp;
- error:
+ error:
TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ error2:
Tcl_DeleteInterp(slaveInterp);
return NULL;