Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

clock.tcl @ 5114

Last change on this file since 5114 was 5049, checked in by landauf, 17 years ago
added tcl files
File size: 125.9 KB

Line
1	#----------------------------------------------------------------------
2	#
3	# clock.tcl --
4	#
5	# This file implements the portions of the [clock] ensemble that
6	# are coded in Tcl. Refer to the users' manual to see the description
7	# of the [clock] command and its subcommands.
8	#
9	#
10	#----------------------------------------------------------------------
11	#
12	# Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
13	# See the file "license.terms" for information on usage and redistribution
14	# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15	#
16	# RCS: @(#) $Id: clock.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
17	#
18	#----------------------------------------------------------------------
19
20	# We must have message catalogs that support the root locale, and
21	# we need access to the Registry on Windows systems.
22
23	uplevel \#0 {
24	package require msgcat 1.4
25	if { $::tcl_platform(platform) eq {windows} } {
26	if { [catch { package require registry 1.1 }] } {
27	namespace eval ::tcl::clock [list variable NoRegistry {}]
28	}
29	}
30	}
31
32	# Put the library directory into the namespace for the ensemble
33	# so that the library code can find message catalogs and time zone
34	# definition files.
35
36	namespace eval ::tcl::clock \
37	[list variable LibDir [file dirname [info script]]]
38
39	#----------------------------------------------------------------------
40	#
41	# clock --
42	#
43	# Manipulate times.
44	#
45	# The 'clock' command manipulates time. Refer to the user documentation
46	# for the available subcommands and what they do.
47	#
48	#----------------------------------------------------------------------
49
50	namespace eval ::tcl::clock {
51
52	# Export the subcommands
53
54	namespace export format
55	namespace export clicks
56	namespace export microseconds
57	namespace export milliseconds
58	namespace export scan
59	namespace export seconds
60	namespace export add
61
62	# Import the message catalog commands that we use.
63
64	namespace import ::msgcat::mcload
65	namespace import ::msgcat::mclocale
66
67	}
68
69	#----------------------------------------------------------------------
70	#
71	# ::tcl::clock::Initialize --
72	#
73	# Finish initializing the 'clock' subsystem
74	#
75	# Results:
76	# None.
77	#
78	# Side effects:
79	# Namespace variable in the 'clock' subsystem are initialized.
80	#
81	# The '::tcl::clock::Initialize' procedure initializes the namespace
82	# variables and root locale message catalog for the 'clock' subsystem.
83	# It is broken into a procedure rather than simply evaluated as a script
84	# so that it will be able to use local variables, avoiding the dangers
85	# of 'creative writing' as in Bug 1185933.
86	#
87	#----------------------------------------------------------------------
88
89	proc ::tcl::clock::Initialize {} {
90
91	rename ::tcl::clock::Initialize {}
92
93	variable LibDir
94
95	# Define the Greenwich time zone
96
97	proc InitTZData {} {
98	variable TZData
99	array unset TZData
100	set TZData(:Etc/GMT) {
101	{-9223372036854775808 0 0 GMT}
102	}
103	set TZData(:GMT) $TZData(:Etc/GMT)
104	set TZData(:Etc/UTC) {
105	{-9223372036854775808 0 0 UTC}
106	}
107	set TZData(:UTC) $TZData(:Etc/UTC)
108	set TZData(:localtime) {}
109	}
110	InitTZData
111
112	# Define the message catalog for the root locale.
113
114	::msgcat::mcmset {} {
115	AM {am}
116	BCE {B.C.E.}
117	CE {C.E.}
118	DATE_FORMAT {%m/%d/%Y}
119	DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
120	DAYS_OF_WEEK_ABBREV {
121	Sun Mon Tue Wed Thu Fri Sat
122	}
123	DAYS_OF_WEEK_FULL {
124	Sunday Monday Tuesday Wednesday Thursday Friday Saturday
125	}
126	GREGORIAN_CHANGE_DATE 2299161
127	LOCALE_DATE_FORMAT {%m/%d/%Y}
128	LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
129	LOCALE_ERAS {}
130	LOCALE_NUMERALS {
131	00 01 02 03 04 05 06 07 08 09
132	10 11 12 13 14 15 16 17 18 19
133	20 21 22 23 24 25 26 27 28 29
134	30 31 32 33 34 35 36 37 38 39
135	40 41 42 43 44 45 46 47 48 49
136	50 51 52 53 54 55 56 57 58 59
137	60 61 62 63 64 65 66 67 68 69
138	70 71 72 73 74 75 76 77 78 79
139	80 81 82 83 84 85 86 87 88 89
140	90 91 92 93 94 95 96 97 98 99
141	}
142	LOCALE_TIME_FORMAT {%H:%M:%S}
143	LOCALE_YEAR_FORMAT {%EC%Ey}
144	MONTHS_ABBREV {
145	Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
146	}
147	MONTHS_FULL {
148	January February March
149	April May June
150	July August September
151	October November December
152	}
153	PM {pm}
154	TIME_FORMAT {%H:%M:%S}
155	TIME_FORMAT_12 {%I:%M:%S %P}
156	TIME_FORMAT_24 {%H:%M}
157	TIME_FORMAT_24_SECS {%H:%M:%S}
158	}
159
160	# Define a few Gregorian change dates for other locales. In most cases
161	# the change date follows a language, because a nation's colonies changed
162	# at the same time as the nation itself. In many cases, different
163	# national boundaries existed; the dominating rule is to follow the
164	# nation's capital.
165
166	# Italy, Spain, Portugal, Poland
167
168	::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
169	::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
170	::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
171	::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
172
173	# France, Austria
174
175	::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
176
177	# For Belgium, we follow Southern Netherlands; Liege Diocese
178	# changed several weeks later.
179
180	::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
181	::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
182
183	# Austria
184
185	::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
186
187	# Hungary
188
189	::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
190
191	# Germany, Norway, Denmark (Catholic Germany changed earlier)
192
193	::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
194	::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032
195	::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
196	::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
197	::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
198
199	# Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed
200	# at various times)
201
202	::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
203
204	# Protestant Switzerland (Catholic cantons changed earlier)
205
206	::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
207	::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
208	::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
209
210	# English speaking countries
211
212	::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
213
214	# Sweden (had several changes onto and off of the Gregorian calendar)
215
216	::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
217
218	# Russia
219
220	::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
221
222	# Romania (Transylvania changed earler - perhaps de_RO should show
223	# the earlier date?)
224
225	::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
226
227	# Greece
228
229	::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
230
231	#------------------------------------------------------------------
232	#
233	# CONSTANTS
234	#
235	#------------------------------------------------------------------
236
237	# Paths at which binary time zone data for the Olson libraries
238	# are known to reside on various operating systems
239
240	variable ZoneinfoPaths {}
241	foreach path {
242	/usr/share/zoneinfo
243	/usr/share/lib/zoneinfo
244	/usr/lib/zoneinfo
245	/usr/local/etc/zoneinfo
246	} {
247	if { [file isdirectory $path] } {
248	lappend ZoneinfoPaths $path
249	}
250	}
251
252	# Define the directories for time zone data and message catalogs.
253
254	variable DataDir [file join $LibDir tzdata]
255	variable MsgDir [file join $LibDir msgs]
256
257	# Number of days in the months, in common years and leap years.
258
259	variable DaysInRomanMonthInCommonYear \
260	{ 31 28 31 30 31 30 31 31 30 31 30 31 }
261	variable DaysInRomanMonthInLeapYear \
262	{ 31 29 31 30 31 30 31 31 30 31 30 31 }
263	variable DaysInPriorMonthsInCommonYear [list 0]
264	variable DaysInPriorMonthsInLeapYear [list 0]
265	set i 0
266	foreach j $DaysInRomanMonthInCommonYear {
267	lappend DaysInPriorMonthsInCommonYear [incr i $j]
268	}
269	set i 0
270	foreach j $DaysInRomanMonthInLeapYear {
271	lappend DaysInPriorMonthsInLeapYear [incr i $j]
272	}
273
274	# Another epoch (Hi, Jeff!)
275
276	variable Roddenberry 1946
277
278	# Integer ranges
279
280	variable MINWIDE -9223372036854775808
281	variable MAXWIDE 9223372036854775807
282
283	# Day before Leap Day
284
285	variable FEB_28 58
286
287	# Translation table to map Windows TZI onto cities, so that
288	# the Olson rules can apply. In some cases the mapping is ambiguous,
289	# so it's wise to specify $::env(TCL_TZ) rather than simply depending
290	# on the system time zone.
291
292	# The keys are long lists of values obtained from the time zone
293	# information in the Registry. In order, the list elements are:
294	# Bias StandardBias DaylightBias
295	# StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
296	# StandardDate.wDay StandardDate.wHour StandardDate.wMinute
297	# StandardDate.wSecond StandardDate.wMilliseconds
298	# DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
299	# DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
300	# DaylightDate.wSecond DaylightDate.wMilliseconds
301	# The values are the names of time zones where those rules apply.
302	# There is considerable ambiguity in certain zones; an attempt has
303	# been made to make a reasonable guess, but this table needs to be
304	# taken with a grain of salt.
305
306	variable WinZoneInfo [dict create {*}{
307	{-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
308	{-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
309	{-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
310	{-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
311	{-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
312	{-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
313	{-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
314	{-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
315	{-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
316	{-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
317	{-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
318	{-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
319	{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
320	{-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
321	{-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
322	{-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
323	:America/Santiago
324	{-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
325	{-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
326	{-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
327	{-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
328	{-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
329	{-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
330	{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia
331	{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
332	{-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
333	{-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
334	{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
335	{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
336	{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
337	{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
338	{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
339	{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
340	{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
341	:Africa/Cairo
342	{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
343	{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
344	{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
345	{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
346	{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
347	{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
348	:Asia/Beirut
349	{7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
350	{10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
351	{10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
352	{10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
353	{12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
354	{14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
355	{14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
356	{14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
357	{16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
358	{18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi
359	{18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg
360	{19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta
361	{20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu
362	{21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka
363	{21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk
364	{23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon
365	{25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok
366	{25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk
367	{28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing
368	{28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk
369	{32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo
370	{32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk
371	{34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide
372	{34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin
373	{36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane
374	{36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok
375	{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart
376	{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
377	{39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
378	{43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
379	{43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
380	{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
381	}]
382
383	# Groups of fields that specify the date, priorities, and
384	# code bursts that determine Julian Day Number given those groups.
385	# The code in [clock scan] will choose the highest priority
386	# (lowest numbered) set of fields that determines the date.
387
388	variable DateParseActions {
389
390	{ seconds } 0 {}
391
392	{ julianDay } 1 {}
393
394	{ era century yearOfCentury month dayOfMonth } 2 {
395	dict set date year [expr { 100 * [dict get $date century]
396	+ [dict get $date yearOfCentury] }]
397	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
398	$changeover]
399	}
400	{ era century yearOfCentury dayOfYear } 2 {
401	dict set date year [expr { 100 * [dict get $date century]
402	+ [dict get $date yearOfCentury] }]
403	set date [GetJulianDayFromEraYearDay $date[set date {}] \
404	$changeover]
405	}
406
407	{ century yearOfCentury month dayOfMonth } 3 {
408	dict set date era CE
409	dict set date year [expr { 100 * [dict get $date century]
410	+ [dict get $date yearOfCentury] }]
411	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
412	$changeover]
413	}
414	{ century yearOfCentury dayOfYear } 3 {
415	dict set date era CE
416	dict set date year [expr { 100 * [dict get $date century]
417	+ [dict get $date yearOfCentury] }]
418	set date [GetJulianDayFromEraYearDay $date[set date {}] \
419	$changeover]
420	}
421	{ iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
422	dict set date era CE
423	dict set date iso8601Year \
424	[expr { 100 * [dict get $date iso8601Century]
425	+ [dict get $date iso8601YearOfCentury] }]
426	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
427	$changeover]
428	}
429
430	{ yearOfCentury month dayOfMonth } 4 {
431	set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
432	dict set date era CE
433	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
434	$changeover]
435	}
436	{ yearOfCentury dayOfYear } 4 {
437	set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
438	dict set date era CE
439	set date [GetJulianDayFromEraYearDay $date[set date {}] \
440	$changeover]
441	}
442	{ iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
443	set date [InterpretTwoDigitYear \
444	$date[set date {}] $baseTime \
445	iso8601YearOfCentury iso8601Year]
446	dict set date era CE
447	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
448	$changeover]
449	}
450
451	{ month dayOfMonth } 5 {
452	set date [AssignBaseYear $date[set date {}] \
453	$baseTime $timeZone $changeover]
454	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
455	$changeover]
456	}
457	{ dayOfYear } 5 {
458	set date [AssignBaseYear $date[set date {}] \
459	$baseTime $timeZone $changeover]
460	set date [GetJulianDayFromEraYearDay $date[set date {}] \
461	$changeover]
462	}
463	{ iso8601Week dayOfWeek } 5 {
464	set date [AssignBaseIso8601Year $date[set date {}] \
465	$baseTime $timeZone $changeover]
466	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
467	$changeover]
468	}
469
470	{ dayOfMonth } 6 {
471	set date [AssignBaseMonth $date[set date {}] \
472	$baseTime $timeZone $changeover]
473	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
474	$changeover]
475	}
476
477	{ dayOfWeek } 7 {
478	set date [AssignBaseWeek $date[set date {}] \
479	$baseTime $timeZone $changeover]
480	set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
481	$changeover]
482	}
483
484	{} 8 {
485	set date [AssignBaseJulianDay $date[set date {}] \
486	$baseTime $timeZone $changeover]
487	}
488	}
489
490	# Groups of fields that specify time of day, priorities,
491	# and code that processes them
492
493	variable TimeParseActions {
494
495	seconds 1 {}
496
497	{ hourAMPM minute second amPmIndicator } 2 {
498	dict set date secondOfDay [InterpretHMSP $date]
499	}
500	{ hour minute second } 2 {
501	dict set date secondOfDay [InterpretHMS $date]
502	}
503
504	{ hourAMPM minute amPmIndicator } 3 {
505	dict set date second 0
506	dict set date secondOfDay [InterpretHMSP $date]
507	}
508	{ hour minute } 3 {
509	dict set date second 0
510	dict set date secondOfDay [InterpretHMS $date]
511	}
512
513	{ hourAMPM amPmIndicator } 4 {
514	dict set date minute 0
515	dict set date second 0
516	dict set date secondOfDay [InterpretHMSP $date]
517	}
518	{ hour } 4 {
519	dict set date minute 0
520	dict set date second 0
521	dict set date secondOfDay [InterpretHMS $date]
522	}
523
524	{ } 5 {
525	dict set date secondOfDay 0
526	}
527	}
528
529	# Legacy time zones, used primarily for parsing RFC822 dates.
530
531	variable LegacyTimeZone [dict create \
532	gmt +0000 \
533	ut +0000 \
534	utc +0000 \
535	bst +0100 \
536	wet +0000 \
537	wat -0100 \
538	at -0200 \
539	nft -0330 \
540	nst -0330 \
541	ndt -0230 \
542	ast -0400 \
543	adt -0300 \
544	est -0500 \
545	edt -0400 \
546	cst -0600 \
547	cdt -0500 \
548	mst -0700 \
549	mdt -0600 \
550	pst -0800 \
551	pdt -0700 \
552	yst -0900 \
553	ydt -0800 \
554	hst -1000 \
555	hdt -0900 \
556	cat -1000 \
557	ahst -1000 \
558	nt -1100 \
559	idlw -1200 \
560	cet +0100 \
561	cest +0200 \
562	met +0100 \
563	mewt +0100 \
564	mest +0200 \
565	swt +0100 \
566	sst +0200 \
567	fwt +0100 \
568	fst +0200 \
569	eet +0200 \
570	eest +0300 \
571	bt +0300 \
572	it +0330 \
573	zp4 +0400 \
574	zp5 +0500 \
575	ist +0530 \
576	zp6 +0600 \
577	wast +0700 \
578	wadt +0800 \
579	jt +0730 \
580	cct +0800 \
581	jst +0900 \
582	kst +0900 \
583	cast +0930 \
584	jdt +1000 \
585	kdt +1000 \
586	cadt +1030 \
587	east +1000 \
588	eadt +1030 \
589	gst +1000 \
590	nzt +1200 \
591	nzst +1200 \
592	nzdt +1300 \
593	idle +1200 \
594	a +0100 \
595	b +0200 \
596	c +0300 \
597	d +0400 \
598	e +0500 \
599	f +0600 \
600	g +0700 \
601	h +0800 \
602	i +0900 \
603	k +1000 \
604	l +1100 \
605	m +1200 \
606	n -0100 \
607	o -0200 \
608	p -0300 \
609	q -0400 \
610	r -0500 \
611	s -0600 \
612	t -0700 \
613	u -0800 \
614	v -0900 \
615	w -1000 \
616	x -1100 \
617	y -1200 \
618	z +0000 \
619	]
620
621	# Caches
622
623	variable LocaleNumeralCache {}; # Dictionary whose keys are locale
624	# names and whose values are pairs
625	# comprising regexes matching numerals
626	# in the given locales and dictionaries
627	# mapping the numerals to their numeric
628	# values.
629	variable McLoaded {}; # Dictionary whose keys are locales
630	# in which [mcload] has been executed
631	# and whose values are second-level
632	# dictionaries indexed by message
633	# name and giving message text.
634	# variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
635	# it contains the value of the
636	# system time zone, as determined from
637	# the environment.
638	variable TimeZoneBad {}; # Dictionary whose keys are time zone
639	# names and whose values are 1 if
640	# the time zone is unknown and 0
641	# if it is known.
642	variable TZData; # Array whose keys are time zone names
643	# and whose values are lists of quads
644	# comprising start time, UTC offset,
645	# Daylight Saving Time indicator, and
646	# time zone abbreviation.
647	variable FormatProc; # Array mapping format group
648	# and locale to the name of a procedure
649	# that renders the given format
650	}
651	::tcl::clock::Initialize
652
653	#----------------------------------------------------------------------
654	#
655	# clock format --
656	#
657	# Formats a count of seconds since the Posix Epoch as a time
658	# of day.
659	#
660	# The 'clock format' command formats times of day for output.
661	# Refer to the user documentation to see what it does.
662	#
663	#----------------------------------------------------------------------
664
665	proc ::tcl::clock::format { args } {
666
667	variable FormatProc
668	variable TZData
669
670	lassign [ParseFormatArgs {*}$args] format locale timezone
671	set locale [string tolower $locale]
672	set clockval [lindex $args 0]
673
674	# Get the data for time changes in the given zone
675
676	if {$timezone eq ""} {
677	set timezone [GetSystemTimeZone]
678	}
679	if {![info exists TZData($timezone)]} {
680	if {[catch {SetupTimeZone $timezone} retval opts]} {
681	dict unset opts -errorinfo
682	return -options $opts $retval
683	}
684	}
685
686	# Build a procedure to format the result. Cache the built procedure's
687	# name in the 'FormatProc' array to avoid losing its internal
688	# representation, which contains the name resolution.
689
690	set procName ::tcl::clock::formatproc'$format'$locale
691	if {[info exists FormatProc($procName)]} {
692	set procName $FormatProc($procName)
693	} else {
694	set FormatProc($procName) \
695	[ParseClockFormatFormat $procName $format $locale]
696	}
697
698	return [$procName $clockval $timezone]
699
700	}
701
702	#----------------------------------------------------------------------
703	#
704	# ParseClockFormatFormat --
705	#
706	# Builds and caches a procedure that formats a time value.
707	#
708	# Parameters:
709	# format -- Format string to use
710	# locale -- Locale in which the format string is to be interpreted
711	#
712	# Results:
713	# Returns the name of the newly-built procedure.
714	#
715	#----------------------------------------------------------------------
716
717	proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {
718
719	if {[namespace which $procName] ne {}} {
720	return $procName
721	}
722
723	# Map away the locale-dependent composite format groups
724
725	EnterLocale $locale oldLocale
726
727	# Change locale if a fresh locale has been given on the command line.
728
729	set status [catch {
730
731	ParseClockFormatFormat2 $format $locale $procName
732
733	} result opts]
734
735	# Restore the locale
736
737	if { [info exists oldLocale] } {
738	mclocale $oldLocale
739	}
740
741	# Return either the error or the proc name
742
743	if { $status == 1 } {
744	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
745	return -code error $result
746	} else {
747	return -options $opts $result
748	}
749	} else {
750	return $result
751	}
752
753	}
754
755	proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
756
757	set didLocaleEra 0
758	set didLocaleNumerals 0
759	set preFormatCode \
760	[string map [list @GREGORIAN_CHANGE_DATE@ \
761	[mc GREGORIAN_CHANGE_DATE]] \
762	{
763	variable TZData
764	set date [GetDateFields $clockval \
765	$TZData($timezone) \
766	@GREGORIAN_CHANGE_DATE@]
767	}]
768	set formatString {}
769	set substituents {}
770	set state {}
771
772	set format [LocalizeFormat $locale $format]
773
774	foreach char [split $format {}] {
775	switch -exact -- $state {
776	{} {
777	if { [string equal % $char] } {
778	set state percent
779	} else {
780	append formatString $char
781	}
782	}
783	percent { # Character following a '%' character
784	set state {}
785	switch -exact -- $char {
786	% { # A literal character, '%'
787	append formatString %%
788	}
789	a { # Day of week, abbreviated
790	append formatString %s
791	append substituents \
792	[string map \
793	[list @DAYS_OF_WEEK_ABBREV@ \
794	[list [mc DAYS_OF_WEEK_ABBREV]]] \
795	{ [lindex @DAYS_OF_WEEK_ABBREV@ \
796	[expr {[dict get $date dayOfWeek] \
797	% 7}]]}]
798	}
799	A { # Day of week, spelt out.
800	append formatString %s
801	append substituents \
802	[string map \
803	[list @DAYS_OF_WEEK_FULL@ \
804	[list [mc DAYS_OF_WEEK_FULL]]] \
805	{ [lindex @DAYS_OF_WEEK_FULL@ \
806	[expr {[dict get $date dayOfWeek] \
807	% 7}]]}]
808	}
809	b - h { # Name of month, abbreviated.
810	append formatString %s
811	append substituents \
812	[string map \
813	[list @MONTHS_ABBREV@ \
814	[list [mc MONTHS_ABBREV]]] \
815	{ [lindex @MONTHS_ABBREV@ \
816	[expr {[dict get $date month]-1}]]}]
817	}
818	B { # Name of month, spelt out
819	append formatString %s
820	append substituents \
821	[string map \
822	[list @MONTHS_FULL@ \
823	[list [mc MONTHS_FULL]]] \
824	{ [lindex @MONTHS_FULL@ \
825	[expr {[dict get $date month]-1}]]}]
826	}
827	C { # Century number
828	append formatString %02d
829	append substituents \
830	{ [expr {[dict get $date year] / 100}]}
831	}
832	d { # Day of month, with leading zero
833	append formatString %02d
834	append substituents { [dict get $date dayOfMonth]}
835	}
836	e { # Day of month, without leading zero
837	append formatString %2d
838	append substituents { [dict get $date dayOfMonth]}
839	}
840	E { # Format group in a locale-dependent
841	# alternative era
842	set state percentE
843	if {!$didLocaleEra} {
844	append preFormatCode \
845	[string map \
846	[list @LOCALE_ERAS@ \
847	[list [mc LOCALE_ERAS]]] \
848	{
849	set date [GetLocaleEra \
850	$date[set date {}] \
851	@LOCALE_ERAS@]}] \n
852	set didLocaleEra 1
853	}
854	if {!$didLocaleNumerals} {
855	append preFormatCode \
856	[list set localeNumerals \
857	[mc LOCALE_NUMERALS]] \n
858	set didLocaleNumerals 1
859	}
860	}
861	g { # Two-digit year relative to ISO8601
862	# week number
863	append formatString %02d
864	append substituents \
865	{ [expr { [dict get $date iso8601Year] % 100 }]}
866	}
867	G { # Four-digit year relative to ISO8601
868	# week number
869	append formatString %02d
870	append substituents { [dict get $date iso8601Year]}
871	}
872	H { # Hour in the 24-hour day, leading zero
873	append formatString %02d
874	append substituents \
875	{ [expr { [dict get $date localSeconds] \
876	/ 3600 % 24}]}
877	}
878	I { # Hour AM/PM, with leading zero
879	append formatString %02d
880	append substituents \
881	{ [expr { ( ( ( [dict get $date localSeconds] \
882	% 86400 ) \
883	+ 86400 \
884	- 3600 ) \
885	/ 3600 ) \
886	% 12 + 1 }] }
887	}
888	j { # Day of year (001-366)
889	append formatString %03d
890	append substituents { [dict get $date dayOfYear]}
891	}
892	J { # Julian Day Number
893	append formatString %07ld
894	append substituents { [dict get $date julianDay]}
895	}
896	k { # Hour (0-23), no leading zero
897	append formatString %2d
898	append substituents \
899	{ [expr { [dict get $date localSeconds]
900	/ 3600
901	% 24 }]}
902	}
903	l { # Hour (12-11), no leading zero
904	append formatString %2d
905	append substituents \
906	{ [expr { ( ( ( [dict get $date localSeconds]
907	% 86400 )
908	+ 86400
909	- 3600 )
910	/ 3600 )
911	% 12 + 1 }]}
912	}
913	m { # Month number, leading zero
914	append formatString %02d
915	append substituents { [dict get $date month]}
916	}
917	M { # Minute of the hour, leading zero
918	append formatString %02d
919	append substituents \
920	{ [expr { [dict get $date localSeconds]
921	/ 60
922	% 60 }]}
923	}
924	n { # A literal newline
925	append formatString \n
926	}
927	N { # Month number, no leading zero
928	append formatString %2d
929	append substituents { [dict get $date month]}
930	}
931	O { # A format group in the locale's
932	# alternative numerals
933	set state percentO
934	if {!$didLocaleNumerals} {
935	append preFormatCode \
936	[list set localeNumerals \
937	[mc LOCALE_NUMERALS]] \n
938	set didLocaleNumerals 1
939	}
940	}
941	p { # Localized 'AM' or 'PM' indicator
942	# converted to uppercase
943	append formatString %s
944	append preFormatCode \
945	[list set AM [string toupper [mc AM]]] \n \
946	[list set PM [string toupper [mc PM]]] \n
947	append substituents \
948	{ [expr {(([dict get $date localSeconds]
949	% 86400) < 43200) ?
950	$AM : $PM}]}
951	}
952	P { # Localized 'AM' or 'PM' indicator
953	append formatString %s
954	append preFormatCode \
955	[list set am [mc AM]] \n \
956	[list set pm [mc PM]] \n
957	append substituents \
958	{ [expr {(([dict get $date localSeconds]
959	% 86400) < 43200) ?
960	$am : $pm}]}
961
962	}
963	Q { # Hi, Jeff!
964	append formatString %s
965	append substituents { [FormatStarDate $date]}
966	}
967	s { # Seconds from the Posix Epoch
968	append formatString %s
969	append substituents { [dict get $date seconds]}
970	}
971	S { # Second of the minute, with
972	# leading zero
973	append formatString %02d
974	append substituents \
975	{ [expr { [dict get $date localSeconds]
976	% 60 }]}
977	}
978	t { # A literal tab character
979	append formatString \t
980	}
981	u { # Day of the week (1-Monday, 7-Sunday)
982	append formatString %1d
983	append substituents { [dict get $date dayOfWeek]}
984	}
985	U { # Week of the year (00-53). The
986	# first Sunday of the year is the
987	# first day of week 01
988	append formatString %02d
989	append preFormatCode {
990	set dow [dict get $date dayOfWeek]
991	if { $dow == 7 } {
992	set dow 0
993	}
994	incr dow
995	set UweekNumber \
996	[expr { ( [dict get $date dayOfYear]
997	- $dow + 7 )
998	/ 7 }]
999	}
1000	append substituents { $UweekNumber}
1001	}
1002	V { # The ISO8601 week number
1003	append formatString %02d
1004	append substituents { [dict get $date iso8601Week]}
1005	}
1006	w { # Day of the week (0-Sunday,
1007	# 6-Saturday)
1008	append formatString %1d
1009	append substituents \
1010	{ [expr { [dict get $date dayOfWeek] % 7 }]}
1011	}
1012	W { # Week of the year (00-53). The first
1013	# Monday of the year is the first day
1014	# of week 01.
1015	append preFormatCode {
1016	set WweekNumber \
1017	[expr { ( [dict get $date dayOfYear]
1018	- [dict get $date dayOfWeek]
1019	+ 7 )
1020	/ 7 }]
1021	}
1022	append formatString %02d
1023	append substituents { $WweekNumber}
1024	}
1025	y { # The two-digit year of the century
1026	append formatString %02d
1027	append substituents \
1028	{ [expr { [dict get $date year] % 100 }]}
1029	}
1030	Y { # The four-digit year
1031	append formatString %04d
1032	append substituents { [dict get $date year]}
1033	}
1034	z { # The time zone as hours and minutes
1035	# east (+) or west (-) of Greenwich
1036	append formatString %s
1037	append substituents { [FormatNumericTimeZone \
1038	[dict get $date tzOffset]]}
1039	}
1040	Z { # The name of the time zone
1041	append formatString %s
1042	append substituents { [dict get $date tzName]}
1043	}
1044	% { # A literal percent character
1045	append formatString %%
1046	}
1047	default { # An unknown escape sequence
1048	append formatString %% $char
1049	}
1050	}
1051	}
1052	percentE { # Character following %E
1053	set state {}
1054	switch -exact -- $char {
1055	E {
1056	append formatString %s
1057	append substituents { } \
1058	[string map \
1059	[list @BCE@ [list [mc BCE]] \
1060	@CE@ [list [mc CE]]] \
1061	{[dict get {BCE @BCE@ CE @CE@} \
1062	[dict get $date era]]}]
1063	}
1064	C { # Locale-dependent era
1065	append formatString %s
1066	append substituents { [dict get $date localeEra]}
1067	}
1068	y { # Locale-dependent year of the era
1069	append preFormatCode {
1070	set y [dict get $date localeYear]
1071	if { $y >= 0 && $y < 100 } {
1072	set Eyear [lindex $localeNumerals $y]
1073	} else {
1074	set Eyear $y
1075	}
1076	}
1077	append formatString %s
1078	append substituents { $Eyear}
1079	}
1080	default { # Unknown %E format group
1081	append formatString %%E $char
1082	}
1083	}
1084	}
1085	percentO { # Character following %O
1086	set state {}
1087	switch -exact -- $char {
1088	d - e { # Day of the month in alternative
1089	# numerals
1090	append formatString %s
1091	append substituents \
1092	{ [lindex $localeNumerals \
1093	[dict get $date dayOfMonth]]}
1094	}
1095	H - k { # Hour of the day in alternative
1096	# numerals
1097	append formatString %s
1098	append substituents \
1099	{ [lindex $localeNumerals \
1100	[expr { [dict get $date localSeconds]
1101	/ 3600
1102	% 24 }]]}
1103	}
1104	I - l { # Hour (12-11) AM/PM in alternative
1105	# numerals
1106	append formatString %s
1107	append substituents \
1108	{ [lindex $localeNumerals \
1109	[expr { ( ( ( [dict get $date localSeconds]
1110	% 86400 )
1111	+ 86400
1112	- 3600 )
1113	/ 3600 )
1114	% 12 + 1 }]]}
1115	}
1116	m { # Month number in alternative numerals
1117	append formatString %s
1118	append substituents \
1119	{ [lindex $localeNumerals [dict get $date month]]}
1120	}
1121	M { # Minute of the hour in alternative
1122	# numerals
1123	append formatString %s
1124	append substituents \
1125	{ [lindex $localeNumerals \
1126	[expr { [dict get $date localSeconds]
1127	/ 60
1128	% 60 }]]}
1129	}
1130	S { # Second of the minute in alternative
1131	# numerals
1132	append formatString %s
1133	append substituents \
1134	{ [lindex $localeNumerals \
1135	[expr { [dict get $date localSeconds]
1136	% 60 }]]}
1137	}
1138	u { # Day of the week (Monday=1,Sunday=7)
1139	# in alternative numerals
1140	append formatString %s
1141	append substituents \
1142	{ [lindex $localeNumerals \
1143	[dict get $date dayOfWeek]]}
1144	}
1145	w { # Day of the week (Sunday=0,Saturday=6)
1146	# in alternative numerals
1147	append formatString %s
1148	append substituents \
1149	{ [lindex $localeNumerals \
1150	[expr { [dict get $date dayOfWeek] % 7 }]]}
1151	}
1152	y { # Year of the century in alternative
1153	# numerals
1154	append formatString %s
1155	append substituents \
1156	{ [lindex $localeNumerals \
1157	[expr { [dict get $date year] % 100 }]]}
1158	}
1159	default { # Unknown format group
1160	append formatString %%O $char
1161	}
1162	}
1163	}
1164	}
1165	}
1166
1167	# Clean up any improperly terminated groups
1168
1169	switch -exact -- $state {
1170	percent {
1171	append formatString %%
1172	}
1173	percentE {
1174	append retval %%E
1175	}
1176	percentO {
1177	append retval %%O
1178	}
1179	}
1180
1181	proc $procName {clockval timezone} "
1182	$preFormatCode
1183	return \[::format [list $formatString] $substituents\]
1184	"
1185
1186	# puts [list $procName [info args $procName] [info body $procName]]
1187
1188	return $procName
1189	}
1190
1191	#----------------------------------------------------------------------
1192	#
1193	# clock scan --
1194	#
1195	# Inputs a count of seconds since the Posix Epoch as a time
1196	# of day.
1197	#
1198	# The 'clock format' command scans times of day on input.
1199	# Refer to the user documentation to see what it does.
1200	#
1201	#----------------------------------------------------------------------
1202
1203	proc ::tcl::clock::scan { args } {
1204
1205	set format {}
1206
1207	# Check the count of args
1208
1209	if { [llength $args] < 1 \|\| [llength $args] % 2 != 1 } {
1210	set cmdName "clock scan"
1211	return -code error \
1212	-errorcode [list CLOCK wrongNumArgs] \
1213	"wrong \# args: should be\
1214	\"$cmdName string\
1215	?-base seconds?\
1216	?-format string? ?-gmt boolean?\
1217	?-locale LOCALE? ?-timezone ZONE?\""
1218	}
1219
1220	# Set defaults
1221
1222	set base [clock seconds]
1223	set string [lindex $args 0]
1224	set format {}
1225	set gmt 0
1226	set locale c
1227	set timezone [GetSystemTimeZone]
1228
1229	# Pick up command line options.
1230
1231	foreach { flag value } [lreplace $args 0 0] {
1232	set saw($flag) {}
1233	switch -exact -- $flag {
1234	-b - -ba - -bas - -base {
1235	set base $value
1236	}
1237	-f - -fo - -for - -form - -forma - -format {
1238	set format $value
1239	}
1240	-g - -gm - -gmt {
1241	set gmt $value
1242	}
1243	-l - -lo - -loc - -loca - -local - -locale {
1244	set locale [string tolower $value]
1245	}
1246	-t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
1247	set timezone $value
1248	}
1249	default {
1250	return -code error \
1251	-errorcode [list CLOCK badSwitch $flag] \
1252	"bad switch \"$flag\",\
1253	must be -base, -format, -gmt, -locale or -timezone"
1254	}
1255	}
1256	}
1257
1258	# Check options for validity
1259
1260	if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
1261	return -code error \
1262	-errorcode [list CLOCK gmtWithTimezone] \
1263	"cannot use -gmt and -timezone in same call"
1264	}
1265	if { [catch { expr { wide($base) } } result] } {
1266	return -code error \
1267	"expected integer but got \"$base\""
1268	}
1269	if { ![string is boolean $gmt] } {
1270	return -code error \
1271	"expected boolean value but got \"$gmt\""
1272	} else {
1273	if { $gmt } {
1274	set timezone :GMT
1275	}
1276	}
1277
1278	if { ![info exists saw(-format)] } {
1279	# Perhaps someday we'll localize the legacy code. Right now,
1280	# it's not localized.
1281	if { [info exists saw(-locale)] } {
1282	return -code error \
1283	-errorcode [list CLOCK flagWithLegacyFormat] \
1284	"legacy \[clock scan\] does not support -locale"
1285
1286	}
1287	return [FreeScan $string $base $timezone $locale]
1288	}
1289
1290	# Change locale if a fresh locale has been given on the command line.
1291
1292	EnterLocale $locale oldLocale
1293
1294	set status [catch {
1295
1296	# Map away the locale-dependent composite format groups
1297
1298	set scanner [ParseClockScanFormat $format $locale]
1299	$scanner $string $base $timezone
1300
1301	} result opts]
1302
1303	# Restore the locale
1304
1305	if { [info exists oldLocale] } {
1306	mclocale $oldLocale
1307	}
1308
1309	if { $status == 1 } {
1310	if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
1311	return -code error $result
1312	} else {
1313	return -options $opts $result
1314	}
1315	} else {
1316	return $result
1317	}
1318
1319	}
1320
1321	#----------------------------------------------------------------------
1322	#
1323	# FreeScan --
1324	#
1325	# Scans a time in free format
1326	#
1327	# Parameters:
1328	# string - String containing the time to scan
1329	# base - Base time, expressed in seconds from the Epoch
1330	# timezone - Default time zone in which the time will be expressed
1331	# locale - (Unused) Name of the locale where the time will be scanned.
1332	#
1333	# Results:
1334	# Returns the date and time extracted from the string in seconds
1335	# from the epoch
1336	#
1337	#----------------------------------------------------------------------
1338
1339	proc ::tcl::clock::FreeScan { string base timezone locale } {
1340
1341	variable TZData
1342
1343	# Get the data for time changes in the given zone
1344
1345	if {[catch {SetupTimeZone $timezone} retval opts]} {
1346	dict unset opts -errorinfo
1347	return -options $opts $retval
1348	}
1349
1350	# Extract year, month and day from the base time for the
1351	# parser to use as defaults
1352
1353	set date [GetDateFields \
1354	$base \
1355	$TZData($timezone) \
1356	2361222]
1357	dict set date secondOfDay [expr { [dict get $date localSeconds]
1358	% 86400 }]
1359
1360	# Parse the date. The parser will return a list comprising
1361	# date, time, time zone, relative month/day/seconds, relative
1362	# weekday, ordinal month.
1363
1364	set status [catch {
1365	Oldscan $string \
1366	[dict get $date year] \
1367	[dict get $date month] \
1368	[dict get $date dayOfMonth]
1369	} result]
1370	if { $status != 0 } {
1371	return -code error "unable to convert date-time string \"$string\""
1372	}
1373
1374	lassign $result parseDate parseTime parseZone parseRel \
1375	parseWeekday parseOrdinalMonth
1376
1377	# If the caller supplied a date in the string, update the 'date' dict
1378	# with the value. If the caller didn't specify a time with the date,
1379	# default to midnight.
1380
1381	if { [llength $parseDate] > 0 } {
1382	lassign $parseDate y m d
1383	if { $y < 100 } {
1384	if { $y >= 39 } {
1385	incr y 1900
1386	} else {
1387	incr y 2000
1388	}
1389	}
1390	dict set date era CE
1391	dict set date year $y
1392	dict set date month $m
1393	dict set date dayOfMonth $d
1394	if { $parseTime eq {} } {
1395	set parseTime 0
1396	}
1397	}
1398
1399	# If the caller supplied a time zone in the string, it comes back
1400	# as a two-element list; the first element is the number of minutes
1401	# east of Greenwich, and the second is a Daylight Saving Time
1402	# indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into
1403	# a time zone indicator of +-hhmm.
1404
1405	if { [llength $parseZone] > 0 } {
1406	lassign $parseZone minEast dstFlag
1407	set timezone [FormatNumericTimeZone \
1408	[expr { 60 * $minEast + 3600 * $dstFlag }]]
1409	SetupTimeZone $timezone
1410	}
1411	dict set date tzName $timezone
1412
1413	# Assemble date, time, zone into seconds-from-epoch
1414
1415	set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
1416	if { $parseTime ne {} } {
1417	dict set date secondOfDay $parseTime
1418	} elseif { [llength $parseWeekday] != 0
1419	\|\| [llength $parseOrdinalMonth] != 0
1420	\|\| ( [llength $parseRel] != 0
1421	&& ( [lindex $parseRel 0] != 0
1422	\|\| [lindex $parseRel 1] != 0 ) ) } {
1423	dict set date secondOfDay 0
1424	}
1425
1426	dict set date localSeconds \
1427	[expr { -210866803200
1428	+ ( 86400 * wide([dict get $date julianDay]) )
1429	+ [dict get $date secondOfDay] }]
1430	dict set date tzName $timezone
1431	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
1432	set seconds [dict get $date seconds]
1433
1434	# Do relative times
1435
1436	if { [llength $parseRel] > 0 } {
1437	lassign $parseRel relMonth relDay relSecond
1438	set seconds [add $seconds \
1439	$relMonth months $relDay days $relSecond seconds \
1440	-timezone $timezone -locale $locale]
1441	}
1442
1443	# Do relative weekday
1444
1445	if { [llength $parseWeekday] > 0 } {
1446
1447	lassign $parseWeekday dayOrdinal dayOfWeek
1448	set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
1449	dict set date2 era CE
1450	set jdwkday [WeekdayOnOrBefore $dayOfWeek \
1451	[expr { [dict get $date2 julianDay]
1452	+ 6 }]]
1453	incr jdwkday [expr { 7 * $dayOrdinal }]
1454	if { $dayOrdinal > 0 } {
1455	incr jdwkday -7
1456	}
1457	dict set date2 secondOfDay \
1458	[expr { [dict get $date2 localSeconds] % 86400 }]
1459	dict set date2 julianDay $jdwkday
1460	dict set date2 localSeconds \
1461	[expr { -210866803200
1462	+ ( 86400 * wide([dict get $date2 julianDay]) )
1463	+ [dict get $date secondOfDay] }]
1464	dict set date2 tzName $timezone
1465	set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
1466	2361222]
1467	set seconds [dict get $date2 seconds]
1468
1469	}
1470
1471	# Do relative month
1472
1473	if { [llength $parseOrdinalMonth] > 0 } {
1474
1475	lassign $parseOrdinalMonth monthOrdinal monthNumber
1476	if { $monthOrdinal > 0 } {
1477	set monthDiff [expr { $monthNumber - [dict get $date month] }]
1478	if { $monthDiff <= 0 } {
1479	incr monthDiff 12
1480	}
1481	incr monthOrdinal -1
1482	} else {
1483	set monthDiff [expr { [dict get $date month] - $monthNumber }]
1484	if { $monthDiff >= 0 } {
1485	incr monthDiff -12
1486	}
1487	incr monthOrdinal
1488	}
1489	set seconds [add $seconds $monthOrdinal years $monthDiff months \
1490	-timezone $timezone -locale $locale]
1491
1492	}
1493
1494	return $seconds
1495	}
1496
1497
1498	#----------------------------------------------------------------------
1499	#
1500	# ParseClockScanFormat --
1501	#
1502	# Parses a format string given to [clock scan -format]
1503	#
1504	# Parameters:
1505	# formatString - The format being parsed
1506	# locale - The current locale
1507	#
1508	# Results:
1509	# Constructs and returns a procedure that accepts the
1510	# string being scanned, the base time, and the time zone.
1511	# The procedure will either return the scanned time or
1512	# else throw an error that should be rethrown to the caller
1513	# of [clock scan]
1514	#
1515	# Side effects:
1516	# The given procedure is defined in the ::tcl::clock
1517	# namespace. Scan procedures are not deleted once installed.
1518	#
1519	# Why do we parse dates by defining a procedure to parse them?
1520	# The reason is that by doing so, we have one convenient place to
1521	# cache all the information: the regular expressions that match the
1522	# patterns (which will be compiled), the code that assembles the
1523	# date information, everything lands in one place. In this way,
1524	# when a given format is reused at run time, all the information
1525	# of how to apply it is available in a single place.
1526	#
1527	#----------------------------------------------------------------------
1528
1529	proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
1530
1531	# Check whether the format has been parsed previously, and return
1532	# the existing recognizer if it has.
1533
1534	set procName [namespace current]::scanproc'$formatString'$locale
1535	if { [namespace which $procName] != {} } {
1536	return $procName
1537	}
1538
1539	variable DateParseActions
1540	variable TimeParseActions
1541
1542	# Localize the %x, %X, etc. groups
1543
1544	set formatString [LocalizeFormat $locale $formatString]
1545
1546	# Condense whitespace
1547
1548	regsub -all {[[:space:]]+} $formatString { } formatString
1549
1550	# Walk through the groups of the format string. In this loop, we
1551	# accumulate:
1552	# - a regular expression that matches the string,
1553	# - the count of capturing brackets in the regexp
1554	# - a set of code that post-processes the fields captured by the regexp,
1555	# - a dictionary whose keys are the names of fields that are present
1556	# in the format string.
1557
1558	set re {^[[:space:]]*}
1559	set captureCount 0
1560	set postcode {}
1561	set fieldSet [dict create]
1562	set fieldCount 0
1563	set postSep {}
1564	set state {}
1565
1566	foreach c [split $formatString {}] {
1567	switch -exact -- $state {
1568	{} {
1569	if { $c eq "%" } {
1570	set state %
1571	} elseif { $c eq " " } {
1572	append re {[[:space:]]+}
1573	} else {
1574	if { ! [string is alnum $c] } {
1575	append re \\
1576	}
1577	append re $c
1578	}
1579	}
1580	% {
1581	set state {}
1582	switch -exact -- $c {
1583	% {
1584	append re %
1585	}
1586	{ } {
1587	append re "\[\[:space:\]\]*"
1588	}
1589	a - A { # Day of week, in words
1590	set l {}
1591	foreach \
1592	i {7 1 2 3 4 5 6} \
1593	abr [mc DAYS_OF_WEEK_ABBREV] \
1594	full [mc DAYS_OF_WEEK_FULL] {
1595	dict set l [string tolower $abr] $i
1596	dict set l [string tolower $full] $i
1597	incr i
1598	}
1599	lassign [UniquePrefixRegexp $l] regex lookup
1600	append re ( $regex )
1601	dict set fieldSet dayOfWeek [incr fieldCount]
1602	append postcode "dict set date dayOfWeek \[" \
1603	"dict get " [list $lookup] " " \
1604	\[ {string tolower $field} [incr captureCount] \] \
1605	"\]\n"
1606	}
1607	b - B - h { # Name of month
1608	set i 0
1609	set l {}
1610	foreach \
1611	abr [mc MONTHS_ABBREV] \
1612	full [mc MONTHS_FULL] {
1613	incr i
1614	dict set l [string tolower $abr] $i
1615	dict set l [string tolower $full] $i
1616	}
1617	lassign [UniquePrefixRegexp $l] regex lookup
1618	append re ( $regex )
1619	dict set fieldSet month [incr fieldCount]
1620	append postcode "dict set date month \[" \
1621	"dict get " [list $lookup] \
1622	" " \[ {string tolower $field} \
1623	[incr captureCount] \] \
1624	"\]\n"
1625	}
1626	C { # Gregorian century
1627	append re \\s*(\\d\\d?)
1628	dict set fieldSet century [incr fieldCount]
1629	append postcode "dict set date century \[" \
1630	"::scan \$field" [incr captureCount] " %d" \
1631	"\]\n"
1632	}
1633	d - e { # Day of month
1634	append re \\s*(\\d\\d?)
1635	dict set fieldSet dayOfMonth [incr fieldCount]
1636	append postcode "dict set date dayOfMonth \[" \
1637	"::scan \$field" [incr captureCount] " %d" \
1638	"\]\n"
1639	}
1640	E { # Prefix for locale-specific codes
1641	set state %E
1642	}
1643	g { # ISO8601 2-digit year
1644	append re \\s*(\\d\\d)
1645	dict set fieldSet iso8601YearOfCentury \
1646	[incr fieldCount]
1647	append postcode \
1648	"dict set date iso8601YearOfCentury \[" \
1649	"::scan \$field" [incr captureCount] " %d" \
1650	"\]\n"
1651	}
1652	G { # ISO8601 4-digit year
1653	append re \\s*(\\d\\d)(\\d\\d)
1654	dict set fieldSet iso8601Century [incr fieldCount]
1655	dict set fieldSet iso8601YearOfCentury \
1656	[incr fieldCount]
1657	append postcode \
1658	"dict set date iso8601Century \[" \
1659	"::scan \$field" [incr captureCount] " %d" \
1660	"\]\n" \
1661	"dict set date iso8601YearOfCentury \[" \
1662	"::scan \$field" [incr captureCount] " %d" \
1663	"\]\n"
1664	}
1665	H - k { # Hour of day
1666	append re \\s*(\\d\\d?)
1667	dict set fieldSet hour [incr fieldCount]
1668	append postcode "dict set date hour \[" \
1669	"::scan \$field" [incr captureCount] " %d" \
1670	"\]\n"
1671	}
1672	I - l { # Hour, AM/PM
1673	append re \\s*(\\d\\d?)
1674	dict set fieldSet hourAMPM [incr fieldCount]
1675	append postcode "dict set date hourAMPM \[" \
1676	"::scan \$field" [incr captureCount] " %d" \
1677	"\]\n"
1678	}
1679	j { # Day of year
1680	append re \\s*(\\d\\d?\\d?)
1681	dict set fieldSet dayOfYear [incr fieldCount]
1682	append postcode "dict set date dayOfYear \[" \
1683	"::scan \$field" [incr captureCount] " %d" \
1684	"\]\n"
1685	}
1686	J { # Julian Day Number
1687	append re \\s*(\\d+)
1688	dict set fieldSet julianDay [incr fieldCount]
1689	append postcode "dict set date julianDay \[" \
1690	"::scan \$field" [incr captureCount] " %ld" \
1691	"\]\n"
1692	}
1693	m - N { # Month number
1694	append re \\s*(\\d\\d?)
1695	dict set fieldSet month [incr fieldCount]
1696	append postcode "dict set date month \[" \
1697	"::scan \$field" [incr captureCount] " %d" \
1698	"\]\n"
1699	}
1700	M { # Minute
1701	append re \\s*(\\d\\d?)
1702	dict set fieldSet minute [incr fieldCount]
1703	append postcode "dict set date minute \[" \
1704	"::scan \$field" [incr captureCount] " %d" \
1705	"\]\n"
1706	}
1707	n { # Literal newline
1708	append re \\n
1709	}
1710	O { # Prefix for locale numerics
1711	set state %O
1712	}
1713	p - P { # AM/PM indicator
1714	set l [list [string tolower [mc AM]] 0 \
1715	[string tolower [mc PM]] 1]
1716	lassign [UniquePrefixRegexp $l] regex lookup
1717	append re ( $regex )
1718	dict set fieldSet amPmIndicator [incr fieldCount]
1719	append postcode "dict set date amPmIndicator \[" \
1720	"dict get " [list $lookup] " \[string tolower " \
1721	"\$field" \
1722	[incr captureCount] \
1723	"\]\]\n"
1724	}
1725	Q { # Hi, Jeff!
1726	append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
1727	incr captureCount
1728	dict set fieldSet seconds [incr fieldCount]
1729	append postcode {dict set date seconds } \[ \
1730	{ParseStarDate $field} [incr captureCount] \
1731	{ $field} [incr captureCount] \
1732	{ $field} [incr captureCount] \
1733	\] \n
1734	}
1735	s { # Seconds from Posix Epoch
1736	# This next case is insanely difficult,
1737	# because it's problematic to determine
1738	# whether the field is actually within
1739	# the range of a wide integer.
1740	append re {\s*([-+]?\d+)}
1741	dict set fieldSet seconds [incr fieldCount]
1742	append postcode {dict set date seconds } \[ \
1743	{ScanWide $field} [incr captureCount] \] \n
1744	}
1745	S { # Second
1746	append re \\s*(\\d\\d?)
1747	dict set fieldSet second [incr fieldCount]
1748	append postcode "dict set date second \[" \
1749	"::scan \$field" [incr captureCount] " %d" \
1750	"\]\n"
1751	}
1752	t { # Literal tab character
1753	append re \\t
1754	}
1755	u - w { # Day number within week, 0 or 7 == Sun
1756	# 1=Mon, 6=Sat
1757	append re \\s*(\\d)
1758	dict set fieldSet dayOfWeek [incr fieldCount]
1759	append postcode {::scan $field} [incr captureCount] \
1760	{ %d dow} \n \
1761	{
1762	if { $dow == 0 } {
1763	set dow 7
1764	} elseif { $dow > 7 } {
1765	return -code error \
1766	-errorcode [list CLOCK badDayOfWeek] \
1767	"day of week is greater than 7"
1768	}
1769	dict set date dayOfWeek $dow
1770	}
1771	}
1772	U { # Week of year. The
1773	# first Sunday of the year is the
1774	# first day of week 01. No scan rule
1775	# uses this group.
1776	append re \\s*\\d\\d?
1777	}
1778	V { # Week of ISO8601 year
1779
1780	append re \\s*(\\d\\d?)
1781	dict set fieldSet iso8601Week [incr fieldCount]
1782	append postcode "dict set date iso8601Week \[" \
1783	"::scan \$field" [incr captureCount] " %d" \
1784	"\]\n"
1785	}
1786	W { # Week of the year (00-53). The first
1787	# Monday of the year is the first day
1788	# of week 01. No scan rule uses this
1789	# group.
1790	append re \\s*\\d\\d?
1791	}
1792	y { # Two-digit Gregorian year
1793	append re \\s*(\\d\\d?)
1794	dict set fieldSet yearOfCentury [incr fieldCount]
1795	append postcode "dict set date yearOfCentury \[" \
1796	"::scan \$field" [incr captureCount] " %d" \
1797	"\]\n"
1798	}
1799	Y { # 4-digit Gregorian year
1800	append re \\s*(\\d\\d)(\\d\\d)
1801	dict set fieldSet century [incr fieldCount]
1802	dict set fieldSet yearOfCentury [incr fieldCount]
1803	append postcode \
1804	"dict set date century \[" \
1805	"::scan \$field" [incr captureCount] " %d" \
1806	"\]\n" \
1807	"dict set date yearOfCentury \[" \
1808	"::scan \$field" [incr captureCount] " %d" \
1809	"\]\n"
1810	}
1811	z - Z { # Time zone name
1812	append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)\|([[:alnum:]]{1,4}))}
1813	dict set fieldSet tzName [incr fieldCount]
1814	append postcode \
1815	{if } \{ { $field} [incr captureCount] \
1816	{ ne "" } \} { } \{ \n \
1817	{dict set date tzName $field} \
1818	$captureCount \n \
1819	\} { else } \{ \n \
1820	{dict set date tzName } \[ \
1821	{ConvertLegacyTimeZone $field} \
1822	[incr captureCount] \] \n \
1823	\} \n \
1824	}
1825	% { # Literal percent character
1826	append re %
1827	}
1828	default {
1829	append re %
1830	if { ! [string is alnum $c] } {
1831	append re \\
1832	}
1833	append re $c
1834	}
1835	}
1836	}
1837	%E {
1838	switch -exact -- $c {
1839	C { # Locale-dependent era
1840	set d {}
1841	foreach triple [mc LOCALE_ERAS] {
1842	lassign $triple t symbol year
1843	dict set d [string tolower $symbol] $year
1844	}
1845	lassign [UniquePrefixRegexp $d] regex lookup
1846	append re (?: $regex )
1847	}
1848	E {
1849	set l {}
1850	dict set l [string tolower [mc BCE]] BCE
1851	dict set l [string tolower [mc CE]] CE
1852	dict set l b.c.e. BCE
1853	dict set l c.e. CE
1854	dict set l b.c. BCE
1855	dict set l a.d. CE
1856	lassign [UniquePrefixRegexp $l] regex lookup
1857	append re ( $regex )
1858	dict set fieldSet era [incr fieldCount]
1859	append postcode "dict set date era \["\
1860	"dict get " [list $lookup] \
1861	{ } \[ {string tolower $field} \
1862	[incr captureCount] \] \
1863	"\]\n"
1864	}
1865	y { # Locale-dependent year of the era
1866	lassign [LocaleNumeralMatcher $locale] regex lookup
1867	append re $regex
1868	incr captureCount
1869	}
1870	default {
1871	append re %E
1872	if { ! [string is alnum $c] } {
1873	append re \\
1874	}
1875	append re $c
1876	}
1877	}
1878	set state {}
1879	}
1880	%O {
1881	switch -exact -- $c {
1882	d - e {
1883	lassign [LocaleNumeralMatcher $locale] regex lookup
1884	append re $regex
1885	dict set fieldSet dayOfMonth [incr fieldCount]
1886	append postcode "dict set date dayOfMonth \[" \
1887	"dict get " [list $lookup] " \$field" \
1888	[incr captureCount] \
1889	"\]\n"
1890	}
1891	H - k {
1892	lassign [LocaleNumeralMatcher $locale] regex lookup
1893	append re $regex
1894	dict set fieldSet hour [incr fieldCount]
1895	append postcode "dict set date hour \[" \
1896	"dict get " [list $lookup] " \$field" \
1897	[incr captureCount] \
1898	"\]\n"
1899	}
1900	I - l {
1901	lassign [LocaleNumeralMatcher $locale] regex lookup
1902	append re $regex
1903	dict set fieldSet hourAMPM [incr fieldCount]
1904	append postcode "dict set date hourAMPM \[" \
1905	"dict get " [list $lookup] " \$field" \
1906	[incr captureCount] \
1907	"\]\n"
1908	}
1909	m {
1910	lassign [LocaleNumeralMatcher $locale] regex lookup
1911	append re $regex
1912	dict set fieldSet month [incr fieldCount]
1913	append postcode "dict set date month \[" \
1914	"dict get " [list $lookup] " \$field" \
1915	[incr captureCount] \
1916	"\]\n"
1917	}
1918	M {
1919	lassign [LocaleNumeralMatcher $locale] regex lookup
1920	append re $regex
1921	dict set fieldSet minute [incr fieldCount]
1922	append postcode "dict set date minute \[" \
1923	"dict get " [list $lookup] " \$field" \
1924	[incr captureCount] \
1925	"\]\n"
1926	}
1927	S {
1928	lassign [LocaleNumeralMatcher $locale] regex lookup
1929	append re $regex
1930	dict set fieldSet second [incr fieldCount]
1931	append postcode "dict set date second \[" \
1932	"dict get " [list $lookup] " \$field" \
1933	[incr captureCount] \
1934	"\]\n"
1935	}
1936	u - w {
1937	lassign [LocaleNumeralMatcher $locale] regex lookup
1938	append re $regex
1939	dict set fieldSet dayOfWeek [incr fieldCount]
1940	append postcode "set dow \[dict get " [list $lookup] \
1941	{ $field} [incr captureCount] \] \n \
1942	{
1943	if { $dow == 0 } {
1944	set dow 7
1945	} elseif { $dow > 7 } {
1946	return -code error \
1947	-errorcode [list CLOCK badDayOfWeek] \
1948	"day of week is greater than 7"
1949	}
1950	dict set date dayOfWeek $dow
1951	}
1952	}
1953	y {
1954	lassign [LocaleNumeralMatcher $locale] regex lookup
1955	append re $regex
1956	dict set fieldSet yearOfCentury [incr fieldCount]
1957	append postcode {dict set date yearOfCentury } \[ \
1958	{dict get } [list $lookup] { $field} \
1959	[incr captureCount] \] \n
1960	}
1961	default {
1962	append re %O
1963	if { ! [string is alnum $c] } {
1964	append re \\
1965	}
1966	append re $c
1967	}
1968	}
1969	set state {}
1970	}
1971	}
1972	}
1973
1974	# Clean up any unfinished format groups
1975
1976	append re $state \\s*\$
1977
1978	# Build the procedure
1979
1980	set procBody {}
1981	append procBody "variable ::tcl::clock::TZData" \n
1982	append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
1983	for { set i 1 } { $i <= $captureCount } { incr i } {
1984	append procBody " " field $i
1985	}
1986	append procBody "\] \} \{" \n
1987	append procBody {
1988	return -code error -errorcode [list CLOCK badInputString] \
1989	{input string does not match supplied format}
1990	}
1991	append procBody \}\n
1992	append procBody "set date \[dict create\]" \n
1993	append procBody {dict set date tzName $timeZone} \n
1994	append procBody $postcode
1995	append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
1996
1997	# Add code that gets Julian Day Number from the fields.
1998
1999	append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
2000
2001	# Get time of day
2002
2003	append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
2004
2005	# Assemble seconds, and convert local nominal time to UTC.
2006
2007	if { ![dict exists $fieldSet seconds]
2008	&& ![dict exists $fieldSet starDate] } {
2009	append procBody {
2010	if { [dict get $date julianDay] > 5373484 } {
2011	return -code error -errorcode [list CLOCK dateTooLarge] \
2012	"requested date too large to represent"
2013	}
2014	dict set date localSeconds \
2015	[expr { -210866803200
2016	+ ( 86400 * wide([dict get $date julianDay]) )
2017	+ [dict get $date secondOfDay] }]
2018	}
2019	}
2020
2021	if { ![dict exists $fieldSet seconds]
2022	&& ![dict exists $fieldSet starDate] } {
2023	if { [dict exists $fieldSet tzName] } {
2024	append procBody {
2025	set timeZone [dict get $date tzName]
2026	}
2027	}
2028	append procBody {
2029	::tcl::clock::SetupTimeZone $timeZone
2030	set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
2031	$TZData($timeZone) \
2032	$changeover]
2033	}
2034	}
2035
2036	# Return result
2037
2038	append procBody {return [dict get $date seconds]} \n
2039
2040	proc $procName { string baseTime timeZone } $procBody
2041
2042	# puts [list proc $procName [list string baseTime timeZone] $procBody]
2043
2044	return $procName
2045	}
2046
2047	#----------------------------------------------------------------------
2048	#
2049	# LocaleNumeralMatcher --
2050	#
2051	# Composes a regexp that captures the numerals in the given
2052	# locale, and a dictionary to map them to conventional numerals.
2053	#
2054	# Parameters:
2055	# locale - Name of the current locale
2056	#
2057	# Results:
2058	# Returns a two-element list comprising the regexp and the
2059	# dictionary.
2060	#
2061	# Side effects:
2062	# Caches the result.
2063	#
2064	#----------------------------------------------------------------------
2065
2066	proc ::tcl::clock::LocaleNumeralMatcher {l} {
2067
2068	variable LocaleNumeralCache
2069
2070	if { ![dict exists $LocaleNumeralCache $l] } {
2071	set d {}
2072	set i 0
2073	set sep \(
2074	foreach n [mc LOCALE_NUMERALS] {
2075	dict set d $n $i
2076	regsub -all {[^[:alnum:]]} $n \\\\& subex
2077	append re $sep $subex
2078	set sep \|
2079	incr i
2080	}
2081	append re \)
2082	dict set LocaleNumeralCache $l [list $re $d]
2083	}
2084	return [dict get $LocaleNumeralCache $l]
2085	}
2086
2087
2088
2089	#----------------------------------------------------------------------
2090	#
2091	# UniquePrefixRegexp --
2092	#
2093	# Composes a regexp that performs unique-prefix matching. The
2094	# RE matches one of a supplied set of strings, or any unique
2095	# prefix thereof.
2096	#
2097	# Parameters:
2098	# data - List of alternating match-strings and values.
2099	# Match-strings with distinct values are considered
2100	# distinct.
2101	#
2102	# Results:
2103	# Returns a two-element list. The first is a regexp that
2104	# matches any unique prefix of any of the strings. The second
2105	# is a dictionary whose keys are match values from the regexp
2106	# and whose values are the corresponding values from 'data'.
2107	#
2108	# Side effects:
2109	# None.
2110	#
2111	#----------------------------------------------------------------------
2112
2113	proc ::tcl::clock::UniquePrefixRegexp { data } {
2114
2115	# The 'successors' dictionary will contain, for each string that
2116	# is a prefix of any key, all characters that may follow that
2117	# prefix. The 'prefixMapping' dictionary will have keys that
2118	# are prefixes of keys and values that correspond to the keys.
2119
2120	set prefixMapping [dict create]
2121	set successors [dict create {} {}]
2122
2123	# Walk the key-value pairs
2124
2125	foreach { key value } $data {
2126
2127	# Construct all prefixes of the key;
2128
2129	set prefix {}
2130	foreach char [split $key {}] {
2131	set oldPrefix $prefix
2132	dict set successors $oldPrefix $char {}
2133	append prefix $char
2134
2135	# Put the prefixes in the 'prefixMapping' and 'successors'
2136	# dictionaries
2137
2138	dict lappend prefixMapping $prefix $value
2139	if { ![dict exists $successors $prefix] } {
2140	dict set successors $prefix {}
2141	}
2142	}
2143	}
2144
2145	# Identify those prefixes that designate unique values, and
2146	# those that are the full keys
2147
2148	set uniquePrefixMapping {}
2149	dict for { key valueList } $prefixMapping {
2150	if { [llength $valueList] == 1 } {
2151	dict set uniquePrefixMapping $key [lindex $valueList 0]
2152	}
2153	}
2154	foreach { key value } $data {
2155	dict set uniquePrefixMapping $key $value
2156	}
2157
2158	# Construct the re.
2159
2160	return [list \
2161	[MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
2162	$uniquePrefixMapping]
2163	}
2164
2165	#----------------------------------------------------------------------
2166	#
2167	# MakeUniquePrefixRegexp --
2168	#
2169	# Service procedure for 'UniquePrefixRegexp' that constructs
2170	# a regular expresison that matches the unique prefixes.
2171	#
2172	# Parameters:
2173	# successors - Dictionary whose keys are all prefixes
2174	# of keys passed to 'UniquePrefixRegexp' and whose
2175	# values are dictionaries whose keys are the characters
2176	# that may follow those prefixes.
2177	# uniquePrefixMapping - Dictionary whose keys are the unique
2178	# prefixes and whose values are not examined.
2179	# prefixString - Current prefix being processed.
2180	#
2181	# Results:
2182	# Returns a constructed regular expression that matches the set
2183	# of unique prefixes beginning with the 'prefixString'.
2184	#
2185	# Side effects:
2186	# None.
2187	#
2188	#----------------------------------------------------------------------
2189
2190	proc ::tcl::clock::MakeUniquePrefixRegexp { successors
2191	uniquePrefixMapping
2192	prefixString } {
2193
2194	# Get the characters that may follow the current prefix string
2195
2196	set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
2197	if { [llength $schars] == 0 } {
2198	return {}
2199	}
2200
2201	# If there is more than one successor character, or if the current
2202	# prefix is a unique prefix, surround the generated re with non-capturing
2203	# parentheses.
2204
2205	set re {}
2206	if { [dict exists $uniquePrefixMapping $prefixString]
2207	\|\| [llength $schars] > 1 } {
2208	append re "(?:"
2209	}
2210
2211	# Generate a regexp that matches the successors.
2212
2213	set sep ""
2214	foreach { c } $schars {
2215	set nextPrefix $prefixString$c
2216	regsub -all {[^[:alnum:]]} $c \\\\& rechar
2217	append re $sep $rechar \
2218	[MakeUniquePrefixRegexp \
2219	$successors $uniquePrefixMapping $nextPrefix]
2220	set sep \|
2221	}
2222
2223	# If the current prefix is a unique prefix, make all following text
2224	# optional. Otherwise, if there is more than one successor character,
2225	# close the non-capturing parentheses.
2226
2227	if { [dict exists $uniquePrefixMapping $prefixString] } {
2228	append re ")?"
2229	} elseif { [llength $schars] > 1 } {
2230	append re ")"
2231	}
2232
2233	return $re
2234	}
2235
2236	#----------------------------------------------------------------------
2237	#
2238	# MakeParseCodeFromFields --
2239	#
2240	# Composes Tcl code to extract the Julian Day Number from a
2241	# dictionary containing date fields.
2242	#
2243	# Parameters:
2244	# dateFields -- Dictionary whose keys are fields of the date,
2245	# and whose values are the rightmost positions
2246	# at which those fields appear.
2247	# parseActions -- List of triples: field set, priority, and
2248	# code to emit. Smaller priorities are better, and
2249	# the list must be in ascending order by priority
2250	#
2251	# Results:
2252	# Returns a burst of code that extracts the day number from the
2253	# given date.
2254	#
2255	# Side effects:
2256	# None.
2257	#
2258	#----------------------------------------------------------------------
2259
2260	proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
2261
2262	set currPrio 999
2263	set currFieldPos [list]
2264	set currCodeBurst {
2265	error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
2266	}
2267
2268	foreach { fieldSet prio parseAction } $parseActions {
2269
2270	# If we've found an answer that's better than any that follow,
2271	# quit now.
2272
2273	if { $prio > $currPrio } {
2274	break
2275	}
2276
2277	# Accumulate the field positions that are used in the current
2278	# field grouping.
2279
2280	set fieldPos [list]
2281	set ok true
2282	foreach field $fieldSet {
2283	if { ! [dict exists $dateFields $field] } {
2284	set ok 0
2285	break
2286	}
2287	lappend fieldPos [dict get $dateFields $field]
2288	}
2289
2290	# Quit if we don't have a complete set of fields
2291	if { !$ok } {
2292	continue
2293	}
2294
2295	# Determine whether the current answer is better than the last.
2296
2297	set fPos [lsort -integer -decreasing $fieldPos]
2298
2299	if { $prio == $currPrio } {
2300	foreach currPos $currFieldPos newPos $fPos {
2301	if { ![string is integer $newPos]
2302	\|\| ![string is integer $currPos]
2303	\|\| $newPos > $currPos } {
2304	break
2305	}
2306	if { $newPos < $currPos } {
2307	set ok 0
2308	break
2309	}
2310	}
2311	}
2312	if { !$ok } {
2313	continue
2314	}
2315
2316	# Remember the best possibility for extracting date information
2317
2318	set currPrio $prio
2319	set currFieldPos $fPos
2320	set currCodeBurst $parseAction
2321
2322	}
2323
2324	return $currCodeBurst
2325
2326	}
2327
2328	#----------------------------------------------------------------------
2329	#
2330	# EnterLocale --
2331	#
2332	# Switch [mclocale] to a given locale if necessary
2333	#
2334	# Parameters:
2335	# locale -- Desired locale
2336	# oldLocaleVar -- Name of a variable in caller's scope that
2337	# tracks the previous locale name.
2338	#
2339	# Results:
2340	# Returns the locale that was previously current.
2341	#
2342	# Side effects:
2343	# Does [mclocale]. If necessary, uses [mcload] to load the
2344	# designated locale's files, and tracks that it has done so
2345	# in the 'McLoaded' variable.
2346	#
2347	#----------------------------------------------------------------------
2348
2349	proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
2350
2351	upvar 1 $oldLocaleVar oldLocale
2352
2353	variable MsgDir
2354	variable McLoaded
2355
2356	set oldLocale [mclocale]
2357	if { $locale eq {system} } {
2358
2359	if { $::tcl_platform(platform) ne {windows} } {
2360
2361	# On a non-windows platform, the 'system' locale is
2362	# the same as the 'current' locale
2363
2364	set locale current
2365	} else {
2366
2367	# On a windows platform, the 'system' locale is
2368	# adapted from the 'current' locale by applying the
2369	# date and time formats from the Control Panel.
2370	# First, load the 'current' locale if it's not yet loaded
2371
2372	if {![dict exists $McLoaded $oldLocale] } {
2373	mcload $MsgDir
2374	dict set McLoaded $oldLocale {}
2375	}
2376
2377	# Make a new locale string for the system locale, and
2378	# get the Control Panel information
2379
2380	set locale ${oldLocale}_windows
2381	if { ![dict exists $McLoaded $locale] } {
2382	LoadWindowsDateTimeFormats $locale
2383	dict set McLoaded $locale {}
2384	}
2385	}
2386	}
2387	if { $locale eq {current}} {
2388	set locale $oldLocale
2389	unset oldLocale
2390	} elseif { $locale eq $oldLocale } {
2391	unset oldLocale
2392	} else {
2393	mclocale $locale
2394	}
2395	if { ![dict exists $McLoaded $locale] } {
2396	mcload $MsgDir
2397	dict set McLoaded $locale {}
2398	}
2399
2400	}
2401
2402	#----------------------------------------------------------------------
2403	#
2404	# LoadWindowsDateTimeFormats --
2405	#
2406	# Load the date/time formats from the Control Panel in Windows
2407	# and convert them so that they're usable by Tcl.
2408	#
2409	# Parameters:
2410	# locale - Name of the locale in whose message catalog
2411	# the converted formats are to be stored.
2412	#
2413	# Results:
2414	# None.
2415	#
2416	# Side effects:
2417	# Updates the given message catalog with the locale strings.
2418	#
2419	# Presumes that on entry, [mclocale] is set to the current locale,
2420	# so that default strings can be obtained if the Registry query
2421	# fails.
2422	#
2423	#----------------------------------------------------------------------
2424
2425	proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
2426
2427	# Bail out if we can't find the Registry
2428
2429	variable NoRegistry
2430	if { [info exists NoRegistry] } return
2431
2432	if { ![catch {
2433	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
2434	sShortDate
2435	} string] } {
2436	set quote {}
2437	set datefmt {}
2438	foreach { unquoted quoted } [split $string '] {
2439	append datefmt $quote [string map {
2440	dddd %A
2441	ddd %a
2442	dd %d
2443	d %e
2444	MMMM %B
2445	MMM %b
2446	MM %m
2447	M %N
2448	yyyy %Y
2449	yy %y
2450	y %y
2451	gg {}
2452	} $unquoted]
2453	if { $quoted eq {} } {
2454	set quote '
2455	} else {
2456	set quote $quoted
2457	}
2458	}
2459	::msgcat::mcset $locale DATE_FORMAT $datefmt
2460	}
2461
2462	if { ![catch {
2463	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
2464	sLongDate
2465	} string] } {
2466	set quote {}
2467	set ldatefmt {}
2468	foreach { unquoted quoted } [split $string '] {
2469	append ldatefmt $quote [string map {
2470	dddd %A
2471	ddd %a
2472	dd %d
2473	d %e
2474	MMMM %B
2475	MMM %b
2476	MM %m
2477	M %N
2478	yyyy %Y
2479	yy %y
2480	y %y
2481	gg {}
2482	} $unquoted]
2483	if { $quoted eq {} } {
2484	set quote '
2485	} else {
2486	set quote $quoted
2487	}
2488	}
2489	::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
2490	}
2491
2492	if { ![catch {
2493	registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
2494	sTimeFormat
2495	} string] } {
2496	set quote {}
2497	set timefmt {}
2498	foreach { unquoted quoted } [split $string '] {
2499	append timefmt $quote [string map {
2500	HH %H
2501	H %k
2502	hh %I
2503	h %l
2504	mm %M
2505	m %M
2506	ss %S
2507	s %S
2508	tt %p
2509	t %p
2510	} $unquoted]
2511	if { $quoted eq {} } {
2512	set quote '
2513	} else {
2514	set quote $quoted
2515	}
2516	}
2517	::msgcat::mcset $locale TIME_FORMAT $timefmt
2518	}
2519
2520	catch {
2521	::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
2522	}
2523	catch {
2524	::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
2525	}
2526
2527	return
2528
2529	}
2530
2531	#----------------------------------------------------------------------
2532	#
2533	# LocalizeFormat --
2534	#
2535	# Map away locale-dependent format groups in a clock format.
2536	#
2537	# Parameters:
2538	# locale -- Current [mclocale] locale, supplied to avoid
2539	# an extra call
2540	# format -- Format supplied to [clock scan] or [clock format]
2541	#
2542	# Results:
2543	# Returns the string with locale-dependent composite format
2544	# groups substituted out.
2545	#
2546	# Side effects:
2547	# None.
2548	#
2549	#----------------------------------------------------------------------
2550
2551	proc ::tcl::clock::LocalizeFormat { locale format } {
2552
2553	variable McLoaded
2554
2555	if { [dict exists $McLoaded $locale FORMAT $format] } {
2556	return [dict get $McLoaded $locale FORMAT $format]
2557	}
2558	set inFormat $format
2559
2560	# Handle locale-dependent format groups by mapping them out of
2561	# the input string. Note that the order of the [string map]
2562	# operations is significant because earlier formats can refer
2563	# to later ones; for example %c can refer to %X, which in turn
2564	# can refer to %T.
2565
2566	set format [string map [list %c [mc DATE_TIME_FORMAT] \
2567	%Ec [mc LOCALE_DATE_TIME_FORMAT]] $format]
2568	set format [string map [list %x [mc DATE_FORMAT] \
2569	%Ex [mc LOCALE_DATE_FORMAT] \
2570	%X [mc TIME_FORMAT] \
2571	%EX [mc LOCALE_TIME_FORMAT]] $format]
2572	set format [string map [list %r [mc TIME_FORMAT_12] \
2573	%R [mc TIME_FORMAT_24] \
2574	%T [mc TIME_FORMAT_24_SECS]] $format]
2575	set format [string map [list %D %m/%d/%Y \
2576	%EY [mc LOCALE_YEAR_FORMAT]\
2577	%+ {%a %b %e %H:%M:%S %Z %Y}] $format]
2578
2579	dict set McLoaded $locale FORMAT $inFormat $format
2580	return $format
2581	}
2582
2583	#----------------------------------------------------------------------
2584	#
2585	# FormatNumericTimeZone --
2586	#
2587	# Formats a time zone as +hhmmss
2588	#
2589	# Parameters:
2590	# z - Time zone in seconds east of Greenwich
2591	#
2592	# Results:
2593	# Returns the time zone formatted in a numeric form
2594	#
2595	# Side effects:
2596	# None.
2597	#
2598	#----------------------------------------------------------------------
2599
2600	proc ::tcl::clock::FormatNumericTimeZone { z } {
2601
2602	if { $z < 0 } {
2603	set z [expr { - $z }]
2604	set retval -
2605	} else {
2606	set retval +
2607	}
2608	append retval [::format %02d [expr { $z / 3600 }]]
2609	set z [expr { $z % 3600 }]
2610	append retval [::format %02d [expr { $z / 60 }]]
2611	set z [expr { $z % 60 }]
2612	if { $z != 0 } {
2613	append retval [::format %02d $z]
2614	}
2615	return $retval
2616
2617	}
2618
2619	#----------------------------------------------------------------------
2620	#
2621	# FormatStarDate --
2622	#
2623	# Formats a date as a StarDate.
2624	#
2625	# Parameters:
2626	# date - Dictionary containing 'year', 'dayOfYear', and
2627	# 'localSeconds' fields.
2628	#
2629	# Results:
2630	# Returns the given date formatted as a StarDate.
2631	#
2632	# Side effects:
2633	# None.
2634	#
2635	# Jeff Hobbs put this in to support an atrocious pun about Tcl being
2636	# "Enterprise ready." Now we're stuck with it.
2637	#
2638	#----------------------------------------------------------------------
2639
2640	proc ::tcl::clock::FormatStarDate { date } {
2641
2642	variable Roddenberry
2643
2644	# Get day of year, zero based
2645
2646	set doy [expr { [dict get $date dayOfYear] - 1 }]
2647
2648	# Determine whether the year is a leap year
2649
2650	set lp [IsGregorianLeapYear $date]
2651
2652	# Convert day of year to a fractional year
2653
2654	if { $lp } {
2655	set fractYear [expr { 1000 * $doy / 366 }]
2656	} else {
2657	set fractYear [expr { 1000 * $doy / 365 }]
2658	}
2659
2660	# Put together the StarDate
2661
2662	return [::format "Stardate %02d%03d.%1d" \
2663	[expr { [dict get $date year] - $Roddenberry }] \
2664	$fractYear \
2665	[expr { [dict get $date localSeconds] % 86400
2666	/ ( 86400 / 10 ) }]]
2667	}
2668
2669	#----------------------------------------------------------------------
2670	#
2671	# ParseStarDate --
2672	#
2673	# Parses a StarDate
2674	#
2675	# Parameters:
2676	# year - Year from the Roddenberry epoch
2677	# fractYear - Fraction of a year specifiying the day of year.
2678	# fractDay - Fraction of a day
2679	#
2680	# Results:
2681	# Returns a count of seconds from the Posix epoch.
2682	#
2683	# Side effects:
2684	# None.
2685	#
2686	# Jeff Hobbs put this in to support an atrocious pun about Tcl being
2687	# "Enterprise ready." Now we're stuck with it.
2688	#
2689	#----------------------------------------------------------------------
2690
2691	proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
2692
2693	variable Roddenberry
2694
2695	# Build a tentative date from year and fraction.
2696
2697	set date [dict create \
2698	gregorian 1 \
2699	era CE \
2700	year [expr { $year + $Roddenberry }] \
2701	dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
2702	set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
2703
2704	# Determine whether the given year is a leap year
2705
2706	set lp [IsGregorianLeapYear $date]
2707
2708	# Reconvert the fractional year according to whether the given
2709	# year is a leap year
2710
2711	if { $lp } {
2712	dict set date dayOfYear \
2713	[expr { $fractYear * 366 / 1000 + 1 }]
2714	} else {
2715	dict set date dayOfYear \
2716	[expr { $fractYear * 365 / 1000 + 1 }]
2717	}
2718	dict unset date julianDay
2719	dict unset date gregorian
2720	set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
2721
2722	return [expr { 86400 * [dict get $date julianDay]
2723	- 210866803200
2724	+ ( 86400 / 10 ) * $fractDay }]
2725
2726	}
2727
2728	#----------------------------------------------------------------------
2729	#
2730	# ScanWide --
2731	#
2732	# Scans a wide integer from an input
2733	#
2734	# Parameters:
2735	# str - String containing a decimal wide integer
2736	#
2737	# Results:
2738	# Returns the string as a pure wide integer. Throws an error if
2739	# the string is misformatted or out of range.
2740	#
2741	#----------------------------------------------------------------------
2742
2743	proc ::tcl::clock::ScanWide { str } {
2744	set count [::scan $str {%ld %c} result junk]
2745	if { $count != 1 } {
2746	return -code error -errorcode [list CLOCK notAnInteger $str] \
2747	"\"$str\" is not an integer"
2748	}
2749	if { [incr result 0] != $str } {
2750	return -code error -errorcode [list CLOCK integervalueTooLarge] \
2751	"integer value too large to represent"
2752	}
2753	return $result
2754	}
2755
2756	#----------------------------------------------------------------------
2757	#
2758	# InterpretTwoDigitYear --
2759	#
2760	# Given a date that contains only the year of the century,
2761	# determines the target value of a two-digit year.
2762	#
2763	# Parameters:
2764	# date - Dictionary containing fields of the date.
2765	# baseTime - Base time relative to which the date is expressed.
2766	# twoDigitField - Name of the field that stores the two-digit year.
2767	# Default is 'yearOfCentury'
2768	# fourDigitField - Name of the field that will receive the four-digit
2769	# year. Default is 'year'
2770	#
2771	# Results:
2772	# Returns the dictionary augmented with the four-digit year, stored in
2773	# the given key.
2774	#
2775	# Side effects:
2776	# None.
2777	#
2778	# The current rule for interpreting a two-digit year is that the year
2779	# shall be between 1937 and 2037, thus staying within the range of a
2780	# 32-bit signed value for time. This rule may change to a sliding
2781	# window in future versions, so the 'baseTime' parameter (which is
2782	# currently ignored) is provided in the procedure signature.
2783	#
2784	#----------------------------------------------------------------------
2785
2786	proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
2787	{ twoDigitField yearOfCentury }
2788	{ fourDigitField year } } {
2789
2790	set yr [dict get $date $twoDigitField]
2791	if { $yr <= 37 } {
2792	dict set date $fourDigitField [expr { $yr + 2000 }]
2793	} else {
2794	dict set date $fourDigitField [expr { $yr + 1900 }]
2795	}
2796	return $date
2797
2798	}
2799
2800	#----------------------------------------------------------------------
2801	#
2802	# AssignBaseYear --
2803	#
2804	# Places the number of the current year into a dictionary.
2805	#
2806	# Parameters:
2807	# date - Dictionary value to update
2808	# baseTime - Base time from which to extract the year, expressed
2809	# in seconds from the Posix epoch
2810	# timezone - the time zone in which the date is being scanned
2811	# changeover - the Julian Day on which the Gregorian calendar
2812	# was adopted in the target locale.
2813	#
2814	# Results:
2815	# Returns the dictionary with the current year assigned.
2816	#
2817	# Side effects:
2818	# None.
2819	#
2820	#----------------------------------------------------------------------
2821
2822	proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
2823
2824	variable TZData
2825
2826	# Find the Julian Day Number corresponding to the base time, and
2827	# find the Gregorian year corresponding to that Julian Day.
2828
2829	set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
2830
2831	# Store the converted year
2832
2833	dict set date era [dict get $date2 era]
2834	dict set date year [dict get $date2 year]
2835
2836	return $date
2837
2838	}
2839
2840	#----------------------------------------------------------------------
2841	#
2842	# AssignBaseIso8601Year --
2843	#
2844	# Determines the base year in the ISO8601 fiscal calendar.
2845	#
2846	# Parameters:
2847	# date - Dictionary containing the fields of the date that
2848	# is to be augmented with the base year.
2849	# baseTime - Base time expressed in seconds from the Posix epoch.
2850	# timeZone - Target time zone
2851	# changeover - Julian Day of adoption of the Gregorian calendar in
2852	# the target locale.
2853	#
2854	# Results:
2855	# Returns the given date with "iso8601Year" set to the
2856	# base year.
2857	#
2858	# Side effects:
2859	# None.
2860	#
2861	#----------------------------------------------------------------------
2862
2863	proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
2864
2865	variable TZData
2866
2867	# Find the Julian Day Number corresponding to the base time
2868
2869	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
2870
2871	# Calculate the ISO8601 date and transfer the year
2872
2873	dict set date era CE
2874	dict set date iso8601Year [dict get $date2 iso8601Year]
2875	return $date
2876	}
2877
2878	#----------------------------------------------------------------------
2879	#
2880	# AssignBaseMonth --
2881	#
2882	# Places the number of the current year and month into a
2883	# dictionary.
2884	#
2885	# Parameters:
2886	# date - Dictionary value to update
2887	# baseTime - Time from which the year and month are to be
2888	# obtained, expressed in seconds from the Posix epoch.
2889	# timezone - Name of the desired time zone
2890	# changeover - Julian Day on which the Gregorian calendar was adopted.
2891	#
2892	# Results:
2893	# Returns the dictionary with the base year and month assigned.
2894	#
2895	# Side effects:
2896	# None.
2897	#
2898	#----------------------------------------------------------------------
2899
2900	proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
2901
2902	variable TZData
2903
2904	# Find the year and month corresponding to the base time
2905
2906	set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
2907	dict set date era [dict get $date2 era]
2908	dict set date year [dict get $date2 year]
2909	dict set date month [dict get $date2 month]
2910	return $date
2911
2912	}
2913
2914	#----------------------------------------------------------------------
2915	#
2916	# AssignBaseWeek --
2917	#
2918	# Determines the base year and week in the ISO8601 fiscal calendar.
2919	#
2920	# Parameters:
2921	# date - Dictionary containing the fields of the date that
2922	# is to be augmented with the base year and week.
2923	# baseTime - Base time expressed in seconds from the Posix epoch.
2924	# changeover - Julian Day on which the Gregorian calendar was adopted
2925	# in the target locale.
2926	#
2927	# Results:
2928	# Returns the given date with "iso8601Year" set to the
2929	# base year and "iso8601Week" to the week number.
2930	#
2931	# Side effects:
2932	# None.
2933	#
2934	#----------------------------------------------------------------------
2935
2936	proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
2937
2938	variable TZData
2939
2940	# Find the Julian Day Number corresponding to the base time
2941
2942	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
2943
2944	# Calculate the ISO8601 date and transfer the year
2945
2946	dict set date era CE
2947	dict set date iso8601Year [dict get $date2 iso8601Year]
2948	dict set date iso8601Week [dict get $date2 iso8601Week]
2949	return $date
2950	}
2951
2952	#----------------------------------------------------------------------
2953	#
2954	# AssignBaseJulianDay --
2955	#
2956	# Determines the base day for a time-of-day conversion.
2957	#
2958	# Parameters:
2959	# date - Dictionary that is to get the base day
2960	# baseTime - Base time expressed in seconds from the Posix epoch
2961	# changeover - Julian day on which the Gregorian calendar was
2962	# adpoted in the target locale.
2963	#
2964	# Results:
2965	# Returns the given dictionary augmented with a 'julianDay' field
2966	# that contains the base day.
2967	#
2968	# Side effects:
2969	# None.
2970	#
2971	#----------------------------------------------------------------------
2972
2973	proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
2974
2975	variable TZData
2976
2977	# Find the Julian Day Number corresponding to the base time
2978
2979	set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
2980	dict set date julianDay [dict get $date2 julianDay]
2981
2982	return $date
2983	}
2984
2985	#----------------------------------------------------------------------
2986	#
2987	# InterpretHMSP --
2988	#
2989	# Interprets a time in the form "hh:mm:ss am".
2990	#
2991	# Parameters:
2992	# date -- Dictionary containing "hourAMPM", "minute", "second"
2993	# and "amPmIndicator" fields.
2994	#
2995	# Results:
2996	# Returns the number of seconds from local midnight.
2997	#
2998	# Side effects:
2999	# None.
3000	#
3001	#----------------------------------------------------------------------
3002
3003	proc ::tcl::clock::InterpretHMSP { date } {
3004
3005	set hr [dict get $date hourAMPM]
3006	if { $hr == 12 } {
3007	set hr 0
3008	}
3009	if { [dict get $date amPmIndicator] } {
3010	incr hr 12
3011	}
3012	dict set date hour $hr
3013	return [InterpretHMS $date[set date {}]]
3014
3015	}
3016
3017	#----------------------------------------------------------------------
3018	#
3019	# InterpretHMS --
3020	#
3021	# Interprets a 24-hour time "hh:mm:ss"
3022	#
3023	# Parameters:
3024	# date -- Dictionary containing the "hour", "minute" and "second"
3025	# fields.
3026	#
3027	# Results:
3028	# Returns the given dictionary augmented with a "secondOfDay"
3029	# field containing the number of seconds from local midnight.
3030	#
3031	# Side effects:
3032	# None.
3033	#
3034	#----------------------------------------------------------------------
3035
3036	proc ::tcl::clock::InterpretHMS { date } {
3037
3038	return [expr { ( [dict get $date hour] * 60
3039	+ [dict get $date minute] ) * 60
3040	+ [dict get $date second] }]
3041
3042	}
3043
3044	#----------------------------------------------------------------------
3045	#
3046	# GetSystemTimeZone --
3047	#
3048	# Determines the system time zone, which is the default for the
3049	# 'clock' command if no other zone is supplied.
3050	#
3051	# Parameters:
3052	# None.
3053	#
3054	# Results:
3055	# Returns the system time zone.
3056	#
3057	# Side effects:
3058	# Stores the sustem time zone in the 'CachedSystemTimeZone'
3059	# variable, since determining it may be an expensive process.
3060	#
3061	#----------------------------------------------------------------------
3062
3063	proc ::tcl::clock::GetSystemTimeZone {} {
3064
3065	variable CachedSystemTimeZone
3066	variable TimeZoneBad
3067
3068	if {[set result [getenv TCL_TZ]] ne {}} {
3069	set timezone $result
3070	} elseif {[set result [getenv TZ]] ne {}} {
3071	set timezone $result
3072	} elseif { [info exists CachedSystemTimeZone] } {
3073	set timezone $CachedSystemTimeZone
3074	} elseif { $::tcl_platform(platform) eq {windows} } {
3075	set timezone [GuessWindowsTimeZone]
3076	} elseif { [file exists /etc/localtime]
3077	&& ![catch {ReadZoneinfoFile \
3078	Tcl/Localtime /etc/localtime}] } {
3079	set timezone :Tcl/Localtime
3080	} else {
3081	set timezone :localtime
3082	}
3083	set CachedSystemTimeZone $timezone
3084	if { ![dict exists $TimeZoneBad $timezone] } {
3085	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
3086	}
3087	if { [dict get $TimeZoneBad $timezone] } {
3088	return :localtime
3089	} else {
3090	return $timezone
3091	}
3092
3093	}
3094
3095	#----------------------------------------------------------------------
3096	#
3097	# ConvertLegacyTimeZone --
3098	#
3099	# Given an alphanumeric time zone identifier and the system
3100	# time zone, convert the alphanumeric identifier to an
3101	# unambiguous time zone.
3102	#
3103	# Parameters:
3104	# tzname - Name of the time zone to convert
3105	#
3106	# Results:
3107	# Returns a time zone name corresponding to tzname, but
3108	# in an unambiguous form, generally +hhmm.
3109	#
3110	# This procedure is implemented primarily to allow the parsing of
3111	# RFC822 date/time strings. Processing a time zone name on input
3112	# is not recommended practice, because there is considerable room
3113	# for ambiguity; for instance, is BST Brazilian Standard Time, or
3114	# British Summer Time?
3115	#
3116	#----------------------------------------------------------------------
3117
3118	proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
3119
3120	variable LegacyTimeZone
3121
3122	set tzname [string tolower $tzname]
3123	if { ![dict exists $LegacyTimeZone $tzname] } {
3124	return -code error -errorcode [list CLOCK badTZName $tzname] \
3125	"time zone \"$tzname\" not found"
3126	} else {
3127	return [dict get $LegacyTimeZone $tzname]
3128	}
3129
3130	}
3131
3132	#----------------------------------------------------------------------
3133	#
3134	# SetupTimeZone --
3135	#
3136	# Given the name or specification of a time zone, sets up
3137	# its in-memory data.
3138	#
3139	# Parameters:
3140	# tzname - Name of a time zone
3141	#
3142	# Results:
3143	# Unless the time zone is ':localtime', sets the TZData array
3144	# to contain the lookup table for local<->UTC conversion.
3145	# Returns an error if the time zone cannot be parsed.
3146	#
3147	#----------------------------------------------------------------------
3148
3149	proc ::tcl::clock::SetupTimeZone { timezone } {
3150
3151	variable TZData
3152
3153	if {! [info exists TZData($timezone)] } {
3154	variable MINWIDE
3155	if { $timezone eq {:localtime} } {
3156
3157	# Nothing to do, we'll convert using the localtime function
3158
3159	} elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
3160	-> s hh mm ss] } {
3161
3162	# Make a fixed offset
3163
3164	::scan $hh %d hh
3165	if { $mm eq {} } {
3166	set mm 0
3167	} else {
3168	::scan $mm %d mm
3169	}
3170	if { $ss eq {} } {
3171	set ss 0
3172	} else {
3173	::scan $ss %d ss
3174	}
3175	set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
3176	if { $s eq {-} } {
3177	set offset [expr { - $offset }]
3178	}
3179	set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
3180
3181	} elseif { [string index $timezone 0] eq {:} } {
3182
3183	# Convert using a time zone file
3184
3185	if {
3186	[catch {
3187	LoadTimeZoneFile [string range $timezone 1 end]
3188	}]
3189	&& [catch {
3190	LoadZoneinfoFile [string range $timezone 1 end]
3191	}]
3192	} {
3193	return -code error \
3194	-errorcode [list CLOCK badTimeZone $timezone] \
3195	"time zone \"$timezone\" not found"
3196	}
3197
3198	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
3199
3200	# This looks like a POSIX time zone - try to process it
3201
3202	if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
3203	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
3204	dict unset opts -errorinfo
3205	}
3206	return -options $opts $data
3207	} else {
3208	set TZData($timezone) $data
3209	}
3210
3211	} else {
3212
3213	# We couldn't parse this as a POSIX time zone. Try
3214	# again with a time zone file - this time without a colon
3215
3216	if { [catch { LoadTimeZoneFile $timezone }]
3217	&& [catch { ZoneinfoFile $timezone } - opts] } {
3218	dict unset opts -errorinfo
3219	return -options $opts "time zone $timezone not found"
3220	}
3221	set TZData($timezone) $TZData(:$timezone)
3222	}
3223	}
3224
3225	return
3226	}
3227
3228	#----------------------------------------------------------------------
3229	#
3230	# GuessWindowsTimeZone --
3231	#
3232	# Determines the system time zone on windows.
3233	#
3234	# Parameters:
3235	# None.
3236	#
3237	# Results:
3238	# Returns a time zone specifier that corresponds to the system
3239	# time zone information found in the Registry.
3240	#
3241	# Bugs:
3242	# Fixed dates for DST change are unimplemented at present, because
3243	# no time zone information supplied with Windows actually uses
3244	# them!
3245	#
3246	# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is
3247	# specified, GuessWindowsTimeZone looks in the Registry for the
3248	# system time zone information. It then attempts to find an entry
3249	# in WinZoneInfo for a time zone that uses the same rules. If
3250	# it finds one, it returns it; otherwise, it constructs a Posix-style
3251	# time zone string and returns that.
3252	#
3253	#----------------------------------------------------------------------
3254
3255	proc ::tcl::clock::GuessWindowsTimeZone {} {
3256
3257	variable WinZoneInfo
3258	variable NoRegistry
3259	variable TimeZoneBad
3260
3261	if { [info exists NoRegistry] } {
3262	return :localtime
3263	}
3264
3265	# Dredge time zone information out of the registry
3266
3267	if { [catch {
3268	set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
3269	set data [list \
3270	[expr { -60
3271	* [registry get $rpath Bias] }] \
3272	[expr { -60
3273	* [registry get $rpath StandardBias] }] \
3274	[expr { -60 \
3275	* [registry get $rpath DaylightBias] }]]
3276	set stdtzi [registry get $rpath StandardStart]
3277	foreach ind {0 2 14 4 6 8 10 12} {
3278	binary scan $stdtzi @${ind}s val
3279	lappend data $val
3280	}
3281	set daytzi [registry get $rpath DaylightStart]
3282	foreach ind {0 2 14 4 6 8 10 12} {
3283	binary scan $daytzi @${ind}s val
3284	lappend data $val
3285	}
3286	}] } {
3287
3288	# Missing values in the Registry - bail out
3289
3290	return :localtime
3291	}
3292
3293	# Make up a Posix time zone specifier if we can't find one.
3294	# Check here that the tzdata file exists, in case we're running
3295	# in an environment (e.g. starpack) where tzdata is incomplete.
3296	# (Bug 1237907)
3297
3298	if { [dict exists $WinZoneInfo $data] } {
3299	set tzname [dict get $WinZoneInfo $data]
3300	if { ! [dict exists $TimeZoneBad $tzname] } {
3301	dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
3302	}
3303	} else {
3304	set tzname {}
3305	}
3306	if { $tzname eq {} \|\| [dict get $TimeZoneBad $tzname] } {
3307	lassign $data \
3308	bias stdBias dstBias \
3309	stdYear stdMonth stdDayOfWeek stdDayOfMonth \
3310	stdHour stdMinute stdSecond stdMillisec \
3311	dstYear dstMonth dstDayOfWeek dstDayOfMonth \
3312	dstHour dstMinute dstSecond dstMillisec
3313	set stdDelta [expr { $bias + $stdBias }]
3314	set dstDelta [expr { $bias + $dstBias }]
3315	if { $stdDelta <= 0 } {
3316	set stdSignum +
3317	set stdDelta [expr { - $stdDelta }]
3318	set dispStdSignum -
3319	} else {
3320	set stdSignum -
3321	set dispStdSignum +
3322	}
3323	set hh [::format %02d [expr { $stdDelta / 3600 }]]
3324	set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
3325	set ss [::format %02d [expr { $stdDelta % 60 }]]
3326	set tzname {}
3327	append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
3328	if { $stdMonth >= 0 } {
3329	if { $dstDelta <= 0 } {
3330	set dstSignum +
3331	set dstDelta [expr { - $dstDelta }]
3332	set dispDstSignum -
3333	} else {
3334	set dstSignum -
3335	set dispDstSignum +
3336	}
3337	set hh [::format %02d [expr { $dstDelta / 3600 }]]
3338	set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
3339	set ss [::format %02d [expr { $dstDelta % 60 }]]
3340	append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
3341	if { $dstYear == 0 } {
3342	append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
3343	} else {
3344	# I have not been able to find any locale on which
3345	# Windows converts time zone on a fixed day of the year,
3346	# hence don't know how to interpret the fields.
3347	# If someone can inform me, I'd be glad to code it up.
3348	# For right now, we bail out in such a case.
3349	return :localtime
3350	}
3351	append tzname / [::format %02d $dstHour] \
3352	: [::format %02d $dstMinute] \
3353	: [::format %02d $dstSecond]
3354	if { $stdYear == 0 } {
3355	append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
3356	} else {
3357	# I have not been able to find any locale on which
3358	# Windows converts time zone on a fixed day of the year,
3359	# hence don't know how to interpret the fields.
3360	# If someone can inform me, I'd be glad to code it up.
3361	# For right now, we bail out in such a case.
3362	return :localtime
3363	}
3364	append tzname / [::format %02d $stdHour] \
3365	: [::format %02d $stdMinute] \
3366	: [::format %02d $stdSecond]
3367	}
3368	dict set WinZoneInfo $data $tzname
3369	}
3370
3371	return [dict get $WinZoneInfo $data]
3372
3373	}
3374
3375	#----------------------------------------------------------------------
3376	#
3377	# LoadTimeZoneFile --
3378	#
3379	# Load the data file that specifies the conversion between a
3380	# given time zone and Greenwich.
3381	#
3382	# Parameters:
3383	# fileName -- Name of the file to load
3384	#
3385	# Results:
3386	# None.
3387	#
3388	# Side effects:
3389	# TZData(:fileName) contains the time zone data
3390	#
3391	#----------------------------------------------------------------------
3392
3393	proc ::tcl::clock::LoadTimeZoneFile { fileName } {
3394	variable DataDir
3395	variable TZData
3396
3397	if { [info exists TZData($fileName)] } {
3398	return
3399	}
3400
3401	# Since an unsafe interp uses the [clock] command in the master,
3402	# this code is security sensitive. Make sure that the path name
3403	# cannot escape the given directory.
3404
3405	if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
3406	return -code error \
3407	-errorcode [list CLOCK badTimeZone $:fileName] \
3408	"time zone \":$fileName\" not valid"
3409	}
3410	if { [catch {
3411	source -encoding utf-8 [file join $DataDir $fileName]
3412	}] } {
3413	return -code error \
3414	-errorcode [list CLOCK badTimeZone :$fileName] \
3415	"time zone \":$fileName\" not found"
3416	}
3417	return
3418	}
3419
3420	#----------------------------------------------------------------------
3421	#
3422	# LoadZoneinfoFile --
3423	#
3424	# Loads a binary time zone information file in Olson format.
3425	#
3426	# Parameters:
3427	# fileName - Relative path name of the file to load.
3428	#
3429	# Results:
3430	# Returns an empty result normally; returns an error if no
3431	# Olson file was found or the file was malformed in some way.
3432	#
3433	# Side effects:
3434	# TZData(:fileName) contains the time zone data
3435	#
3436	#----------------------------------------------------------------------
3437
3438	proc ::tcl::clock::LoadZoneinfoFile { fileName } {
3439
3440	variable ZoneinfoPaths
3441
3442	# Since an unsafe interp uses the [clock] command in the master,
3443	# this code is security sensitive. Make sure that the path name
3444	# cannot escape the given directory.
3445
3446	if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
3447	return -code error \
3448	-errorcode [list CLOCK badTimeZone $:fileName] \
3449	"time zone \":$fileName\" not valid"
3450	}
3451	foreach d $ZoneinfoPaths {
3452	set fname [file join $d $fileName]
3453	if { [file readable $fname] && [file isfile $fname] } {
3454	break
3455	}
3456	unset fname
3457	}
3458	ReadZoneinfoFile $fileName $fname
3459	}
3460
3461	#----------------------------------------------------------------------
3462	#
3463	# ReadZoneinfoFile --
3464	#
3465	# Loads a binary time zone information file in Olson format.
3466	#
3467	# Parameters:
3468	# fileName - Name of the time zone (relative path name of the
3469	# file).
3470	# fname - Absolute path name of the file.
3471	#
3472	# Results:
3473	# Returns an empty result normally; returns an error if no
3474	# Olson file was found or the file was malformed in some way.
3475	#
3476	# Side effects:
3477	# TZData(:fileName) contains the time zone data
3478	#
3479	#----------------------------------------------------------------------
3480
3481
3482	proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
3483	variable MINWIDE
3484	variable TZData
3485	if { ![info exists fname] } {
3486	return -code error "$fileName not found"
3487	}
3488
3489	if { [file size $fname] > 262144 } {
3490	return -code error "$fileName too big"
3491	}
3492
3493	# Suck in all the data from the file
3494
3495	set f [open $fname r]
3496	fconfigure $f -translation binary
3497	set d [read $f]
3498	close $f
3499
3500	# The file begins with a magic number, sixteen reserved bytes,
3501	# and then six 4-byte integers giving counts of fileds in the file.
3502
3503	binary scan $d a4a1x15IIIIII \
3504	magic version nIsGMT nIsStd nLeap nTime nType nChar
3505	set seek 44
3506	set ilen 4
3507	set iformat I
3508	if { $magic != {TZif} } {
3509	return -code error "$fileName not a time zone information file"
3510	}
3511	if { $nType > 255 } {
3512	return -code error "$fileName contains too many time types"
3513	}
3514	# Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots.
3515	if { $nLeap != 0 } {
3516	return -code error "$fileName contains leap seconds"
3517	}
3518
3519	# In a version 2 file, we use the second part of the file, which
3520	# contains 64-bit transition times.
3521
3522	if {$version eq "2"} {
3523	set seek [expr {44
3524	+ 5 * $nTime
3525	+ 6 * $nType
3526	+ 4 * $nLeap
3527	+ $nIsStd
3528	+ $nIsGMT
3529	+ $nChar
3530	}]
3531	binary scan $d @${seek}a4a1x15IIIIII \
3532	magic version nIsGMT nIsStd nLeap nTime nType nChar
3533	if {$magic ne {TZif}} {
3534	return -code error "seek address $seek miscomputed, magic = $magic"
3535	}
3536	set iformat W
3537	set ilen 8
3538	incr seek 44
3539	}
3540
3541	# Next come ${nTime} transition times, followed by ${nTime} time type
3542	# codes. The type codes are unsigned 1-byte quantities. We insert an
3543	# arbitrary start time in front of the transitions.
3544
3545	binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
3546	incr seek [expr { ($ilen + 1) * $nTime }]
3547	set times [linsert $times 0 $MINWIDE]
3548	set codes {}
3549	foreach c $tempCodes {
3550	lappend codes [expr { $c & 0xff }]
3551	}
3552	set codes [linsert $codes 0 0]
3553
3554	# Next come ${nType} time type descriptions, each of which has an
3555	# offset (seconds east of GMT), a DST indicator, and an index into
3556	# the abbreviation text.
3557
3558	for { set i 0 } { $i < $nType } { incr i } {
3559	binary scan $d @${seek}Icc gmtOff isDst abbrInd
3560	lappend types [list $gmtOff $isDst $abbrInd]
3561	incr seek 6
3562	}
3563
3564	# Next come $nChar characters of time zone name abbreviations,
3565	# which are null-terminated.
3566	# We build them up into a dictionary indexed by character index,
3567	# because that's what's in the indices above.
3568
3569	binary scan $d @${seek}a${nChar} abbrs
3570	incr seek ${nChar}
3571	set abbrList [split $abbrs \0]
3572	set i 0
3573	set abbrevs {}
3574	foreach a $abbrList {
3575	dict set abbrevs $i $a
3576	incr i [expr { [string length $a] + 1 }]
3577	}
3578
3579	# Package up a list of tuples, each of which contains transition time,
3580	# seconds east of Greenwich, DST flag and time zone abbreviation.
3581
3582	set r {}
3583	set lastTime $MINWIDE
3584	foreach t $times c $codes {
3585	if { $t < $lastTime } {
3586	return -code error "$fileName has times out of order"
3587	}
3588	set lastTime $t
3589	lassign [lindex $types $c] gmtoff isDst abbrInd
3590	set abbrev [dict get $abbrevs $abbrInd]
3591	lappend r [list $t $gmtoff $isDst $abbrev]
3592	}
3593
3594	# In a version 2 file, there is also a POSIX-style time zone description
3595	# at the very end of the file. To get to it, skip over
3596	# nLeap leap second values (8 bytes each),
3597	# nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
3598
3599	if {$version eq {2}} {
3600	set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
3601	set last [string first \n $d $seek]
3602	set posix [string range $d $seek [expr {$last-1}]]
3603	if {[llength $posix] > 0} {
3604	set posixFields [ParsePosixTimeZone $posix]
3605	foreach tuple [ProcessPosixTimeZone $posixFields] {
3606	lassign $tuple t gmtoff isDst abbrev
3607	if {$t > $lastTime} {
3608	lappend r $tuple
3609	}
3610	}
3611	}
3612	}
3613
3614	set TZData(:$fileName) $r
3615
3616	return
3617	}
3618
3619	#----------------------------------------------------------------------
3620	#
3621	# ParsePosixTimeZone --
3622	#
3623	# Parses the TZ environment variable in Posix form
3624	#
3625	# Parameters:
3626	# tz Time zone specifier to be interpreted
3627	#
3628	# Results:
3629	# Returns a dictionary whose values contain the various pieces of
3630	# the time zone specification.
3631	#
3632	# Side effects:
3633	# None.
3634	#
3635	# Errors:
3636	# Throws an error if the syntax of the time zone is incorrect.
3637	#
3638	# The following keys are present in the dictionary:
3639	# stdName - Name of the time zone when Daylight Saving Time
3640	# is not in effect.
3641	# stdSignum - Sign (+, -, or empty) of the offset from Greenwich
3642	# to the given (non-DST) time zone. + and the empty
3643	# string denote zones west of Greenwich, - denotes east
3644	# of Greenwich; this is contrary to the ISO convention
3645	# but follows Posix.
3646	# stdHours - Hours part of the offset from Greenwich to the given
3647	# (non-DST) time zone.
3648	# stdMinutes - Minutes part of the offset from Greenwich to the
3649	# given (non-DST) time zone. Empty denotes zero.
3650	# stdSeconds - Seconds part of the offset from Greenwich to the
3651	# given (non-DST) time zone. Empty denotes zero.
3652	# dstName - Name of the time zone when DST is in effect, or the
3653	# empty string if the time zone does not observe Daylight
3654	# Saving Time.
3655	# dstSignum, dstHours, dstMinutes, dstSeconds -
3656	# Fields corresponding to stdSignum, stdHours, stdMinutes,
3657	# stdSeconds for the Daylight Saving Time version of the
3658	# time zone. If dstHours is empty, it is presumed to be 1.
3659	# startDayOfYear - The ordinal number of the day of the year on which
3660	# Daylight Saving Time begins. If this field is
3661	# empty, then DST begins on a given month-week-day,
3662	# as below.
3663	# startJ - The letter J, or an empty string. If a J is present in
3664	# this field, then startDayOfYear does not count February 29
3665	# even in leap years.
3666	# startMonth - The number of the month in which Daylight Saving Time
3667	# begins, supplied if startDayOfYear is empty. If both
3668	# startDayOfYear and startMonth are empty, then US rules
3669	# are presumed.
3670	# startWeekOfMonth - The number of the week in the month in which
3671	# Daylight Saving Time begins, in the range 1-5.
3672	# 5 denotes the last week of the month even in a
3673	# 4-week month.
3674	# startDayOfWeek - The number of the day of the week (Sunday=0,
3675	# Saturday=6) on which Daylight Saving Time begins.
3676	# startHours - The hours part of the time of day at which Daylight
3677	# Saving Time begins. An empty string is presumed to be 2.
3678	# startMinutes - The minutes part of the time of day at which DST begins.
3679	# An empty string is presumed zero.
3680	# startSeconds - The seconds part of the time of day at which DST begins.
3681	# An empty string is presumed zero.
3682	# endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
3683	# endHours, endMinutes, endSeconds -
3684	# Specify the end of DST in the same way that the start* fields
3685	# specify the beginning of DST.
3686	#
3687	# This procedure serves only to break the time specifier into fields.
3688	# No attempt is made to canonicalize the fields or supply default values.
3689	#
3690	#----------------------------------------------------------------------
3691
3692	proc ::tcl::clock::ParsePosixTimeZone { tz } {
3693
3694	if {[regexp -expanded -nocase -- {
3695	^
3696	# 1 - Standard time zone name
3697	([[:alpha:]]+ \| <[-+[:alnum:]]+>)
3698	# 2 - Standard time zone offset, signum
3699	([-+]?)
3700	# 3 - Standard time zone offset, hours
3701	([[:digit:]]{1,2})
3702	(?:
3703	# 4 - Standard time zone offset, minutes
3704	: ([[:digit:]]{1,2})
3705	(?:
3706	# 5 - Standard time zone offset, seconds
3707	: ([[:digit:]]{1,2} )
3708	)?
3709	)?
3710	(?:
3711	# 6 - DST time zone name
3712	([[:alpha:]]+ \| <[-+[:alnum:]]+>)
3713	(?:
3714	(?:
3715	# 7 - DST time zone offset, signum
3716	([-+]?)
3717	# 8 - DST time zone offset, hours
3718	([[:digit:]]{1,2})
3719	(?:
3720	# 9 - DST time zone offset, minutes
3721	: ([[:digit:]]{1,2})
3722	(?:
3723	# 10 - DST time zone offset, seconds
3724	: ([[:digit:]]{1,2})
3725	)?
3726	)?
3727	)?
3728	(?:
3729	,
3730	(?:
3731	# 11 - Optional J in n and Jn form 12 - Day of year
3732	( J ? ) ( [[:digit:]]+ )
3733	\| M
3734	# 13 - Month number 14 - Week of month 15 - Day of week
3735	( [[:digit:]] + )
3736	[.] ( [[:digit:]] + )
3737	[.] ( [[:digit:]] + )
3738	)
3739	(?:
3740	# 16 - Start time of DST - hours
3741	/ ( [[:digit:]]{1,2} )
3742	(?:
3743	# 17 - Start time of DST - minutes
3744	: ( [[:digit:]]{1,2} )
3745	(?:
3746	# 18 - Start time of DST - seconds
3747	: ( [[:digit:]]{1,2} )
3748	)?
3749	)?
3750	)?
3751	,
3752	(?:
3753	# 19 - Optional J in n and Jn form 20 - Day of year
3754	( J ? ) ( [[:digit:]]+ )
3755	\| M
3756	# 21 - Month number 22 - Week of month 23 - Day of week
3757	( [[:digit:]] + )
3758	[.] ( [[:digit:]] + )
3759	[.] ( [[:digit:]] + )
3760	)
3761	(?:
3762	# 24 - End time of DST - hours
3763	/ ( [[:digit:]]{1,2} )
3764	(?:
3765	# 25 - End time of DST - minutes
3766	: ( [[:digit:]]{1,2} )
3767	(?:
3768	# 26 - End time of DST - seconds
3769	: ( [[:digit:]]{1,2} )
3770	)?
3771	)?
3772	)?
3773	)?
3774	)?
3775	)?
3776	$
3777	} $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
3778	x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
3779	x(startJ) x(startDayOfYear) \
3780	x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
3781	x(startHours) x(startMinutes) x(startSeconds) \
3782	x(endJ) x(endDayOfYear) \
3783	x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
3784	x(endHours) x(endMinutes) x(endSeconds)] } {
3785
3786	# it's a good timezone
3787
3788	return [array get x]
3789
3790	} else {
3791
3792	return -code error\
3793	-errorcode [list CLOCK badTimeZone $tz] \
3794	"unable to parse time zone specification \"$tz\""
3795
3796	}
3797
3798	}
3799
3800	#----------------------------------------------------------------------
3801	#
3802	# ProcessPosixTimeZone --
3803	#
3804	# Handle a Posix time zone after it's been broken out into
3805	# fields.
3806	#
3807	# Parameters:
3808	# z - Dictionary returned from 'ParsePosixTimeZone'
3809	#
3810	# Results:
3811	# Returns time zone information for the 'TZData' array.
3812	#
3813	# Side effects:
3814	# None.
3815	#
3816	#----------------------------------------------------------------------
3817
3818	proc ::tcl::clock::ProcessPosixTimeZone { z } {
3819
3820	variable MINWIDE
3821	variable TZData
3822
3823	# Determine the standard time zone name and seconds east of Greenwich
3824
3825	set stdName [dict get $z stdName]
3826	if { [string index $stdName 0] eq {<} } {
3827	set stdName [string range $stdName 1 end-1]
3828	}
3829	if { [dict get $z stdSignum] eq {-} } {
3830	set stdSignum +1
3831	} else {
3832	set stdSignum -1
3833	}
3834	set stdHours [lindex [::scan [dict get $z stdHours] %d] 0]
3835	if { [dict get $z stdMinutes] ne {} } {
3836	set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0]
3837	} else {
3838	set stdMinutes 0
3839	}
3840	if { [dict get $z stdSeconds] ne {} } {
3841	set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0]
3842	} else {
3843	set stdSeconds 0
3844	}
3845	set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes )
3846	* 60 + $stdSeconds )
3847	* $stdSignum }]
3848	set data [list [list $MINWIDE $stdOffset 0 $stdName]]
3849
3850	# If there's no daylight zone, we're done
3851
3852	set dstName [dict get $z dstName]
3853	if { $dstName eq {} } {
3854	return $data
3855	}
3856	if { [string index $dstName 0] eq {<} } {
3857	set dstName [string range $dstName 1 end-1]
3858	}
3859
3860	# Determine the daylight name
3861
3862	if { [dict get $z dstSignum] eq {-} } {
3863	set dstSignum +1
3864	} else {
3865	set dstSignum -1
3866	}
3867	if { [dict get $z dstHours] eq {} } {
3868	set dstOffset [expr { 3600 + $stdOffset }]
3869	} else {
3870	set dstHours [lindex [::scan [dict get $z dstHours] %d] 0]
3871	if { [dict get $z dstMinutes] ne {} } {
3872	set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0]
3873	} else {
3874	set dstMinutes 0
3875	}
3876	if { [dict get $z dstSeconds] ne {} } {
3877	set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0]
3878	} else {
3879	set dstSeconds 0
3880	}
3881	set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes )
3882	* 60 + $dstSeconds )
3883	* $dstSignum }]
3884	}
3885
3886	# Fill in defaults for US DST rules
3887
3888	if { [dict get $z startDayOfYear] eq {}
3889	&& [dict get $z startMonth] eq {} } {
3890	dict set z startMonth 3
3891	dict set z startWeekOfMonth 2
3892	dict set z startDayOfWeek 0
3893	dict set z startHours 2
3894	dict set z startMinutes 0
3895	dict set z startSeconds 0
3896	}
3897	if { [dict get $z endDayOfYear] eq {}
3898	&& [dict get $z endMonth] eq {} } {
3899	dict set z endMonth 11
3900	dict set z endWeekOfMonth 1
3901	dict set z endDayOfWeek 0
3902	dict set z endHours 2
3903	dict set z endMinutes 0
3904	dict set z endSeconds 0
3905	}
3906
3907	# Put DST in effect in all years from 1916 to 2099.
3908
3909	for { set y 1916 } { $y < 2099 } { incr y } {
3910	set startTime [DeterminePosixDSTTime $z start $y]
3911	incr startTime [expr { - wide($stdOffset) }]
3912	set endTime [DeterminePosixDSTTime $z end $y]
3913	incr endTime [expr { - wide($dstOffset) }]
3914	if { $startTime < $endTime } {
3915	lappend data \
3916	[list $startTime $dstOffset 1 $dstName] \
3917	[list $endTime $stdOffset 0 $stdName]
3918	} else {
3919	lappend data \
3920	[list $endTime $stdOffset 0 $stdName] \
3921	[list $startTime $dstOffset 1 $dstName]
3922	}
3923	}
3924
3925	return $data
3926
3927	}
3928
3929	#----------------------------------------------------------------------
3930	#
3931	# DeterminePosixDSTTime --
3932	#
3933	# Determines the time that Daylight Saving Time starts or ends
3934	# from a Posix time zone specification.
3935	#
3936	# Parameters:
3937	# z - Time zone data returned from ParsePosixTimeZone.
3938	# Missing fields are expected to be filled in with
3939	# default values.
3940	# bound - The word 'start' or 'end'
3941	# y - The year for which the transition time is to be determined.
3942	#
3943	# Results:
3944	# Returns the transition time as a count of seconds from
3945	# the epoch. The time is relative to the wall clock, not UTC.
3946	#
3947	#----------------------------------------------------------------------
3948
3949	proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
3950
3951	variable FEB_28
3952
3953	# Determine the start or end day of DST
3954
3955	set date [dict create era CE year $y]
3956	set doy [dict get $z ${bound}DayOfYear]
3957	if { $doy ne {} } {
3958
3959	# Time was specified as a day of the year
3960
3961	if { [dict get $z ${bound}J] ne {}
3962	&& [IsGregorianLeapYear $y]
3963	&& ( $doy > $FEB_28 ) } {
3964	incr doy
3965	}
3966	dict set date dayOfYear $doy
3967	set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
3968	} else {
3969
3970	# Time was specified as a day of the week within a month
3971
3972	dict set date month [dict get $z ${bound}Month]
3973	dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
3974	set dowim [dict get $z ${bound}WeekOfMonth]
3975	if { $dowim >= 5 } {
3976	set dowim -1
3977	}
3978	dict set date dayOfWeekInMonth $dowim
3979	set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
3980
3981	}
3982
3983	set jd [dict get $date julianDay]
3984	set seconds [expr { wide($jd) * wide(86400)
3985	- wide(210866803200) }]
3986
3987	set h [dict get $z ${bound}Hours]
3988	if { $h eq {} } {
3989	set h 2
3990	} else {
3991	set h [lindex [::scan $h %d] 0]
3992	}
3993	set m [dict get $z ${bound}Minutes]
3994	if { $m eq {} } {
3995	set m 0
3996	} else {
3997	set m [lindex [::scan $m %d] 0]
3998	}
3999	set s [dict get $z ${bound}Seconds]
4000	if { $s eq {} } {
4001	set s 0
4002	} else {
4003	set s [lindex [::scan $s %d] 0]
4004	}
4005	set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
4006	return [expr { $seconds + $tod }]
4007
4008	}
4009
4010	#----------------------------------------------------------------------
4011	#
4012	# GetLocaleEra --
4013	#
4014	# Given local time expressed in seconds from the Posix epoch,
4015	# determine localized era and year within the era.
4016	#
4017	# Parameters:
4018	# date - Dictionary that must contain the keys, 'localSeconds',
4019	# whose value is expressed as the appropriate local time;
4020	# and 'year', whose value is the Gregorian year.
4021	# etable - Value of the LOCALE_ERAS key in the message catalogue
4022	# for the target locale.
4023	#
4024	# Results:
4025	# Returns the dictionary, augmented with the keys, 'localeEra'
4026	# and 'localeYear'.
4027	#
4028	#----------------------------------------------------------------------
4029
4030	proc ::tcl::clock::GetLocaleEra { date etable } {
4031
4032	set index [BSearch $etable [dict get $date localSeconds]]
4033	if { $index < 0} {
4034	dict set date localeEra \
4035	[::format %02d [expr { [dict get $date year] / 100 }]]
4036	dict set date localeYear \
4037	[expr { [dict get $date year] % 100 }]
4038	} else {
4039	dict set date localeEra [lindex $etable $index 1]
4040	dict set date localeYear [expr { [dict get $date year]
4041	- [lindex $etable $index 2] }]
4042	}
4043	return $date
4044
4045	}
4046
4047	#----------------------------------------------------------------------
4048	#
4049	# GetJulianDayFromEraYearDay --
4050	#
4051	# Given a year, month and day on the Gregorian calendar, determines
4052	# the Julian Day Number beginning at noon on that date.
4053	#
4054	# Parameters:
4055	# date -- A dictionary in which the 'era', 'year', and
4056	# 'dayOfYear' slots are populated. The calendar in use
4057	# is determined by the date itself relative to:
4058	# changeover -- Julian day on which the Gregorian calendar was
4059	# adopted in the current locale.
4060	#
4061	# Results:
4062	# Returns the given dictionary augmented with a 'julianDay' key
4063	# whose value is the desired Julian Day Number, and a 'gregorian'
4064	# key that specifies whether the calendar is Gregorian (1) or
4065	# Julian (0).
4066	#
4067	# Side effects:
4068	# None.
4069	#
4070	# Bugs:
4071	# This code needs to be moved to the C layer.
4072	#
4073	#----------------------------------------------------------------------
4074
4075	proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
4076
4077	# Get absolute year number from the civil year
4078
4079	switch -exact -- [dict get $date era] {
4080	BCE {
4081	set year [expr { 1 - [dict get $date year] }]
4082	}
4083	CE {
4084	set year [dict get $date year]
4085	}
4086	}
4087	set ym1 [expr { $year - 1 }]
4088
4089	# Try the Gregorian calendar first.
4090
4091	dict set date gregorian 1
4092	set jd [expr { 1721425
4093	+ [dict get $date dayOfYear]
4094	+ ( 365 * $ym1 )
4095	+ ( $ym1 / 4 )
4096	- ( $ym1 / 100 )
4097	+ ( $ym1 / 400 ) }]
4098
4099	# If the date is before the Gregorian change, use the Julian calendar.
4100
4101	if { $jd < $changeover } {
4102	dict set date gregorian 0
4103	set jd [expr { 1721423
4104	+ [dict get $date dayOfYear]
4105	+ ( 365 * $ym1 )
4106	+ ( $ym1 / 4 ) }]
4107	}
4108
4109	dict set date julianDay $jd
4110	return $date
4111	}
4112
4113	#----------------------------------------------------------------------
4114	#
4115	# GetJulianDayFromEraYearMonthWeekDay --
4116	#
4117	# Determines the Julian Day number corresponding to the nth
4118	# given day-of-the-week in a given month.
4119	#
4120	# Parameters:
4121	# date - Dictionary containing the keys, 'era', 'year', 'month'
4122	# 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
4123	# changeover - Julian Day of adoption of the Gregorian calendar
4124	#
4125	# Results:
4126	# Returns the given dictionary, augmented with a 'julianDay' key.
4127	#
4128	# Side effects:
4129	# None.
4130	#
4131	# Bugs:
4132	# This code needs to be moved to the C layer.
4133	#
4134	#----------------------------------------------------------------------
4135
4136	proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
4137
4138	# Come up with a reference day; either the zeroeth day of the
4139	# given month (dayOfWeekInMonth >= 0) or the seventh day of the
4140	# following month (dayOfWeekInMonth < 0)
4141
4142	set date2 $date
4143	set week [dict get $date dayOfWeekInMonth]
4144	if { $week >= 0 } {
4145	dict set date2 dayOfMonth 0
4146	} else {
4147	dict incr date2 month
4148	dict set date2 dayOfMonth 7
4149	}
4150	set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
4151	$changeover]
4152	set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
4153	[dict get $date2 julianDay]]
4154	dict set date julianDay [expr { $wd0 + 7 * $week }]
4155	return $date
4156
4157	}
4158
4159	#----------------------------------------------------------------------
4160	#
4161	# IsGregorianLeapYear --
4162	#
4163	# Determines whether a given date represents a leap year in the
4164	# Gregorian calendar.
4165	#
4166	# Parameters:
4167	# date -- The date to test. The fields, 'era', 'year' and 'gregorian'
4168	# must be set.
4169	#
4170	# Results:
4171	# Returns 1 if the year is a leap year, 0 otherwise.
4172	#
4173	# Side effects:
4174	# None.
4175	#
4176	#----------------------------------------------------------------------
4177
4178	proc ::tcl::clock::IsGregorianLeapYear { date } {
4179
4180	switch -exact -- [dict get $date era] {
4181	BCE {
4182	set year [expr { 1 - [dict get $date year]}]
4183	}
4184	CE {
4185	set year [dict get $date year]
4186	}
4187	}
4188	if { $year % 4 != 0 } {
4189	return 0
4190	} elseif { ![dict get $date gregorian] } {
4191	return 1
4192	} elseif { $year % 400 == 0 } {
4193	return 1
4194	} elseif { $year % 100 == 0 } {
4195	return 0
4196	} else {
4197	return 1
4198	}
4199
4200	}
4201
4202	#----------------------------------------------------------------------
4203	#
4204	# WeekdayOnOrBefore --
4205	#
4206	# Determine the nearest day of week (given by the 'weekday'
4207	# parameter, Sunday==0) on or before a given Julian Day.
4208	#
4209	# Parameters:
4210	# weekday -- Day of the week
4211	# j -- Julian Day number
4212	#
4213	# Results:
4214	# Returns the Julian Day Number of the desired date.
4215	#
4216	# Side effects:
4217	# None.
4218	#
4219	#----------------------------------------------------------------------
4220
4221	proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
4222
4223	set k [expr { ( $weekday + 6 ) % 7 }]
4224	return [expr { $j - ( $j - $k ) % 7 }]
4225
4226	}
4227
4228	#----------------------------------------------------------------------
4229	#
4230	# BSearch --
4231	#
4232	# Service procedure that does binary search in several places
4233	# inside the 'clock' command.
4234	#
4235	# Parameters:
4236	# list - List of lists, sorted in ascending order by the
4237	# first elements
4238	# key - Value to search for
4239	#
4240	# Results:
4241	# Returns the index of the greatest element in $list that is less
4242	# than or equal to $key.
4243	#
4244	# Side effects:
4245	# None.
4246	#
4247	#----------------------------------------------------------------------
4248
4249	proc ::tcl::clock::BSearch { list key } {
4250
4251	if {[llength $list] == 0} {
4252	return -1
4253	}
4254	if { $key < [lindex $list 0 0] } {
4255	return -1
4256	}
4257
4258	set l 0
4259	set u [expr { [llength $list] - 1 }]
4260
4261	while { $l < $u } {
4262
4263	# At this point, we know that
4264	# $k >= [lindex $list $l 0]
4265	# Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
4266	# We find the midpoint of the interval {l,u} rounded UP, compare
4267	# against it, and set l or u to maintain the invariant. Note
4268	# that the interval shrinks at each step, guaranteeing convergence.
4269
4270	set m [expr { ( $l + $u + 1 ) / 2 }]
4271	if { $key >= [lindex $list $m 0] } {
4272	set l $m
4273	} else {
4274	set u [expr { $m - 1 }]
4275	}
4276	}
4277
4278	return $l
4279	}
4280
4281	#----------------------------------------------------------------------
4282	#
4283	# clock add --
4284	#
4285	# Adds an offset to a given time.
4286	#
4287	# Syntax:
4288	# clock add clockval ?count unit?... ?-option value?
4289	#
4290	# Parameters:
4291	# clockval -- Starting time value
4292	# count -- Amount of a unit of time to add
4293	# unit -- Unit of time to add, must be one of:
4294	# years year months month weeks week
4295	# days day hours hour minutes minute
4296	# seconds second
4297	#
4298	# Options:
4299	# -gmt BOOLEAN
4300	# (Deprecated) Flag synonymous with '-timezone :GMT'
4301	# -timezone ZONE
4302	# Name of the time zone in which calculations are to be done.
4303	# -locale NAME
4304	# Name of the locale in which calculations are to be done.
4305	# Used to determine the Gregorian change date.
4306	#
4307	# Results:
4308	# Returns the given time adjusted by the given offset(s) in
4309	# order.
4310	#
4311	# Notes:
4312	# It is possible that adding a number of months or years will adjust
4313	# the day of the month as well. For instance, the time at
4314	# one month after 31 January is either 28 or 29 February, because
4315	# February has fewer than 31 days.
4316	#
4317	#----------------------------------------------------------------------
4318
4319	proc ::tcl::clock::add { clockval args } {
4320
4321	if { [llength $args] % 2 != 0 } {
4322	set cmdName "clock add"
4323	return -code error \
4324	-errorcode [list CLOCK wrongNumArgs] \
4325	"wrong \# args: should be\
4326	\"$cmdName clockval ?number units?...\
4327	?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
4328	}
4329	if { [catch { expr {wide($clockval)} } result] } {
4330	return -code error $result
4331	}
4332
4333	set offsets {}
4334	set gmt 0
4335	set locale c
4336	set timezone [GetSystemTimeZone]
4337
4338	foreach { a b } $args {
4339
4340	if { [string is integer -strict $a] } {
4341
4342	lappend offsets $a $b
4343
4344	} else {
4345
4346	switch -exact -- $a {
4347
4348	-g - -gm - -gmt {
4349	set gmt $b
4350	}
4351	-l - -lo - -loc - -loca - -local - -locale {
4352	set locale [string tolower $b]
4353	}
4354	-t - -ti - -tim - -time - -timez - -timezo - -timezon -
4355	-timezone {
4356	set timezone $b
4357	}
4358	default {
4359	return -code error \
4360	-errorcode [list CLOCK badSwitch $flag] \
4361	"bad switch \"$flag\",\
4362	must be -gmt, -locale or -timezone"
4363	}
4364	}
4365	}
4366	}
4367
4368	# Check options for validity
4369
4370	if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
4371	return -code error \
4372	-errorcode [list CLOCK gmtWithTimezone] \
4373	"cannot use -gmt and -timezone in same call"
4374	}
4375	if { [catch { expr { wide($clockval) } } result] } {
4376	return -code error \
4377	"expected integer but got \"$clockval\""
4378	}
4379	if { ![string is boolean $gmt] } {
4380	return -code error \
4381	"expected boolean value but got \"$gmt\""
4382	} else {
4383	if { $gmt } {
4384	set timezone :GMT
4385	}
4386	}
4387
4388	EnterLocale $locale oldLocale
4389
4390	set changeover [mc GREGORIAN_CHANGE_DATE]
4391
4392	if {[catch {SetupTimeZone $timezone} retval opts]} {
4393	dict unset opts -errorinfo
4394	return -options $opts $retval
4395	}
4396
4397	set status [catch {
4398
4399	foreach { quantity unit } $offsets {
4400
4401	switch -exact -- $unit {
4402
4403	years - year {
4404	set clockval \
4405	[AddMonths [expr { 12 * $quantity }] \
4406	$clockval $timezone $changeover]
4407	}
4408	months - month {
4409	set clockval [AddMonths $quantity $clockval $timezone \
4410	$changeover]
4411	}
4412
4413	weeks - week {
4414	set clockval [AddDays [expr { 7 * $quantity }] \
4415	$clockval $timezone $changeover]
4416	}
4417	days - day {
4418	set clockval [AddDays $quantity $clockval $timezone \
4419	$changeover]
4420	}
4421
4422	hours - hour {
4423	set clockval [expr { 3600 * $quantity + $clockval }]
4424	}
4425	minutes - minute {
4426	set clockval [expr { 60 * $quantity + $clockval }]
4427	}
4428	seconds - second {
4429	set clockval [expr { $quantity + $clockval }]
4430	}
4431
4432	default {
4433	error "unknown unit \"$unit\", must be \
4434	years, months, weeks, days, hours, minutes or seconds" \
4435	"unknown unit \"$unit\", must be \
4436	years, months, weeks, days, hours, minutes or seconds" \
4437	[list CLOCK badUnit $unit]
4438	}
4439	}
4440	}
4441	} result opts]
4442
4443	# Restore the locale
4444
4445	if { [info exists oldLocale] } {
4446	mclocale $oldLocale
4447	}
4448
4449	if { $status == 1 } {
4450	if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
4451	dict unset opts -errorinfo
4452	}
4453	return -options $opts $result
4454	} else {
4455	return $clockval
4456	}
4457
4458	}
4459
4460	#----------------------------------------------------------------------
4461	#
4462	# AddMonths --
4463	#
4464	# Add a given number of months to a given clock value in a given
4465	# time zone.
4466	#
4467	# Parameters:
4468	# months - Number of months to add (may be negative)
4469	# clockval - Seconds since the epoch before the operation
4470	# timezone - Time zone in which the operation is to be performed
4471	#
4472	# Results:
4473	# Returns the new clock value as a number of seconds since
4474	# the epoch.
4475	#
4476	# Side effects:
4477	# None.
4478	#
4479	#----------------------------------------------------------------------
4480
4481	proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
4482
4483	variable DaysInRomanMonthInCommonYear
4484	variable DaysInRomanMonthInLeapYear
4485	variable TZData
4486
4487	# Convert the time to year, month, day, and fraction of day.
4488
4489	set date [GetDateFields $clockval $TZData($timezone) $changeover]
4490	dict set date secondOfDay [expr { [dict get $date localSeconds]
4491	% 86400 }]
4492	dict set date tzName $timezone
4493
4494	# Add the requisite number of months
4495
4496	set m [dict get $date month]
4497	incr m $months
4498	incr m -1
4499	set delta [expr { $m / 12 }]
4500	set mm [expr { $m % 12 }]
4501	dict set date month [expr { $mm + 1 }]
4502	dict incr date year $delta
4503
4504	# If the date doesn't exist in the current month, repair it
4505
4506	if { [IsGregorianLeapYear $date] } {
4507	set hath [lindex $DaysInRomanMonthInLeapYear $mm]
4508	} else {
4509	set hath [lindex $DaysInRomanMonthInCommonYear $mm]
4510	}
4511	if { [dict get $date dayOfMonth] > $hath } {
4512	dict set date dayOfMonth $hath
4513	}
4514
4515	# Reconvert to a number of seconds
4516
4517	set date [GetJulianDayFromEraYearMonthDay \
4518	$date[set date {}]\
4519	$changeover]
4520	dict set date localSeconds \
4521	[expr { -210866803200
4522	+ ( 86400 * wide([dict get $date julianDay]) )
4523	+ [dict get $date secondOfDay] }]
4524	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
4525	$changeover]
4526
4527	return [dict get $date seconds]
4528
4529	}
4530
4531	#----------------------------------------------------------------------
4532	#
4533	# AddDays --
4534	#
4535	# Add a given number of days to a given clock value in a given
4536	# time zone.
4537	#
4538	# Parameters:
4539	# days - Number of days to add (may be negative)
4540	# clockval - Seconds since the epoch before the operation
4541	# timezone - Time zone in which the operation is to be performed
4542	# changeover - Julian Day on which the Gregorian calendar was adopted
4543	# in the target locale.
4544	#
4545	# Results:
4546	# Returns the new clock value as a number of seconds since
4547	# the epoch.
4548	#
4549	# Side effects:
4550	# None.
4551	#
4552	#----------------------------------------------------------------------
4553
4554	proc ::tcl::clock::AddDays { days clockval timezone changeover } {
4555
4556	variable TZData
4557
4558	# Convert the time to Julian Day
4559
4560	set date [GetDateFields $clockval $TZData($timezone) $changeover]
4561	dict set date secondOfDay [expr { [dict get $date localSeconds]
4562	% 86400 }]
4563	dict set date tzName $timezone
4564
4565	# Add the requisite number of days
4566
4567	dict incr date julianDay $days
4568
4569	# Reconvert to a number of seconds
4570
4571	dict set date localSeconds \
4572	[expr { -210866803200
4573	+ ( 86400 * wide([dict get $date julianDay]) )
4574	+ [dict get $date secondOfDay] }]
4575	set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
4576	$changeover]
4577
4578	return [dict get $date seconds]
4579
4580	}
4581
4582	#----------------------------------------------------------------------
4583	#
4584	# mc --
4585	#
4586	# Wrapper around ::msgcat::mc that caches the result according
4587	# to the locale.
4588	#
4589	# Parameters:
4590	# Accepts the name of the message to retrieve.
4591	#
4592	# Results:
4593	# Returns the message text.
4594	#
4595	# Side effects:
4596	# Caches the message text.
4597	#
4598	# Notes:
4599	# Only the single-argument version of [mc] is supported.
4600	#
4601	#----------------------------------------------------------------------
4602
4603	proc ::tcl::clock::mc { name } {
4604	variable McLoaded
4605	set Locale [mclocale]
4606	if { [dict exists $McLoaded $Locale $name] } {
4607	return [dict get $McLoaded $Locale $name]
4608	} else {
4609	set val [::msgcat::mc $name]
4610	dict set McLoaded $Locale $name $val
4611	return $val
4612	}
4613	}
4614
4615	#----------------------------------------------------------------------
4616	#
4617	# ClearCaches --
4618	#
4619	# Clears all caches to reclaim the memory used in [clock]
4620	#
4621	# Parameters:
4622	# None.
4623	#
4624	# Results:
4625	# None.
4626	#
4627	# Side effects:
4628	# Caches are cleared.
4629	#
4630	#----------------------------------------------------------------------
4631
4632	proc ::tcl::clock::ClearCaches {} {
4633
4634	variable FormatProc
4635	variable LocaleNumeralCache
4636	variable McLoaded
4637	variable CachedSystemTimeZone
4638	variable TimeZoneBad
4639
4640	foreach p [info procs [namespace current]::scanproc'*] {
4641	rename $p {}
4642	}
4643	foreach p [info procs [namespace current]::formatproc'*] {
4644	rename $p {}
4645	}
4646
4647	catch {unset FormatProc}
4648	set LocaleNumeralCache {}
4649	set McLoaded {}
4650	catch {unset CachedSystemTimeZone}
4651	set TimeZoneBad {}
4652	InitTZData
4653
4654	}

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: data/Media/tcl/clock.tcl @ 5114

Download in other formats: