Planet

navi

home

PPS

about

screenshots

download

development

forum

Context Navigation

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

Last change on this file since 25 was 25, checked in by landauf, 16 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
47	static 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	};
51	static 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
60	typedef 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;
76	static 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
96	typedef 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
105	typedef 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;
124	static 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
131	static Tcl_ThreadDataKey tmKey;
132
133	/*
134	* Mutex protecting 'gmtime', 'localtime' and 'mktime' calls and the statics
135	* in the date parsing code.
136	*/
137
138	TCL_DECLARE_MUTEX(clockMutex)
139
140	/*
141	* Function prototypes for local procedures in this file:
142	*/
143
144	static int ConvertUTCToLocal(Tcl_Interp*,
145	TclDateFields, Tcl_Obj, int);
146	static int ConvertUTCToLocalUsingTable(Tcl_Interp*,
147	TclDateFields, int, Tcl_Obj const[]);
148	static int ConvertUTCToLocalUsingC(Tcl_Interp*,
149	TclDateFields*, int);
150	static int ConvertLocalToUTC(Tcl_Interp*,
151	TclDateFields, Tcl_Obj, int);
152	static int ConvertLocalToUTCUsingTable(Tcl_Interp*,
153	TclDateFields, int, Tcl_Obj const[]);
154	static int ConvertLocalToUTCUsingC(Tcl_Interp*,
155	TclDateFields*, int);
156	static Tcl_Obj* LookupLastTransition(Tcl_Interp*, Tcl_WideInt,
157	int, Tcl_Obj const );
158	static void GetYearWeekDay(TclDateFields*, int);
159	static void GetGregorianEraYearDay(TclDateFields*, int);
160	static void GetMonthDay(TclDateFields*);
161	static void GetJulianDayFromEraYearWeekDay(TclDateFields*, int);
162	static void GetJulianDayFromEraYearMonthDay(TclDateFields*, int);
163	static int IsGregorianLeapYear(TclDateFields*);
164	static int WeekdayOnOrBefore(int, int);
165	static int ClockClicksObjCmd(
166	ClientData clientData, Tcl_Interp *interp,
167	int objc, Tcl_Obj *const objv[]);
168	static int ClockConvertlocaltoutcObjCmd(
169	ClientData clientData, Tcl_Interp *interp,
170	int objc, Tcl_Obj *const objv[]);
171	static int ClockGetdatefieldsObjCmd(
172	ClientData clientData, Tcl_Interp *interp,
173	int objc, Tcl_Obj *const objv[]);
174	static int ClockGetjuliandayfromerayearmonthdayObjCmd(
175	ClientData clientData, Tcl_Interp *interp,
176	int objc, Tcl_Obj *const objv[]);
177	static int ClockGetjuliandayfromerayearweekdayObjCmd(
178	ClientData clientData, Tcl_Interp *interp,
179	int objc, Tcl_Obj *const objv[]);
180	static int ClockGetenvObjCmd(
181	ClientData clientData, Tcl_Interp *interp,
182	int objc, Tcl_Obj *const objv[]);
183	static int ClockMicrosecondsObjCmd(
184	ClientData clientData, Tcl_Interp *interp,
185	int objc, Tcl_Obj *const objv[]);
186	static int ClockMillisecondsObjCmd(
187	ClientData clientData, Tcl_Interp *interp,
188	int objc, Tcl_Obj *const objv[]);
189	static int ClockParseformatargsObjCmd(
190	ClientData clientData, Tcl_Interp* interp,
191	int objc, Tcl_Obj *const objv[]);
192	static int ClockSecondsObjCmd(
193	ClientData clientData, Tcl_Interp *interp,
194	int objc, Tcl_Obj *const objv[]);
195	static struct tm * ThreadSafeLocalTime(const time_t *);
196	static void TzsetIfNecessary(void);
197	static void ClockDeleteCmdProc(ClientData);
198
199	/*
200	* Structure containing description of "native" clock commands to create.
201	*/
202
203	struct 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
212	static 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
247	void
248	TclClockInit(
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
311	static int
312	ClockConvertlocaltoutcObjCmd(
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
396	int
397	ClockGetdatefieldsObjCmd(
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
510	static int
511	ClockGetjuliandayfromerayearmonthdayObjCmd (
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
601	static int
602	ClockGetjuliandayfromerayearweekdayObjCmd (
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
691	static int
692	ConvertLocalToUTC(
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
739	static int
740	ConvertLocalToUTCUsingTable(
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
815	static int
816	ConvertLocalToUTCUsingC(
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
895	static int
896	ConvertUTCToLocal(
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
943	static int
944	ConvertUTCToLocalUsingTable(
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
995	static int
996	ConvertUTCToLocalUsingC(
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
1083	static Tcl_Obj*
1084	LookupLastTransition(
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
1153	static void
1154	GetYearWeekDay(
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
1220	static void
1221	GetGregorianEraYearDay(
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
1338	static void
1339	GetMonthDay(
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
1370	static void
1371	GetJulianDayFromEraYearWeekDay(
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
1421	static void
1422	GetJulianDayFromEraYearMonthDay(
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
1519	static int
1520	IsGregorianLeapYear(
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
1557	static int
1558	WeekdayOnOrBefore(
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
1590	int
1591	ClockGetenvObjCmd(
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
1630	static struct tm *
1631	ThreadSafeLocalTime(
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
1677	int
1678	ClockClicksObjCmd(
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
1750	int
1751	ClockMillisecondsObjCmd(
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
1787	int
1788	ClockMicrosecondsObjCmd(
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
1824	static int
1825	ClockParseformatargsObjCmd(
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
1942	int
1943	ClockSecondsObjCmd(
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
1977	static void
1978	TzsetIfNecessary(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
2015	static void
2016	ClockDeleteCmdProc(
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.

Download in other formats: