util/src/TclTk/tcl8.6.12/library/clock.tcl

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