Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclClock.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

File size: 52.6 KB
Line 
1/*
2 * tclClock.c --
3 *
4 *      Contains the time and date related commands. This code is derived from
5 *      the time and date facilities of TclX, by Mark Diekhans and Karl
6 *      Lehenbauer.
7 *
8 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
9 * Copyright (c) 1995 Sun Microsystems, Inc.
10 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
11 *
12 * See the file "license.terms" for information on usage and redistribution of
13 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
14 *
15 * RCS: @(#) $Id: tclClock.c,v 1.66 2008/02/27 02:08:27 kennykb Exp $
16 */
17
18#include "tclInt.h"
19
20/*
21 * Windows has mktime. The configurators do not check.
22 */
23
24#ifdef __WIN32__
25#define HAVE_MKTIME 1
26#endif
27
28/*
29 * Constants
30 */
31
32#define JULIAN_DAY_POSIX_EPOCH          2440588
33#define SECONDS_PER_DAY                 86400
34#define JULIAN_SEC_POSIX_EPOCH        (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
35                                        * SECONDS_PER_DAY)
36#define FOUR_CENTURIES                  146097 /* days */
37#define JDAY_1_JAN_1_CE_JULIAN          1721424
38#define JDAY_1_JAN_1_CE_GREGORIAN       1721426
39#define ONE_CENTURY_GREGORIAN           36524  /* days */
40#define FOUR_YEARS                      1461   /* days */
41#define ONE_YEAR                        365    /* days */
42
43/*
44 * Table of the days in each month, leap and common years
45 */
46
47static const int hath[2][12] = {
48    {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},
49    {31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
50};
51static const int daysInPriorMonths[2][13] = {
52    {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365},
53    {0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366}
54};
55
56/*
57 * Enumeration of the string literals used in [clock]
58 */
59
60typedef enum ClockLiteral {
61    LIT__NIL,
62    LIT__DEFAULT_FORMAT,
63    LIT_BCE,            LIT_C,                 
64    LIT_CANNOT_USE_GMT_AND_TIMEZONE,
65    LIT_CE,
66    LIT_DAYOFMONTH,     LIT_DAYOFWEEK,          LIT_DAYOFYEAR,
67    LIT_ERA,            LIT_GMT,                LIT_GREGORIAN,
68    LIT_INTEGER_VALUE_TOO_LARGE,
69    LIT_ISO8601WEEK,    LIT_ISO8601YEAR,
70    LIT_JULIANDAY,      LIT_LOCALSECONDS,
71    LIT_MONTH,
72    LIT_SECONDS,        LIT_TZNAME,             LIT_TZOFFSET,
73    LIT_YEAR,
74    LIT__END
75} ClockLiteral;
76static const char *const literals[] = {
77    "",
78    "%a %b %d %H:%M:%S %Z %Y",
79    "BCE",              "C",                   
80    "cannot use -gmt and -timezone in same call",
81    "CE",
82    "dayOfMonth",       "dayOfWeek",            "dayOfYear",
83    "era",              ":GMT",                 "gregorian",
84    "integer value too large to represent",
85    "iso8601Week",      "iso8601Year",
86    "julianDay",        "localSeconds",
87    "month",
88    "seconds",          "tzName",               "tzOffset",
89    "year"
90};
91
92/*
93 * Structure containing the client data for [clock]
94 */
95
96typedef struct ClockClientData {
97    int refCount;               /* Number of live references */
98    Tcl_Obj** literals;         /* Pool of object literals */
99} ClockClientData;
100
101/*
102 * Structure containing the fields used in [clock format] and [clock scan]
103 */
104
105typedef struct TclDateFields {
106    Tcl_WideInt seconds;        /* Time expressed in seconds from the Posix
107                                 * epoch */
108    Tcl_WideInt localSeconds;   /* Local time expressed in nominal seconds
109                                 * from the Posix epoch */
110    int tzOffset;               /* Time zone offset in seconds east of
111                                 * Greenwich */
112    Tcl_Obj* tzName;            /* Time zone name */
113    int julianDay;              /* Julian Day Number in local time zone */
114    enum {BCE=1, CE=0} era;     /* Era */
115    int gregorian;              /* Flag == 1 if the date is Gregorian */
116    int year;                   /* Year of the era */
117    int dayOfYear;              /* Day of the year (1 January == 1) */
118    int month;                  /* Month number */
119    int dayOfMonth;             /* Day of the month */
120    int iso8601Year;            /* ISO8601 week-based year */
121    int iso8601Week;            /* ISO8601 week number */
122    int dayOfWeek;              /* Day of the week */
123} TclDateFields;
124static const char* eras[] = { "CE", "BCE", NULL };
125
126/*
127 * Thread specific data block holding a 'struct tm' for the 'gmtime' and
128 * 'localtime' library calls.
129 */
130
131static Tcl_ThreadDataKey tmKey;
132
133/*
134 * Mutex protecting 'gmtime', 'localtime' and 'mktime' calls and the statics
135 * in the date parsing code.
136 */
137
138TCL_DECLARE_MUTEX(clockMutex)
139
140/*
141 * Function prototypes for local procedures in this file:
142 */
143
144static int              ConvertUTCToLocal(Tcl_Interp*,
145                            TclDateFields*, Tcl_Obj*, int);
146static int              ConvertUTCToLocalUsingTable(Tcl_Interp*,
147                            TclDateFields*, int, Tcl_Obj *const[]);
148static int              ConvertUTCToLocalUsingC(Tcl_Interp*,
149                            TclDateFields*, int);
150static int              ConvertLocalToUTC(Tcl_Interp*,
151                            TclDateFields*, Tcl_Obj*, int);
152static int              ConvertLocalToUTCUsingTable(Tcl_Interp*,
153                            TclDateFields*, int, Tcl_Obj *const[]);
154static int              ConvertLocalToUTCUsingC(Tcl_Interp*,
155                            TclDateFields*, int);
156static Tcl_Obj*         LookupLastTransition(Tcl_Interp*, Tcl_WideInt,
157                            int, Tcl_Obj *const *);
158static void             GetYearWeekDay(TclDateFields*, int);
159static void             GetGregorianEraYearDay(TclDateFields*, int);
160static void             GetMonthDay(TclDateFields*);
161static void             GetJulianDayFromEraYearWeekDay(TclDateFields*, int);
162static void             GetJulianDayFromEraYearMonthDay(TclDateFields*, int);
163static int              IsGregorianLeapYear(TclDateFields*);
164static int              WeekdayOnOrBefore(int, int);
165static int              ClockClicksObjCmd(
166                            ClientData clientData, Tcl_Interp *interp,
167                            int objc, Tcl_Obj *const objv[]);
168static int              ClockConvertlocaltoutcObjCmd(
169                            ClientData clientData, Tcl_Interp *interp,
170                            int objc, Tcl_Obj *const objv[]);
171static int              ClockGetdatefieldsObjCmd(
172                            ClientData clientData, Tcl_Interp *interp,
173                            int objc, Tcl_Obj *const objv[]);
174static int              ClockGetjuliandayfromerayearmonthdayObjCmd(
175                            ClientData clientData, Tcl_Interp *interp,
176                            int objc, Tcl_Obj *const objv[]);
177static int              ClockGetjuliandayfromerayearweekdayObjCmd(
178                            ClientData clientData, Tcl_Interp *interp,
179                            int objc, Tcl_Obj *const objv[]);
180static int              ClockGetenvObjCmd(
181                            ClientData clientData, Tcl_Interp *interp,
182                            int objc, Tcl_Obj *const objv[]);
183static int              ClockMicrosecondsObjCmd(
184                            ClientData clientData, Tcl_Interp *interp,
185                            int objc, Tcl_Obj *const objv[]);
186static int              ClockMillisecondsObjCmd(
187                            ClientData clientData, Tcl_Interp *interp,
188                            int objc, Tcl_Obj *const objv[]);
189static int              ClockParseformatargsObjCmd(
190                            ClientData clientData, Tcl_Interp* interp,
191                            int objc, Tcl_Obj *const objv[]);
192static int              ClockSecondsObjCmd(
193                            ClientData clientData, Tcl_Interp *interp,
194                            int objc, Tcl_Obj *const objv[]);
195static struct tm *      ThreadSafeLocalTime(const time_t *);
196static void             TzsetIfNecessary(void);
197static void             ClockDeleteCmdProc(ClientData);
198
199/*
200 * Structure containing description of "native" clock commands to create.
201 */
202
203struct ClockCommand {
204    const char *name;           /* The tail of the command name. The full name
205                                 * is "::tcl::clock::<name>". When NULL marks
206                                 * the end of the table. */
207    Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
208                                 * will always have the ClockClientData sent
209                                 * to it, but may well ignore this data. */
210};
211
212static const struct ClockCommand clockCommands[] = {
213    { "clicks",                 ClockClicksObjCmd },
214    { "getenv",                 ClockGetenvObjCmd },
215    { "microseconds",           ClockMicrosecondsObjCmd },
216    { "milliseconds",           ClockMillisecondsObjCmd },
217    { "seconds",                ClockSecondsObjCmd },
218    { "Oldscan",                TclClockOldscanObjCmd },
219    { "ConvertLocalToUTC",      ClockConvertlocaltoutcObjCmd },
220    { "GetDateFields",          ClockGetdatefieldsObjCmd },
221    { "GetJulianDayFromEraYearMonthDay",
222                ClockGetjuliandayfromerayearmonthdayObjCmd },
223    { "GetJulianDayFromEraYearWeekDay",
224                ClockGetjuliandayfromerayearweekdayObjCmd },
225    { "ParseFormatArgs",        ClockParseformatargsObjCmd },
226    { NULL, NULL }
227};
228
229/*
230 *----------------------------------------------------------------------
231 *
232 * TclClockInit --
233 *
234 *      Registers the 'clock' subcommands with the Tcl interpreter and
235 *      initializes its client data (which consists mostly of constant
236 *      Tcl_Obj's that it is too much trouble to keep recreating).
237 *
238 * Results:
239 *      None.
240 *
241 * Side effects:
242 *      Installs the commands and creates the client data
243 *
244 *----------------------------------------------------------------------
245 */
246
247void
248TclClockInit(
249    Tcl_Interp *interp)         /* Tcl interpreter */
250{
251    const struct ClockCommand *clockCmdPtr;
252    char cmdName[50];           /* Buffer large enough to hold the string
253                                 *::tcl::clock::GetJulianDayFromEraYearMonthDay
254                                 * plus a terminating NULL. */
255    ClockClientData *data;
256    int i;
257
258    /*
259     * Create the client data, which is a refcounted literal pool.
260     */
261
262    data = (ClockClientData *) ckalloc(sizeof(ClockClientData));
263    data->refCount = 0;
264    data->literals = (Tcl_Obj**) ckalloc(LIT__END * sizeof(Tcl_Obj*));
265    for (i = 0; i < LIT__END; ++i) {
266        data->literals[i] = Tcl_NewStringObj(literals[i], -1);
267        Tcl_IncrRefCount(data->literals[i]);
268    }
269
270    /*
271     * Install the commands.
272     */
273
274    strcpy(cmdName, "::tcl::clock::");
275#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
276    for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
277        strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
278        data->refCount++;
279        Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data,
280                ClockDeleteCmdProc);
281    }
282}
283
284/*
285 *----------------------------------------------------------------------
286 *
287 * ClockConvertlocaltoutcObjCmd --
288 *
289 *      Tcl command that converts a UTC time to a local time by whatever means
290 *      is available.
291 *
292 * Usage:
293 *      ::tcl::clock::ConvertUTCToLocal dictionary tzdata changeover
294 *
295 * Parameters:
296 *      dict - Dictionary containing a 'localSeconds' entry.
297 *      tzdata - Time zone data
298 *      changeover - Julian Day of the adoption of the Gregorian calendar.
299 *
300 * Results:
301 *      Returns a standard Tcl result.
302 *
303 * Side effects:
304 *      On success, sets the interpreter result to the given dictionary
305 *      augmented with a 'seconds' field giving the UTC time. On failure,
306 *      leaves an error message in the interpreter result.
307 *
308 *----------------------------------------------------------------------
309 */
310
311static int
312ClockConvertlocaltoutcObjCmd(
313    ClientData clientData,      /* Client data  */
314    Tcl_Interp* interp,         /* Tcl interpreter */
315    int objc,                   /* Parameter count */
316    Tcl_Obj *const *objv)       /* Parameter vector */
317{
318    ClockClientData* data = (ClockClientData*) clientData;
319    Tcl_Obj* const * literals = data->literals;
320    Tcl_Obj* secondsObj;
321    Tcl_Obj* dict;
322    int changeover;
323    TclDateFields fields;
324    int created = 0;
325    int status;
326
327    /*
328     * Check params and convert time.
329     */
330
331    if (objc != 4) {
332        Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
333        return TCL_ERROR;
334    }
335    dict = objv[1];
336    if ((Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS],
337                &secondsObj) != TCL_OK)
338            || (Tcl_GetWideIntFromObj(interp, secondsObj,
339                &(fields.localSeconds)) != TCL_OK)
340            || (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
341            || ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
342        return TCL_ERROR;
343    }
344
345    /*
346     * Copy-on-write; set the 'seconds' field in the dictionary and place the
347     * modified dictionary in the interpreter result.
348     */
349
350    if (Tcl_IsShared(dict)) {
351        dict = Tcl_DuplicateObj(dict);
352        created = 1;
353        Tcl_IncrRefCount(dict);
354    }
355    status = Tcl_DictObjPut(interp, dict, literals[LIT_SECONDS],
356            Tcl_NewWideIntObj(fields.seconds));
357    if (status == TCL_OK) {
358        Tcl_SetObjResult(interp, dict);
359    }
360    if (created) {
361        Tcl_DecrRefCount(dict);
362    }
363    return status;
364}
365
366/*
367 *----------------------------------------------------------------------
368 *
369 * ClockGetdatefieldsObjCmd --
370 *
371 *      Tcl command that determines the values that [clock format] will use in
372 *      formatting a date, and populates a dictionary with them.
373 *
374 * Usage:
375 *      ::tcl::clock::GetDateFields seconds tzdata changeover
376 *
377 * Parameters:
378 *      seconds - Time expressed in seconds from the Posix epoch.
379 *      tzdata - Time zone data of the time zone in which time is to
380 *                 be expressed.
381 *      changeover - Julian Day Number at which the current locale adopted
382 *                   the Gregorian calendar
383 *
384 * Results:
385 *      Returns a dictonary populated with the fields:
386 *              seconds - Seconds from the Posix epoch
387 *              localSeconds - Nominal seconds from the Posix epoch in
388 *                             the local time zone.
389 *              tzOffset - Time zone offset in seconds east of Greenwich
390 *              tzName - Time zone name
391 *              julianDay - Julian Day Number in the local time zone
392 *
393 *----------------------------------------------------------------------
394 */
395
396int
397ClockGetdatefieldsObjCmd(
398    ClientData clientData,      /* Opaque pointer to literal pool, etc. */
399    Tcl_Interp* interp,         /* Tcl interpreter */
400    int objc,                   /* Parameter count */
401    Tcl_Obj *const *objv)       /* Parameter vector */
402{
403    TclDateFields fields;
404    Tcl_Obj* dict;
405    ClockClientData* data = (ClockClientData*) clientData;
406    Tcl_Obj* const * literals = data->literals;
407    int changeover;
408
409    /*
410     * Check params.
411     */
412
413    if (objc != 4) {
414        Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover");
415        return TCL_ERROR;
416    }
417    if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK
418            || TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
419        return TCL_ERROR;
420    }
421
422    /*
423     * fields.seconds could be an unsigned number that overflowed.  Make
424     * sure that it isn't.
425     */
426
427    if (objv[1]->typePtr == &tclBignumType) {
428        Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]);
429        return TCL_ERROR;
430    }
431
432    /*
433     * Convert UTC time to local.
434     */
435
436    if (ConvertUTCToLocal(interp, &fields, objv[2], changeover) != TCL_OK) {
437        return TCL_ERROR;
438    }
439
440    /*
441     * Extract Julian day.
442     */
443
444    fields.julianDay = (int) ((fields.localSeconds + JULIAN_SEC_POSIX_EPOCH)
445            / SECONDS_PER_DAY);
446
447    /*
448     * Convert to Julian or Gregorian calendar.
449     */
450
451    GetGregorianEraYearDay(&fields, changeover);
452    GetMonthDay(&fields);
453    GetYearWeekDay(&fields, changeover);
454
455    dict = Tcl_NewDictObj();
456    Tcl_DictObjPut(NULL, dict, literals[LIT_LOCALSECONDS],
457            Tcl_NewWideIntObj(fields.localSeconds));
458    Tcl_DictObjPut(NULL, dict, literals[LIT_SECONDS],
459            Tcl_NewWideIntObj(fields.seconds));
460    Tcl_DictObjPut(NULL, dict, literals[LIT_TZNAME], fields.tzName);
461    Tcl_DecrRefCount(fields.tzName);
462    Tcl_DictObjPut(NULL, dict, literals[LIT_TZOFFSET],
463            Tcl_NewIntObj(fields.tzOffset));
464    Tcl_DictObjPut(NULL, dict, literals[LIT_JULIANDAY],
465            Tcl_NewIntObj(fields.julianDay));
466    Tcl_DictObjPut(NULL, dict, literals[LIT_GREGORIAN],
467            Tcl_NewIntObj(fields.gregorian));
468    Tcl_DictObjPut(NULL, dict, literals[LIT_ERA],
469            literals[fields.era ? LIT_BCE : LIT_CE]);
470    Tcl_DictObjPut(NULL, dict, literals[LIT_YEAR],
471            Tcl_NewIntObj(fields.year));
472    Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFYEAR],
473            Tcl_NewIntObj(fields.dayOfYear));
474    Tcl_DictObjPut(NULL, dict, literals[LIT_MONTH],
475            Tcl_NewIntObj(fields.month));
476    Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFMONTH],
477            Tcl_NewIntObj(fields.dayOfMonth));
478    Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601YEAR],
479            Tcl_NewIntObj(fields.iso8601Year));
480    Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601WEEK],
481            Tcl_NewIntObj(fields.iso8601Week));
482    Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK],
483            Tcl_NewIntObj(fields.dayOfWeek));
484    Tcl_SetObjResult(interp, dict);
485
486    return TCL_OK;
487}
488
489/*
490 *----------------------------------------------------------------------
491 *
492 * ClockGetjuliandayfromerayearmonthdayObjCmd --
493 *
494 *      Tcl command that converts a time from era-year-month-day to a Julian
495 *      Day Number.
496 *
497 * Parameters:
498 *      dict - Dictionary that contains 'era', 'year', 'month' and
499 *             'dayOfMonth' keys.
500 *      changeover - Julian Day of changeover to the Gregorian calendar
501 *
502 * Results:
503 *      Result is either TCL_OK, with the interpreter result being the
504 *      dictionary augmented with a 'julianDay' key, or TCL_ERROR,
505 *      with the result being an error message.
506 *
507 *----------------------------------------------------------------------
508 */
509
510static int
511ClockGetjuliandayfromerayearmonthdayObjCmd (
512    ClientData clientData,      /* Opaque pointer to literal pool, etc. */
513    Tcl_Interp* interp,         /* Tcl interpreter */
514    int objc,                   /* Parameter count */
515    Tcl_Obj *const *objv)       /* Parameter vector */
516{
517    TclDateFields fields;
518    Tcl_Obj* dict;
519    ClockClientData* data = (ClockClientData*) clientData;
520    Tcl_Obj* const * literals = data->literals;
521    Tcl_Obj* fieldPtr;
522    int changeover;
523    int copied = 0;
524    int status;
525    int era = 0;
526
527    /*
528     * Check params.
529     */
530
531    if (objc != 3) {
532        Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
533        return TCL_ERROR;
534    }
535    dict = objv[1];
536    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
537            || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
538                &era) != TCL_OK
539            || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
540                &fieldPtr) != TCL_OK
541            || TclGetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK
542            || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
543                &fieldPtr) != TCL_OK
544            || TclGetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK
545            || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
546                &fieldPtr) != TCL_OK
547            || TclGetIntFromObj(interp, fieldPtr,
548                &(fields.dayOfMonth)) != TCL_OK
549            || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
550        return TCL_ERROR;
551    }
552    fields.era = era;
553
554    /*
555     * Get Julian day.
556     */
557
558    GetJulianDayFromEraYearMonthDay(&fields, changeover);
559
560    /*
561     * Store Julian day in the dictionary - copy on write.
562     */
563
564    if (Tcl_IsShared(dict)) {
565        dict = Tcl_DuplicateObj(dict);
566        Tcl_IncrRefCount(dict);
567        copied = 1;
568    }
569    status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
570            Tcl_NewIntObj(fields.julianDay));
571    if (status == TCL_OK) {
572        Tcl_SetObjResult(interp, dict);
573    }
574    if (copied) {
575        Tcl_DecrRefCount(dict);
576    }
577    return status;
578}
579
580/*
581 *----------------------------------------------------------------------
582 *
583 * ClockGetjuliandayfromerayearweekdayObjCmd --
584 *
585 *      Tcl command that converts a time from the ISO calendar to a Julian Day
586 *      Number.
587 *
588 * Parameters:
589 *      dict - Dictionary that contains 'era', 'iso8601Year', 'iso8601Week'
590 *             and 'dayOfWeek' keys.
591 *      changeover - Julian Day of changeover to the Gregorian calendar
592 *
593 * Results:
594 *      Result is either TCL_OK, with the interpreter result being the
595 *      dictionary augmented with a 'julianDay' key, or TCL_ERROR, with the
596 *      result being an error message.
597 *
598 *----------------------------------------------------------------------
599 */
600
601static int
602ClockGetjuliandayfromerayearweekdayObjCmd (
603    ClientData clientData,      /* Opaque pointer to literal pool, etc. */
604    Tcl_Interp* interp,         /* Tcl interpreter */
605    int objc,                   /* Parameter count */
606    Tcl_Obj *const *objv)       /* Parameter vector */
607{
608    TclDateFields fields;
609    Tcl_Obj* dict;
610    ClockClientData* data = (ClockClientData*) clientData;
611    Tcl_Obj* const * literals = data->literals;
612    Tcl_Obj* fieldPtr;
613    int changeover;
614    int copied = 0;
615    int status;
616    int era = 0;
617
618    /*
619     * Check params.
620     */
621
622    if (objc != 3) {
623        Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
624        return TCL_ERROR;
625    }
626    dict = objv[1];
627    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
628            || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
629                &era) != TCL_OK
630            || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR],
631                &fieldPtr) != TCL_OK
632            || TclGetIntFromObj(interp, fieldPtr,
633                &(fields.iso8601Year)) != TCL_OK
634            || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK],
635                &fieldPtr) != TCL_OK
636            || TclGetIntFromObj(interp, fieldPtr,
637                &(fields.iso8601Week)) != TCL_OK
638            || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK],
639                &fieldPtr) != TCL_OK
640            || TclGetIntFromObj(interp, fieldPtr,
641                &(fields.dayOfWeek)) != TCL_OK
642            || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
643        return TCL_ERROR;
644    }
645    fields.era = era;
646
647    /*
648     * Get Julian day.
649     */
650
651    GetJulianDayFromEraYearWeekDay(&fields, changeover);
652
653    /*
654     * Store Julian day in the dictionary - copy on write.
655     */
656
657    if (Tcl_IsShared(dict)) {
658        dict = Tcl_DuplicateObj(dict);
659        Tcl_IncrRefCount(dict);
660        copied = 1;
661    }
662    status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY],
663            Tcl_NewIntObj(fields.julianDay));
664    if (status == TCL_OK) {
665        Tcl_SetObjResult(interp, dict);
666    }
667    if (copied) {
668        Tcl_DecrRefCount(dict);
669    }
670    return status;
671}
672
673/*
674 *----------------------------------------------------------------------
675 *
676 * ConvertLocalToUTC --
677 *
678 *      Converts a time (in a TclDateFields structure) from the local wall
679 *      clock to UTC.
680 *
681 * Results:
682 *      Returns a standard Tcl result.
683 *
684 * Side effects:
685 *      Populates the 'seconds' field if successful; stores an error message
686 *      in the interpreter result on failure.
687 *
688 *----------------------------------------------------------------------
689 */
690
691static int
692ConvertLocalToUTC(
693    Tcl_Interp* interp,         /* Tcl interpreter */
694    TclDateFields* fields,      /* Fields of the time */
695    Tcl_Obj* tzdata,            /* Time zone data */
696    int changeover)             /* Julian Day of the Gregorian transition */
697{
698    int rowc;                   /* Number of rows in tzdata */
699    Tcl_Obj** rowv;             /* Pointers to the rows */
700
701    /*
702     * Unpack the tz data.
703     */
704
705    if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
706        return TCL_ERROR;
707    }
708
709    /*
710     * Special case: If the time zone is :localtime, the tzdata will be empty.
711     * Use 'mktime' to convert the time to local
712     */
713
714    if (rowc == 0) {
715        return ConvertLocalToUTCUsingC(interp, fields, changeover);
716    } else {
717        return ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv);
718    }
719}
720
721/*
722 *----------------------------------------------------------------------
723 *
724 * ConvertLocalToUTCUsingTable --
725 *
726 *      Converts a time (in a TclDateFields structure) from local time in a
727 *      given time zone to UTC.
728 *
729 * Results:
730 *      Returns a standard Tcl result.
731 *
732 * Side effects:
733 *      Stores an error message in the interpreter if an error occurs; if
734 *      successful, stores the 'seconds' field in 'fields.
735 *
736 *----------------------------------------------------------------------
737 */
738
739static int
740ConvertLocalToUTCUsingTable(
741    Tcl_Interp* interp,         /* Tcl interpreter */
742    TclDateFields* fields,      /* Time to convert, with 'seconds' filled in */
743    int rowc,                   /* Number of points at which time changes */
744    Tcl_Obj *const rowv[])      /* Points at which time changes */
745{
746    Tcl_Obj* row;
747    int cellc;
748    Tcl_Obj** cellv;
749    int have[8];
750    int nHave = 0;
751    int i;
752    int found;
753
754    /*
755     * Perform an initial lookup assuming that local == UTC, and locate the
756     * last time conversion prior to that time. Get the offset from that row,
757     * and look up again. Continue until we find an offset that we found
758     * before. This definition, rather than "the same offset" ensures that we
759     * don't enter an endless loop, as would otherwise happen when trying to
760     * convert a non-existent time such as 02:30 during the US Spring Daylight
761     * Saving Time transition.
762     */
763
764    found = 0;
765    fields->tzOffset = 0;
766    fields->seconds = fields->localSeconds;
767    while (!found) {
768        row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
769        if ((row == NULL)
770                || TclListObjGetElements(interp, row, &cellc,
771                    &cellv) != TCL_OK
772                || TclGetIntFromObj(interp, cellv[1],
773                    &(fields->tzOffset)) != TCL_OK) {
774            return TCL_ERROR;
775        }
776        found = 0;
777        for (i = 0; !found && i < nHave; ++i) {
778            if (have[i] == fields->tzOffset) {
779                found = 1;
780                break;
781            }
782        }
783        if (!found) {
784            if (nHave == 8) {
785                Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
786            }
787            have[nHave] = fields->tzOffset;
788            ++nHave;
789        }
790        fields->seconds = fields->localSeconds - fields->tzOffset;
791    }
792    fields->tzOffset = have[i];
793    fields->seconds = fields->localSeconds - fields->tzOffset;
794    return TCL_OK;
795}
796
797/*
798 *----------------------------------------------------------------------
799 *
800 * ConvertLocalToUTCUsingC --
801 *
802 *      Converts a time from local wall clock to UTC when the local time zone
803 *      cannot be determined. Uses 'mktime' to do the job.
804 *
805 * Results:
806 *      Returns a standard Tcl result.
807 *
808 * Side effects:
809 *      Stores an error message in the interpreter if an error occurs; if
810 *      successful, stores the 'seconds' field in 'fields.
811 *
812 *----------------------------------------------------------------------
813 */
814
815static int
816ConvertLocalToUTCUsingC(
817    Tcl_Interp* interp,         /* Tcl interpreter */
818    TclDateFields* fields,      /* Time to convert, with 'seconds' filled in */
819    int changeover)             /* Julian Day of the Gregorian transition */
820{
821    struct tm timeVal;
822    int localErrno;
823    int secondOfDay;
824    Tcl_WideInt jsec;
825
826    /*
827     * Convert the given time to a date.
828     */
829
830    jsec = fields->localSeconds + JULIAN_SEC_POSIX_EPOCH;
831    fields->julianDay = (int) (jsec / SECONDS_PER_DAY);
832    secondOfDay = (int)(jsec % SECONDS_PER_DAY);
833    if (secondOfDay < 0) {
834        secondOfDay += SECONDS_PER_DAY;
835        --fields->julianDay;
836    }
837    GetGregorianEraYearDay(fields, changeover);
838    GetMonthDay(fields);
839
840    /*
841     * Convert the date/time to a 'struct tm'.
842     */
843
844    timeVal.tm_year = fields->year - 1900;
845    timeVal.tm_mon = fields->month - 1;
846    timeVal.tm_mday = fields->dayOfMonth;
847    timeVal.tm_hour = (secondOfDay / 3600) % 24;
848    timeVal.tm_min = (secondOfDay / 60) % 60;
849    timeVal.tm_sec = secondOfDay % 60;
850    timeVal.tm_isdst = -1;
851    timeVal.tm_wday = -1;
852    timeVal.tm_yday = -1;
853
854    /*
855     * Get local time. It is rumored that mktime is not thread safe on some
856     * platforms, so seize a mutex before attempting this.
857     */
858
859    TzsetIfNecessary();
860    Tcl_MutexLock(&clockMutex);
861    errno = 0;
862    fields->seconds = (Tcl_WideInt) mktime(&timeVal);
863    localErrno = errno;
864    Tcl_MutexUnlock(&clockMutex);
865
866    /*
867     * If conversion fails, report an error.
868     */
869
870    if (localErrno != 0
871            || (fields->seconds == -1 && timeVal.tm_yday == -1)) {
872        Tcl_SetResult(interp, "time value too large/small to represent",
873                TCL_STATIC);
874        return TCL_ERROR;
875    }
876    return TCL_OK;
877}
878
879/*
880 *----------------------------------------------------------------------
881 *
882 * ConvertUTCToLocal --
883 *
884 *      Converts a time (in a TclDateFields structure) from UTC to local time.
885 *
886 * Results:
887 *      Returns a standard Tcl result.
888 *
889 * Side effects:
890 *      Populates the 'tzName' and 'tzOffset' fields.
891 *
892 *----------------------------------------------------------------------
893 */
894
895static int
896ConvertUTCToLocal(
897    Tcl_Interp* interp,         /* Tcl interpreter */
898    TclDateFields* fields,      /* Fields of the time */
899    Tcl_Obj* tzdata,            /* Time zone data */
900    int changeover)             /* Julian Day of the Gregorian transition */
901{
902    int rowc;                   /* Number of rows in tzdata */
903    Tcl_Obj** rowv;             /* Pointers to the rows */
904
905    /*
906     * Unpack the tz data.
907     */
908
909    if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
910        return TCL_ERROR;
911    }
912
913    /*
914     * Special case: If the time zone is :localtime, the tzdata will be empty.
915     * Use 'localtime' to convert the time to local
916     */
917
918    if (rowc == 0) {
919        return ConvertUTCToLocalUsingC(interp, fields, changeover);
920    } else {
921        return ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv);
922    }
923}
924
925/*
926 *----------------------------------------------------------------------
927 *
928 * ConvertUTCToLocalUsingTable --
929 *
930 *      Converts UTC to local time, given a table of transition points
931 *
932 * Results:
933 *      Returns a standard Tcl result
934 *
935 * Side effects:
936 *      On success, fills fields->tzName, fields->tzOffset and
937 *      fields->localSeconds. On failure, places an error message in the
938 *      interpreter result.
939 *
940 *----------------------------------------------------------------------
941 */
942
943static int
944ConvertUTCToLocalUsingTable(
945    Tcl_Interp* interp,         /* Tcl interpreter */
946    TclDateFields* fields,      /* Fields of the date */
947    int rowc,                   /* Number of rows in the conversion table
948                                 * (>= 1) */
949    Tcl_Obj *const rowv[])      /* Rows of the conversion table */
950{
951    Tcl_Obj* row;               /* Row containing the current information */
952    int cellc;                  /* Count of cells in the row (must be 4) */
953    Tcl_Obj** cellv;            /* Pointers to the cells */
954
955    /*
956     * Look up the nearest transition time.
957     */
958
959    row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
960    if (row == NULL ||
961            TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
962            TclGetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) {
963        return TCL_ERROR;
964    }
965
966    /*
967     * Convert the time.
968     */
969
970    fields->tzName = cellv[3];
971    Tcl_IncrRefCount(fields->tzName);
972    fields->localSeconds = fields->seconds + fields->tzOffset;
973    return TCL_OK;
974}
975
976/*
977 *----------------------------------------------------------------------
978 *
979 * ConvertUTCToLocalUsingC --
980 *
981 *      Converts UTC to localtime in cases where the local time zone is not
982 *      determinable, using the C 'localtime' function to do it.
983 *
984 * Results:
985 *      Returns a standard Tcl result.
986 *
987 * Side effects:
988 *      On success, fills fields->tzName, fields->tzOffset and
989 *      fields->localSeconds. On failure, places an error message in the
990 *      interpreter result.
991 *
992 *----------------------------------------------------------------------
993 */
994
995static int
996ConvertUTCToLocalUsingC(
997    Tcl_Interp* interp,         /* Tcl interpreter */
998    TclDateFields* fields,      /* Time to convert, with 'seconds' filled in */
999    int changeover)             /* Julian Day of the Gregorian transition */
1000{
1001    time_t tock;
1002    struct tm* timeVal;         /* Time after conversion */
1003    int diff;                   /* Time zone diff local-Greenwich */
1004    char buffer[8];             /* Buffer for time zone name */
1005
1006    /*
1007     * Use 'localtime' to determine local year, month, day, time of day.
1008     */
1009
1010    tock = (time_t) fields->seconds;
1011    if ((Tcl_WideInt) tock != fields->seconds) {
1012        Tcl_AppendResult(interp,
1013                "number too large to represent as a Posix time", NULL);
1014        Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
1015        return TCL_ERROR;
1016    }
1017    TzsetIfNecessary();
1018    timeVal = ThreadSafeLocalTime(&tock);
1019    if (timeVal == NULL) {
1020        Tcl_AppendResult(interp,
1021                "localtime failed (clock value may be too "
1022                "large/small to represent)", NULL);
1023        Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
1024        return TCL_ERROR;
1025    }
1026
1027    /*
1028     * Fill in the date in 'fields' and use it to derive Julian Day.
1029     */
1030
1031    fields->era = CE;
1032    fields->year = timeVal->tm_year + 1900;
1033    fields->month = timeVal->tm_mon + 1;
1034    fields->dayOfMonth = timeVal->tm_mday;
1035    GetJulianDayFromEraYearMonthDay(fields, changeover);
1036
1037    /*
1038     * Convert that value to seconds.
1039     */
1040
1041    fields->localSeconds = (((fields->julianDay * (Tcl_WideInt) 24
1042            + timeVal->tm_hour) * 60 + timeVal->tm_min) * 60
1043            + timeVal->tm_sec) - JULIAN_SEC_POSIX_EPOCH;
1044
1045    /*
1046     * Determine a time zone offset and name; just use +hhmm for the name.
1047     */
1048
1049    diff = (int) (fields->localSeconds - fields->seconds);
1050    fields->tzOffset = diff;
1051    if (diff < 0) {
1052        *buffer = '-';
1053        diff = -diff;
1054    } else {
1055        *buffer = '+';
1056    }
1057    sprintf(buffer+1, "%02d", diff / 3600);
1058    diff %= 3600;
1059    sprintf(buffer+3, "%02d", diff / 60);
1060    diff %= 60;
1061    if (diff > 0) {
1062        sprintf(buffer+5, "%02d", diff);
1063    }
1064    fields->tzName = Tcl_NewStringObj(buffer, -1);
1065    Tcl_IncrRefCount(fields->tzName);
1066    return TCL_OK;
1067}
1068
1069/*
1070 *----------------------------------------------------------------------
1071 *
1072 * LookupLastTransition --
1073 *
1074 *      Given a UTC time and a tzdata array, looks up the last transition on
1075 *      or before the given time.
1076 *
1077 * Results:
1078 *      Returns a pointer to the row, or NULL if an error occurs.
1079 *
1080 *----------------------------------------------------------------------
1081 */
1082
1083static Tcl_Obj*
1084LookupLastTransition(
1085    Tcl_Interp* interp,         /* Interpreter for error messages */
1086    Tcl_WideInt tick,           /* Time from the epoch */
1087    int rowc,                   /* Number of rows of tzdata */
1088    Tcl_Obj *const *rowv)       /* Rows in tzdata */
1089{
1090    int l;
1091    int u;
1092    Tcl_Obj* compObj;
1093    Tcl_WideInt compVal;
1094
1095    /*
1096     * Examine the first row to make sure we're in bounds.
1097     */
1098
1099    if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK
1100            || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
1101        return NULL;
1102    }
1103
1104    /*
1105     * Bizarre case - first row doesn't begin at MIN_WIDE_INT. Return it
1106     * anyway.
1107     */
1108
1109    if (tick < compVal) {
1110        return rowv[0];
1111    }
1112
1113    /*
1114     * Binary-search to find the transition.
1115     */
1116
1117    l = 0;
1118    u = rowc-1;
1119    while (l < u) {
1120        int m = (l + u + 1) / 2;
1121
1122        if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK ||
1123                Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
1124            return NULL;
1125        }
1126        if (tick >= compVal) {
1127            l = m;
1128        } else {
1129            u = m-1;
1130        }
1131    }
1132    return rowv[l];
1133}
1134
1135/*
1136 *----------------------------------------------------------------------
1137 *
1138 * GetYearWeekDay --
1139 *
1140 *      Given a date with Julian Calendar Day, compute the year, week, and day
1141 *      in the ISO8601 calendar.
1142 *
1143 * Results:
1144 *      None.
1145 *
1146 * Side effects:
1147 *      Stores 'iso8601Year', 'iso8601Week' and 'dayOfWeek' in the date
1148 *      fields.
1149 *
1150 *----------------------------------------------------------------------
1151 */
1152
1153static void
1154GetYearWeekDay(
1155    TclDateFields* fields,      /* Date to convert, must have 'julianDay' */
1156    int changeover)             /* Julian Day Number of the Gregorian
1157                                 * transition */
1158{
1159    TclDateFields temp;
1160    int dayOfFiscalYear;
1161
1162    /*
1163     * Find the given date, minus three days, plus one year. That date's
1164     * iso8601 year is an upper bound on the ISO8601 year of the given date.
1165     */
1166
1167    temp.julianDay = fields->julianDay - 3;
1168    GetGregorianEraYearDay(&temp, changeover);
1169    if (temp.era == BCE) {
1170        temp.iso8601Year = temp.year - 1;
1171    } else {
1172        temp.iso8601Year = temp.year + 1;
1173    }
1174    temp.iso8601Week = 1;
1175    temp.dayOfWeek = 1;
1176    GetJulianDayFromEraYearWeekDay(&temp, changeover);
1177
1178    /*
1179     * temp.julianDay is now the start of an ISO8601 year, either the one
1180     * corresponding to the given date, or the one after. If we guessed high,
1181     * move one year earlier
1182     */
1183
1184    if (fields->julianDay < temp.julianDay) {
1185        if (temp.era == BCE) {
1186            temp.iso8601Year += 1;
1187        } else {
1188            temp.iso8601Year -= 1;
1189        }
1190        GetJulianDayFromEraYearWeekDay(&temp, changeover);
1191    }
1192
1193    fields->iso8601Year = temp.iso8601Year;
1194    dayOfFiscalYear = fields->julianDay - temp.julianDay;
1195    fields->iso8601Week = (dayOfFiscalYear / 7) + 1;
1196    fields->dayOfWeek = (dayOfFiscalYear + 1) % 7;
1197    if (fields->dayOfWeek < 1) {
1198        fields->dayOfWeek += 7;
1199    }
1200}
1201
1202/*
1203 *----------------------------------------------------------------------
1204 *
1205 * GetGregorianEraYearDay --
1206 *
1207 *      Given a Julian Day Number, extracts the year and day of the year and
1208 *      puts them into TclDateFields, along with the era (BCE or CE) and a
1209 *      flag indicating whether the date is Gregorian or Julian.
1210 *
1211 * Results:
1212 *      None.
1213 *
1214 * Side effects:
1215 *      Stores 'era', 'gregorian', 'year', and 'dayOfYear'.
1216 *
1217 *----------------------------------------------------------------------
1218 */
1219
1220static void
1221GetGregorianEraYearDay(
1222    TclDateFields* fields,      /* Date fields containing 'julianDay' */
1223    int changeover)             /* Gregorian transition date */
1224{
1225    int jday = fields->julianDay;
1226    int day;
1227    int year;
1228    int n;
1229
1230    if (jday >= changeover) {
1231        /*
1232         * Gregorian calendar.
1233         */
1234
1235        fields->gregorian = 1;
1236        year = 1;
1237
1238        /*
1239         * n = Number of 400-year cycles since 1 January, 1 CE in the
1240         * proleptic Gregorian calendar. day = remaining days.
1241         */
1242
1243        day = jday - JDAY_1_JAN_1_CE_GREGORIAN;
1244        n = day / FOUR_CENTURIES;
1245        day %= FOUR_CENTURIES;
1246        if (day < 0) {
1247            day += FOUR_CENTURIES;
1248            --n;
1249        }
1250        year += 400 * n;
1251
1252        /*
1253         * n = number of centuries since the start of (year);
1254         * day = remaining days
1255         */
1256
1257        n = day / ONE_CENTURY_GREGORIAN;
1258        day %= ONE_CENTURY_GREGORIAN;
1259        if (n > 3) {
1260            /*
1261             * 31 December in the last year of a 400-year cycle.
1262             */
1263
1264            n = 3;
1265            day += ONE_CENTURY_GREGORIAN;
1266        }
1267        year += 100 * n;
1268
1269    } else {
1270        /*
1271         * Julian calendar.
1272         */
1273
1274        fields->gregorian = 0;
1275        year = 1;
1276        day = jday - JDAY_1_JAN_1_CE_JULIAN;
1277
1278    }
1279
1280    /*
1281     * n = number of 4-year cycles; days = remaining days.
1282     */
1283
1284    n = day / FOUR_YEARS;
1285    day %= FOUR_YEARS;
1286    if (day < 0) {
1287        day += FOUR_YEARS;
1288        --n;
1289    }
1290    year += 4 * n;
1291
1292    /*
1293     * n = number of years; days = remaining days.
1294     */
1295
1296    n = day / ONE_YEAR;
1297    day %= ONE_YEAR;
1298    if (n > 3) {
1299        /*
1300         * 31 December of a leap year.
1301         */
1302
1303        n = 3;
1304        day += 365;
1305    }
1306    year += n;
1307
1308    /*
1309     * store era/year/day back into fields.
1310     */
1311
1312    if (year <= 0) {
1313        fields->era = BCE;
1314        fields->year = 1 - year;
1315    } else {
1316        fields->era = CE;
1317        fields->year = year;
1318    }
1319    fields->dayOfYear = day + 1;
1320}
1321
1322/*
1323 *----------------------------------------------------------------------
1324 *
1325 * GetMonthDay --
1326 *
1327 *      Given a date as year and day-of-year, find month and day.
1328 *
1329 * Results:
1330 *      None.
1331 *
1332 * Side effects:
1333 *      Stores 'month' and 'dayOfMonth' in the 'fields' structure.
1334 *
1335 *----------------------------------------------------------------------
1336 */
1337
1338static void
1339GetMonthDay(
1340    TclDateFields* fields)      /* Date to convert */
1341{
1342    int day = fields->dayOfYear;
1343    int month;
1344    const int* h = hath[IsGregorianLeapYear(fields)];
1345
1346    for (month = 0; month < 12 && day > h[month]; ++month) {
1347        day -= h[month];
1348    }
1349    fields->month = month+1;
1350    fields->dayOfMonth = day;
1351}
1352
1353/*
1354 *----------------------------------------------------------------------
1355 *
1356 * GetJulianDayFromEraYearWeekDay --
1357 *
1358 *      Given a TclDateFields structure containing era, ISO8601 year, ISO8601
1359 *      week, and day of week, computes the Julian Day Number.
1360 *
1361 * Results:
1362 *      None.
1363 *
1364 * Side effects:
1365 *      Stores 'julianDay' in the fields.
1366 *
1367 *----------------------------------------------------------------------
1368 */
1369
1370static void
1371GetJulianDayFromEraYearWeekDay(
1372    TclDateFields* fields,      /* Date to convert */
1373    int changeover)             /* Julian Day Number of the Gregorian
1374                                 * transition */
1375{
1376    int firstMonday;            /* Julian day number of week 1, day 1 in the
1377                                 * given year */
1378
1379    /*
1380     * Find January 4 in the ISO8601 year, which will always be in week 1.
1381     */
1382
1383    TclDateFields firstWeek;
1384    firstWeek.era = fields->era;
1385    firstWeek.year = fields->iso8601Year;
1386    firstWeek.month = 1;
1387    firstWeek.dayOfMonth = 4;
1388    GetJulianDayFromEraYearMonthDay(&firstWeek, changeover);
1389
1390    /*
1391     * Find Monday of week 1.
1392     */
1393
1394    firstMonday = WeekdayOnOrBefore(1, firstWeek.julianDay);
1395
1396    /*
1397     * Advance to the given week and day.
1398     */
1399
1400    fields->julianDay = firstMonday + 7 * (fields->iso8601Week - 1)
1401            + fields->dayOfWeek - 1;
1402}
1403
1404/*
1405 *----------------------------------------------------------------------
1406 *
1407 * GetJulianDayFromEraYearMonthDay --
1408 *
1409 *      Given era, year, month, and dayOfMonth (in TclDateFields), and the
1410 *      Gregorian transition date, computes the Julian Day Number.
1411 *
1412 * Results:
1413 *      None.
1414 *
1415 * Side effects:
1416 *      Stores day number in 'julianDay'
1417 *
1418 *----------------------------------------------------------------------
1419 */
1420
1421static void
1422GetJulianDayFromEraYearMonthDay(
1423    TclDateFields* fields,      /* Date to convert */
1424    int changeover)             /* Gregorian transition date as a Julian Day */
1425{
1426    int year;  int ym1;
1427    int month; int mm1;
1428    int q; int r;
1429    int ym1o4; int ym1o100; int ym1o400;
1430
1431    if (fields->era == BCE) {
1432        year = 1 - fields->year;
1433    } else {
1434        year = fields->year;
1435    }
1436
1437    /*
1438     * Reduce month modulo 12.
1439     */
1440
1441    month = fields->month;
1442    mm1 = month - 1;
1443    q = mm1 / 12;
1444    r = (mm1 % 12);
1445    if (r < 0) {
1446        r += 12;
1447        q -= 1;
1448    }
1449    year += q;
1450    month = r + 1;
1451    ym1 = year - 1;
1452
1453    /*
1454     * Adjust the year after reducing the month.
1455     */
1456
1457    fields->gregorian = 1;
1458    if (year < 1) {
1459        fields->era = BCE;
1460        fields->year = 1-year;
1461    } else {
1462        fields->era = CE;
1463        fields->year = year;
1464    }
1465
1466    /*
1467     * Try an initial conversion in the Gregorian calendar.
1468     */
1469
1470    ym1o4 = ym1 / 4;
1471    if (ym1 % 4 < 0) {
1472        --ym1o4;
1473    }
1474    ym1o100 = ym1 / 100;
1475    if (ym1 % 100 < 0) {
1476        --ym1o100;
1477    }
1478    ym1o400 = ym1 / 400;
1479    if (ym1 % 400 < 0) {
1480        --ym1o400;
1481    }
1482    fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1
1483            + fields->dayOfMonth
1484            + daysInPriorMonths[IsGregorianLeapYear(fields)][month - 1]
1485            + (ONE_YEAR * ym1)
1486            + ym1o4
1487            - ym1o100
1488            + ym1o400;
1489
1490    /*
1491     * If the resulting date is before the Gregorian changeover, convert in
1492     * the Julian calendar instead.
1493     */
1494
1495    if (fields->julianDay < changeover) {
1496        fields->gregorian = 0;
1497        fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1
1498                + fields->dayOfMonth
1499                + daysInPriorMonths[year%4 == 0][month - 1]
1500                + (365 * ym1)
1501                + ym1o4;
1502    }
1503}
1504
1505/*
1506 *----------------------------------------------------------------------
1507 *
1508 * IsGregorianLeapYear --
1509 *
1510 *      Tests whether a given year is a leap year, in either Julian or
1511 *      Gregorian calendar.
1512 *
1513 * Results:
1514 *      Returns 1 for a leap year, 0 otherwise.
1515 *
1516 *----------------------------------------------------------------------
1517 */
1518
1519static int
1520IsGregorianLeapYear(
1521    TclDateFields* fields)      /* Date to test */
1522{
1523    int year;
1524
1525    if (fields->era == BCE) {
1526        year = 1 - fields->year;
1527    } else {
1528        year = fields->year;
1529    }
1530    if (year%4 != 0) {
1531        return 0;
1532    } else if (!(fields->gregorian)) {
1533        return 1;
1534    } else if (year%400 == 0) {
1535        return 1;
1536    } else if (year%100 == 0) {
1537        return 0;
1538    } else {
1539        return 1;
1540    }
1541}
1542
1543/*
1544 *----------------------------------------------------------------------
1545 *
1546 * WeekdayOnOrBefore --
1547 *
1548 *      Finds the Julian Day Number of a given day of the week that falls on
1549 *      or before a given date, expressed as Julian Day Number.
1550 *
1551 * Results:
1552 *      Returns the Julian Day Number
1553 *
1554 *----------------------------------------------------------------------
1555 */
1556
1557static int
1558WeekdayOnOrBefore(
1559    int dayOfWeek,              /* Day of week; Sunday == 0 or 7 */
1560    int julianDay)              /* Reference date */
1561{
1562    int k = (dayOfWeek + 6) % 7;
1563    if (k < 0) {
1564        k += 7;
1565    }
1566    return julianDay - ((julianDay - k) % 7);
1567}
1568
1569/*
1570 *----------------------------------------------------------------------
1571 *
1572 * ClockGetenvObjCmd --
1573 *
1574 *      Tcl command that reads an environment variable from the system
1575 *
1576 * Usage:
1577 *      ::tcl::clock::getEnv NAME
1578 *
1579 * Parameters:
1580 *      NAME - Name of the environment variable desired
1581 *
1582 * Results:
1583 *      Returns a standard Tcl result. Returns an error if the variable does
1584 *      not exist, with a message left in the interpreter. Returns TCL_OK and
1585 *      the value of the variable if the variable does exist,
1586 *
1587 *----------------------------------------------------------------------
1588 */
1589
1590int
1591ClockGetenvObjCmd(
1592    ClientData clientData,
1593    Tcl_Interp* interp,
1594    int objc,
1595    Tcl_Obj *const objv[])
1596{
1597    const char* varName;
1598    const char* varValue;
1599
1600    if (objc != 2) {
1601        Tcl_WrongNumArgs(interp, 1, objv, "name");
1602        return TCL_ERROR;
1603    }
1604    varName = TclGetString(objv[1]);
1605    varValue = getenv(varName);
1606    if (varValue == NULL) {
1607        varValue = "";
1608    }
1609    Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
1610    return TCL_OK;
1611}
1612
1613/*
1614 *----------------------------------------------------------------------
1615 *
1616 * ThreadSafeLocalTime --
1617 *
1618 *      Wrapper around the 'localtime' library function to make it thread
1619 *      safe.
1620 *
1621 * Results:
1622 *      Returns a pointer to a 'struct tm' in thread-specific data.
1623 *
1624 * Side effects:
1625 *      Invokes localtime or localtime_r as appropriate.
1626 *
1627 *----------------------------------------------------------------------
1628 */
1629
1630static struct tm *
1631ThreadSafeLocalTime(
1632    const time_t *timePtr)      /* Pointer to the number of seconds since the
1633                                 * local system's epoch */
1634{
1635    /*
1636     * Get a thread-local buffer to hold the returned time.
1637     */
1638
1639    struct tm *tmPtr = (struct tm *)
1640            Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
1641#ifdef HAVE_LOCALTIME_R
1642    localtime_r(timePtr, tmPtr);
1643#else
1644    struct tm *sysTmPtr;
1645
1646    Tcl_MutexLock(&clockMutex);
1647    sysTmPtr = localtime(timePtr);
1648    if (sysTmPtr == NULL) {
1649        Tcl_MutexUnlock(&clockMutex);
1650        return NULL;
1651    } else {
1652        memcpy((void *) tmPtr, (void *) localtime(timePtr), sizeof(struct tm));
1653        Tcl_MutexUnlock(&clockMutex);
1654    }
1655#endif
1656    return tmPtr;
1657}
1658
1659/*----------------------------------------------------------------------
1660 *
1661 * ClockClicksObjCmd --
1662 *
1663 *      Returns a high-resolution counter.
1664 *
1665 * Results:
1666 *      Returns a standard Tcl result.
1667 *
1668 * Side effects:
1669 *      None.
1670 *
1671 * This function implements the 'clock clicks' Tcl command. Refer to the user
1672 * documentation for details on what it does.
1673 *
1674 *----------------------------------------------------------------------
1675 */
1676
1677int
1678ClockClicksObjCmd(
1679    ClientData clientData,      /* Client data is unused */
1680    Tcl_Interp* interp,         /* Tcl interpreter */
1681    int objc,                   /* Parameter count */
1682    Tcl_Obj* const* objv)       /* Parameter values */
1683{
1684    static const char *clicksSwitches[] = {
1685        "-milliseconds", "-microseconds", NULL
1686    };
1687    enum ClicksSwitch {
1688        CLICKS_MILLIS,   CLICKS_MICROS,   CLICKS_NATIVE
1689    };
1690    int index = CLICKS_NATIVE;
1691    Tcl_Time now;
1692
1693    switch (objc) {
1694    case 1:
1695        break;
1696    case 2:
1697        if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
1698                &index) != TCL_OK) {
1699            return TCL_ERROR;
1700        }
1701        break;
1702    default:
1703        Tcl_WrongNumArgs(interp, 1, objv, "?option?");
1704        return TCL_ERROR;
1705    }
1706
1707    switch (index) {
1708    case CLICKS_MILLIS:
1709        Tcl_GetTime(&now);
1710        Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
1711                now.sec * 1000 + now.usec / 1000));
1712        break;
1713    case CLICKS_NATIVE: {
1714#ifndef TCL_WIDE_CLICKS
1715        unsigned long clicks = TclpGetClicks();
1716#else
1717        Tcl_WideInt clicks = TclpGetWideClicks();
1718#endif
1719        Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) clicks));
1720        break;
1721    }
1722    case CLICKS_MICROS:
1723        Tcl_GetTime(&now);
1724        Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
1725                ((Tcl_WideInt) now.sec * 1000000) + now.usec));
1726        break;
1727    }
1728
1729    return TCL_OK;
1730}
1731
1732/*----------------------------------------------------------------------
1733 *
1734 * ClockMillisecondsObjCmd -
1735 *
1736 *      Returns a count of milliseconds since the epoch.
1737 *
1738 * Results:
1739 *      Returns a standard Tcl result.
1740 *
1741 * Side effects:
1742 *      None.
1743 *
1744 * This function implements the 'clock milliseconds' Tcl command. Refer to the
1745 * user documentation for details on what it does.
1746 *
1747 *----------------------------------------------------------------------
1748 */
1749
1750int
1751ClockMillisecondsObjCmd(
1752    ClientData clientData,      /* Client data is unused */
1753    Tcl_Interp* interp,         /* Tcl interpreter */
1754    int objc,                   /* Parameter count */
1755    Tcl_Obj* const* objv)       /* Parameter values */
1756{
1757    Tcl_Time now;
1758
1759    if (objc != 1) {
1760        Tcl_WrongNumArgs(interp, 1, objv, NULL);
1761        return TCL_ERROR;
1762    }
1763    Tcl_GetTime(&now);
1764    Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt)
1765            now.sec * 1000 + now.usec / 1000));
1766    return TCL_OK;
1767}
1768
1769/*----------------------------------------------------------------------
1770 *
1771 * ClockMicrosecondsObjCmd -
1772 *
1773 *      Returns a count of microseconds since the epoch.
1774 *
1775 * Results:
1776 *      Returns a standard Tcl result.
1777 *
1778 * Side effects:
1779 *      None.
1780 *
1781 * This function implements the 'clock microseconds' Tcl command. Refer to the
1782 * user documentation for details on what it does.
1783 *
1784 *----------------------------------------------------------------------
1785 */
1786
1787int
1788ClockMicrosecondsObjCmd(
1789    ClientData clientData,      /* Client data is unused */
1790    Tcl_Interp* interp,         /* Tcl interpreter */
1791    int objc,                   /* Parameter count */
1792    Tcl_Obj* const* objv)       /* Parameter values */
1793{
1794    Tcl_Time now;
1795
1796    if (objc != 1) {
1797        Tcl_WrongNumArgs(interp, 1, objv, NULL);
1798        return TCL_ERROR;
1799    }
1800    Tcl_GetTime(&now);
1801    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
1802            ((Tcl_WideInt) now.sec * 1000000) + now.usec));
1803    return TCL_OK;
1804}
1805
1806/*
1807 *-----------------------------------------------------------------------------
1808 *
1809 * ClockParseformatargsObjCmd --
1810 *
1811 *      Parses the arguments for [clock format].
1812 *
1813 * Results:
1814 *      Returns a standard Tcl result, whose value is a four-element
1815 *      list comprising the time format, the locale, and the timezone.
1816 *
1817 * This function exists because the loop that parses the [clock format]
1818 * options is a known performance "hot spot", and is implemented in an
1819 * effort to speed that particular code up.
1820 *
1821 *-----------------------------------------------------------------------------
1822 */
1823
1824static int
1825ClockParseformatargsObjCmd(
1826    ClientData clientData,      /* Client data containing literal pool */
1827    Tcl_Interp* interp,         /* Tcl interpreter */
1828    int objc,                   /* Parameter count */
1829    Tcl_Obj *const objv[]       /* Parameter vector */
1830) {
1831
1832    ClockClientData* dataPtr = (ClockClientData*) clientData;
1833    Tcl_Obj** litPtr = dataPtr->literals;
1834
1835    /* Format, locale and timezone */
1836
1837    Tcl_Obj* results[3];
1838#define formatObj results[0]
1839#define localeObj results[1]
1840#define timezoneObj results[2]
1841    int gmtFlag = 0;
1842
1843    /* Command line options expected */
1844
1845    static const char* options[] = {
1846        "-format",              "-gmt",                 "-locale",
1847        "-timezone",            NULL };
1848    enum optionInd {
1849        CLOCK_FORMAT_FORMAT,    CLOCK_FORMAT_GMT,       CLOCK_FORMAT_LOCALE,
1850        CLOCK_FORMAT_TIMEZONE
1851    };
1852    int optionIndex;            /* Index of an option */
1853    int saw = 0;                /* Flag == 1 if option was seen already */
1854    Tcl_WideInt clockVal;       /* Clock value - just used to parse */
1855    int i;
1856
1857    /* Args consist of a time followed by keyword-value pairs */
1858
1859    if (objc < 2 || (objc % 2) != 0) {
1860        Tcl_WrongNumArgs(interp, 0, objv,
1861                         "clock format clockval ?-format string? "
1862                         "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
1863        Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL);
1864        return TCL_ERROR;
1865    }
1866
1867    /* Extract values for the keywords */
1868
1869    formatObj = litPtr[LIT__DEFAULT_FORMAT];
1870    localeObj = litPtr[LIT_C];
1871    timezoneObj = litPtr[LIT__NIL];
1872    for (i = 2; i < objc; i+=2) {
1873        if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0,
1874                                &optionIndex) != TCL_OK) {
1875            Tcl_SetErrorCode(interp, "CLOCK", "badSwitch",
1876                             Tcl_GetString(objv[i]), NULL);
1877            return TCL_ERROR;
1878        }
1879        switch (optionIndex) {
1880        case CLOCK_FORMAT_FORMAT:
1881            formatObj = objv[i+1];
1882            break;
1883        case CLOCK_FORMAT_GMT:
1884            if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK) {
1885                return TCL_ERROR;
1886            }
1887            break;
1888        case CLOCK_FORMAT_LOCALE:
1889            localeObj = objv[i+1];
1890            break;
1891        case CLOCK_FORMAT_TIMEZONE:
1892            timezoneObj = objv[i+1];
1893            break;
1894        }
1895        saw |= (1 << optionIndex);
1896    }
1897
1898    /* Check options */
1899
1900    if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
1901        return TCL_ERROR;
1902    }
1903    if ((saw & (1 << CLOCK_FORMAT_GMT))
1904        && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
1905        Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]);
1906        Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL);
1907        return TCL_ERROR;
1908    }
1909    if (gmtFlag) {
1910        timezoneObj = litPtr[LIT_GMT];
1911    }
1912
1913    /* Return options as a list */
1914
1915    Tcl_SetObjResult(interp, Tcl_NewListObj(3, results));
1916    return TCL_OK;
1917
1918#undef timezoneObj
1919#undef localeObj
1920#undef formatObj
1921
1922}
1923
1924/*----------------------------------------------------------------------
1925 *
1926 * ClockSecondsObjCmd -
1927 *
1928 *      Returns a count of microseconds since the epoch.
1929 *
1930 * Results:
1931 *      Returns a standard Tcl result.
1932 *
1933 * Side effects:
1934 *      None.
1935 *
1936 * This function implements the 'clock seconds' Tcl command. Refer to the user
1937 * documentation for details on what it does.
1938 *
1939 *----------------------------------------------------------------------
1940 */
1941
1942int
1943ClockSecondsObjCmd(
1944    ClientData clientData,      /* Client data is unused */
1945    Tcl_Interp* interp,         /* Tcl interpreter */
1946    int objc,                   /* Parameter count */
1947    Tcl_Obj* const* objv)       /* Parameter values */
1948{
1949    Tcl_Time now;
1950
1951    if (objc != 1) {
1952        Tcl_WrongNumArgs(interp, 1, objv, NULL);
1953        return TCL_ERROR;
1954    }
1955    Tcl_GetTime(&now);
1956    Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
1957    return TCL_OK;
1958}
1959
1960/*
1961 *----------------------------------------------------------------------
1962 *
1963 * TzsetIfNecessary --
1964 *
1965 *      Calls the tzset() library function if the contents of the TZ
1966 *      environment variable has changed.
1967 *
1968 * Results:
1969 *      None.
1970 *
1971 * Side effects:
1972 *      Calls tzset.
1973 *
1974 *----------------------------------------------------------------------
1975 */
1976
1977static void
1978TzsetIfNecessary(void)
1979{
1980    static char* tzWas = NULL;  /* Previous value of TZ, protected by
1981                                 * clockMutex. */
1982    const char* tzIsNow;        /* Current value of TZ */
1983
1984    Tcl_MutexLock(&clockMutex);
1985    tzIsNow = getenv("TZ");
1986    if (tzIsNow != NULL && (tzWas == NULL || strcmp(tzIsNow, tzWas) != 0)) {
1987        tzset();
1988        if (tzWas != NULL) {
1989            ckfree(tzWas);
1990        }
1991        tzWas = ckalloc(strlen(tzIsNow) + 1);
1992        strcpy(tzWas, tzIsNow);
1993    } else if (tzIsNow == NULL && tzWas != NULL) {
1994        tzset();
1995        ckfree(tzWas);
1996        tzWas = NULL;
1997    }
1998    Tcl_MutexUnlock(&clockMutex);
1999}
2000
2001/*
2002 *----------------------------------------------------------------------
2003 *
2004 * ClockDeleteCmdProc --
2005 *
2006 *      Remove a reference to the clock client data, and clean up memory
2007 *      when it's all gone.
2008 *
2009 * Results:
2010 *      None.
2011 *
2012 *----------------------------------------------------------------------
2013 */
2014
2015static void
2016ClockDeleteCmdProc(
2017    ClientData clientData)      /* Opaque pointer to the client data */
2018{
2019    ClockClientData *data = (ClockClientData*) clientData;
2020    int i;
2021
2022    --(data->refCount);
2023    if (data->refCount == 0) {
2024        for (i = 0; i < LIT__END; ++i) {
2025            Tcl_DecrRefCount(data->literals[i]);
2026        }
2027        ckfree((char*) (data->literals));
2028        ckfree((char*) data);
2029    }
2030}
2031
2032/*
2033 * Local Variables:
2034 * mode: c
2035 * c-basic-offset: 4
2036 * fill-column: 78
2037 * End:
2038 */
Note: See TracBrowser for help on using the repository browser.