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.40 2005/08/12 23:55:28 kennykb 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 _ANSI_ARGS_(( CONST time_t* ));
static void TzsetIfNecessary _ANSI_ARGS_(( 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_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 );
    if ( timeVal == NULL ) {
	Tcl_SetObjResult(interp, 
			 Tcl_NewStringObj("localtime failed (clock "
					  "value may be too large/"
					  "small to represent)", -1));
	Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char*) 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(timePtr)
    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_SetObjResult( interp,
		      Tcl_NewStringObj( "cannot determine local time", -1 ) );
    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_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

}

/*----------------------------------------------------------------------
 *
 * 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, interp, objc, objv)
    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", (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;
    }

    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, 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, 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, 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, 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, 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, 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()
{
    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 );
}