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