/* * 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.44 2005/11/30 14:48:04 kennykb Exp $ */ #include "tclInt.h" /* * Windows has mktime. The configurators do not check. */ #ifdef __WIN32__ #define HAVE_MKTIME 1 #endif /* * Constants */ #define JULIAN_SEC_POSIX_EPOCH ((Tcl_WideInt) 210866803200) #define SECONDS_PER_DAY 86400 #define FOUR_CENTURIES 146097 /* days */ #define JDAY_1_JAN_1_CE_JULIAN 1721424 #define JDAY_1_JAN_1_CE_GREGORIAN 1721426 #define ONE_CENTURY_GREGORIAN 36524 /* days */ #define FOUR_YEARS 1461 /* days */ #define ONE_YEAR 365 /* days */ /* * Table of the days in each month, leap and common years */ static const int hath[2][12] = { {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}, {31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31} }; static const int daysInPriorMonths[2][13] = { {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365}, {0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366} }; /* * Enumeration of the string literals used in [clock] */ typedef enum ClockLiteral { LIT_BCE, LIT_CE, LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR, LIT_ERA, LIT_GREGORIAN, LIT_ISO8601WEEK, LIT_ISO8601YEAR, LIT_JULIANDAY, LIT_LOCALSECONDS, LIT_MONTH, LIT_SECONDS, LIT_TZNAME, LIT_TZOFFSET, LIT_YEAR, LIT__END } ClockLiteral; static const char *const literals[] = { "BCE", "CE", "dayOfMonth", "dayOfWeek", "dayOfYear", "era", "gregorian", "iso8601Week", "iso8601Year", "julianDay", "localSeconds", "month", "seconds", "tzName", "tzOffset", "year" }; /* * Structure containing the client data for [clock] */ typedef struct ClockClientData { int refCount; /* Number of live references */ Tcl_Obj** literals; /* Pool of object literals */ } ClockClientData; /* * Structure containing the fields used in [clock format] and [clock scan] */ typedef struct TclDateFields { Tcl_WideInt seconds; /* Time expressed in seconds from the * Posix epoch */ Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds * from the Posix epoch */ int tzOffset; /* Time zone offset in seconds east of * Greenwich */ Tcl_Obj* tzName; /* Time zone name */ int julianDay; /* Julian Day Number in local time zone */ enum {BCE=1, CE=0} era; /* Era */ int gregorian; /* Flag == 1 if the date is Gregorian */ int year; /* Year of the era */ int dayOfYear; /* Day of the year (1 January == 1) */ int month; /* Month number */ int dayOfMonth; /* Day of the month */ int iso8601Year; /* ISO8601 week-based year */ int iso8601Week; /* ISO8601 week number */ int dayOfWeek; /* Day of the week */ } TclDateFields; /* * 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 int ConvertUTCToLocal(Tcl_Interp*, TclDateFields*, Tcl_Obj*, int); static int ConvertUTCToLocalUsingTable(Tcl_Interp*, TclDateFields*, int, Tcl_Obj *CONST[]); static int ConvertUTCToLocalUsingC(Tcl_Interp*, TclDateFields*, int); static int ConvertLocalToUTC(Tcl_Interp*, TclDateFields*, Tcl_Obj*, int); static int ConvertLocalToUTCUsingTable(Tcl_Interp*, TclDateFields*, int, Tcl_Obj *CONST[]); static int ConvertLocalToUTCUsingC(Tcl_Interp*, TclDateFields*, int); static Tcl_Obj* LookupLastTransition(Tcl_Interp*, Tcl_WideInt, int, Tcl_Obj *CONST *); static void GetYearWeekDay(TclDateFields*, int); static void GetGregorianEraYearDay(TclDateFields*, int); static void GetMonthDay(TclDateFields*); static void GetJulianDayFromEraYearWeekDay(TclDateFields*, int); static void GetJulianDayFromEraYearMonthDay(TclDateFields*, int); static int IsGregorianLeapYear(TclDateFields*); static int WeekdayOnOrBefore(int, int); static int ClockClicksObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockConvertlocaltoutcObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockGetdatefieldsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockGetenvObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockMicrosecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockMillisecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int ClockSecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static struct tm * ThreadSafeLocalTime(CONST time_t *); static void TzsetIfNecessary(void); static void ClockDeleteCmdProc(ClientData); /* *---------------------------------------------------------------------- * * TclClockInit -- * * Registers the 'clock' subcommands with the Tcl interpreter * and initializes its client data (which consists mostly of * constant Tcl_Obj's that it is too much trouble to keep * recreating). * * Results: * None. * * Side effects: * Installs the commands and creates the client data * *---------------------------------------------------------------------- */ void TclClockInit( Tcl_Interp* interp /* Tcl interpreter */ ) { int i; /* Create the client data */ ClockClientData *data = (ClockClientData*) ckalloc(sizeof(ClockClientData)); data->refCount = 0; /* * Create the literal pool */ data->literals = (Tcl_Obj**) ckalloc(LIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < LIT__END; ++i) { data->literals[i] = Tcl_NewStringObj(literals[i], -1); Tcl_IncrRefCount(data->literals[i]); } /* Install the commands */ Tcl_CreateObjCommand(interp, "::tcl::clock::clicks", ClockClicksObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::getenv", ClockGetenvObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::microseconds", ClockMicrosecondsObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::milliseconds", ClockMillisecondsObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::seconds", ClockSecondsObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", TclClockOldscanObjCmd, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd, (ClientData) data, ClockDeleteCmdProc); ++data->refCount; Tcl_CreateObjCommand(interp, "::tcl::clock::GetDateFields", ClockGetdatefieldsObjCmd,(ClientData) data, ClockDeleteCmdProc); ++data->refCount; } /* *---------------------------------------------------------------------- * * ClockConvertlocaltoutcObjCmd -- * * Tcl command that converts a UTC time to a local time by * whatever means is available. * * Usage: * ::tcl::clock::ConvertUTCToLocal dictionary tzdata changeover * * Parameters: * dict - Dictionary containing a 'localSeconds' entry. * tzdata - Time zone data * changeover - Julian Day of the adoption of the Gregorian calendar. * * Results: * Returns a standard Tcl result. * * Side effects: * On success, sets the interpreter result to the given dictionary * augmented with a 'seconds' field giving the UTC time. On failure, * leaves an error message in the interpreter result. * *---------------------------------------------------------------------- */ static int ClockConvertlocaltoutcObjCmd( ClientData clientData, /* Client data */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *CONST * objv /* Parameter vector */ ) { ClockClientData* data = (ClockClientData*) clientData; Tcl_Obj* CONST * literals = data->literals; Tcl_Obj* secondsObj; Tcl_Obj* dict; int changeover; TclDateFields fields; int created = 0; int status; /* Check params and convert time */ if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover"); return TCL_ERROR; } dict = objv[1]; if ((Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS], &secondsObj) != TCL_OK) || (Tcl_GetWideIntFromObj(interp, secondsObj, &(fields.localSeconds)) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[3], &changeover) != TCL_OK) || ConvertLocalToUTC(interp, &fields, objv[2], changeover)) { return TCL_ERROR; } /* * Copy-on-write; set the 'seconds' field in the dictionary and * place the modified dictionary in the interpreter result. */ if (Tcl_IsShared(dict)) { dict = Tcl_DuplicateObj(dict); created = 1; Tcl_IncrRefCount(dict); } status = Tcl_DictObjPut(interp, dict, literals[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (created) { Tcl_DecrRefCount(dict); } return status; } /* *---------------------------------------------------------------------- * * ClockGetdatefieldsObjCmd -- * * Tcl command that determines the values that [clock format] will * use in formatting a date, and populates a dictionary with them. * * Usage: * ::tcl::clock::GetDateFields seconds tzdata changeover * * Parameters: * seconds - Time expressed in seconds from the Posix epoch. * tzdata - Time zone data of the time zone in which time is to * be expressed. * changeover - Julian Day Number at which the current locale adopted * the Gregorian calendar * * Results: * Returns a dictonary populated with the fields: * seconds - Seconds from the Posix epoch * localSeconds - Nominal seconds from the Posix epoch in * the local time zone. * tzOffset - Time zone offset in seconds east of Greenwich * tzName - Time zone name * julianDay - Julian Day Number in the local time zone * *---------------------------------------------------------------------- */ int ClockGetdatefieldsObjCmd( ClientData clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *CONST *objv /* Parameter vector */ ) { TclDateFields fields; Tcl_Obj* dict; ClockClientData* data = (ClockClientData*) clientData; Tcl_Obj* CONST * literals = data->literals; int changeover; /* Check params */ if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover"); return TCL_ERROR; } if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK || Tcl_GetIntFromObj(interp, objv[3], &changeover) != TCL_OK) { return TCL_ERROR; } /* Convert UTC time to local */ if (ConvertUTCToLocal(interp, &fields, objv[2], changeover) != TCL_OK) { return TCL_ERROR; } /* Extract Julian day */ fields.julianDay = (int) ((fields.localSeconds + JULIAN_SEC_POSIX_EPOCH) / SECONDS_PER_DAY); /* Convert to Julian or Gregorian calendar */ GetGregorianEraYearDay(&fields, changeover); GetMonthDay(&fields); GetYearWeekDay(&fields, changeover); dict = Tcl_NewDictObj(); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_LOCALSECONDS], Tcl_NewWideIntObj(fields.localSeconds)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_TZNAME], fields.tzName); Tcl_DecrRefCount(fields.tzName); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_TZOFFSET], Tcl_NewIntObj(fields.tzOffset)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_JULIANDAY], Tcl_NewWideIntObj(fields.julianDay)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_GREGORIAN], Tcl_NewIntObj(fields.gregorian)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_ERA], literals[fields.era ? LIT_BCE : LIT_CE]); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_YEAR], Tcl_NewIntObj(fields.year)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_DAYOFYEAR], Tcl_NewIntObj(fields.dayOfYear)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_MONTH], Tcl_NewIntObj(fields.month)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_DAYOFMONTH], Tcl_NewIntObj(fields.dayOfMonth)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_ISO8601YEAR], Tcl_NewIntObj(fields.iso8601Year)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_ISO8601WEEK], Tcl_NewIntObj(fields.iso8601Week)); Tcl_DictObjPut((Tcl_Interp*) NULL, dict, literals[LIT_DAYOFWEEK], Tcl_NewIntObj(fields.dayOfWeek)); Tcl_SetObjResult(interp, dict); return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertLocalToUTC -- * * Converts a time (in a TclDateFields structure) from the * local wall clock to UTC. * * Results: * Returns a standard Tcl result. * * Side effects: * Populates the 'seconds' field if successful; stores an error * message in the interpreter result on failure. * *---------------------------------------------------------------------- */ static int ConvertLocalToUTC( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Fields of the time */ Tcl_Obj* tzdata, /* Time zone data */ int changeover /* Julian Day of the Gregorian transition */ ) { int rowc; /* Number of rows in tzdata */ Tcl_Obj** rowv; /* Pointers to the rows */ /* unpack the tz data */ if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } /* * Special case: If the time zone is :localtime, the tzdata will be empty. * Use 'mktime' to convert the time to local */ if (rowc == 0) { return ConvertLocalToUTCUsingC(interp, fields, changeover); } else { return ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv); } } /* *---------------------------------------------------------------------- * * ConvertLocalToUTCUsingTable -- * * Converts a time (in a TclDateFields structure) from local time * in a given time zone to UTC. * * Results: * Returns a standard Tcl result. * * Side effects: * Stores an error message in the interpreter if an error occurs; * if successful, stores the 'seconds' field in 'fields. * *---------------------------------------------------------------------- */ static int ConvertLocalToUTCUsingTable( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Time to convert, with 'seconds' filled in */ int rowc, /* Number of points at which time changes */ Tcl_Obj *CONST rowv[] /* Points at which time changes */ ) { Tcl_Obj* row; int cellc; Tcl_Obj** cellv; int have[8]; int nHave = 0; int i; int found; /* * Perform an initial lookup assuming that local == UTC, and locate * the last time conversion prior to that time. Get the offset from * that row, and look up again. Continue until we find an offset * that we found before. This definition, rather than "the same offset" * ensures that we don't enter an endless loop, as would otherwise happen * when trying to convert a non-existent time such as 02:30 during * the US Spring Daylight Saving Time transition. */ found = 0; fields->tzOffset = 0; fields->seconds = fields->localSeconds; while (!found) { row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if ((row == NULL) || (Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK) || (Tcl_GetIntFromObj(interp, cellv[1], &(fields->tzOffset)) != TCL_OK)) { return TCL_ERROR; } found = 0; for (i = 0; !found && i < nHave; ++i) { if (have[i] == fields->tzOffset) { found = 1; break; } } if (!found) { if (nHave == 8) { Tcl_Panic("loop in ConvertLocalToUTCUsingTable"); } have[nHave] = fields->tzOffset; ++nHave; } fields->seconds = fields->localSeconds - fields->tzOffset; } fields->tzOffset = have[i]; fields->seconds = fields->localSeconds - fields->tzOffset; return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertLocalToUTCUsingC -- * * Converts a time from local wall clock to UTC when the local * time zone cannot be determined. Uses 'mktime' to do the job. * * Results: * Returns a standard Tcl result. * * Side effects: * Stores an error message in the interpreter if an error occurs; * if successful, stores the 'seconds' field in 'fields. * *---------------------------------------------------------------------- */ static int ConvertLocalToUTCUsingC( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Time to convert, with 'seconds' filled in */ int changeover /* Julian Day of the Gregorian transition */ ) { struct tm timeVal; int localErrno; /* Convert the given time to a date */ fields->julianDay = (int) ((fields->localSeconds + JULIAN_SEC_POSIX_EPOCH) / SECONDS_PER_DAY); GetGregorianEraYearDay(fields, changeover); GetMonthDay(fields); /* Convert the date/time to a 'struct tm' */ timeVal.tm_year = fields->year - 1900; timeVal.tm_mon = fields->month - 1; timeVal.tm_mday = fields->dayOfMonth; timeVal.tm_hour = (int)((fields->localSeconds / 3600) % 24); timeVal.tm_min = (int)((fields->localSeconds / 60) % 60); timeVal.tm_sec = (int)(fields->localSeconds % 60); timeVal.tm_isdst = -1; timeVal.tm_wday = -1; timeVal.tm_yday = -1; /* * Get local time. It is rumored that mktime is not thread safe * on some platforms, so seize a mutex before attempting this. */ TzsetIfNecessary(); Tcl_MutexLock(&clockMutex); errno = 0; fields->seconds = (Tcl_WideInt) mktime(&timeVal); localErrno = errno; Tcl_MutexUnlock(&clockMutex); /* If conversion fails, report an error */ if (localErrno != 0 || (fields->seconds == -1 && timeVal.tm_yday == -1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "time value too large/small to " "represent", -1)); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertUTCToLocal -- * * Converts a time (in a TclDateFields structure) from UTC to * local time. * * Results: * Returns a standard Tcl result. * * Side effects: * Populates the 'tzName' and 'tzOffset' fields. * *---------------------------------------------------------------------- */ static int ConvertUTCToLocal( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Fields of the time */ Tcl_Obj* tzdata, /* Time zone data */ int changeover /* Julian Day of the Gregorian transition */ ) { int rowc; /* Number of rows in tzdata */ Tcl_Obj** rowv; /* Pointers to the rows */ /* unpack the tz data */ if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) { return TCL_ERROR; } /* * Special case: If the time zone is :localtime, the tzdata will be empty. * Use 'localtime' to convert the time to local */ if (rowc == 0) { return ConvertUTCToLocalUsingC(interp, fields, changeover); } else { return ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv); } } /* *---------------------------------------------------------------------- * * ConvertUTCToLocalUsingTable -- * * Converts UTC to local time, given a table of transition points * * Results: * Returns a standard Tcl result * * Side effects: * On success, fills fields->tzName, fields->tzOffset and * fields->localSeconds. On failure, places an error message in * the interpreter result. * *---------------------------------------------------------------------- */ static int ConvertUTCToLocalUsingTable( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Fields of the date */ int rowc, /* Number of rows in the conversion table * (>= 1) */ Tcl_Obj *CONST rowv[] /* Rows of the conversion table */ ) { Tcl_Obj* row; /* Row containing the current information */ int cellc; /* Count of cells in the row (must be 4) */ Tcl_Obj** cellv; /* Pointers to the cells */ /* Look up the nearest transition time */ row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if (row == NULL || (Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK) || (Tcl_GetIntFromObj(interp, cellv[1], &(fields->tzOffset)) != TCL_OK)) { return TCL_ERROR; } /* Convert the time */ fields->tzName = cellv[3]; Tcl_IncrRefCount(fields->tzName); fields->localSeconds = fields->seconds + fields->tzOffset; return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertUTCToLocalUsingC -- * * Converts UTC to localtime in cases where the local time zone is * not determinable, using the C 'localtime' function to do it. * * Results: * Returns a standard Tcl result. * * Side effects: * On success, fills fields->tzName, fields->tzOffset and * fields->localSeconds. On failure, places an error message in * the interpreter result. * *---------------------------------------------------------------------- */ static int ConvertUTCToLocalUsingC( Tcl_Interp* interp, /* Tcl interpreter */ TclDateFields* fields, /* Time to convert, with 'seconds' filled in */ int changeover /* Julian Day of the Gregorian transition */ ) { time_t tock; struct tm* timeVal; /* Time after conversion */ int diff; /* Time zone diff local-Greenwich */ char buffer[8]; /* Buffer for time zone name */ /* Use 'localtime' to determine local year, month, day, time of day. */ tock = (time_t) fields->seconds; if ((Tcl_WideInt) tock != fields->seconds) { 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; } /* Fill in the date in 'fields' and use it to derive Julian Day */ fields->era = CE; fields->year = timeVal->tm_year + 1900; fields->month = timeVal->tm_mon + 1; fields->dayOfMonth = timeVal->tm_mday; GetJulianDayFromEraYearMonthDay(fields, changeover); /* Convert that value to seconds */ fields->localSeconds = (((fields->julianDay * (Tcl_WideInt) 24 + timeVal->tm_hour) * 60 + timeVal->tm_min) * 60 + timeVal->tm_sec) - JULIAN_SEC_POSIX_EPOCH; /* Determine a time zone offset and name; just use +hhmm for the name */ diff = (int) (fields->localSeconds - fields->seconds); fields->tzOffset = diff; if (diff < 0) { *buffer = '-'; diff = -diff; } else { *buffer = '+'; } sprintf(buffer+1, "%02d", diff / 3600); diff %= 3600; sprintf(buffer+3, "%02d", diff / 60); diff %= 60; if (diff > 0) { sprintf(buffer+5, "%02d", diff); } fields->tzName = Tcl_NewStringObj(buffer, -1); Tcl_IncrRefCount(fields->tzName); return TCL_OK; } /* *---------------------------------------------------------------------- * * LookupLastTransition -- * * Given a UTC time and a tzdata array, looks up the last * transition on or before the given time. * * Results: * Returns a pointer to the row, or NULL if an error occurs. * *---------------------------------------------------------------------- */ static Tcl_Obj* LookupLastTransition( Tcl_Interp* interp, /* Interpreter for error messages */ Tcl_WideInt tick, /* Time from the epoch */ int rowc, /* Number of rows of tzdata */ Tcl_Obj *CONST * rowv) /* Rows in tzdata */ { int l; int u; Tcl_Obj* compObj; Tcl_WideInt compVal; /* Examine the first row to make sure we're in bounds */ if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } /* * Bizarre case - first row doesn't begin at MIN_WIDE_INT. * Return it anyway. */ if (tick < compVal) { return rowv[0]; } /* * Binary-search to find the transition. */ l = 0; u = rowc-1; while (l < u) { int m = (l + u + 1) / 2; if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } if (tick >= compVal) { l = m; } else { u = m-1; } } return rowv[l]; } /* *---------------------------------------------------------------------- * * GetYearWeekDay -- * * Given a date with Julian Calendar Day, compute the year, week, * and day in the ISO8601 calendar. * * Results: * None. * * Side effects: * Stores 'iso8601Year', 'iso8601Week' and 'dayOfWeek' in * the date fields. * *---------------------------------------------------------------------- */ static void GetYearWeekDay( TclDateFields* fields, /* Date to convert, must have 'julianDay' */ int changeover /* Julian Day Number of the Gregorian * transition */ ) { TclDateFields temp; int dayOfFiscalYear; /* * Find the given date, minus three days, plus one year. That date's * iso8601 year is an upper bound on the ISO8601 year of the given date. */ temp.julianDay = fields->julianDay - 3; GetGregorianEraYearDay(&temp, changeover); if (temp.era == BCE) { temp.iso8601Year = temp.year - 1; } else { temp.iso8601Year = temp.year + 1; } temp.iso8601Week = 1; temp.dayOfWeek = 1; GetJulianDayFromEraYearWeekDay(&temp, changeover); /* * temp.julianDay is now the start of an ISO8601 year, either the * one corresponding to the given date, or the one after. If we guessed * high, move one year earlier */ if (fields->julianDay < temp.julianDay) { if (temp.era == BCE) { temp.iso8601Year += 1; } else { temp.iso8601Year -= 1; } GetJulianDayFromEraYearWeekDay(&temp, changeover); } fields->iso8601Year = temp.iso8601Year; dayOfFiscalYear = fields->julianDay - temp.julianDay; fields->iso8601Week = (dayOfFiscalYear / 7) + 1; fields->dayOfWeek = (dayOfFiscalYear + 1) % 7; if (fields->dayOfWeek < 1) { fields->dayOfWeek += 7; } } /* *---------------------------------------------------------------------- * * GetGregorianEraYearDay -- * * Given a Julian Day Number, extracts the year and day of the * year and puts them into TclDateFields, along with the era * (BCE or CE) and a flag indicating whether the date is Gregorian * or Julian. * * Results: * None. * * Side effects: * Stores 'era', 'gregorian', 'year', and 'dayOfYear'. * *---------------------------------------------------------------------- */ static void GetGregorianEraYearDay( TclDateFields* fields, /* Date fields containing 'julianDay' */ int changeover /* Gregorian transition date */ ) { int jday = fields->julianDay; int day; int year; int n; if (jday >= changeover) { /* Gregorian calendar */ fields->gregorian = 1; year = 1; /* * n = Number of 400-year cycles since 1 January, 1 CE in the * proleptic Gregorian calendar. day = remaining days. */ day = jday - JDAY_1_JAN_1_CE_GREGORIAN; n = day / FOUR_CENTURIES; day %= FOUR_CENTURIES; year += 400 * n; /* * n = number of centuries since the start of (year); * day = remaining days */ n = day / ONE_CENTURY_GREGORIAN; day %= ONE_CENTURY_GREGORIAN; if (n > 3) { /* 31 December in the last year of a 400-year cycle */ n = 3; day += ONE_CENTURY_GREGORIAN; } year += 100 * n; } else { /* Julian calendar */ fields->gregorian = 0; year = 1; day = jday - JDAY_1_JAN_1_CE_JULIAN; } /* n = number of 4-year cycles; days = remaining days */ n = day / FOUR_YEARS; day %= 1461; year += 4 * n; /* n = number of years; days = remaining days */ n = day / ONE_YEAR; day %= ONE_YEAR; if (n > 3) { /* 31 December of a leap year */ n = 3; day += 365; } year += n; /* store era/year/day back into fields */ if (year < 0) { fields->era = BCE; fields->year = 1 - year; } else { fields->era = CE; fields->year = year; } fields->dayOfYear = day + 1; } /* *---------------------------------------------------------------------- * * GetMonthDay -- * * Given a date as year and day-of-year, find month and day. * * Results: * None. * * Side effects: * Stores 'month' and 'dayOfMonth' in the 'fields' structure. * *---------------------------------------------------------------------- */ static void GetMonthDay( TclDateFields* fields /* Date to convert */ ) { int day = fields->dayOfYear; int month; const int* h = hath[IsGregorianLeapYear(fields)]; for (month = 0; month < 12 && day > h[month]; ++month) { day -= h[month]; } fields->month = month+1; fields->dayOfMonth = day; } /* *---------------------------------------------------------------------- * * GetJulianDayFromEraYearWeekDay -- * * Given a TclDateFields structure containing era, ISO8601 year, * ISO8601 week, and day of week, computes the Julian Day Number. * * Results: * None. * * Side effects: * Stores 'julianDay' in the fields. * *---------------------------------------------------------------------- */ static void GetJulianDayFromEraYearWeekDay( TclDateFields* fields, /* Date to convert */ int changeover /* Julian Day Number of the * Gregorian transition */ ) { int firstMonday; /* Julian day number of week 1, day 1 * in the given year */ /* Find January 4 in the ISO8601 year, which will always be in week 1 */ TclDateFields firstWeek; firstWeek.era = fields->era; firstWeek.year = fields->iso8601Year; firstWeek.month = 1; firstWeek.dayOfMonth = 4; GetJulianDayFromEraYearMonthDay(&firstWeek, changeover); /* Find Monday of week 1. */ firstMonday = WeekdayOnOrBefore(1, firstWeek.julianDay); /* Advance to the given week and day */ fields->julianDay = firstMonday + 7 * (fields->iso8601Week - 1) + fields->dayOfWeek - 1; } /* *---------------------------------------------------------------------- * * GetJulianDayFromEraYearMonthDay -- * * Given era, year, month, and dayOfMonth (in TclDateFields), and * the Gregorian transition date, computes the Julian Day Number. * * Results: * None. * * Side effects: * Stores day number in 'julianDay' * *---------------------------------------------------------------------- */ static void GetJulianDayFromEraYearMonthDay( TclDateFields* fields, /* Date to convert */ int changeover /* Gregorian transition date as a Julian Day */ ) { int year; int ym1; int month; int mm1; if (fields->era == BCE) { year = 1 - fields->year; } else { year = fields->year; } /* Reduce month modulo 12 */ month = fields->month; mm1 = month - 1; year += mm1 / 12; month = (mm1 % 12) + 1; ym1 = year - 1; /* Adjust the year after reducing the month */ fields->gregorian = 1; if (year < 1) { fields->era = BCE; fields->year = 1-year; } else { fields->era = CE; fields->year = year; } /* Try an initial conversion in the Gregorian calendar */ fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1 + fields->dayOfMonth + daysInPriorMonths[IsGregorianLeapYear(fields)][month - 1] + (ONE_YEAR * ym1) + (ym1 / 4) - (ym1 / 100) + (ym1 / 400); /* * If the resulting date is before the Gregorian changeover, convert * in the Julian calendar instead. */ if (fields->julianDay < changeover) { fields->gregorian = 0; fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1 + fields->dayOfMonth + daysInPriorMonths[year%4 == 0][month - 1] + (365 * ym1) + (ym1 / 4); } } /* *---------------------------------------------------------------------- * * IsGregorianLeapYear -- * * Tests whether a given year is a leap year, in either Julian * or Gregorian calendar. * * Results: * Returns 1 for a leap year, 0 otherwise. * *---------------------------------------------------------------------- */ static int IsGregorianLeapYear( TclDateFields* fields /* Date to test */ ) { int year; if (fields->era == BCE) { year = 1 - fields->year; } else { year = fields->year; } if (year%4 != 0) { return 0; } else if (!(fields->gregorian)) { return 1; } else if (year%400 == 0) { return 1; } else if (year%100 == 0) { return 0; } else { return 1; } } /* *---------------------------------------------------------------------- * * WeekdayOnOrBefore -- * * Finds the Julian Day Number of a given day of the week that * falls on or before a given date, expressed as Julian Day Number. * * Results: * Returns the Julian Day Number * *---------------------------------------------------------------------- */ static int WeekdayOnOrBefore( int dayOfWeek, /* Day of week; Sunday == 0 or 7 */ int julianDay /* Reference date */ ) { int k = (dayOfWeek + 6) % 7; return julianDay - ((julianDay - k) % 7); } /* *---------------------------------------------------------------------- * * ClockGetenvObjCmd -- * * 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 ClockGetenvObjCmd( 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; } } /* *---------------------------------------------------------------------- * * 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; } /*---------------------------------------------------------------------- * * ClockClicksObjCmd -- * * 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 ClockClicksObjCmd( 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; } /*---------------------------------------------------------------------- * * ClockMillisecondsObjCmd - * * 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 ClockMillisecondsObjCmd( 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; } /*---------------------------------------------------------------------- * * ClockMicrosecondsObjCmd - * * 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 ClockMicrosecondsObjCmd( 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; } /*---------------------------------------------------------------------- * * ClockSecondsObjCmd - * * 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 ClockSecondsObjCmd( 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); } /* *---------------------------------------------------------------------- * * ClockDeleteCmdProc -- * * Remove a reference to the clock client data, and clean up memory * when it's all gone. * * Results: * None. * *---------------------------------------------------------------------- */ static void ClockDeleteCmdProc(ClientData clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData*) clientData; int i; --(data->refCount); if (data->refCount == 0) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } ckfree((char*) (data->literals)); ckfree((char*) data); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */