Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/clock.tcl @ 68:5028fdace37b

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