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