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