path: root/generic/tclClock.c

/*
 * tclClock.c --
 *
 *	Contains the time and date related commands. This code is derived from
 *	the time and date facilities of TclX, by Mark Diekhans and Karl
 *	Lehenbauer.
 *
 * 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.42 2005/11/01 15:30:52 dkf Exp $
 */

#include "tclInt.h"

/*
 * Windows has mktime. The configurators do not check.
 */

#ifdef __WIN32__
#define HAVE_MKTIME 1
#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)

/*
 * Function prototypes for local procedures in this file:
 */

static struct tm *	ThreadSafeLocalTime(CONST time_t *);
static void		TzsetIfNecessary(void);

/*
 *----------------------------------------------------------------------
 *
 * TclClockGetenvObjCmd --
 *
 *	Tcl command that reads an environment variable from the system
 *
 * Usage:
 *	::tcl::clock::getEnv NAME
 *
 * Parameters:
 *	NAME - Name of the environment variable desired
 *
 * Results:
 *	Returns a standard Tcl result.  Returns an error if the
 *	variable does not exist, with a message left in the interpreter.
 *	Returns TCL_OK and the value of the variable if the variable
 *	does exist,
 *
 *----------------------------------------------------------------------
 */

int
TclClockGetenvObjCmd(
    ClientData clientData,
    Tcl_Interp* interp,
    int objc,
    Tcl_Obj *CONST objv[])
{

    CONST char* varName;
    CONST char* varValue;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    varName = Tcl_GetStringFromObj(objv[1], NULL);
    varValue = getenv(varName);
    if (varValue == NULL) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("variable not found", -1));
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
	return TCL_OK;
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * TclClockLocaltimeObjCmd --
 *
 *	Tcl command that extracts local time using the C library to do
 *	it.
 *
 * Usage:
 *	::tcl::clock::Localtime <tick>
 *
 * Parameters:
 *	<tick> -- A count of seconds from the Posix epoch.
 *
 * Results:

 *	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:
 *	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
TclClockLocaltimeObjCmd(
    ClientData clientData,	/* Unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* CONST* objv)	/* Parameter vector */
{
    Tcl_WideInt tick;		/* Time to convert */
    time_t tock;
    struct tm* timeVal;		/* Time after conversion */

    Tcl_Obj* returnVec[ 6 ];

    /*
     * Check args
     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "seconds");
	return TCL_ERROR;
    }
    if (Tcl_GetWideIntFromObj(interp, objv[1], &tick) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Convert the time, checking for overflow
     */

    tock = (time_t) tick;
    if ((Tcl_WideInt) tock != tick) {
	Tcl_AppendResult(interp,
		"number too large to represent as a Posix time", NULL);
	Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
	return TCL_ERROR;
    }
    TzsetIfNecessary();
    timeVal = ThreadSafeLocalTime(&tock);
    if (timeVal == NULL) {
	Tcl_AppendResult(interp, "localtime failed (clock value may be too ",
		"large/small to represent)", NULL);
	Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
	return TCL_ERROR;
    }

    /*
     * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeLocalTime(
    CONST time_t *timePtr)	/* Pointer to the number of seconds since the
				 * local system's epoch */
{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, tmPtr);
#else
    struct tm *sysTmPtr;

    Tcl_MutexLock(&clockMutex);
    sysTmPtr = localtime(timePtr);
    if (sysTmPtr == NULL) {
	Tcl_MutexUnlock(&clockMutex);
	return NULL;
    } else {
	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.
 *
 *----------------------------------------------------------------------
 */

int
TclClockMktimeObjCmd(
    ClientData clientData,	/* Unused */
    Tcl_Interp *interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *CONST *objv)	/* Parameter vector */
{
#ifndef HAVE_MKTIME
    Tcl_AppendResult(interp, "cannot determine local time", NULL);
    return TCL_ERROR;
#else

    int i;
    struct tm toConvert;	/* Time to be converted */
    time_t convertedTime;	/* Time converted from mktime */
    int localErrno;

    /*
     * Convert parameters
     */

    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 - 1;
    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 = -1;
    toConvert.tm_yday = -1;

    /*
     * Convert the time. It is rumored that mktime is not thread safe on some
     * platforms.
     */

    TzsetIfNecessary();
    Tcl_MutexLock(&clockMutex);
    errno = 0;
    convertedTime = mktime(&toConvert);
    localErrno = errno;
    Tcl_MutexUnlock(&clockMutex);

    /*
     * Return the converted time, or an error if conversion fails.
     */

    if (localErrno != 0 || (convertedTime == -1 && toConvert.tm_yday == -1)) {
	Tcl_AppendResult(interp, "time value too large/small to represent",
		NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) convertedTime));
    return TCL_OK;
#endif /* HAVE_MKTIME */
}

/*----------------------------------------------------------------------
 *
 * TclClockClicksObjCmd --
 *
 *	Returns a high-resolution counter.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 * This function implements the 'clock clicks' Tcl command. Refer to the user
 * documentation for details on what it does.
 *
 *----------------------------------------------------------------------
 */

int
TclClockClicksObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* CONST* objv)	/* Parameter values */
{
    static CONST char *clicksSwitches[] = {
	"-milliseconds", "-microseconds", 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:
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt)
		TclpGetClicks()));
	break;
    case CLICKS_MICROS:
	Tcl_GetTime(&now);
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
		((Tcl_WideInt) now.sec * 1000000) + now.usec));
	break;
    }

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

int
TclClockMillisecondsObjCmd(
    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, NULL);
	return TCL_ERROR;
    }
    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.
 *
 *----------------------------------------------------------------------
 */

int
TclClockMicrosecondsObjCmd(
    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, NULL);
	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.
 *
 *----------------------------------------------------------------------
 */

int
TclClockSecondsObjCmd(
    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, NULL);
	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.
 *
 *----------------------------------------------------------------------
 */

static void
TzsetIfNecessary(void)
{
    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);
	}
	tzWas = ckalloc(strlen(tzIsNow) + 1);
	strcpy(tzWas, tzIsNow);
    } else if (tzIsNow == NULL && tzWas != NULL) {
	tzset();
	ckfree(tzWas);
	tzWas = NULL;
    }
    Tcl_MutexUnlock(&clockMutex);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */