comparison CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/clock.tcl @ 69:33d812a61356

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