Mercurial > repos > rliterman > csp2
comparison CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/clock.tcl @ 68:5028fdace37b
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author | jpayne |
---|---|
date | Tue, 18 Mar 2025 16:23:26 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
67:0e9998148a16 | 68:5028fdace37b |
---|---|
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 } |