diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 20 | ||||
| -rw-r--r-- | generic/tclClock.c | 1402 | ||||
| -rw-r--r-- | generic/tclInt.h | 24 | ||||
| -rw-r--r-- | library/clock.tcl | 678 |
5 files changed, 1317 insertions, 814 deletions
@@ -1,3 +1,10 @@ +2005-11-29 Kevin Kenny <kennykb@acm.org> + + * generic/tclBasic.c: Moved a big part of [clock format] down + * generic/tclClock.c: to the C level in order to make it go faster. + * generic/tclInt.h: Preliminary measurements suggest that it + * generic/clock.tcl: more than doubles in speed with this change. + 2005-11-29 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Allow [lsearch -regexp] to diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c5c842d..6bd2627 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.182 2005/11/14 16:45:11 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.183 2005/11/29 22:50:56 kennykb Exp $ */ #include "tclInt.h" @@ -466,22 +466,8 @@ Tcl_CreateInterp(void) * Tcl_CreateObjCommand, since they aren't in the global namespace. */ - Tcl_CreateObjCommand(interp, "::tcl::clock::clicks", - TclClockClicksObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::getenv", - TclClockGetenvObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::microseconds", - TclClockMicrosecondsObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::milliseconds", - TclClockMillisecondsObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::seconds", - TclClockSecondsObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::Localtime", - TclClockLocaltimeObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::Mktime", - TclClockMktimeObjCmd, (ClientData) NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", - TclClockOldscanObjCmd, (ClientData) NULL, NULL); + TclClockInit(interp); + /* TIP #208 */ Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", TclChanTruncateObjCmd, (ClientData) NULL, NULL); diff --git a/generic/tclClock.c b/generic/tclClock.c index 71dec02..3dc93fa 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -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: tclClock.c,v 1.42 2005/11/01 15:30:52 dkf Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.43 2005/11/29 22:50:58 kennykb Exp $ */ #include "tclInt.h" @@ -26,6 +26,92 @@ #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. */ @@ -43,312 +129,1216 @@ 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); + /* *---------------------------------------------------------------------- * - * TclClockGetenvObjCmd -- + * TclClockInit -- * - * Tcl command that reads an environment variable from the system + * 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); + 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::getEnv NAME + * ::tcl::clock::ConvertUTCToLocal dictionary tzdata changeover * * Parameters: - * NAME - Name of the environment variable desired + * 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. 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, + * 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. * *---------------------------------------------------------------------- */ -int -TclClockGetenvObjCmd( - ClientData clientData, - Tcl_Interp* interp, - int objc, - Tcl_Obj *CONST objv[]) -{ +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; - CONST char* varName; - CONST char* varValue; + /* Check params and convert time */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover"); return TCL_ERROR; } - varName = Tcl_GetStringFromObj(objv[1], NULL); - varValue = getenv(varName); - if (varValue == NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("variable not found", -1)); + 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; - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); - return TCL_OK; } + + /* + * 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; } /* - *------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclClockLocaltimeObjCmd -- + * ClockGetdatefieldsObjCmd -- * - * Tcl command that extracts local time using the C library to do - * it. + * Tcl command that determines the values that [clock format] will + * use in formatting a date, and populates a dictionary with them. * * Usage: - * ::tcl::clock::Localtime <tick> + * ::tcl::clock::GetDateFields seconds tzdata changeover * * Parameters: - * <tick> -- A count of seconds from the Posix epoch. + * 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; - * 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'. + /* 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; +} + +/* + *---------------------------------------------------------------------- * - * Side effects: - * None. + * ConvertLocalToUTC -- + * + * Converts a time (in a TclDateFields structure) from the + * local wall clock to UTC. + * + * Results: + * Returns a standard Tcl result. * - * 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. + * Side effects: + * Populates the 'seconds' field if successful; stores an error + * message in the interpreter result on failure. * - *------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -int -TclClockLocaltimeObjCmd( - ClientData clientData, /* Unused */ +static int +ConvertLocalToUTC( 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 */ + 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 */ - Tcl_Obj* returnVec[ 6 ]; + /* 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; /* - * Check args + * 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. */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "seconds"); + 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; } - if (Tcl_GetWideIntFromObj(interp, objv[1], &tick) != TCL_OK) { + 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; } - /* - * Convert the time, checking for overflow + /* + * Special case: If the time zone is :localtime, the tzdata will be empty. + * Use 'localtime' to convert the time to local */ - tock = (time_t) tick; - if ((Tcl_WideInt) tock != tick) { + 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); + "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_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. - */ + /* 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); - 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)); + /* 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; } /* *---------------------------------------------------------------------- * - * ThreadSafeLocalTime -- + * LookupLastTransition -- * - * Wrapper around the 'localtime' library function to make it thread - * safe. + * Given a UTC time and a tzdata array, looks up the last + * transition on or before the given time. * * Results: - * Returns a pointer to a 'struct tm' in thread-specific data. - * - * Side effects: - * Invokes localtime or localtime_r as appropriate. + * Returns a pointer to the row, or NULL if an error occurs. * *---------------------------------------------------------------------- */ -static struct tm * -ThreadSafeLocalTime( - CONST time_t *timePtr) /* Pointer to the number of seconds since the - * local system's epoch */ +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 */ { - /* - * Get a thread-local buffer to hold the returned time. - */ + int l; + int u; + Tcl_Obj* compObj; + Tcl_WideInt compVal; - struct tm *tmPtr = (struct tm *) - Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm)); -#ifdef HAVE_LOCALTIME_R - localtime_r(timePtr, tmPtr); -#else - struct tm *sysTmPtr; + /* Examine the first row to make sure we're in bounds */ - Tcl_MutexLock(&clockMutex); - sysTmPtr = localtime(timePtr); - if (sysTmPtr == NULL) { - Tcl_MutexUnlock(&clockMutex); + if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK + || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; - } else { - memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm)); - Tcl_MutexUnlock(&clockMutex); } -#endif - return tmPtr; + /* + * 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]; + } /* *---------------------------------------------------------------------- * - * TclClockMktimeObjCmd -- + * GetYearWeekDay -- * - * Determine seconds from the epoch, given the fields of a local time. + * Given a date with Julian Calendar Day, compute the year, week, + * and day in the ISO8601 calendar. * - * Usage: - * mktime <year> <month> <day> <hour> <minute> <second> + * Results: + * None. * - * Parameters: - * year -- Calendar year - * month -- Calendar month - * day -- Calendar day - * hour -- Hour of day (00-23) - * minute -- Minute of hour - * second -- Second of minute + * 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: - * Returns the given local time. + * None. * - * 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: + * 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. + * *---------------------------------------------------------------------- */ -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 +static void +GetJulianDayFromEraYearWeekDay( + TclDateFields* fields, /* Date to convert */ + int changeover /* Julian Day Number of the + * Gregorian transition */ +) { - int i; - struct tm toConvert; /* Time to be converted */ - time_t convertedTime; /* Time converted from mktime */ - int localErrno; + int firstMonday; /* Julian day number of week 1, day 1 + * in the given year */ - /* - * Convert parameters - */ + /* Find January 4 in the ISO8601 year, which will always be in week 1 */ - if (objc != 7) { - Tcl_WrongNumArgs(interp, 1, objv, "year month day hour minute second"); - return TCL_ERROR; + 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; } - if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { - return TCL_ERROR; + + /* 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; } - toConvert.tm_year = i - 1900; - if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) { - return TCL_ERROR; + + /* 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); } - toConvert.tm_mon = i - 1; - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { - return TCL_ERROR; + +} + +/* + *---------------------------------------------------------------------- + * + * 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; } - toConvert.tm_mday = i; - if (Tcl_GetIntFromObj(interp, objv[4], &i) != TCL_OK) { - return TCL_ERROR; + 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; } - toConvert.tm_hour = i; - if (Tcl_GetIntFromObj(interp, objv[5], &i) != TCL_OK) { +} + +/* + *---------------------------------------------------------------------- + * + * 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; } - toConvert.tm_min = i; - if (Tcl_GetIntFromObj(interp, objv[6], &i) != TCL_OK) { + 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; } - toConvert.tm_sec = i; - toConvert.tm_isdst = -1; - toConvert.tm_wday = -1; - toConvert.tm_yday = -1; +} + +/* + *---------------------------------------------------------------------- + * + * 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 */ +{ /* - * Convert the time. It is rumored that mktime is not thread safe on some - * platforms. + * Get a thread-local buffer to hold the returned time. */ - TzsetIfNecessary(); - Tcl_MutexLock(&clockMutex); - errno = 0; - convertedTime = mktime(&toConvert); - localErrno = errno; - Tcl_MutexUnlock(&clockMutex); - - /* - * Return the converted time, or an error if conversion fails. - */ + struct tm *tmPtr = (struct tm *) + Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm)); +#ifdef HAVE_LOCALTIME_R + localtime_r(timePtr, tmPtr); +#else + struct tm *sysTmPtr; - if (localErrno != 0 || (convertedTime == -1 && toConvert.tm_yday == -1)) { - Tcl_AppendResult(interp, "time value too large/small to represent", - NULL); - return TCL_ERROR; + 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); } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) convertedTime)); - return TCL_OK; -#endif /* HAVE_MKTIME */ +#endif + return tmPtr; } /*---------------------------------------------------------------------- * - * TclClockClicksObjCmd -- + * ClockClicksObjCmd -- * * Returns a high-resolution counter. * @@ -365,7 +1355,7 @@ TclClockMktimeObjCmd( */ int -TclClockClicksObjCmd( +ClockClicksObjCmd( ClientData clientData, /* Client data is unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ @@ -416,7 +1406,7 @@ TclClockClicksObjCmd( /*---------------------------------------------------------------------- * - * TclClockMillisecondsObjCmd - + * ClockMillisecondsObjCmd - * * Returns a count of milliseconds since the epoch. * @@ -433,7 +1423,7 @@ TclClockClicksObjCmd( */ int -TclClockMillisecondsObjCmd( +ClockMillisecondsObjCmd( ClientData clientData, /* Client data is unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ @@ -453,7 +1443,7 @@ TclClockMillisecondsObjCmd( /*---------------------------------------------------------------------- * - * TclClockMicrosecondsObjCmd - + * ClockMicrosecondsObjCmd - * * Returns a count of microseconds since the epoch. * @@ -470,7 +1460,7 @@ TclClockMillisecondsObjCmd( */ int -TclClockMicrosecondsObjCmd( +ClockMicrosecondsObjCmd( ClientData clientData, /* Client data is unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ @@ -490,7 +1480,7 @@ TclClockMicrosecondsObjCmd( /*---------------------------------------------------------------------- * - * TclClockSecondsObjCmd - + * ClockSecondsObjCmd - * * Returns a count of microseconds since the epoch. * @@ -507,7 +1497,7 @@ TclClockMicrosecondsObjCmd( */ int -TclClockSecondsObjCmd( +ClockSecondsObjCmd( ClientData clientData, /* Client data is unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ @@ -566,6 +1556,36 @@ TzsetIfNecessary(void) } /* + *---------------------------------------------------------------------- + * + * 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 diff --git a/generic/tclInt.h b/generic/tclInt.h index 7ad1f25..d04b285 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.259 2005/11/27 02:33:49 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.260 2005/11/29 22:50:58 kennykb Exp $ */ #ifndef _TCLINT @@ -2261,27 +2261,7 @@ MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, MODULE_SCOPE int TclChanTruncateObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockClicksObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockGetenvObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockMicrosecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockMillisecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockSecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockLocaltimeObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int TclClockMktimeObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE void TclClockInit(Tcl_Interp*); MODULE_SCOPE int TclClockOldscanObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); diff --git a/library/clock.tcl b/library/clock.tcl index eaa512d..6f6b1ed 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -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: clock.tcl,v 1.20 2005/11/04 20:13:30 kennykb Exp $ +# RCS: @(#) $Id: clock.tcl,v 1.21 2005/11/29 22:50:58 kennykb Exp $ # #---------------------------------------------------------------------- @@ -123,6 +123,7 @@ proc ::tcl::clock::Initialize {} { {-9223372036854775808 0 0 UTC} } set TZData(:UTC) $TZData(:Etc/UTC) + set TZData(:localtime) {} } InitTZData @@ -640,6 +641,8 @@ proc ::tcl::clock::Initialize {} { proc ::tcl::clock::format { args } { + variable TZData + set format {} # Check the count of args @@ -719,15 +722,18 @@ proc ::tcl::clock::format { args } { # Convert the given time to local time. - set date [dict create seconds $clockval] - set date [ConvertUTCToLocal $date[set date {}] $timezone] + # Get the data for time changes in the given zone + if {[catch {SetupTimeZone $timezone} retval opts]} { + dict unset opts -errorinfo + return -options $opts $retval + } + # Extract the fields of the date. - - set date [GetJulianDay $date[set date {}]] - set date [GetGregorianEraYearDay $date[set date {}]] - set date [GetMonthDay $date[set date {}]] - set date [GetYearWeekDay $date[set date {}]] + + set date [GetDateFields $clockval \ + $TZData($timezone) \ + [mc GREGORIAN_CHANGE_DATE]] # Format the result @@ -1233,15 +1239,22 @@ proc ::tcl::clock::scan { args } { proc ::tcl::clock::FreeScan { string base timezone locale } { + variable TZData + + # Get the data for time changes in the given zone + + if {[catch {SetupTimeZone $timezone} retval opts]} { + dict unset opts -errorinfo + return -options $opts $retval + } + # Extract year, month and day from the base time for the # parser to use as defaults - set date [GetMonthDay \ - [GetGregorianEraYearDay \ - [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $base] \ - $timezone]]]] + set date [GetDateFields \ + $base \ + $TZData($timezone) \ + 2299161] dict set date secondOfDay [expr { [dict get $date localSeconds] % 86400 }] @@ -1294,6 +1307,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { foreach { minEast dstFlag } $parseZone break set timezone [FormatNumericTimeZone \ [expr { 60 * $minEast + 3600 * $dstFlag }]] + SetupTimeZone $timezone } dict set date tzName $timezone @@ -1315,7 +1329,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { + ( 86400 * wide([dict get $date julianDay]) ) + [dict get $date secondOfDay] }] dict set date tzName $timezone - set date [ConvertLocalToUTC $date[set date {}]] + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2299161] set seconds [dict get $date seconds] # Do relative times @@ -1332,10 +1346,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { if { [llength $parseWeekday] > 0 } { foreach {dayOrdinal dayOfWeek} $parseWeekday break - set date2 [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $seconds] \ - $timezone]] + set date2 [GetDateFields $seconds $TZData($timezone) 2299161] dict set date2 era CE set jdwkday [WeekdayOnOrBefore $dayOfWeek \ [expr { [dict get $date2 julianDay] @@ -1352,7 +1363,8 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { + ( 86400 * wide([dict get $date2 julianDay]) ) + [dict get $date secondOfDay] }] dict set date2 tzName $timezone - set date2 [ConvertLocalToUTC $date2[set date2 {}]] + set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ + 2299161] set seconds [dict get $date2 seconds] } @@ -1844,6 +1856,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { # Build the procedure set procBody {} + append procBody "variable ::tcl::clock::TZData" \n append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->" for { set i 1 } { $i <= $captureCount } { incr i } { append procBody " " field $i @@ -1884,8 +1897,16 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { + if { [dict exists $fieldSet tzName] } { + append procBody { + set timeZone [dict get $date tzName] + } + } append procBody { - set date [::tcl::clock::ConvertLocalToUTC $date[set date {}]] + ::tcl::clock::SetupTimeZone $timeZone + set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ + $TZData($timeZone) \ + [mc GREGORIAN_CHANGE_DATE]] } } @@ -2473,7 +2494,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { } - #---------------------------------------------------------------------- # # FormatStarDate -- @@ -2681,15 +2701,15 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { +proc ::tcl::clock::AssignBaseYear { date baseTime timezone } { + + variable TZData # Find the Julian Day Number corresponding to the base time, and # find the Gregorian year corresponding to that Julian Day. - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] - set date2 [GetGregorianEraYearDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timezone) \ + [mc GREGORIAN_CHANGE_DATE]] # Store the converted year @@ -2722,15 +2742,15 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } { + variable TZData + # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) \ + [mc GREGORIAN_CHANGE_DATE]] # Calculate the ISO8601 date and transfer the year - set date2 [GetYearWeekDay $date2[set date2 {}]] dict set date era CE dict set date iso8601Year [dict get $date2 iso8601Year] return $date @@ -2756,18 +2776,14 @@ proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } { +proc ::tcl::clock::AssignBaseMonth { date baseTime timezone } { - # Find the Julian Day Number corresponding to the base time - - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + variable TZData - # Find the Gregorian year corresponding to that Julian Day + # Find the year and month corresponding to the base time - set date2 [GetGregorianEraYearDay $date2[set date2 {}]] - set date2 [GetMonthDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timezone) \ + [mc GREGORIAN_CHANGE_DATE]] dict set date era [dict get $date2 era] dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] @@ -2797,15 +2813,15 @@ proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } { proc ::tcl::clock::AssignBaseWeek { date baseTime timeZone } { + variable TZData + # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) \ + [mc GREGORIAN_CHANGE_DATE]] # Calculate the ISO8601 date and transfer the year - set date2 [GetYearWeekDay $date2[set date2 {}]] dict set date era CE dict set date iso8601Year [dict get $date2 iso8601Year] dict set date iso8601Week [dict get $date2 iso8601Week] @@ -2833,11 +2849,12 @@ proc ::tcl::clock::AssignBaseWeek { date baseTime timeZone } { proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone } { + variable TZData + # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) \ + [mc GREGORIAN_CHANGE_DATE]] dict set date julianDay [dict get $date2 julianDay] return $date @@ -2992,249 +3009,6 @@ proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { #---------------------------------------------------------------------- # -# ConvertLocalToUTC -- -# -# Given a time zone and nominal local seconds, compute seconds -# of UTC time from the Posix epoch. -# -# Parameters: -# date - Dictionary populated with the 'localSeconds' and -# 'tzName' fields -# -# Results: -# Returns the given dictionary augmented with a 'seconds' field. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertLocalToUTC { date } { - - variable TZData - - set timezone [dict get $date tzName] - if { $timezone eq ":localtime" } { - - # Convert using the mktime function if possible - - if { [catch { - ConvertLocalToUTCViaC [dict get $date localSeconds] - } result opts] } { - dict unset opts -errorinfo - return -options $opts $result - } - dict set date seconds $result - return $date - - } else { - - # Get the time zone data - - if { [catch { SetupTimeZone $timezone } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - - # Initially assume that local == UTC, and locate the last time - # conversion prior to that time. Get the offset from that, - # and look up again. If that lookup finds a different offset, - # continue looking until we find an offset that we found - # before. The check for "any offset previously found" rather - # than "the same offset" avoids an endless loop if we try to - # convert a non-existent time, for example 2:30am during the - # US spring DST change. - - set localseconds [dict get $date localSeconds] - set utcseconds(0) $localseconds - set seconds $localseconds - while { 1 } { - set i [BSearch $TZData($timezone) $seconds] - set offset [lindex $TZData($timezone) $i 1] - if { [info exists utcseconds($offset)] } { - dict set date seconds $utcseconds($offset) - return $date - } else { - set seconds [expr { $localseconds - $offset }] - set utcseconds($offset) $seconds - } - } - - # In the absolute worst case, the loop above can visit each tzdata - # row only once, so it's guaranteed to terminate. - - error "in ConvertLocalToUTC, can't happen" - } - -} - -#---------------------------------------------------------------------- -# -# ConvertLocalToUTCViaC -- -# -# Given seconds of nominal local time, compute seconds from the -# Posix epoch. -# -# Parameters: -# localSeconds - Seconds of nominal local time -# -# Results: -# Returns the seconds from the epoch. May throw an error if -# the time is to large/small to represent, or if 'mktime' is -# not present in the C library. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertLocalToUTCViaC { localSeconds } { - - set date [dict create localSeconds $localSeconds] - set date [GetJulianDay $date[set date {}]] - set date [GetGregorianEraYearDay $date[set date {}]] - set date [GetMonthDay $date[set date {}]] - set retval \ - [Mktime \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth] \ - [expr { $localSeconds / 3600 % 24 }] \ - [expr { $localSeconds / 60 % 60 }] \ - [expr { $localSeconds % 60 }]] - return $retval -} - -#---------------------------------------------------------------------- -# -# ConvertUTCToLocal -- -# -# Given the seconds from the Posix epoch, compute seconds of -# nominal local time. -# -# Parameters: -# date - Dictionary populated on entry with the 'seconds' field -# -# Results: -# The given dictionary is returned, augmented with 'localSeconds', -# 'tzOffset', and 'tzName' fields. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertUTCToLocal { date timezone } { - - variable TZData - - # Get the data for time changes in the given zone - - if { [catch { SetupTimeZone $timezone } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - - if { $timezone eq {:localtime} } { - - # Convert using the localtime function - - if { [catch { - ConvertUTCToLocalViaC $date - } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - return $retval - } - - # Find the most recent transition in the time zone data - - set i [BSearch $TZData($timezone) [dict get $date seconds]] - set row [lindex $TZData($timezone) $i] - foreach { junk1 offset junk2 name } $row break - - # Add appropriate offset to convert Greenwich to local, and return - # the local time - - dict set date localSeconds [expr { [dict get $date seconds] + $offset }] - dict set date tzOffset $offset - dict set date tzName $name - - return $date - -} - -#---------------------------------------------------------------------- -# -# ConvertUTCToLocalViaC -- -# -# Convert local time using the C localtime function -# -# Parameters: -# date - Dictionary populated on entry with the 'seconds' -# and 'timeZone' fields. -# -# Results: -# The given dictionary is returned, augmented with 'localSeconds', -# 'tzOffset', and 'tzName' fields. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertUTCToLocalViaC { date } { - - # Get y-m-d-h-m-s from the C library - - set gmtSeconds [dict get $date seconds] - set localFields [Localtime $gmtSeconds] - set date2 [dict create] - foreach key { - year month dayOfMonth hour minute second - } value $localFields { - dict set date2 $key $value - } - dict set date2 era CE - - # Convert to Julian Day - - set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}]] - - # Reconvert to seconds from the epoch in local time. - - set localSeconds [expr { ( ( ( wide([dict get $date2 julianDay]) - * 24 - + wide([dict get $date2 hour]) ) - * 60 - + wide([dict get $date2 minute]) ) - * 60 - + wide([dict get $date2 second]) ) - - 210866803200 }] - - # Determine the name and offset of the timezone - - set diff [expr { $localSeconds - $gmtSeconds }] - if { $diff <= 0 } { - set signum - - set delta [expr { - $diff }] - } else { - set signum + - set delta $diff - } - set hh [::format %02d [expr { $delta / 3600 }]] - set mm [::format %02d [expr { ($delta / 60 ) - % 60 }]] - set ss [::format %02d [expr { $delta % 60 }]] - - set zoneName $signum$hh$mm - if { $ss ne {00} } { - append zoneName $ss - } - - # Fix the dictionary - - dict set date localSeconds $localSeconds - dict set date tzOffset $diff - dict set date tzName $zoneName - return $date - -} - -#---------------------------------------------------------------------- -# # SetupTimeZone -- # # Given the name or specification of a time zone, sets up @@ -4101,288 +3875,6 @@ proc ::tcl::clock::GetLocaleEra { date } { return $date } -#---------------------------------------------------------------------- -# -# GetJulianDay -- -# -# Given the seconds from the Posix epoch, derives the Julian -# day number. -# -# Parameters: -# date - Dictionary containing the date fields. On input, -# populated with a 'localSeconds' field that gives the -# nominal seconds from the epoch (in the local time zone, -# rather than UTC). -# -# Results: -# Returns the given dictionary, augmented by a 'julianDay' -# field that gives the Julian Day Number at noon of the current -# date. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetJulianDay { date } { - - set secs [dict get $date localSeconds] - - return [dict set date julianDay \ - [expr { ( $secs + 210866803200 ) - / 86400 }]] - -} - -#---------------------------------------------------------------------- -# -# GetGregorianEraYearDay -- -# -# Given the time from the Posix epoch and the current time zone, -# develops the era, year, and day of year in the Gregorian calendar. -# -# Parameters: -# date - Dictionary containing the date fields. On input, populated -# with the 'julianDay' key whose value is the Julian Day Number. -# -# Results: -# Returns the given dictionary with the 'gregorian', 'era', -# 'year', and 'dayOfYear' populated. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetGregorianEraYearDay { date } { - - set jday [dict get $date julianDay] - - set changeover [mc GREGORIAN_CHANGE_DATE] - - if { $jday >= $changeover } { - - # Gregorian date - - dict set date gregorian 1 - - # Calculate number of days since 1 January, 1 CE - - set day [expr { $jday - 1721425 - 1 }] - - # Calculate number of 400 year cycles - - set year 1 - set n [expr { $day / 146097 }] - incr year [expr { 400 * $n }] - set day [expr { $day % 146097 }] - - # Calculate number of centuries in the current cycle - - set n [expr { $day / 36524 }] - set day [expr { $day % 36524 }] - if { $n > 3 } { - set n 3 ; # 31 December 2000, for instance - incr day 36524 ; # is last day of 400 year cycle - } - incr year [expr { 100 * $n }] - - } else { - - # Julian date - - dict set date gregorian 0 - - # Calculate days since 0 January, 1 CE Julian - - set day [expr { $jday - 1721423 - 1 }] - set year 1 - - } - - # Calculate number of 4-year cycles in current century (or in - # the Common Era, if the calendar is Julian) - - set n [expr { $day / 1461 }] - set day [expr { $day % 1461 }] - incr year [expr { 4 * $n }] - - # Calculate number of years in current 4-year cycle - - set n [expr { $day / 365 }] - set day [expr { $day % 365 }] - if { $n > 3 } { - set n 3 ;# 31 December in a leap year - incr day 365 - } - incr year $n - - # Calculate the era - - if { $year <= 0 } { - dict set date year [expr { 1 - $year }] - dict set date era BCE - } else { - dict set date year $year - dict set date era CE - } - - # Return day of the year - - dict set date dayOfYear [expr { $day + 1 }] - - return $date - -} - -#---------------------------------------------------------------------- -# -# GetMonthDay -- -# -# Given the ordinal number of the day within the year, determines -# month and day of month in the Gregorian calendar. -# -# Parameters: -# date - Dictionary containing the date fields. On input, populated -# with the 'era', 'gregorian', 'year' and 'dayOfYear' fields. -# -# Results: -# Returns the given dictionary with the 'month' and 'dayOfMonth' -# fields populated. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetMonthDay { date } { - - variable DaysInRomanMonthInCommonYear - variable DaysInRomanMonthInLeapYear - - set day [dict get $date dayOfYear] - if { [IsGregorianLeapYear $date] } { - set hath $DaysInRomanMonthInLeapYear - } else { - set hath $DaysInRomanMonthInCommonYear - } - set month 1 - foreach n $hath { - if { $day <= $n } { - break - } - incr month - incr day [expr { -$n }] - } - dict set date month $month - dict set date dayOfMonth $day - - return $date - -} - -#---------------------------------------------------------------------- -# -# GetYearWeekDay -# -# Given a julian day number, fiscal year, fiscal week, -# and day of week in the ISO8601 calendar. -# -# Parameters: -# -# date - Dictionary where the 'julianDay' field is populated. -# daysInFirstWeek - (Optional) Parameter giving the minimum number -# of days in the first week of a year. Default is 4. -# -# Results: -# Returns the given dictionary with values filled in for the -# three given keys. -# -# Side effects: -# None. -# -# Bugs: -# Since ISO8601 week numbering is defined only for the Gregorian -# calendar, dates on the Julian calendar or before the Common -# Era may yield unexpected results. In particular, the year of -# the Julian-to-Gregorian change may be up to three weeks short. -# The era is not managed separately, so if the Common Era begins -# (or the period Before the Common Era ends) with a partial week, -# the few days at the beginning or end of the era may show up -# as incorrectly belonging to the year zero. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetYearWeekDay { date - { keys { iso8601Year iso8601Week dayOfWeek } } } { - - set daysInFirstWeek 4 - set firstDayOfWeek 1 - - # Determine the calendar year of $j - $daysInFirstWeek + 1. - # Compute an upper bound of the fiscal year as being one year - # past the day on which the current week begins. Find the start - # of that year. - - set j [dict get $date julianDay] - set jd [expr { $j - $daysInFirstWeek + 1 }] - set date1 [GetGregorianEraYearDay [dict create julianDay $jd]] - switch -exact -- [dict get $date1 era] { - BCE { - dict set date1 fiscalYear [expr { [dict get $date1 year] - 1}] - } - CE { - dict set date1 fiscalYear [expr { [dict get $date1 year] + 1}] - } - } - dict unset date1 year - dict unset date1 dayOfYear - dict set date1 weekOfFiscalYear 1 - dict set date1 dayOfWeek $firstDayOfWeek - - set date1 [GetJulianDayFromEraYearWeekDay \ - $date1[set date1 {}] \ - $daysInFirstWeek \ - $firstDayOfWeek \ - { fiscalYear weekOfFiscalYear dayOfWeek }] - set startOfFiscalYear [dict get $date1 julianDay] - - # If we guessed high, move one year earlier. - - if { $j < $startOfFiscalYear } { - switch -exact -- [dict get $date1 era] { - BCE { - dict incr date1 fiscalYear - } - CE { - dict incr date1 fiscalYear -1 - } - } - set date1 [GetJulianDayFromEraYearWeekDay \ - $date1[set date1 {}] \ - $daysInFirstWeek \ - $firstDayOfWeek \ - {fiscalYear weekOfFiscalYear dayOfWeek }] - set startOfFiscalYear [dict get $date1 julianDay] - } - - # Get the week number and the day within the week - - set fiscalYear [dict get $date1 fiscalYear] - set dayOfFiscalYear [expr { $j - $startOfFiscalYear }] - set weekOfFiscalYear [expr { ( $dayOfFiscalYear / 7 ) + 1 }] - set dayOfWeek [expr { ( $dayOfFiscalYear + 1 ) % 7 }] - if { $dayOfWeek < $firstDayOfWeek } { - incr dayOfWeek 7 - } - - # Store the fiscal year, week, and day in the given slots in the - # given dictionary. - - foreach key $keys \ - value [list $fiscalYear $weekOfFiscalYear $dayOfWeek] { - dict set date $key $value - } - - return $date -} #---------------------------------------------------------------------- # @@ -4408,6 +3900,9 @@ proc ::tcl::clock::GetYearWeekDay { date # that gives the Julian Day Number corresponding to the given # date. # +# Bugs: +# This code needs to be moved to the C layer. +# #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearWeekDay { @@ -4467,6 +3962,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearWeekDay { # Side effects: # None. # +# Bugs: +# This code needs to be moved to the C layer. +# #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { @@ -4552,6 +4050,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { # Side effects: # None. # +# Bugs: +# This code needs to be moved to the C layer. +# #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { @@ -4609,6 +4110,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { # Side effects: # None. # +# Bugs: +# This code needs to be moved to the C layer. +# #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay { date } { @@ -4859,6 +4363,11 @@ proc ::tcl::clock::add { clockval args } { } EnterLocale $locale oldLocale + + if {[catch {SetupTimeZone $timezone} retval opts]} { + dict unset opts -errorinfo + return -options $opts $retval + } set status [catch { @@ -4946,15 +4455,13 @@ proc ::tcl::clock::AddMonths { months clockval timezone } { variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear + variable TZData + + set changeover [mc GREGORIAN_CHANGE_DATE] # Convert the time to year, month, day, and fraction of day. - set date [GetMonthDay \ - [GetGregorianEraYearDay \ - [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $clockval] \ - $timezone]]]] + set date [GetDateFields $clockval $TZData($timezone) $changeover] dict set date secondOfDay [expr { [dict get $date localSeconds] % 86400 }] dict set date tzName $timezone @@ -4988,7 +4495,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone } { [expr { -210866803200 + ( 86400 * wide([dict get $date julianDay]) ) + [dict get $date secondOfDay] }] - set date [ConvertLocalToUTC $date[set date {}]] + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ + $changeover] return [dict get $date seconds] @@ -5017,12 +4525,13 @@ proc ::tcl::clock::AddMonths { months clockval timezone } { proc ::tcl::clock::AddDays { days clockval timezone } { + variable TZData + + set changeover [mc GREGORIAN_CHANGE_DATE] + # Convert the time to Julian Day - set date [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $clockval] \ - $timezone]] + set date [GetDateFields $clockval $TZData($timezone) $changeover] dict set date secondOfDay [expr { [dict get $date localSeconds] % 86400 }] dict set date tzName $timezone @@ -5037,7 +4546,8 @@ proc ::tcl::clock::AddDays { days clockval timezone } { [expr { -210866803200 + ( 86400 * wide([dict get $date julianDay]) ) + [dict get $date secondOfDay] }] - set date [ConvertLocalToUTC $date[set date {}]] + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ + $changeover] return [dict get $date seconds] |