+++ /dev/null
-#----------------------------------------------------------------------
-#
-# clock.tcl --
-#
-# This file implements the portions of the [clock] ensemble that are
-# coded in Tcl. Refer to the users' manual to see the description of
-# the [clock] command and its subcommands.
-#
-#
-#----------------------------------------------------------------------
-#
-# Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-#----------------------------------------------------------------------
-
-# We must have message catalogs that support the root locale, and we need
-# access to the Registry on Windows systems.
-
-uplevel \#0 {
- package require msgcat 1.4
- if { $::tcl_platform(platform) eq {windows} } {
- if { [catch { package require registry 1.1 }] } {
- namespace eval ::tcl::clock [list variable NoRegistry {}]
- }
- }
-}
-
-# Put the library directory into the namespace for the ensemble so that the
-# library code can find message catalogs and time zone definition files.
-
-namespace eval ::tcl::clock \
- [list variable LibDir [file dirname [info script]]]
-
-#----------------------------------------------------------------------
-#
-# clock --
-#
-# Manipulate times.
-#
-# The 'clock' command manipulates time. Refer to the user documentation for
-# the available subcommands and what they do.
-#
-#----------------------------------------------------------------------
-
-namespace eval ::tcl::clock {
-
- # Export the subcommands
-
- namespace export format
- namespace export clicks
- namespace export microseconds
- namespace export milliseconds
- namespace export scan
- namespace export seconds
- namespace export add
-
- # Import the message catalog commands that we use.
-
- namespace import ::msgcat::mcload
- namespace import ::msgcat::mclocale
-
-}
-
-#----------------------------------------------------------------------
-#
-# ::tcl::clock::Initialize --
-#
-# Finish initializing the 'clock' subsystem
-#
-# Results:
-# None.
-#
-# Side effects:
-# Namespace variable in the 'clock' subsystem are initialized.
-#
-# The '::tcl::clock::Initialize' procedure initializes the namespace variables
-# and root locale message catalog for the 'clock' subsystem. It is broken
-# into a procedure rather than simply evaluated as a script so that it will be
-# able to use local variables, avoiding the dangers of 'creative writing' as
-# in Bug 1185933.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::Initialize {} {
-
- rename ::tcl::clock::Initialize {}
-
- variable LibDir
-
- # Define the Greenwich time zone
-
- proc InitTZData {} {
- variable TZData
- array unset TZData
- set TZData(:Etc/GMT) {
- {-9223372036854775808 0 0 GMT}
- }
- set TZData(:GMT) $TZData(:Etc/GMT)
- set TZData(:Etc/UTC) {
- {-9223372036854775808 0 0 UTC}
- }
- set TZData(:UTC) $TZData(:Etc/UTC)
- set TZData(:localtime) {}
- }
- InitTZData
-
- # Define the message catalog for the root locale.
-
- ::msgcat::mcmset {} {
- AM {am}
- BCE {B.C.E.}
- CE {C.E.}
- DATE_FORMAT {%m/%d/%Y}
- DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
- DAYS_OF_WEEK_ABBREV {
- Sun Mon Tue Wed Thu Fri Sat
- }
- DAYS_OF_WEEK_FULL {
- Sunday Monday Tuesday Wednesday Thursday Friday Saturday
- }
- GREGORIAN_CHANGE_DATE 2299161
- LOCALE_DATE_FORMAT {%m/%d/%Y}
- LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
- LOCALE_ERAS {}
- LOCALE_NUMERALS {
- 00 01 02 03 04 05 06 07 08 09
- 10 11 12 13 14 15 16 17 18 19
- 20 21 22 23 24 25 26 27 28 29
- 30 31 32 33 34 35 36 37 38 39
- 40 41 42 43 44 45 46 47 48 49
- 50 51 52 53 54 55 56 57 58 59
- 60 61 62 63 64 65 66 67 68 69
- 70 71 72 73 74 75 76 77 78 79
- 80 81 82 83 84 85 86 87 88 89
- 90 91 92 93 94 95 96 97 98 99
- }
- LOCALE_TIME_FORMAT {%H:%M:%S}
- LOCALE_YEAR_FORMAT {%EC%Ey}
- MONTHS_ABBREV {
- Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
- }
- MONTHS_FULL {
- January February March
- April May June
- July August September
- October November December
- }
- PM {pm}
- TIME_FORMAT {%H:%M:%S}
- TIME_FORMAT_12 {%I:%M:%S %P}
- TIME_FORMAT_24 {%H:%M}
- TIME_FORMAT_24_SECS {%H:%M:%S}
- }
-
- # Define a few Gregorian change dates for other locales. In most cases
- # the change date follows a language, because a nation's colonies changed
- # at the same time as the nation itself. In many cases, different
- # national boundaries existed; the dominating rule is to follow the
- # nation's capital.
-
- # Italy, Spain, Portugal, Poland
-
- ::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
-
- # France, Austria
-
- ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
-
- # For Belgium, we follow Southern Netherlands; Liege Diocese changed
- # several weeks later.
-
- ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
- ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
-
- # Austria
-
- ::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
-
- # Hungary
-
- ::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
-
- # Germany, Norway, Denmark (Catholic Germany changed earlier)
-
- ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
-
- # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at
- # various times)
-
- ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
-
- # Protestant Switzerland (Catholic cantons changed earlier)
-
- ::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
- ::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
- ::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
-
- # English speaking countries
-
- ::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
-
- # Sweden (had several changes onto and off of the Gregorian calendar)
-
- ::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
-
- # Russia
-
- ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
-
- # Romania (Transylvania changed earler - perhaps de_RO should show the
- # earlier date?)
-
- ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
-
- # Greece
-
- ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
-
- #------------------------------------------------------------------
- #
- # CONSTANTS
- #
- #------------------------------------------------------------------
-
- # Paths at which binary time zone data for the Olson libraries are known
- # to reside on various operating systems
-
- variable ZoneinfoPaths {}
- foreach path {
- /usr/share/zoneinfo
- /usr/share/lib/zoneinfo
- /usr/lib/zoneinfo
- /usr/local/etc/zoneinfo
- } {
- if { [file isdirectory $path] } {
- lappend ZoneinfoPaths $path
- }
- }
-
- # Define the directories for time zone data and message catalogs.
-
- variable DataDir [file join $LibDir tzdata]
- variable MsgDir [file join $LibDir msgs]
-
- # Number of days in the months, in common years and leap years.
-
- variable DaysInRomanMonthInCommonYear \
- { 31 28 31 30 31 30 31 31 30 31 30 31 }
- variable DaysInRomanMonthInLeapYear \
- { 31 29 31 30 31 30 31 31 30 31 30 31 }
- variable DaysInPriorMonthsInCommonYear [list 0]
- variable DaysInPriorMonthsInLeapYear [list 0]
- set i 0
- foreach j $DaysInRomanMonthInCommonYear {
- lappend DaysInPriorMonthsInCommonYear [incr i $j]
- }
- set i 0
- foreach j $DaysInRomanMonthInLeapYear {
- lappend DaysInPriorMonthsInLeapYear [incr i $j]
- }
-
- # Another epoch (Hi, Jeff!)
-
- variable Roddenberry 1946
-
- # Integer ranges
-
- variable MINWIDE -9223372036854775808
- variable MAXWIDE 9223372036854775807
-
- # Day before Leap Day
-
- variable FEB_28 58
-
- # Translation table to map Windows TZI onto cities, so that the Olson
- # rules can apply. In some cases the mapping is ambiguous, so it's wise
- # to specify $::env(TCL_TZ) rather than simply depending on the system
- # time zone.
-
- # The keys are long lists of values obtained from the time zone
- # information in the Registry. In order, the list elements are:
- # Bias StandardBias DaylightBias
- # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
- # StandardDate.wDay StandardDate.wHour StandardDate.wMinute
- # StandardDate.wSecond StandardDate.wMilliseconds
- # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
- # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
- # DaylightDate.wSecond DaylightDate.wMilliseconds
- # The values are the names of time zones where those rules apply. There
- # is considerable ambiguity in certain zones; an attempt has been made to
- # make a reasonable guess, but this table needs to be taken with a grain
- # of salt.
-
- variable WinZoneInfo [dict create {*}{
- {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
- {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
- {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
- {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
- {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
- {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
- {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
- {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
- {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
- {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
- {-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
- {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
- {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
- {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
- {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
- {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
- :America/Santiago
- {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
- {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
- {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
- {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
- {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
- {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
- {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
- {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
- {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
- {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
- {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
- {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
- {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
- {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
- {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
- {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
- {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
- :Africa/Cairo
- {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
- {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
- {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
- {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
- {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
- {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
- :Asia/Beirut
- {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
- {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
- {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
- {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
- {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
- {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
- {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
- {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
- {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
- {18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi
- {18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg
- {19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta
- {20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu
- {21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka
- {21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk
- {23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon
- {25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok
- {25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk
- {28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing
- {28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk
- {32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo
- {32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk
- {34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide
- {34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin
- {36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane
- {36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok
- {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart
- {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
- {39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
- {43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
- {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
- {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
- }]
-
- # Groups of fields that specify the date, priorities, and code bursts that
- # determine Julian Day Number given those groups. The code in [clock
- # scan] will choose the highest priority (lowest numbered) set of fields
- # that determines the date.
-
- variable DateParseActions {
-
- { seconds } 0 {}
-
- { julianDay } 1 {}
-
- { era century yearOfCentury month dayOfMonth } 2 {
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { era century yearOfCentury dayOfYear } 2 {
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
-
- { century yearOfCentury month dayOfMonth } 3 {
- dict set date era CE
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { century yearOfCentury dayOfYear } 3 {
- dict set date era CE
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
- dict set date era CE
- dict set date iso8601Year \
- [expr { 100 * [dict get $date iso8601Century]
- + [dict get $date iso8601YearOfCentury] }]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
-
- { yearOfCentury month dayOfMonth } 4 {
- set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
- dict set date era CE
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { yearOfCentury dayOfYear } 4 {
- set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
- dict set date era CE
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
- set date [InterpretTwoDigitYear \
- $date[set date {}] $baseTime \
- iso8601YearOfCentury iso8601Year]
- dict set date era CE
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
-
- { month dayOfMonth } 5 {
- set date [AssignBaseYear $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { dayOfYear } 5 {
- set date [AssignBaseYear $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601Week dayOfWeek } 5 {
- set date [AssignBaseIso8601Year $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
-
- { dayOfMonth } 6 {
- set date [AssignBaseMonth $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
-
- { dayOfWeek } 7 {
- set date [AssignBaseWeek $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
-
- {} 8 {
- set date [AssignBaseJulianDay $date[set date {}] \
- $baseTime $timeZone $changeover]
- }
- }
-
- # Groups of fields that specify time of day, priorities, and code that
- # processes them
-
- variable TimeParseActions {
-
- seconds 1 {}
-
- { hourAMPM minute second amPmIndicator } 2 {
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour minute second } 2 {
- dict set date secondOfDay [InterpretHMS $date]
- }
-
- { hourAMPM minute amPmIndicator } 3 {
- dict set date second 0
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour minute } 3 {
- dict set date second 0
- dict set date secondOfDay [InterpretHMS $date]
- }
-
- { hourAMPM amPmIndicator } 4 {
- dict set date minute 0
- dict set date second 0
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour } 4 {
- dict set date minute 0
- dict set date second 0
- dict set date secondOfDay [InterpretHMS $date]
- }
-
- { } 5 {
- dict set date secondOfDay 0
- }
- }
-
- # Legacy time zones, used primarily for parsing RFC822 dates.
-
- variable LegacyTimeZone [dict create \
- gmt +0000 \
- ut +0000 \
- utc +0000 \
- bst +0100 \
- wet +0000 \
- wat -0100 \
- at -0200 \
- nft -0330 \
- nst -0330 \
- ndt -0230 \
- ast -0400 \
- adt -0300 \
- est -0500 \
- edt -0400 \
- cst -0600 \
- cdt -0500 \
- mst -0700 \
- mdt -0600 \
- pst -0800 \
- pdt -0700 \
- yst -0900 \
- ydt -0800 \
- hst -1000 \
- hdt -0900 \
- cat -1000 \
- ahst -1000 \
- nt -1100 \
- idlw -1200 \
- cet +0100 \
- cest +0200 \
- met +0100 \
- mewt +0100 \
- mest +0200 \
- swt +0100 \
- sst +0200 \
- fwt +0100 \
- fst +0200 \
- eet +0200 \
- eest +0300 \
- bt +0300 \
- it +0330 \
- zp4 +0400 \
- zp5 +0500 \
- ist +0530 \
- zp6 +0600 \
- wast +0700 \
- wadt +0800 \
- jt +0730 \
- cct +0800 \
- jst +0900 \
- kst +0900 \
- cast +0930 \
- jdt +1000 \
- kdt +1000 \
- cadt +1030 \
- east +1000 \
- eadt +1030 \
- gst +1000 \
- nzt +1200 \
- nzst +1200 \
- nzdt +1300 \
- idle +1200 \
- a +0100 \
- b +0200 \
- c +0300 \
- d +0400 \
- e +0500 \
- f +0600 \
- g +0700 \
- h +0800 \
- i +0900 \
- k +1000 \
- l +1100 \
- m +1200 \
- n -0100 \
- o -0200 \
- p -0300 \
- q -0400 \
- r -0500 \
- s -0600 \
- t -0700 \
- u -0800 \
- v -0900 \
- w -1000 \
- x -1100 \
- y -1200 \
- z +0000 \
- ]
-
- # Caches
-
- variable LocaleNumeralCache {}; # Dictionary whose keys are locale
- # names and whose values are pairs
- # comprising regexes matching numerals
- # in the given locales and dictionaries
- # mapping the numerals to their numeric
- # values.
- variable McLoaded {}; # Dictionary whose keys are locales
- # in which [mcload] has been executed
- # and whose values are second-level
- # dictionaries indexed by message
- # name and giving message text.
- # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
- # it contains the value of the
- # system time zone, as determined from
- # the environment.
- variable TimeZoneBad {}; # Dictionary whose keys are time zone
- # names and whose values are 1 if
- # the time zone is unknown and 0
- # if it is known.
- variable TZData; # Array whose keys are time zone names
- # and whose values are lists of quads
- # comprising start time, UTC offset,
- # Daylight Saving Time indicator, and
- # time zone abbreviation.
- variable FormatProc; # Array mapping format group
- # and locale to the name of a procedure
- # that renders the given format
-}
-::tcl::clock::Initialize
-
-#----------------------------------------------------------------------
-#
-# clock format --
-#
-# Formats a count of seconds since the Posix Epoch as a time of day.
-#
-# The 'clock format' command formats times of day for output. Refer to the
-# user documentation to see what it does.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::format { args } {
- variable FormatProc
- variable TZData
-
- lassign [ParseFormatArgs {*}$args] format locale timezone
- set locale [string tolower $locale]
- set clockval [lindex $args 0]
-
- # Get the data for time changes in the given zone
-
- if {$timezone eq ""} {
- set timezone [GetSystemTimeZone]
- }
- if {![info exists TZData($timezone)]} {
- if {[catch {SetupTimeZone $timezone} retval opts]} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
- }
-
- # Build a procedure to format the result. Cache the built procedure's name
- # in the 'FormatProc' array to avoid losing its internal representation,
- # which contains the name resolution.
-
- set procName formatproc'$format'$locale
- set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
- if {[info exists FormatProc($procName)]} {
- set procName $FormatProc($procName)
- } else {
- set FormatProc($procName) \
- [ParseClockFormatFormat $procName $format $locale]
- }
-
- return [$procName $clockval $timezone]
-}
-
-#----------------------------------------------------------------------
-#
-# ParseClockFormatFormat --
-#
-# Builds and caches a procedure that formats a time value.
-#
-# Parameters:
-# format -- Format string to use
-# locale -- Locale in which the format string is to be interpreted
-#
-# Results:
-# Returns the name of the newly-built procedure.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {
- if {[namespace which $procName] ne {}} {
- return $procName
- }
-
- # Map away the locale-dependent composite format groups
-
- EnterLocale $locale oldLocale
-
- # Change locale if a fresh locale has been given on the command line.
-
- try {
- return [ParseClockFormatFormat2 $format $locale $procName]
- } trap CLOCK {result opts} {
- dict unset opts -errorinfo
- return -options $opts $result
- } finally {
- # Restore the locale
-
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- }
-}
-
-proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
- set didLocaleEra 0
- set didLocaleNumerals 0
- set preFormatCode \
- [string map [list @GREGORIAN_CHANGE_DATE@ \
- [mc GREGORIAN_CHANGE_DATE]] \
- {
- variable TZData
- set date [GetDateFields $clockval \
- $TZData($timezone) \
- @GREGORIAN_CHANGE_DATE@]
- }]
- set formatString {}
- set substituents {}
- set state {}
-
- set format [LocalizeFormat $locale $format]
-
- foreach char [split $format {}] {
- switch -exact -- $state {
- {} {
- if { [string equal % $char] } {
- set state percent
- } else {
- append formatString $char
- }
- }
- percent { # Character following a '%' character
- set state {}
- switch -exact -- $char {
- % { # A literal character, '%'
- append formatString %%
- }
- a { # Day of week, abbreviated
- append formatString %s
- append substituents \
- [string map \
- [list @DAYS_OF_WEEK_ABBREV@ \
- [list [mc DAYS_OF_WEEK_ABBREV]]] \
- { [lindex @DAYS_OF_WEEK_ABBREV@ \
- [expr {[dict get $date dayOfWeek] \
- % 7}]]}]
- }
- A { # Day of week, spelt out.
- append formatString %s
- append substituents \
- [string map \
- [list @DAYS_OF_WEEK_FULL@ \
- [list [mc DAYS_OF_WEEK_FULL]]] \
- { [lindex @DAYS_OF_WEEK_FULL@ \
- [expr {[dict get $date dayOfWeek] \
- % 7}]]}]
- }
- b - h { # Name of month, abbreviated.
- append formatString %s
- append substituents \
- [string map \
- [list @MONTHS_ABBREV@ \
- [list [mc MONTHS_ABBREV]]] \
- { [lindex @MONTHS_ABBREV@ \
- [expr {[dict get $date month]-1}]]}]
- }
- B { # Name of month, spelt out
- append formatString %s
- append substituents \
- [string map \
- [list @MONTHS_FULL@ \
- [list [mc MONTHS_FULL]]] \
- { [lindex @MONTHS_FULL@ \
- [expr {[dict get $date month]-1}]]}]
- }
- C { # Century number
- append formatString %02d
- append substituents \
- { [expr {[dict get $date year] / 100}]}
- }
- d { # Day of month, with leading zero
- append formatString %02d
- append substituents { [dict get $date dayOfMonth]}
- }
- e { # Day of month, without leading zero
- append formatString %2d
- append substituents { [dict get $date dayOfMonth]}
- }
- E { # Format group in a locale-dependent
- # alternative era
- set state percentE
- if {!$didLocaleEra} {
- append preFormatCode \
- [string map \
- [list @LOCALE_ERAS@ \
- [list [mc LOCALE_ERAS]]] \
- {
- set date [GetLocaleEra \
- $date[set date {}] \
- @LOCALE_ERAS@]}] \n
- set didLocaleEra 1
- }
- if {!$didLocaleNumerals} {
- append preFormatCode \
- [list set localeNumerals \
- [mc LOCALE_NUMERALS]] \n
- set didLocaleNumerals 1
- }
- }
- g { # Two-digit year relative to ISO8601
- # week number
- append formatString %02d
- append substituents \
- { [expr { [dict get $date iso8601Year] % 100 }]}
- }
- G { # Four-digit year relative to ISO8601
- # week number
- append formatString %02d
- append substituents { [dict get $date iso8601Year]}
- }
- H { # Hour in the 24-hour day, leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds] \
- / 3600 % 24}]}
- }
- I { # Hour AM/PM, with leading zero
- append formatString %02d
- append substituents \
- { [expr { ( ( ( [dict get $date localSeconds] \
- % 86400 ) \
- + 86400 \
- - 3600 ) \
- / 3600 ) \
- % 12 + 1 }] }
- }
- j { # Day of year (001-366)
- append formatString %03d
- append substituents { [dict get $date dayOfYear]}
- }
- J { # Julian Day Number
- append formatString %07ld
- append substituents { [dict get $date julianDay]}
- }
- k { # Hour (0-23), no leading zero
- append formatString %2d
- append substituents \
- { [expr { [dict get $date localSeconds]
- / 3600
- % 24 }]}
- }
- l { # Hour (12-11), no leading zero
- append formatString %2d
- append substituents \
- { [expr { ( ( ( [dict get $date localSeconds]
- % 86400 )
- + 86400
- - 3600 )
- / 3600 )
- % 12 + 1 }]}
- }
- m { # Month number, leading zero
- append formatString %02d
- append substituents { [dict get $date month]}
- }
- M { # Minute of the hour, leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds]
- / 60
- % 60 }]}
- }
- n { # A literal newline
- append formatString \n
- }
- N { # Month number, no leading zero
- append formatString %2d
- append substituents { [dict get $date month]}
- }
- O { # A format group in the locale's
- # alternative numerals
- set state percentO
- if {!$didLocaleNumerals} {
- append preFormatCode \
- [list set localeNumerals \
- [mc LOCALE_NUMERALS]] \n
- set didLocaleNumerals 1
- }
- }
- p { # Localized 'AM' or 'PM' indicator
- # converted to uppercase
- append formatString %s
- append preFormatCode \
- [list set AM [string toupper [mc AM]]] \n \
- [list set PM [string toupper [mc PM]]] \n
- append substituents \
- { [expr {(([dict get $date localSeconds]
- % 86400) < 43200) ?
- $AM : $PM}]}
- }
- P { # Localized 'AM' or 'PM' indicator
- append formatString %s
- append preFormatCode \
- [list set am [mc AM]] \n \
- [list set pm [mc PM]] \n
- append substituents \
- { [expr {(([dict get $date localSeconds]
- % 86400) < 43200) ?
- $am : $pm}]}
-
- }
- Q { # Hi, Jeff!
- append formatString %s
- append substituents { [FormatStarDate $date]}
- }
- s { # Seconds from the Posix Epoch
- append formatString %s
- append substituents { [dict get $date seconds]}
- }
- S { # Second of the minute, with
- # leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds]
- % 60 }]}
- }
- t { # A literal tab character
- append formatString \t
- }
- u { # Day of the week (1-Monday, 7-Sunday)
- append formatString %1d
- append substituents { [dict get $date dayOfWeek]}
- }
- U { # Week of the year (00-53). The
- # first Sunday of the year is the
- # first day of week 01
- append formatString %02d
- append preFormatCode {
- set dow [dict get $date dayOfWeek]
- if { $dow == 7 } {
- set dow 0
- }
- incr dow
- set UweekNumber \
- [expr { ( [dict get $date dayOfYear]
- - $dow + 7 )
- / 7 }]
- }
- append substituents { $UweekNumber}
- }
- V { # The ISO8601 week number
- append formatString %02d
- append substituents { [dict get $date iso8601Week]}
- }
- w { # Day of the week (0-Sunday,
- # 6-Saturday)
- append formatString %1d
- append substituents \
- { [expr { [dict get $date dayOfWeek] % 7 }]}
- }
- W { # Week of the year (00-53). The first
- # Monday of the year is the first day
- # of week 01.
- append preFormatCode {
- set WweekNumber \
- [expr { ( [dict get $date dayOfYear]
- - [dict get $date dayOfWeek]
- + 7 )
- / 7 }]
- }
- append formatString %02d
- append substituents { $WweekNumber}
- }
- y { # The two-digit year of the century
- append formatString %02d
- append substituents \
- { [expr { [dict get $date year] % 100 }]}
- }
- Y { # The four-digit year
- append formatString %04d
- append substituents { [dict get $date year]}
- }
- z { # The time zone as hours and minutes
- # east (+) or west (-) of Greenwich
- append formatString %s
- append substituents { [FormatNumericTimeZone \
- [dict get $date tzOffset]]}
- }
- Z { # The name of the time zone
- append formatString %s
- append substituents { [dict get $date tzName]}
- }
- % { # A literal percent character
- append formatString %%
- }
- default { # An unknown escape sequence
- append formatString %% $char
- }
- }
- }
- percentE { # Character following %E
- set state {}
- switch -exact -- $char {
- E {
- append formatString %s
- append substituents { } \
- [string map \
- [list @BCE@ [list [mc BCE]] \
- @CE@ [list [mc CE]]] \
- {[dict get {BCE @BCE@ CE @CE@} \
- [dict get $date era]]}]
- }
- C { # Locale-dependent era
- append formatString %s
- append substituents { [dict get $date localeEra]}
- }
- y { # Locale-dependent year of the era
- append preFormatCode {
- set y [dict get $date localeYear]
- if { $y >= 0 && $y < 100 } {
- set Eyear [lindex $localeNumerals $y]
- } else {
- set Eyear $y
- }
- }
- append formatString %s
- append substituents { $Eyear}
- }
- default { # Unknown %E format group
- append formatString %%E $char
- }
- }
- }
- percentO { # Character following %O
- set state {}
- switch -exact -- $char {
- d - e { # Day of the month in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [dict get $date dayOfMonth]]}
- }
- H - k { # Hour of the day in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- / 3600
- % 24 }]]}
- }
- I - l { # Hour (12-11) AM/PM in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { ( ( ( [dict get $date localSeconds]
- % 86400 )
- + 86400
- - 3600 )
- / 3600 )
- % 12 + 1 }]]}
- }
- m { # Month number in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals [dict get $date month]]}
- }
- M { # Minute of the hour in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- / 60
- % 60 }]]}
- }
- S { # Second of the minute in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- % 60 }]]}
- }
- u { # Day of the week (Monday=1,Sunday=7)
- # in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [dict get $date dayOfWeek]]}
- }
- w { # Day of the week (Sunday=0,Saturday=6)
- # in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date dayOfWeek] % 7 }]]}
- }
- y { # Year of the century in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date year] % 100 }]]}
- }
- default { # Unknown format group
- append formatString %%O $char
- }
- }
- }
- }
- }
-
- # Clean up any improperly terminated groups
-
- switch -exact -- $state {
- percent {
- append formatString %%
- }
- percentE {
- append retval %%E
- }
- percentO {
- append retval %%O
- }
- }
-
- proc $procName {clockval timezone} "
- $preFormatCode
- return \[::format [list $formatString] $substituents\]
- "
-
- # puts [list $procName [info args $procName] [info body $procName]]
-
- return $procName
-}
-
-#----------------------------------------------------------------------
-#
-# clock scan --
-#
-# Inputs a count of seconds since the Posix Epoch as a time of day.
-#
-# The 'clock format' command scans times of day on input. Refer to the user
-# documentation to see what it does.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::scan { args } {
- set format {}
-
- # Check the count of args
-
- if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
- set cmdName "clock scan"
- return -code error \
- -errorcode [list CLOCK wrongNumArgs] \
- "wrong \# args: should be\
- \"$cmdName string\
- ?-base seconds?\
- ?-format string? ?-gmt boolean?\
- ?-locale LOCALE? ?-timezone ZONE?\""
- }
-
- # Set defaults
-
- set base [clock seconds]
- set string [lindex $args 0]
- set format {}
- set gmt 0
- set locale c
- set timezone [GetSystemTimeZone]
-
- # Pick up command line options.
-
- foreach { flag value } [lreplace $args 0 0] {
- set saw($flag) {}
- switch -exact -- $flag {
- -b - -ba - -bas - -base {
- set base $value
- }
- -f - -fo - -for - -form - -forma - -format {
- set format $value
- }
- -g - -gm - -gmt {
- set gmt $value
- }
- -l - -lo - -loc - -loca - -local - -locale {
- set locale [string tolower $value]
- }
- -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
- set timezone $value
- }
- default {
- return -code error \
- -errorcode [list CLOCK badOption $flag] \
- "bad option \"$flag\",\
- must be -base, -format, -gmt, -locale or -timezone"
- }
- }
- }
-
- # Check options for validity
-
- if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
- return -code error \
- -errorcode [list CLOCK gmtWithTimezone] \
- "cannot use -gmt and -timezone in same call"
- }
- if { [catch { expr { wide($base) } } result] } {
- return -code error "expected integer but got \"$base\""
- }
- if { ![string is boolean -strict $gmt] } {
- return -code error "expected boolean value but got \"$gmt\""
- } elseif { $gmt } {
- set timezone :GMT
- }
-
- if { ![info exists saw(-format)] } {
- # Perhaps someday we'll localize the legacy code. Right now, it's not
- # localized.
- if { [info exists saw(-locale)] } {
- return -code error \
- -errorcode [list CLOCK flagWithLegacyFormat] \
- "legacy \[clock scan\] does not support -locale"
-
- }
- return [FreeScan $string $base $timezone $locale]
- }
-
- # Change locale if a fresh locale has been given on the command line.
-
- EnterLocale $locale oldLocale
-
- try {
- # Map away the locale-dependent composite format groups
-
- set scanner [ParseClockScanFormat $format $locale]
- return [$scanner $string $base $timezone]
- } trap CLOCK {result opts} {
- # Conceal location of generation of expected errors
-
- dict unset opts -errorinfo
- return -options $opts $result
- } finally {
- # Restore the locale
-
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- }
-}
-
-#----------------------------------------------------------------------
-#
-# FreeScan --
-#
-# Scans a time in free format
-#
-# Parameters:
-# string - String containing the time to scan
-# base - Base time, expressed in seconds from the Epoch
-# timezone - Default time zone in which the time will be expressed
-# locale - (Unused) Name of the locale where the time will be scanned.
-#
-# Results:
-# Returns the date and time extracted from the string in seconds from
-# the epoch
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::FreeScan { string base timezone locale } {
- variable TZData
-
- # Get the data for time changes in the given zone
-
- try {
- SetupTimeZone $timezone
- } on error {retval opts} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
-
- # Extract year, month and day from the base time for the parser to use as
- # defaults
-
- set date [GetDateFields $base $TZData($timezone) 2361222]
- dict set date secondOfDay [expr {
- [dict get $date localSeconds] % 86400
- }]
-
- # Parse the date. The parser will return a list comprising date, time,
- # time zone, relative month/day/seconds, relative weekday, ordinal month.
-
- try {
- set scanned [Oldscan $string \
- [dict get $date year] \
- [dict get $date month] \
- [dict get $date dayOfMonth]]
- lassign $scanned \
- parseDate parseTime parseZone parseRel \
- parseWeekday parseOrdinalMonth
- } on error message {
- return -code error \
- "unable to convert date-time string \"$string\": $message"
- }
-
- # If the caller supplied a date in the string, update the 'date' dict with
- # the value. If the caller didn't specify a time with the date, default to
- # midnight.
-
- if { [llength $parseDate] > 0 } {
- lassign $parseDate y m d
- if { $y < 100 } {
- if { $y >= 39 } {
- incr y 1900
- } else {
- incr y 2000
- }
- }
- dict set date era CE
- dict set date year $y
- dict set date month $m
- dict set date dayOfMonth $d
- if { $parseTime eq {} } {
- set parseTime 0
- }
- }
-
- # If the caller supplied a time zone in the string, it comes back as a
- # two-element list; the first element is the number of minutes east of
- # Greenwich, and the second is a Daylight Saving Time indicator (1 == yes,
- # 0 == no, -1 == unknown). We make it into a time zone indicator of
- # +-hhmm.
-
- if { [llength $parseZone] > 0 } {
- lassign $parseZone minEast dstFlag
- set timezone [FormatNumericTimeZone \
- [expr { 60 * $minEast + 3600 * $dstFlag }]]
- SetupTimeZone $timezone
- }
- dict set date tzName $timezone
-
- # Assemble date, time, zone into seconds-from-epoch
-
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
- if { $parseTime ne {} } {
- dict set date secondOfDay $parseTime
- } elseif { [llength $parseWeekday] != 0
- || [llength $parseOrdinalMonth] != 0
- || ( [llength $parseRel] != 0
- && ( [lindex $parseRel 0] != 0
- || [lindex $parseRel 1] != 0 ) ) } {
- dict set date secondOfDay 0
- }
-
- dict set date localSeconds [expr {
- -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay]
- }]
- dict set date tzName $timezone
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
- set seconds [dict get $date seconds]
-
- # Do relative times
-
- if { [llength $parseRel] > 0 } {
- lassign $parseRel relMonth relDay relSecond
- set seconds [add $seconds \
- $relMonth months $relDay days $relSecond seconds \
- -timezone $timezone -locale $locale]
- }
-
- # Do relative weekday
-
- if { [llength $parseWeekday] > 0 } {
- lassign $parseWeekday dayOrdinal dayOfWeek
- set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
- dict set date2 era CE
- set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr {
- [dict get $date2 julianDay] + 6
- }]]
- incr jdwkday [expr { 7 * $dayOrdinal }]
- if { $dayOrdinal > 0 } {
- incr jdwkday -7
- }
- dict set date2 secondOfDay \
- [expr { [dict get $date2 localSeconds] % 86400 }]
- dict set date2 julianDay $jdwkday
- dict set date2 localSeconds [expr {
- -210866803200
- + ( 86400 * wide([dict get $date2 julianDay]) )
- + [dict get $date secondOfDay]
- }]
- dict set date2 tzName $timezone
- set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
- 2361222]
- set seconds [dict get $date2 seconds]
- }
-
- # Do relative month
-
- if { [llength $parseOrdinalMonth] > 0 } {
- lassign $parseOrdinalMonth monthOrdinal monthNumber
- if { $monthOrdinal > 0 } {
- set monthDiff [expr { $monthNumber - [dict get $date month] }]
- if { $monthDiff <= 0 } {
- incr monthDiff 12
- }
- incr monthOrdinal -1
- } else {
- set monthDiff [expr { [dict get $date month] - $monthNumber }]
- if { $monthDiff >= 0 } {
- incr monthDiff -12
- }
- incr monthOrdinal
- }
- set seconds [add $seconds $monthOrdinal years $monthDiff months \
- -timezone $timezone -locale $locale]
- }
-
- return $seconds
-}
-
-
-#----------------------------------------------------------------------
-#
-# ParseClockScanFormat --
-#
-# Parses a format string given to [clock scan -format]
-#
-# Parameters:
-# formatString - The format being parsed
-# locale - The current locale
-#
-# Results:
-# Constructs and returns a procedure that accepts the string being
-# scanned, the base time, and the time zone. The procedure will either
-# return the scanned time or else throw an error that should be rethrown
-# to the caller of [clock scan]
-#
-# Side effects:
-# The given procedure is defined in the ::tcl::clock namespace. Scan
-# procedures are not deleted once installed.
-#
-# Why do we parse dates by defining a procedure to parse them? The reason is
-# that by doing so, we have one convenient place to cache all the information:
-# the regular expressions that match the patterns (which will be compiled),
-# the code that assembles the date information, everything lands in one place.
-# In this way, when a given format is reused at run time, all the information
-# of how to apply it is available in a single place.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
- # Check whether the format has been parsed previously, and return the
- # existing recognizer if it has.
-
- set procName scanproc'$formatString'$locale
- set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
- if { [namespace which $procName] != {} } {
- return $procName
- }
-
- variable DateParseActions
- variable TimeParseActions
-
- # Localize the %x, %X, etc. groups
-
- set formatString [LocalizeFormat $locale $formatString]
-
- # Condense whitespace
-
- regsub -all {[[:space:]]+} $formatString { } formatString
-
- # Walk through the groups of the format string. In this loop, we
- # accumulate:
- # - a regular expression that matches the string,
- # - the count of capturing brackets in the regexp
- # - a set of code that post-processes the fields captured by the regexp,
- # - a dictionary whose keys are the names of fields that are present
- # in the format string.
-
- set re {^[[:space:]]*}
- set captureCount 0
- set postcode {}
- set fieldSet [dict create]
- set fieldCount 0
- set postSep {}
- set state {}
-
- foreach c [split $formatString {}] {
- switch -exact -- $state {
- {} {
- if { $c eq "%" } {
- set state %
- } elseif { $c eq " " } {
- append re {[[:space:]]+}
- } else {
- if { ! [string is alnum $c] } {
- append re "\\"
- }
- append re $c
- }
- }
- % {
- set state {}
- switch -exact -- $c {
- % {
- append re %
- }
- { } {
- append re "\[\[:space:\]\]*"
- }
- a - A { # Day of week, in words
- set l {}
- foreach \
- i {7 1 2 3 4 5 6} \
- abr [mc DAYS_OF_WEEK_ABBREV] \
- full [mc DAYS_OF_WEEK_FULL] {
- dict set l [string tolower $abr] $i
- dict set l [string tolower $full] $i
- incr i
- }
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode "dict set date dayOfWeek \[" \
- "dict get " [list $lookup] " " \
- \[ {string tolower $field} [incr captureCount] \] \
- "\]\n"
- }
- b - B - h { # Name of month
- set i 0
- set l {}
- foreach \
- abr [mc MONTHS_ABBREV] \
- full [mc MONTHS_FULL] {
- incr i
- dict set l [string tolower $abr] $i
- dict set l [string tolower $full] $i
- }
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "dict get " [list $lookup] \
- " " \[ {string tolower $field} \
- [incr captureCount] \] \
- "\]\n"
- }
- C { # Gregorian century
- append re \\s*(\\d\\d?)
- dict set fieldSet century [incr fieldCount]
- append postcode "dict set date century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- d - e { # Day of month
- append re \\s*(\\d\\d?)
- dict set fieldSet dayOfMonth [incr fieldCount]
- append postcode "dict set date dayOfMonth \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- E { # Prefix for locale-specific codes
- set state %E
- }
- g { # ISO8601 2-digit year
- append re \\s*(\\d\\d)
- dict set fieldSet iso8601YearOfCentury \
- [incr fieldCount]
- append postcode \
- "dict set date iso8601YearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- G { # ISO8601 4-digit year
- append re \\s*(\\d\\d)(\\d\\d)
- dict set fieldSet iso8601Century [incr fieldCount]
- dict set fieldSet iso8601YearOfCentury \
- [incr fieldCount]
- append postcode \
- "dict set date iso8601Century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n" \
- "dict set date iso8601YearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- H - k { # Hour of day
- append re \\s*(\\d\\d?)
- dict set fieldSet hour [incr fieldCount]
- append postcode "dict set date hour \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- I - l { # Hour, AM/PM
- append re \\s*(\\d\\d?)
- dict set fieldSet hourAMPM [incr fieldCount]
- append postcode "dict set date hourAMPM \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- j { # Day of year
- append re \\s*(\\d\\d?\\d?)
- dict set fieldSet dayOfYear [incr fieldCount]
- append postcode "dict set date dayOfYear \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- J { # Julian Day Number
- append re \\s*(\\d+)
- dict set fieldSet julianDay [incr fieldCount]
- append postcode "dict set date julianDay \[" \
- "::scan \$field" [incr captureCount] " %ld" \
- "\]\n"
- }
- m - N { # Month number
- append re \\s*(\\d\\d?)
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- M { # Minute
- append re \\s*(\\d\\d?)
- dict set fieldSet minute [incr fieldCount]
- append postcode "dict set date minute \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- n { # Literal newline
- append re \\n
- }
- O { # Prefix for locale numerics
- set state %O
- }
- p - P { # AM/PM indicator
- set l [list [string tolower [mc AM]] 0 \
- [string tolower [mc PM]] 1]
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet amPmIndicator [incr fieldCount]
- append postcode "dict set date amPmIndicator \[" \
- "dict get " [list $lookup] " \[string tolower " \
- "\$field" \
- [incr captureCount] \
- "\]\]\n"
- }
- Q { # Hi, Jeff!
- append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
- incr captureCount
- dict set fieldSet seconds [incr fieldCount]
- append postcode {dict set date seconds } \[ \
- {ParseStarDate $field} [incr captureCount] \
- { $field} [incr captureCount] \
- { $field} [incr captureCount] \
- \] \n
- }
- s { # Seconds from Posix Epoch
- # This next case is insanely difficult, because it's
- # problematic to determine whether the field is
- # actually within the range of a wide integer.
- append re {\s*([-+]?\d+)}
- dict set fieldSet seconds [incr fieldCount]
- append postcode {dict set date seconds } \[ \
- {ScanWide $field} [incr captureCount] \] \n
- }
- S { # Second
- append re \\s*(\\d\\d?)
- dict set fieldSet second [incr fieldCount]
- append postcode "dict set date second \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- t { # Literal tab character
- append re \\t
- }
- u - w { # Day number within week, 0 or 7 == Sun
- # 1=Mon, 6=Sat
- append re \\s*(\\d)
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode {::scan $field} [incr captureCount] \
- { %d dow} \n \
- {
- if { $dow == 0 } {
- set dow 7
- } elseif { $dow > 7 } {
- return -code error \
- -errorcode [list CLOCK badDayOfWeek] \
- "day of week is greater than 7"
- }
- dict set date dayOfWeek $dow
- }
- }
- U { # Week of year. The first Sunday of
- # the year is the first day of week
- # 01. No scan rule uses this group.
- append re \\s*\\d\\d?
- }
- V { # Week of ISO8601 year
-
- append re \\s*(\\d\\d?)
- dict set fieldSet iso8601Week [incr fieldCount]
- append postcode "dict set date iso8601Week \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- W { # Week of the year (00-53). The first
- # Monday of the year is the first day
- # of week 01. No scan rule uses this
- # group.
- append re \\s*\\d\\d?
- }
- y { # Two-digit Gregorian year
- append re \\s*(\\d\\d?)
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode "dict set date yearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- Y { # 4-digit Gregorian year
- append re \\s*(\\d\\d)(\\d\\d)
- dict set fieldSet century [incr fieldCount]
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode \
- "dict set date century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n" \
- "dict set date yearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- z - Z { # Time zone name
- append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)|([[:alnum:]]{1,4}))}
- dict set fieldSet tzName [incr fieldCount]
- append postcode \
- {if } \{ { $field} [incr captureCount] \
- { ne "" } \} { } \{ \n \
- {dict set date tzName $field} \
- $captureCount \n \
- \} { else } \{ \n \
- {dict set date tzName } \[ \
- {ConvertLegacyTimeZone $field} \
- [incr captureCount] \] \n \
- \} \n \
- }
- % { # Literal percent character
- append re %
- }
- default {
- append re %
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- }
- %E {
- switch -exact -- $c {
- C { # Locale-dependent era
- set d {}
- foreach triple [mc LOCALE_ERAS] {
- lassign $triple t symbol year
- dict set d [string tolower $symbol] $year
- }
- lassign [UniquePrefixRegexp $d] regex lookup
- append re (?: $regex )
- }
- E {
- set l {}
- dict set l [string tolower [mc BCE]] BCE
- dict set l [string tolower [mc CE]] CE
- dict set l b.c.e. BCE
- dict set l c.e. CE
- dict set l b.c. BCE
- dict set l a.d. CE
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet era [incr fieldCount]
- append postcode "dict set date era \["\
- "dict get " [list $lookup] \
- { } \[ {string tolower $field} \
- [incr captureCount] \] \
- "\]\n"
- }
- y { # Locale-dependent year of the era
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- incr captureCount
- }
- default {
- append re %E
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- set state {}
- }
- %O {
- switch -exact -- $c {
- d - e {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet dayOfMonth [incr fieldCount]
- append postcode "dict set date dayOfMonth \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- H - k {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet hour [incr fieldCount]
- append postcode "dict set date hour \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- I - l {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet hourAMPM [incr fieldCount]
- append postcode "dict set date hourAMPM \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- m {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- M {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet minute [incr fieldCount]
- append postcode "dict set date minute \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- S {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet second [incr fieldCount]
- append postcode "dict set date second \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- u - w {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode "set dow \[dict get " [list $lookup] \
- { $field} [incr captureCount] \] \n \
- {
- if { $dow == 0 } {
- set dow 7
- } elseif { $dow > 7 } {
- return -code error \
- -errorcode [list CLOCK badDayOfWeek] \
- "day of week is greater than 7"
- }
- dict set date dayOfWeek $dow
- }
- }
- y {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode {dict set date yearOfCentury } \[ \
- {dict get } [list $lookup] { $field} \
- [incr captureCount] \] \n
- }
- default {
- append re %O
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- set state {}
- }
- }
- }
-
- # Clean up any unfinished format groups
-
- append re $state \\s*\$
-
- # Build the procedure
-
- set procBody {}
- append procBody "variable ::tcl::clock::TZData" \n
- append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
- for { set i 1 } { $i <= $captureCount } { incr i } {
- append procBody " " field $i
- }
- append procBody "\] \} \{" \n
- append procBody {
- return -code error -errorcode [list CLOCK badInputString] \
- {input string does not match supplied format}
- }
- append procBody \}\n
- append procBody "set date \[dict create\]" \n
- append procBody {dict set date tzName $timeZone} \n
- append procBody $postcode
- append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
-
- # Set up the time zone before doing anything with a default base date
- # that might need a timezone to interpret it.
-
- if { ![dict exists $fieldSet seconds]
- && ![dict exists $fieldSet starDate] } {
- if { [dict exists $fieldSet tzName] } {
- append procBody {
- set timeZone [dict get $date tzName]
- }
- }
- append procBody {
- ::tcl::clock::SetupTimeZone $timeZone
- }
- }
-
- # Add code that gets Julian Day Number from the fields.
-
- append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
-
- # Get time of day
-
- append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
-
- # Assemble seconds from the Julian day and second of the day.
- # Convert to local time unless epoch seconds or stardate are
- # being processed - they're always absolute
-
- if { ![dict exists $fieldSet seconds]
- && ![dict exists $fieldSet starDate] } {
- append procBody {
- if { [dict get $date julianDay] > 5373484 } {
- return -code error -errorcode [list CLOCK dateTooLarge] \
- "requested date too large to represent"
- }
- dict set date localSeconds [expr {
- -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay]
- }]
- }
-
- # Finally, convert the date to local time
-
- append procBody {
- set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
- $TZData($timeZone) $changeover]
- }
- }
-
- # Return result
-
- append procBody {return [dict get $date seconds]} \n
-
- proc $procName { string baseTime timeZone } $procBody
-
- # puts [list proc $procName [list string baseTime timeZone] $procBody]
-
- return $procName
-}
-
-#----------------------------------------------------------------------
-#
-# LocaleNumeralMatcher --
-#
-# Composes a regexp that captures the numerals in the given locale, and
-# a dictionary to map them to conventional numerals.
-#
-# Parameters:
-# locale - Name of the current locale
-#
-# Results:
-# Returns a two-element list comprising the regexp and the dictionary.
-#
-# Side effects:
-# Caches the result.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::LocaleNumeralMatcher {l} {
- variable LocaleNumeralCache
-
- if { ![dict exists $LocaleNumeralCache $l] } {
- set d {}
- set i 0
- set sep \(
- foreach n [mc LOCALE_NUMERALS] {
- dict set d $n $i
- regsub -all {[^[:alnum:]]} $n \\\\& subex
- append re $sep $subex
- set sep |
- incr i
- }
- append re \)
- dict set LocaleNumeralCache $l [list $re $d]
- }
- return [dict get $LocaleNumeralCache $l]
-}
-
-
-
-#----------------------------------------------------------------------
-#
-# UniquePrefixRegexp --
-#
-# Composes a regexp that performs unique-prefix matching. The RE
-# matches one of a supplied set of strings, or any unique prefix
-# thereof.
-#
-# Parameters:
-# data - List of alternating match-strings and values.
-# Match-strings with distinct values are considered
-# distinct.
-#
-# Results:
-# Returns a two-element list. The first is a regexp that matches any
-# unique prefix of any of the strings. The second is a dictionary whose
-# keys are match values from the regexp and whose values are the
-# corresponding values from 'data'.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::UniquePrefixRegexp { data } {
- # The 'successors' dictionary will contain, for each string that is a
- # prefix of any key, all characters that may follow that prefix. The
- # 'prefixMapping' dictionary will have keys that are prefixes of keys and
- # values that correspond to the keys.
-
- set prefixMapping [dict create]
- set successors [dict create {} {}]
-
- # Walk the key-value pairs
-
- foreach { key value } $data {
- # Construct all prefixes of the key;
-
- set prefix {}
- foreach char [split $key {}] {
- set oldPrefix $prefix
- dict set successors $oldPrefix $char {}
- append prefix $char
-
- # Put the prefixes in the 'prefixMapping' and 'successors'
- # dictionaries
-
- dict lappend prefixMapping $prefix $value
- if { ![dict exists $successors $prefix] } {
- dict set successors $prefix {}
- }
- }
- }
-
- # Identify those prefixes that designate unique values, and those that are
- # the full keys
-
- set uniquePrefixMapping {}
- dict for { key valueList } $prefixMapping {
- if { [llength $valueList] == 1 } {
- dict set uniquePrefixMapping $key [lindex $valueList 0]
- }
- }
- foreach { key value } $data {
- dict set uniquePrefixMapping $key $value
- }
-
- # Construct the re.
-
- return [list \
- [MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
- $uniquePrefixMapping]
-}
-
-#----------------------------------------------------------------------
-#
-# MakeUniquePrefixRegexp --
-#
-# Service procedure for 'UniquePrefixRegexp' that constructs a regular
-# expresison that matches the unique prefixes.
-#
-# Parameters:
-# successors - Dictionary whose keys are all prefixes
-# of keys passed to 'UniquePrefixRegexp' and whose
-# values are dictionaries whose keys are the characters
-# that may follow those prefixes.
-# uniquePrefixMapping - Dictionary whose keys are the unique
-# prefixes and whose values are not examined.
-# prefixString - Current prefix being processed.
-#
-# Results:
-# Returns a constructed regular expression that matches the set of
-# unique prefixes beginning with the 'prefixString'.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::MakeUniquePrefixRegexp { successors
- uniquePrefixMapping
- prefixString } {
- # Get the characters that may follow the current prefix string
-
- set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
- if { [llength $schars] == 0 } {
- return {}
- }
-
- # If there is more than one successor character, or if the current prefix
- # is a unique prefix, surround the generated re with non-capturing
- # parentheses.
-
- set re {}
- if {
- [dict exists $uniquePrefixMapping $prefixString]
- || [llength $schars] > 1
- } then {
- append re "(?:"
- }
-
- # Generate a regexp that matches the successors.
-
- set sep ""
- foreach { c } $schars {
- set nextPrefix $prefixString$c
- regsub -all {[^[:alnum:]]} $c \\\\& rechar
- append re $sep $rechar \
- [MakeUniquePrefixRegexp \
- $successors $uniquePrefixMapping $nextPrefix]
- set sep |
- }
-
- # If the current prefix is a unique prefix, make all following text
- # optional. Otherwise, if there is more than one successor character,
- # close the non-capturing parentheses.
-
- if { [dict exists $uniquePrefixMapping $prefixString] } {
- append re ")?"
- } elseif { [llength $schars] > 1 } {
- append re ")"
- }
-
- return $re
-}
-
-#----------------------------------------------------------------------
-#
-# MakeParseCodeFromFields --
-#
-# Composes Tcl code to extract the Julian Day Number from a dictionary
-# containing date fields.
-#
-# Parameters:
-# dateFields -- Dictionary whose keys are fields of the date,
-# and whose values are the rightmost positions
-# at which those fields appear.
-# parseActions -- List of triples: field set, priority, and
-# code to emit. Smaller priorities are better, and
-# the list must be in ascending order by priority
-#
-# Results:
-# Returns a burst of code that extracts the day number from the given
-# date.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
- set currPrio 999
- set currFieldPos [list]
- set currCodeBurst {
- error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
- }
-
- foreach { fieldSet prio parseAction } $parseActions {
- # If we've found an answer that's better than any that follow, quit
- # now.
-
- if { $prio > $currPrio } {
- break
- }
-
- # Accumulate the field positions that are used in the current field
- # grouping.
-
- set fieldPos [list]
- set ok true
- foreach field $fieldSet {
- if { ! [dict exists $dateFields $field] } {
- set ok 0
- break
- }
- lappend fieldPos [dict get $dateFields $field]
- }
-
- # Quit if we don't have a complete set of fields
- if { !$ok } {
- continue
- }
-
- # Determine whether the current answer is better than the last.
-
- set fPos [lsort -integer -decreasing $fieldPos]
-
- if { $prio == $currPrio } {
- foreach currPos $currFieldPos newPos $fPos {
- if {
- ![string is integer $newPos]
- || ![string is integer $currPos]
- || $newPos > $currPos
- } then {
- break
- }
- if { $newPos < $currPos } {
- set ok 0
- break
- }
- }
- }
- if { !$ok } {
- continue
- }
-
- # Remember the best possibility for extracting date information
-
- set currPrio $prio
- set currFieldPos $fPos
- set currCodeBurst $parseAction
- }
-
- return $currCodeBurst
-}
-
-#----------------------------------------------------------------------
-#
-# EnterLocale --
-#
-# Switch [mclocale] to a given locale if necessary
-#
-# Parameters:
-# locale -- Desired locale
-# oldLocaleVar -- Name of a variable in caller's scope that
-# tracks the previous locale name.
-#
-# Results:
-# Returns the locale that was previously current.
-#
-# Side effects:
-# Does [mclocale]. If necessary, uses [mcload] to load the designated
-# locale's files, and tracks that it has done so in the 'McLoaded'
-# variable.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
- upvar 1 $oldLocaleVar oldLocale
-
- variable MsgDir
- variable McLoaded
-
- set oldLocale [mclocale]
- if { $locale eq {system} } {
- if { $::tcl_platform(platform) ne {windows} } {
- # On a non-windows platform, the 'system' locale is the same as
- # the 'current' locale
-
- set locale current
- } else {
- # On a windows platform, the 'system' locale is adapted from the
- # 'current' locale by applying the date and time formats from the
- # Control Panel. First, load the 'current' locale if it's not yet
- # loaded
-
- if {![dict exists $McLoaded $oldLocale] } {
- mcload $MsgDir
- dict set McLoaded $oldLocale {}
- }
-
- # Make a new locale string for the system locale, and get the
- # Control Panel information
-
- set locale ${oldLocale}_windows
- if { ![dict exists $McLoaded $locale] } {
- LoadWindowsDateTimeFormats $locale
- dict set McLoaded $locale {}
- }
- }
- }
- if { $locale eq {current}} {
- set locale $oldLocale
- unset oldLocale
- } elseif { $locale eq $oldLocale } {
- unset oldLocale
- } else {
- mclocale $locale
- }
- if { ![dict exists $McLoaded $locale] } {
- mcload $MsgDir
- dict set McLoaded $locale {}
- }
-}
-
-#----------------------------------------------------------------------
-#
-# LoadWindowsDateTimeFormats --
-#
-# Load the date/time formats from the Control Panel in Windows and
-# convert them so that they're usable by Tcl.
-#
-# Parameters:
-# locale - Name of the locale in whose message catalog
-# the converted formats are to be stored.
-#
-# Results:
-# None.
-#
-# Side effects:
-# Updates the given message catalog with the locale strings.
-#
-# Presumes that on entry, [mclocale] is set to the current locale, so that
-# default strings can be obtained if the Registry query fails.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
- # Bail out if we can't find the Registry
-
- variable NoRegistry
- if { [info exists NoRegistry] } return
-
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sShortDate
- } string] } {
- set quote {}
- set datefmt {}
- foreach { unquoted quoted } [split $string '] {
- append datefmt $quote [string map {
- dddd %A
- ddd %a
- dd %d
- d %e
- MMMM %B
- MMM %b
- MM %m
- M %N
- yyyy %Y
- yy %y
- y %y
- gg {}
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale DATE_FORMAT $datefmt
- }
-
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sLongDate
- } string] } {
- set quote {}
- set ldatefmt {}
- foreach { unquoted quoted } [split $string '] {
- append ldatefmt $quote [string map {
- dddd %A
- ddd %a
- dd %d
- d %e
- MMMM %B
- MMM %b
- MM %m
- M %N
- yyyy %Y
- yy %y
- y %y
- gg {}
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
- }
-
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sTimeFormat
- } string] } {
- set quote {}
- set timefmt {}
- foreach { unquoted quoted } [split $string '] {
- append timefmt $quote [string map {
- HH %H
- H %k
- hh %I
- h %l
- mm %M
- m %M
- ss %S
- s %S
- tt %p
- t %p
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale TIME_FORMAT $timefmt
- }
-
- catch {
- ::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
- }
- catch {
- ::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
- }
-
- return
-}
-
-#----------------------------------------------------------------------
-#
-# LocalizeFormat --
-#
-# Map away locale-dependent format groups in a clock format.
-#
-# Parameters:
-# locale -- Current [mclocale] locale, supplied to avoid
-# an extra call
-# format -- Format supplied to [clock scan] or [clock format]
-#
-# Results:
-# Returns the string with locale-dependent composite format groups
-# substituted out.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::LocalizeFormat { locale format } {
- variable McLoaded
-
- if { [dict exists $McLoaded $locale FORMAT $format] } {
- return [dict get $McLoaded $locale FORMAT $format]
- }
- set inFormat $format
-
- # Handle locale-dependent format groups by mapping them out of the format
- # string. Note that the order of the [string map] operations is
- # significant because later formats can refer to later ones; for example
- # %c can refer to %X, which in turn can refer to %T.
-
- set list {
- %% %%
- %D %m/%d/%Y
- %+ {%a %b %e %H:%M:%S %Z %Y}
- }
- lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]]
- lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]]
- lappend list %R [string map $list [mc TIME_FORMAT_24]]
- lappend list %r [string map $list [mc TIME_FORMAT_12]]
- lappend list %X [string map $list [mc TIME_FORMAT]]
- lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]]
- lappend list %x [string map $list [mc DATE_FORMAT]]
- lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]]
- lappend list %c [string map $list [mc DATE_TIME_FORMAT]]
- lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]]
- set format [string map $list $format]
-
- dict set McLoaded $locale FORMAT $inFormat $format
- return $format
-}
-
-#----------------------------------------------------------------------
-#
-# FormatNumericTimeZone --
-#
-# Formats a time zone as +hhmmss
-#
-# Parameters:
-# z - Time zone in seconds east of Greenwich
-#
-# Results:
-# Returns the time zone formatted in a numeric form
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::FormatNumericTimeZone { z } {
- if { $z < 0 } {
- set z [expr { - $z }]
- set retval -
- } else {
- set retval +
- }
- append retval [::format %02d [expr { $z / 3600 }]]
- set z [expr { $z % 3600 }]
- append retval [::format %02d [expr { $z / 60 }]]
- set z [expr { $z % 60 }]
- if { $z != 0 } {
- append retval [::format %02d $z]
- }
- return $retval
-}
-
-#----------------------------------------------------------------------
-#
-# FormatStarDate --
-#
-# Formats a date as a StarDate.
-#
-# Parameters:
-# date - Dictionary containing 'year', 'dayOfYear', and
-# 'localSeconds' fields.
-#
-# Results:
-# Returns the given date formatted as a StarDate.
-#
-# Side effects:
-# None.
-#
-# Jeff Hobbs put this in to support an atrocious pun about Tcl being
-# "Enterprise ready." Now we're stuck with it.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::FormatStarDate { date } {
- variable Roddenberry
-
- # Get day of year, zero based
-
- set doy [expr { [dict get $date dayOfYear] - 1 }]
-
- # Determine whether the year is a leap year
-
- set lp [IsGregorianLeapYear $date]
-
- # Convert day of year to a fractional year
-
- if { $lp } {
- set fractYear [expr { 1000 * $doy / 366 }]
- } else {
- set fractYear [expr { 1000 * $doy / 365 }]
- }
-
- # Put together the StarDate
-
- return [::format "Stardate %02d%03d.%1d" \
- [expr { [dict get $date year] - $Roddenberry }] \
- $fractYear \
- [expr { [dict get $date localSeconds] % 86400
- / ( 86400 / 10 ) }]]
-}
-
-#----------------------------------------------------------------------
-#
-# ParseStarDate --
-#
-# Parses a StarDate
-#
-# Parameters:
-# year - Year from the Roddenberry epoch
-# fractYear - Fraction of a year specifiying the day of year.
-# fractDay - Fraction of a day
-#
-# Results:
-# Returns a count of seconds from the Posix epoch.
-#
-# Side effects:
-# None.
-#
-# Jeff Hobbs put this in to support an atrocious pun about Tcl being
-# "Enterprise ready." Now we're stuck with it.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
- variable Roddenberry
-
- # Build a tentative date from year and fraction.
-
- set date [dict create \
- gregorian 1 \
- era CE \
- year [expr { $year + $Roddenberry }] \
- dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
- set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
-
- # Determine whether the given year is a leap year
-
- set lp [IsGregorianLeapYear $date]
-
- # Reconvert the fractional year according to whether the given year is a
- # leap year
-
- if { $lp } {
- dict set date dayOfYear \
- [expr { $fractYear * 366 / 1000 + 1 }]
- } else {
- dict set date dayOfYear \
- [expr { $fractYear * 365 / 1000 + 1 }]
- }
- dict unset date julianDay
- dict unset date gregorian
- set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
-
- return [expr {
- 86400 * [dict get $date julianDay]
- - 210866803200
- + ( 86400 / 10 ) * $fractDay
- }]
-}
-
-#----------------------------------------------------------------------
-#
-# ScanWide --
-#
-# Scans a wide integer from an input
-#
-# Parameters:
-# str - String containing a decimal wide integer
-#
-# Results:
-# Returns the string as a pure wide integer. Throws an error if the
-# string is misformatted or out of range.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ScanWide { str } {
- set count [::scan $str {%ld %c} result junk]
- if { $count != 1 } {
- return -code error -errorcode [list CLOCK notAnInteger $str] \
- "\"$str\" is not an integer"
- }
- if { [incr result 0] != $str } {
- return -code error -errorcode [list CLOCK integervalueTooLarge] \
- "integer value too large to represent"
- }
- return $result
-}
-
-#----------------------------------------------------------------------
-#
-# InterpretTwoDigitYear --
-#
-# Given a date that contains only the year of the century, determines
-# the target value of a two-digit year.
-#
-# Parameters:
-# date - Dictionary containing fields of the date.
-# baseTime - Base time relative to which the date is expressed.
-# twoDigitField - Name of the field that stores the two-digit year.
-# Default is 'yearOfCentury'
-# fourDigitField - Name of the field that will receive the four-digit
-# year. Default is 'year'
-#
-# Results:
-# Returns the dictionary augmented with the four-digit year, stored in
-# the given key.
-#
-# Side effects:
-# None.
-#
-# The current rule for interpreting a two-digit year is that the year shall be
-# between 1937 and 2037, thus staying within the range of a 32-bit signed
-# value for time. This rule may change to a sliding window in future
-# versions, so the 'baseTime' parameter (which is currently ignored) is
-# provided in the procedure signature.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
- { twoDigitField yearOfCentury }
- { fourDigitField year } } {
- set yr [dict get $date $twoDigitField]
- if { $yr <= 37 } {
- dict set date $fourDigitField [expr { $yr + 2000 }]
- } else {
- dict set date $fourDigitField [expr { $yr + 1900 }]
- }
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# AssignBaseYear --
-#
-# Places the number of the current year into a dictionary.
-#
-# Parameters:
-# date - Dictionary value to update
-# baseTime - Base time from which to extract the year, expressed
-# in seconds from the Posix epoch
-# timezone - the time zone in which the date is being scanned
-# changeover - the Julian Day on which the Gregorian calendar
-# was adopted in the target locale.
-#
-# Results:
-# Returns the dictionary with the current year assigned.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
- variable TZData
-
- # Find the Julian Day Number corresponding to the base time, and
- # find the Gregorian year corresponding to that Julian Day.
-
- set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
-
- # Store the converted year
-
- dict set date era [dict get $date2 era]
- dict set date year [dict get $date2 year]
-
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# AssignBaseIso8601Year --
-#
-# Determines the base year in the ISO8601 fiscal calendar.
-#
-# Parameters:
-# date - Dictionary containing the fields of the date that
-# is to be augmented with the base year.
-# baseTime - Base time expressed in seconds from the Posix epoch.
-# timeZone - Target time zone
-# changeover - Julian Day of adoption of the Gregorian calendar in
-# the target locale.
-#
-# Results:
-# Returns the given date with "iso8601Year" set to the
-# base year.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
- variable TZData
-
- # Find the Julian Day Number corresponding to the base time
-
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
-
- # Calculate the ISO8601 date and transfer the year
-
- dict set date era CE
- dict set date iso8601Year [dict get $date2 iso8601Year]
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# AssignBaseMonth --
-#
-# Places the number of the current year and month into a
-# dictionary.
-#
-# Parameters:
-# date - Dictionary value to update
-# baseTime - Time from which the year and month are to be
-# obtained, expressed in seconds from the Posix epoch.
-# timezone - Name of the desired time zone
-# changeover - Julian Day on which the Gregorian calendar was adopted.
-#
-# Results:
-# Returns the dictionary with the base year and month assigned.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
- variable TZData
-
- # Find the year and month corresponding to the base time
-
- set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
- dict set date era [dict get $date2 era]
- dict set date year [dict get $date2 year]
- dict set date month [dict get $date2 month]
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# AssignBaseWeek --
-#
-# Determines the base year and week in the ISO8601 fiscal calendar.
-#
-# Parameters:
-# date - Dictionary containing the fields of the date that
-# is to be augmented with the base year and week.
-# baseTime - Base time expressed in seconds from the Posix epoch.
-# changeover - Julian Day on which the Gregorian calendar was adopted
-# in the target locale.
-#
-# Results:
-# Returns the given date with "iso8601Year" set to the
-# base year and "iso8601Week" to the week number.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
- variable TZData
-
- # Find the Julian Day Number corresponding to the base time
-
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
-
- # Calculate the ISO8601 date and transfer the year
-
- dict set date era CE
- dict set date iso8601Year [dict get $date2 iso8601Year]
- dict set date iso8601Week [dict get $date2 iso8601Week]
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# AssignBaseJulianDay --
-#
-# Determines the base day for a time-of-day conversion.
-#
-# Parameters:
-# date - Dictionary that is to get the base day
-# baseTime - Base time expressed in seconds from the Posix epoch
-# changeover - Julian day on which the Gregorian calendar was
-# adpoted in the target locale.
-#
-# Results:
-# Returns the given dictionary augmented with a 'julianDay' field
-# that contains the base day.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
- variable TZData
-
- # Find the Julian Day Number corresponding to the base time
-
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
- dict set date julianDay [dict get $date2 julianDay]
-
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# InterpretHMSP --
-#
-# Interprets a time in the form "hh:mm:ss am".
-#
-# Parameters:
-# date -- Dictionary containing "hourAMPM", "minute", "second"
-# and "amPmIndicator" fields.
-#
-# Results:
-# Returns the number of seconds from local midnight.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::InterpretHMSP { date } {
- set hr [dict get $date hourAMPM]
- if { $hr == 12 } {
- set hr 0
- }
- if { [dict get $date amPmIndicator] } {
- incr hr 12
- }
- dict set date hour $hr
- return [InterpretHMS $date[set date {}]]
-}
-
-#----------------------------------------------------------------------
-#
-# InterpretHMS --
-#
-# Interprets a 24-hour time "hh:mm:ss"
-#
-# Parameters:
-# date -- Dictionary containing the "hour", "minute" and "second"
-# fields.
-#
-# Results:
-# Returns the given dictionary augmented with a "secondOfDay"
-# field containing the number of seconds from local midnight.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::InterpretHMS { date } {
- return [expr {
- ( [dict get $date hour] * 60
- + [dict get $date minute] ) * 60
- + [dict get $date second]
- }]
-}
-
-#----------------------------------------------------------------------
-#
-# GetSystemTimeZone --
-#
-# Determines the system time zone, which is the default for the
-# 'clock' command if no other zone is supplied.
-#
-# Parameters:
-# None.
-#
-# Results:
-# Returns the system time zone.
-#
-# Side effects:
-# Stores the sustem time zone in the 'CachedSystemTimeZone'
-# variable, since determining it may be an expensive process.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GetSystemTimeZone {} {
- variable CachedSystemTimeZone
- variable TimeZoneBad
-
- if {[set result [getenv TCL_TZ]] ne {}} {
- set timezone $result
- } elseif {[set result [getenv TZ]] ne {}} {
- set timezone $result
- }
- if {![info exists timezone]} {
- # Cache the time zone only if it was detected by one of the
- # expensive methods.
- if { [info exists CachedSystemTimeZone] } {
- set timezone $CachedSystemTimeZone
- } elseif { $::tcl_platform(platform) eq {windows} } {
- set timezone [GuessWindowsTimeZone]
- } elseif { [file exists /etc/localtime]
- && ![catch {ReadZoneinfoFile \
- Tcl/Localtime /etc/localtime}] } {
- set timezone :Tcl/Localtime
- } else {
- set timezone :localtime
- }
- set CachedSystemTimeZone $timezone
- }
- if { ![dict exists $TimeZoneBad $timezone] } {
- dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
- }
- if { [dict get $TimeZoneBad $timezone] } {
- return :localtime
- } else {
- return $timezone
- }
-}
-
-#----------------------------------------------------------------------
-#
-# ConvertLegacyTimeZone --
-#
-# Given an alphanumeric time zone identifier and the system time zone,
-# convert the alphanumeric identifier to an unambiguous time zone.
-#
-# Parameters:
-# tzname - Name of the time zone to convert
-#
-# Results:
-# Returns a time zone name corresponding to tzname, but in an
-# unambiguous form, generally +hhmm.
-#
-# This procedure is implemented primarily to allow the parsing of RFC822
-# date/time strings. Processing a time zone name on input is not recommended
-# practice, because there is considerable room for ambiguity; for instance, is
-# BST Brazilian Standard Time, or British Summer Time?
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
- variable LegacyTimeZone
-
- set tzname [string tolower $tzname]
- if { ![dict exists $LegacyTimeZone $tzname] } {
- return -code error -errorcode [list CLOCK badTZName $tzname] \
- "time zone \"$tzname\" not found"
- }
- return [dict get $LegacyTimeZone $tzname]
-}
-
-#----------------------------------------------------------------------
-#
-# SetupTimeZone --
-#
-# Given the name or specification of a time zone, sets up its in-memory
-# data.
-#
-# Parameters:
-# tzname - Name of a time zone
-#
-# Results:
-# Unless the time zone is ':localtime', sets the TZData array to contain
-# the lookup table for local<->UTC conversion. Returns an error if the
-# time zone cannot be parsed.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::SetupTimeZone { timezone } {
- variable TZData
-
- if {! [info exists TZData($timezone)] } {
- variable MINWIDE
- if { $timezone eq {:localtime} } {
- # Nothing to do, we'll convert using the localtime function
-
- } elseif {
- [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
- -> s hh mm ss]
- } then {
- # Make a fixed offset
-
- ::scan $hh %d hh
- if { $mm eq {} } {
- set mm 0
- } else {
- ::scan $mm %d mm
- }
- if { $ss eq {} } {
- set ss 0
- } else {
- ::scan $ss %d ss
- }
- set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
- if { $s eq {-} } {
- set offset [expr { - $offset }]
- }
- set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
-
- } elseif { [string index $timezone 0] eq {:} } {
- # Convert using a time zone file
-
- if {
- [catch {
- LoadTimeZoneFile [string range $timezone 1 end]
- }] && [catch {
- LoadZoneinfoFile [string range $timezone 1 end]
- }]
- } then {
- return -code error \
- -errorcode [list CLOCK badTimeZone $timezone] \
- "time zone \"$timezone\" not found"
- }
-
- } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
- # This looks like a POSIX time zone - try to process it
-
- if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
- if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
- dict unset opts -errorinfo
- }
- return -options $opts $data
- } else {
- set TZData($timezone) $data
- }
-
- } else {
- # We couldn't parse this as a POSIX time zone. Try again with a
- # time zone file - this time without a colon
-
- if { [catch { LoadTimeZoneFile $timezone }]
- && [catch { LoadZoneinfoFile $timezone } - opts] } {
- dict unset opts -errorinfo
- return -options $opts "time zone $timezone not found"
- }
- set TZData($timezone) $TZData(:$timezone)
- }
- }
-
- return
-}
-
-#----------------------------------------------------------------------
-#
-# GuessWindowsTimeZone --
-#
-# Determines the system time zone on windows.
-#
-# Parameters:
-# None.
-#
-# Results:
-# Returns a time zone specifier that corresponds to the system time zone
-# information found in the Registry.
-#
-# Bugs:
-# Fixed dates for DST change are unimplemented at present, because no
-# time zone information supplied with Windows actually uses them!
-#
-# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified,
-# GuessWindowsTimeZone looks in the Registry for the system time zone
-# information. It then attempts to find an entry in WinZoneInfo for a time
-# zone that uses the same rules. If it finds one, it returns it; otherwise,
-# it constructs a Posix-style time zone string and returns that.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GuessWindowsTimeZone {} {
- variable WinZoneInfo
- variable NoRegistry
- variable TimeZoneBad
-
- if { [info exists NoRegistry] } {
- return :localtime
- }
-
- # Dredge time zone information out of the registry
-
- if { [catch {
- set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
- set data [list \
- [expr { -60
- * [registry get $rpath Bias] }] \
- [expr { -60
- * [registry get $rpath StandardBias] }] \
- [expr { -60 \
- * [registry get $rpath DaylightBias] }]]
- set stdtzi [registry get $rpath StandardStart]
- foreach ind {0 2 14 4 6 8 10 12} {
- binary scan $stdtzi @${ind}s val
- lappend data $val
- }
- set daytzi [registry get $rpath DaylightStart]
- foreach ind {0 2 14 4 6 8 10 12} {
- binary scan $daytzi @${ind}s val
- lappend data $val
- }
- }] } {
- # Missing values in the Registry - bail out
-
- return :localtime
- }
-
- # Make up a Posix time zone specifier if we can't find one. Check here
- # that the tzdata file exists, in case we're running in an environment
- # (e.g. starpack) where tzdata is incomplete. (Bug 1237907)
-
- if { [dict exists $WinZoneInfo $data] } {
- set tzname [dict get $WinZoneInfo $data]
- if { ! [dict exists $TimeZoneBad $tzname] } {
- dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
- }
- } else {
- set tzname {}
- }
- if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } {
- lassign $data \
- bias stdBias dstBias \
- stdYear stdMonth stdDayOfWeek stdDayOfMonth \
- stdHour stdMinute stdSecond stdMillisec \
- dstYear dstMonth dstDayOfWeek dstDayOfMonth \
- dstHour dstMinute dstSecond dstMillisec
- set stdDelta [expr { $bias + $stdBias }]
- set dstDelta [expr { $bias + $dstBias }]
- if { $stdDelta <= 0 } {
- set stdSignum +
- set stdDelta [expr { - $stdDelta }]
- set dispStdSignum -
- } else {
- set stdSignum -
- set dispStdSignum +
- }
- set hh [::format %02d [expr { $stdDelta / 3600 }]]
- set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
- set ss [::format %02d [expr { $stdDelta % 60 }]]
- set tzname {}
- append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
- if { $stdMonth >= 0 } {
- if { $dstDelta <= 0 } {
- set dstSignum +
- set dstDelta [expr { - $dstDelta }]
- set dispDstSignum -
- } else {
- set dstSignum -
- set dispDstSignum +
- }
- set hh [::format %02d [expr { $dstDelta / 3600 }]]
- set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
- set ss [::format %02d [expr { $dstDelta % 60 }]]
- append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
- if { $dstYear == 0 } {
- append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
- } else {
- # I have not been able to find any locale on which Windows
- # converts time zone on a fixed day of the year, hence don't
- # know how to interpret the fields. If someone can inform me,
- # I'd be glad to code it up. For right now, we bail out in
- # such a case.
- return :localtime
- }
- append tzname / [::format %02d $dstHour] \
- : [::format %02d $dstMinute] \
- : [::format %02d $dstSecond]
- if { $stdYear == 0 } {
- append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
- } else {
- # I have not been able to find any locale on which Windows
- # converts time zone on a fixed day of the year, hence don't
- # know how to interpret the fields. If someone can inform me,
- # I'd be glad to code it up. For right now, we bail out in
- # such a case.
- return :localtime
- }
- append tzname / [::format %02d $stdHour] \
- : [::format %02d $stdMinute] \
- : [::format %02d $stdSecond]
- }
- dict set WinZoneInfo $data $tzname
- }
-
- return [dict get $WinZoneInfo $data]
-}
-
-#----------------------------------------------------------------------
-#
-# LoadTimeZoneFile --
-#
-# Load the data file that specifies the conversion between a
-# given time zone and Greenwich.
-#
-# Parameters:
-# fileName -- Name of the file to load
-#
-# Results:
-# None.
-#
-# Side effects:
-# TZData(:fileName) contains the time zone data
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::LoadTimeZoneFile { fileName } {
- variable DataDir
- variable TZData
-
- if { [info exists TZData($fileName)] } {
- return
- }
-
- # Since an unsafe interp uses the [clock] command in the master, this code
- # is security sensitive. Make sure that the path name cannot escape the
- # given directory.
-
- if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $:fileName] \
- "time zone \":$fileName\" not valid"
- }
- try {
- source -encoding utf-8 [file join $DataDir $fileName]
- } on error {} {
- return -code error \
- -errorcode [list CLOCK badTimeZone :$fileName] \
- "time zone \":$fileName\" not found"
- }
- return
-}
-
-#----------------------------------------------------------------------
-#
-# LoadZoneinfoFile --
-#
-# Loads a binary time zone information file in Olson format.
-#
-# Parameters:
-# fileName - Relative path name of the file to load.
-#
-# Results:
-# Returns an empty result normally; returns an error if no Olson file
-# was found or the file was malformed in some way.
-#
-# Side effects:
-# TZData(:fileName) contains the time zone data
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::LoadZoneinfoFile { fileName } {
- variable ZoneinfoPaths
-
- # Since an unsafe interp uses the [clock] command in the master, this code
- # is security sensitive. Make sure that the path name cannot escape the
- # given directory.
-
- if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $:fileName] \
- "time zone \":$fileName\" not valid"
- }
- foreach d $ZoneinfoPaths {
- set fname [file join $d $fileName]
- if { [file readable $fname] && [file isfile $fname] } {
- break
- }
- unset fname
- }
- ReadZoneinfoFile $fileName $fname
-}
-
-#----------------------------------------------------------------------
-#
-# ReadZoneinfoFile --
-#
-# Loads a binary time zone information file in Olson format.
-#
-# Parameters:
-# fileName - Name of the time zone (relative path name of the
-# file).
-# fname - Absolute path name of the file.
-#
-# Results:
-# Returns an empty result normally; returns an error if no Olson file
-# was found or the file was malformed in some way.
-#
-# Side effects:
-# TZData(:fileName) contains the time zone data
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
- variable MINWIDE
- variable TZData
- if { ![file exists $fname] } {
- return -code error "$fileName not found"
- }
-
- if { [file size $fname] > 262144 } {
- return -code error "$fileName too big"
- }
-
- # Suck in all the data from the file
-
- set f [open $fname r]
- fconfigure $f -translation binary
- set d [read $f]
- close $f
-
- # The file begins with a magic number, sixteen reserved bytes, and then
- # six 4-byte integers giving counts of fileds in the file.
-
- binary scan $d a4a1x15IIIIII \
- magic version nIsGMT nIsStd nLeap nTime nType nChar
- set seek 44
- set ilen 4
- set iformat I
- if { $magic != {TZif} } {
- return -code error "$fileName not a time zone information file"
- }
- if { $nType > 255 } {
- return -code error "$fileName contains too many time types"
- }
- # Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots.
- if { $nLeap != 0 } {
- return -code error "$fileName contains leap seconds"
- }
-
- # In a version 2 file, we use the second part of the file, which contains
- # 64-bit transition times.
-
- if {$version eq "2"} {
- set seek [expr {
- 44
- + 5 * $nTime
- + 6 * $nType
- + 4 * $nLeap
- + $nIsStd
- + $nIsGMT
- + $nChar
- }]
- binary scan $d @${seek}a4a1x15IIIIII \
- magic version nIsGMT nIsStd nLeap nTime nType nChar
- if {$magic ne {TZif}} {
- return -code error "seek address $seek miscomputed, magic = $magic"
- }
- set iformat W
- set ilen 8
- incr seek 44
- }
-
- # Next come ${nTime} transition times, followed by ${nTime} time type
- # codes. The type codes are unsigned 1-byte quantities. We insert an
- # arbitrary start time in front of the transitions.
-
- binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
- incr seek [expr { ($ilen + 1) * $nTime }]
- set times [linsert $times 0 $MINWIDE]
- set codes {}
- foreach c $tempCodes {
- lappend codes [expr { $c & 0xff }]
- }
- set codes [linsert $codes 0 0]
-
- # Next come ${nType} time type descriptions, each of which has an offset
- # (seconds east of GMT), a DST indicator, and an index into the
- # abbreviation text.
-
- for { set i 0 } { $i < $nType } { incr i } {
- binary scan $d @${seek}Icc gmtOff isDst abbrInd
- lappend types [list $gmtOff $isDst $abbrInd]
- incr seek 6
- }
-
- # Next come $nChar characters of time zone name abbreviations, which are
- # null-terminated.
- # We build them up into a dictionary indexed by character index, because
- # that's what's in the indices above.
-
- binary scan $d @${seek}a${nChar} abbrs
- incr seek ${nChar}
- set abbrList [split $abbrs \0]
- set i 0
- set abbrevs {}
- foreach a $abbrList {
- for {set j 0} {$j <= [string length $a]} {incr j} {
- dict set abbrevs $i [string range $a $j end]
- incr i
- }
- }
-
- # Package up a list of tuples, each of which contains transition time,
- # seconds east of Greenwich, DST flag and time zone abbreviation.
-
- set r {}
- set lastTime $MINWIDE
- foreach t $times c $codes {
- if { $t < $lastTime } {
- return -code error "$fileName has times out of order"
- }
- set lastTime $t
- lassign [lindex $types $c] gmtoff isDst abbrInd
- set abbrev [dict get $abbrevs $abbrInd]
- lappend r [list $t $gmtoff $isDst $abbrev]
- }
-
- # In a version 2 file, there is also a POSIX-style time zone description
- # at the very end of the file. To get to it, skip over nLeap leap second
- # values (8 bytes each),
- # nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
-
- if {$version eq {2}} {
- set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
- set last [string first \n $d $seek]
- set posix [string range $d $seek [expr {$last-1}]]
- if {[llength $posix] > 0} {
- set posixFields [ParsePosixTimeZone $posix]
- foreach tuple [ProcessPosixTimeZone $posixFields] {
- lassign $tuple t gmtoff isDst abbrev
- if {$t > $lastTime} {
- lappend r $tuple
- }
- }
- }
- }
-
- set TZData(:$fileName) $r
-
- return
-}
-
-#----------------------------------------------------------------------
-#
-# ParsePosixTimeZone --
-#
-# Parses the TZ environment variable in Posix form
-#
-# Parameters:
-# tz Time zone specifier to be interpreted
-#
-# Results:
-# Returns a dictionary whose values contain the various pieces of the
-# time zone specification.
-#
-# Side effects:
-# None.
-#
-# Errors:
-# Throws an error if the syntax of the time zone is incorrect.
-#
-# The following keys are present in the dictionary:
-# stdName - Name of the time zone when Daylight Saving Time
-# is not in effect.
-# stdSignum - Sign (+, -, or empty) of the offset from Greenwich
-# to the given (non-DST) time zone. + and the empty
-# string denote zones west of Greenwich, - denotes east
-# of Greenwich; this is contrary to the ISO convention
-# but follows Posix.
-# stdHours - Hours part of the offset from Greenwich to the given
-# (non-DST) time zone.
-# stdMinutes - Minutes part of the offset from Greenwich to the
-# given (non-DST) time zone. Empty denotes zero.
-# stdSeconds - Seconds part of the offset from Greenwich to the
-# given (non-DST) time zone. Empty denotes zero.
-# dstName - Name of the time zone when DST is in effect, or the
-# empty string if the time zone does not observe Daylight
-# Saving Time.
-# dstSignum, dstHours, dstMinutes, dstSeconds -
-# Fields corresponding to stdSignum, stdHours, stdMinutes,
-# stdSeconds for the Daylight Saving Time version of the
-# time zone. If dstHours is empty, it is presumed to be 1.
-# startDayOfYear - The ordinal number of the day of the year on which
-# Daylight Saving Time begins. If this field is
-# empty, then DST begins on a given month-week-day,
-# as below.
-# startJ - The letter J, or an empty string. If a J is present in
-# this field, then startDayOfYear does not count February 29
-# even in leap years.
-# startMonth - The number of the month in which Daylight Saving Time
-# begins, supplied if startDayOfYear is empty. If both
-# startDayOfYear and startMonth are empty, then US rules
-# are presumed.
-# startWeekOfMonth - The number of the week in the month in which
-# Daylight Saving Time begins, in the range 1-5.
-# 5 denotes the last week of the month even in a
-# 4-week month.
-# startDayOfWeek - The number of the day of the week (Sunday=0,
-# Saturday=6) on which Daylight Saving Time begins.
-# startHours - The hours part of the time of day at which Daylight
-# Saving Time begins. An empty string is presumed to be 2.
-# startMinutes - The minutes part of the time of day at which DST begins.
-# An empty string is presumed zero.
-# startSeconds - The seconds part of the time of day at which DST begins.
-# An empty string is presumed zero.
-# endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
-# endHours, endMinutes, endSeconds -
-# Specify the end of DST in the same way that the start* fields
-# specify the beginning of DST.
-#
-# This procedure serves only to break the time specifier into fields. No
-# attempt is made to canonicalize the fields or supply default values.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ParsePosixTimeZone { tz } {
- if {[regexp -expanded -nocase -- {
- ^
- # 1 - Standard time zone name
- ([[:alpha:]]+ | <[-+[:alnum:]]+>)
- # 2 - Standard time zone offset, signum
- ([-+]?)
- # 3 - Standard time zone offset, hours
- ([[:digit:]]{1,2})
- (?:
- # 4 - Standard time zone offset, minutes
- : ([[:digit:]]{1,2})
- (?:
- # 5 - Standard time zone offset, seconds
- : ([[:digit:]]{1,2} )
- )?
- )?
- (?:
- # 6 - DST time zone name
- ([[:alpha:]]+ | <[-+[:alnum:]]+>)
- (?:
- (?:
- # 7 - DST time zone offset, signum
- ([-+]?)
- # 8 - DST time zone offset, hours
- ([[:digit:]]{1,2})
- (?:
- # 9 - DST time zone offset, minutes
- : ([[:digit:]]{1,2})
- (?:
- # 10 - DST time zone offset, seconds
- : ([[:digit:]]{1,2})
- )?
- )?
- )?
- (?:
- ,
- (?:
- # 11 - Optional J in n and Jn form 12 - Day of year
- ( J ? ) ( [[:digit:]]+ )
- | M
- # 13 - Month number 14 - Week of month 15 - Day of week
- ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- )
- (?:
- # 16 - Start time of DST - hours
- / ( [[:digit:]]{1,2} )
- (?:
- # 17 - Start time of DST - minutes
- : ( [[:digit:]]{1,2} )
- (?:
- # 18 - Start time of DST - seconds
- : ( [[:digit:]]{1,2} )
- )?
- )?
- )?
- ,
- (?:
- # 19 - Optional J in n and Jn form 20 - Day of year
- ( J ? ) ( [[:digit:]]+ )
- | M
- # 21 - Month number 22 - Week of month 23 - Day of week
- ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- )
- (?:
- # 24 - End time of DST - hours
- / ( [[:digit:]]{1,2} )
- (?:
- # 25 - End time of DST - minutes
- : ( [[:digit:]]{1,2} )
- (?:
- # 26 - End time of DST - seconds
- : ( [[:digit:]]{1,2} )
- )?
- )?
- )?
- )?
- )?
- )?
- $
- } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
- x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
- x(startJ) x(startDayOfYear) \
- x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
- x(startHours) x(startMinutes) x(startSeconds) \
- x(endJ) x(endDayOfYear) \
- x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
- x(endHours) x(endMinutes) x(endSeconds)] } {
- # it's a good timezone
-
- return [array get x]
- }
-
- return -code error\
- -errorcode [list CLOCK badTimeZone $tz] \
- "unable to parse time zone specification \"$tz\""
-}
-
-#----------------------------------------------------------------------
-#
-# ProcessPosixTimeZone --
-#
-# Handle a Posix time zone after it's been broken out into fields.
-#
-# Parameters:
-# z - Dictionary returned from 'ParsePosixTimeZone'
-#
-# Results:
-# Returns time zone information for the 'TZData' array.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ProcessPosixTimeZone { z } {
- variable MINWIDE
- variable TZData
-
- # Determine the standard time zone name and seconds east of Greenwich
-
- set stdName [dict get $z stdName]
- if { [string index $stdName 0] eq {<} } {
- set stdName [string range $stdName 1 end-1]
- }
- if { [dict get $z stdSignum] eq {-} } {
- set stdSignum +1
- } else {
- set stdSignum -1
- }
- set stdHours [lindex [::scan [dict get $z stdHours] %d] 0]
- if { [dict get $z stdMinutes] ne {} } {
- set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0]
- } else {
- set stdMinutes 0
- }
- if { [dict get $z stdSeconds] ne {} } {
- set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0]
- } else {
- set stdSeconds 0
- }
- set stdOffset [expr {
- (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum
- }]
- set data [list [list $MINWIDE $stdOffset 0 $stdName]]
-
- # If there's no daylight zone, we're done
-
- set dstName [dict get $z dstName]
- if { $dstName eq {} } {
- return $data
- }
- if { [string index $dstName 0] eq {<} } {
- set dstName [string range $dstName 1 end-1]
- }
-
- # Determine the daylight name
-
- if { [dict get $z dstSignum] eq {-} } {
- set dstSignum +1
- } else {
- set dstSignum -1
- }
- if { [dict get $z dstHours] eq {} } {
- set dstOffset [expr { 3600 + $stdOffset }]
- } else {
- set dstHours [lindex [::scan [dict get $z dstHours] %d] 0]
- if { [dict get $z dstMinutes] ne {} } {
- set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0]
- } else {
- set dstMinutes 0
- }
- if { [dict get $z dstSeconds] ne {} } {
- set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0]
- } else {
- set dstSeconds 0
- }
- set dstOffset [expr {
- (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum
- }]
- }
-
- # Fill in defaults for European or US DST rules
- # US start time is the second Sunday in March
- # EU start time is the last Sunday in March
- # US end time is the first Sunday in November.
- # EU end time is the last Sunday in October
-
- if {
- [dict get $z startDayOfYear] eq {}
- && [dict get $z startMonth] eq {}
- } then {
- if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
- # EU
- dict set z startWeekOfMonth 5
- if {$stdHours>2} {
- dict set z startHours 2
- } else {
- dict set z startHours [expr {$stdHours+1}]
- }
- } else {
- # US
- dict set z startWeekOfMonth 2
- dict set z startHours 2
- }
- dict set z startMonth 3
- dict set z startDayOfWeek 0
- dict set z startMinutes 0
- dict set z startSeconds 0
- }
- if {
- [dict get $z endDayOfYear] eq {}
- && [dict get $z endMonth] eq {}
- } then {
- if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
- # EU
- dict set z endMonth 10
- dict set z endWeekOfMonth 5
- if {$stdHours>2} {
- dict set z endHours 3
- } else {
- dict set z endHours [expr {$stdHours+2}]
- }
- } else {
- # US
- dict set z endMonth 11
- dict set z endWeekOfMonth 1
- dict set z endHours 2
- }
- dict set z endDayOfWeek 0
- dict set z endMinutes 0
- dict set z endSeconds 0
- }
-
- # Put DST in effect in all years from 1916 to 2099.
-
- for { set y 1916 } { $y < 2100 } { incr y } {
- set startTime [DeterminePosixDSTTime $z start $y]
- incr startTime [expr { - wide($stdOffset) }]
- set endTime [DeterminePosixDSTTime $z end $y]
- incr endTime [expr { - wide($dstOffset) }]
- if { $startTime < $endTime } {
- lappend data \
- [list $startTime $dstOffset 1 $dstName] \
- [list $endTime $stdOffset 0 $stdName]
- } else {
- lappend data \
- [list $endTime $stdOffset 0 $stdName] \
- [list $startTime $dstOffset 1 $dstName]
- }
- }
-
- return $data
-}
-
-#----------------------------------------------------------------------
-#
-# DeterminePosixDSTTime --
-#
-# Determines the time that Daylight Saving Time starts or ends from a
-# Posix time zone specification.
-#
-# Parameters:
-# z - Time zone data returned from ParsePosixTimeZone.
-# Missing fields are expected to be filled in with
-# default values.
-# bound - The word 'start' or 'end'
-# y - The year for which the transition time is to be determined.
-#
-# Results:
-# Returns the transition time as a count of seconds from the epoch. The
-# time is relative to the wall clock, not UTC.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
- variable FEB_28
-
- # Determine the start or end day of DST
-
- set date [dict create era CE year $y]
- set doy [dict get $z ${bound}DayOfYear]
- if { $doy ne {} } {
- # Time was specified as a day of the year
-
- if { [dict get $z ${bound}J] ne {}
- && [IsGregorianLeapYear $y]
- && ( $doy > $FEB_28 ) } {
- incr doy
- }
- dict set date dayOfYear $doy
- set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
- } else {
- # Time was specified as a day of the week within a month
-
- dict set date month [dict get $z ${bound}Month]
- dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
- set dowim [dict get $z ${bound}WeekOfMonth]
- if { $dowim >= 5 } {
- set dowim -1
- }
- dict set date dayOfWeekInMonth $dowim
- set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
-
- }
-
- set jd [dict get $date julianDay]
- set seconds [expr {
- wide($jd) * wide(86400) - wide(210866803200)
- }]
-
- set h [dict get $z ${bound}Hours]
- if { $h eq {} } {
- set h 2
- } else {
- set h [lindex [::scan $h %d] 0]
- }
- set m [dict get $z ${bound}Minutes]
- if { $m eq {} } {
- set m 0
- } else {
- set m [lindex [::scan $m %d] 0]
- }
- set s [dict get $z ${bound}Seconds]
- if { $s eq {} } {
- set s 0
- } else {
- set s [lindex [::scan $s %d] 0]
- }
- set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
- return [expr { $seconds + $tod }]
-}
-
-#----------------------------------------------------------------------
-#
-# GetLocaleEra --
-#
-# Given local time expressed in seconds from the Posix epoch,
-# determine localized era and year within the era.
-#
-# Parameters:
-# date - Dictionary that must contain the keys, 'localSeconds',
-# whose value is expressed as the appropriate local time;
-# and 'year', whose value is the Gregorian year.
-# etable - Value of the LOCALE_ERAS key in the message catalogue
-# for the target locale.
-#
-# Results:
-# Returns the dictionary, augmented with the keys, 'localeEra' and
-# 'localeYear'.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GetLocaleEra { date etable } {
- set index [BSearch $etable [dict get $date localSeconds]]
- if { $index < 0} {
- dict set date localeEra \
- [::format %02d [expr { [dict get $date year] / 100 }]]
- dict set date localeYear [expr {
- [dict get $date year] % 100
- }]
- } else {
- dict set date localeEra [lindex $etable $index 1]
- dict set date localeYear [expr {
- [dict get $date year] - [lindex $etable $index 2]
- }]
- }
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# GetJulianDayFromEraYearDay --
-#
-# Given a year, month and day on the Gregorian calendar, determines
-# the Julian Day Number beginning at noon on that date.
-#
-# Parameters:
-# date -- A dictionary in which the 'era', 'year', and
-# 'dayOfYear' slots are populated. The calendar in use
-# is determined by the date itself relative to:
-# changeover -- Julian day on which the Gregorian calendar was
-# adopted in the current locale.
-#
-# Results:
-# Returns the given dictionary augmented with a 'julianDay' key whose
-# value is the desired Julian Day Number, and a 'gregorian' key that
-# specifies whether the calendar is Gregorian (1) or Julian (0).
-#
-# Side effects:
-# None.
-#
-# Bugs:
-# This code needs to be moved to the C layer.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
- # Get absolute year number from the civil year
-
- switch -exact -- [dict get $date era] {
- BCE {
- set year [expr { 1 - [dict get $date year] }]
- }
- CE {
- set year [dict get $date year]
- }
- }
- set ym1 [expr { $year - 1 }]
-
- # Try the Gregorian calendar first.
-
- dict set date gregorian 1
- set jd [expr {
- 1721425
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 )
- - ( $ym1 / 100 )
- + ( $ym1 / 400 )
- }]
-
- # If the date is before the Gregorian change, use the Julian calendar.
-
- if { $jd < $changeover } {
- dict set date gregorian 0
- set jd [expr {
- 1721423
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 )
- }]
- }
-
- dict set date julianDay $jd
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# GetJulianDayFromEraYearMonthWeekDay --
-#
-# Determines the Julian Day number corresponding to the nth given
-# day-of-the-week in a given month.
-#
-# Parameters:
-# date - Dictionary containing the keys, 'era', 'year', 'month'
-# 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
-# changeover - Julian Day of adoption of the Gregorian calendar
-#
-# Results:
-# Returns the given dictionary, augmented with a 'julianDay' key.
-#
-# Side effects:
-# None.
-#
-# Bugs:
-# This code needs to be moved to the C layer.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
- # Come up with a reference day; either the zeroeth day of the given month
- # (dayOfWeekInMonth >= 0) or the seventh day of the following month
- # (dayOfWeekInMonth < 0)
-
- set date2 $date
- set week [dict get $date dayOfWeekInMonth]
- if { $week >= 0 } {
- dict set date2 dayOfMonth 0
- } else {
- dict incr date2 month
- dict set date2 dayOfMonth 7
- }
- set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
- $changeover]
- set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
- [dict get $date2 julianDay]]
- dict set date julianDay [expr { $wd0 + 7 * $week }]
- return $date
-}
-
-#----------------------------------------------------------------------
-#
-# IsGregorianLeapYear --
-#
-# Determines whether a given date represents a leap year in the
-# Gregorian calendar.
-#
-# Parameters:
-# date -- The date to test. The fields, 'era', 'year' and 'gregorian'
-# must be set.
-#
-# Results:
-# Returns 1 if the year is a leap year, 0 otherwise.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::IsGregorianLeapYear { date } {
- switch -exact -- [dict get $date era] {
- BCE {
- set year [expr { 1 - [dict get $date year]}]
- }
- CE {
- set year [dict get $date year]
- }
- }
- if { $year % 4 != 0 } {
- return 0
- } elseif { ![dict get $date gregorian] } {
- return 1
- } elseif { $year % 400 == 0 } {
- return 1
- } elseif { $year % 100 == 0 } {
- return 0
- } else {
- return 1
- }
-}
-
-#----------------------------------------------------------------------
-#
-# WeekdayOnOrBefore --
-#
-# Determine the nearest day of week (given by the 'weekday' parameter,
-# Sunday==0) on or before a given Julian Day.
-#
-# Parameters:
-# weekday -- Day of the week
-# j -- Julian Day number
-#
-# Results:
-# Returns the Julian Day Number of the desired date.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
- set k [expr { ( $weekday + 6 ) % 7 }]
- return [expr { $j - ( $j - $k ) % 7 }]
-}
-
-#----------------------------------------------------------------------
-#
-# BSearch --
-#
-# Service procedure that does binary search in several places inside the
-# 'clock' command.
-#
-# Parameters:
-# list - List of lists, sorted in ascending order by the
-# first elements
-# key - Value to search for
-#
-# Results:
-# Returns the index of the greatest element in $list that is less than
-# or equal to $key.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::BSearch { list key } {
- if {[llength $list] == 0} {
- return -1
- }
- if { $key < [lindex $list 0 0] } {
- return -1
- }
-
- set l 0
- set u [expr { [llength $list] - 1 }]
-
- while { $l < $u } {
- # At this point, we know that
- # $k >= [lindex $list $l 0]
- # Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
- # We find the midpoint of the interval {l,u} rounded UP, compare
- # against it, and set l or u to maintain the invariant. Note that the
- # interval shrinks at each step, guaranteeing convergence.
-
- set m [expr { ( $l + $u + 1 ) / 2 }]
- if { $key >= [lindex $list $m 0] } {
- set l $m
- } else {
- set u [expr { $m - 1 }]
- }
- }
-
- return $l
-}
-
-#----------------------------------------------------------------------
-#
-# clock add --
-#
-# Adds an offset to a given time.
-#
-# Syntax:
-# clock add clockval ?count unit?... ?-option value?
-#
-# Parameters:
-# clockval -- Starting time value
-# count -- Amount of a unit of time to add
-# unit -- Unit of time to add, must be one of:
-# years year months month weeks week
-# days day hours hour minutes minute
-# seconds second
-#
-# Options:
-# -gmt BOOLEAN
-# (Deprecated) Flag synonymous with '-timezone :GMT'
-# -timezone ZONE
-# Name of the time zone in which calculations are to be done.
-# -locale NAME
-# Name of the locale in which calculations are to be done.
-# Used to determine the Gregorian change date.
-#
-# Results:
-# Returns the given time adjusted by the given offset(s) in
-# order.
-#
-# Notes:
-# It is possible that adding a number of months or years will adjust the
-# day of the month as well. For instance, the time at one month after
-# 31 January is either 28 or 29 February, because February has fewer
-# than 31 days.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::add { clockval args } {
- if { [llength $args] % 2 != 0 } {
- set cmdName "clock add"
- return -code error \
- -errorcode [list CLOCK wrongNumArgs] \
- "wrong \# args: should be\
- \"$cmdName clockval ?number units?...\
- ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
- }
- if { [catch { expr {wide($clockval)} } result] } {
- return -code error $result
- }
-
- set offsets {}
- set gmt 0
- set locale c
- set timezone [GetSystemTimeZone]
-
- foreach { a b } $args {
- if { [string is integer -strict $a] } {
- lappend offsets $a $b
- } else {
- switch -exact -- $a {
- -g - -gm - -gmt {
- set gmt $b
- }
- -l - -lo - -loc - -loca - -local - -locale {
- set locale [string tolower $b]
- }
- -t - -ti - -tim - -time - -timez - -timezo - -timezon -
- -timezone {
- set timezone $b
- }
- default {
- throw [list CLOCK badOption $a] \
- "bad option \"$a\",\
- must be -gmt, -locale or -timezone"
- }
- }
- }
- }
-
- # Check options for validity
-
- if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
- return -code error \
- -errorcode [list CLOCK gmtWithTimezone] \
- "cannot use -gmt and -timezone in same call"
- }
- if { [catch { expr { wide($clockval) } } result] } {
- return -code error "expected integer but got \"$clockval\""
- }
- if { ![string is boolean -strict $gmt] } {
- return -code error "expected boolean value but got \"$gmt\""
- } elseif { $gmt } {
- set timezone :GMT
- }
-
- EnterLocale $locale oldLocale
-
- set changeover [mc GREGORIAN_CHANGE_DATE]
-
- if {[catch {SetupTimeZone $timezone} retval opts]} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
-
- try {
- foreach { quantity unit } $offsets {
- switch -exact -- $unit {
- years - year {
- set clockval [AddMonths [expr { 12 * $quantity }] \
- $clockval $timezone $changeover]
- }
- months - month {
- set clockval [AddMonths $quantity $clockval $timezone \
- $changeover]
- }
-
- weeks - week {
- set clockval [AddDays [expr { 7 * $quantity }] \
- $clockval $timezone $changeover]
- }
- days - day {
- set clockval [AddDays $quantity $clockval $timezone \
- $changeover]
- }
-
- hours - hour {
- set clockval [expr { 3600 * $quantity + $clockval }]
- }
- minutes - minute {
- set clockval [expr { 60 * $quantity + $clockval }]
- }
- seconds - second {
- set clockval [expr { $quantity + $clockval }]
- }
-
- default {
- throw [list CLOCK badUnit $unit] \
- "unknown unit \"$unit\", must be \
- years, months, weeks, days, hours, minutes or seconds"
- }
- }
- }
- return $clockval
- } trap CLOCK {result opts} {
- # Conceal the innards of [clock] when it's an expected error
- dict unset opts -errorinfo
- return -options $opts $result
- } finally {
- # Restore the locale
-
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- }
-}
-
-#----------------------------------------------------------------------
-#
-# AddMonths --
-#
-# Add a given number of months to a given clock value in a given
-# time zone.
-#
-# Parameters:
-# months - Number of months to add (may be negative)
-# clockval - Seconds since the epoch before the operation
-# timezone - Time zone in which the operation is to be performed
-#
-# Results:
-# Returns the new clock value as a number of seconds since
-# the epoch.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
- variable DaysInRomanMonthInCommonYear
- variable DaysInRomanMonthInLeapYear
- variable TZData
-
- # Convert the time to year, month, day, and fraction of day.
-
- set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr {
- [dict get $date localSeconds] % 86400
- }]
- dict set date tzName $timezone
-
- # Add the requisite number of months
-
- set m [dict get $date month]
- incr m $months
- incr m -1
- set delta [expr { $m / 12 }]
- set mm [expr { $m % 12 }]
- dict set date month [expr { $mm + 1 }]
- dict incr date year $delta
-
- # If the date doesn't exist in the current month, repair it
-
- if { [IsGregorianLeapYear $date] } {
- set hath [lindex $DaysInRomanMonthInLeapYear $mm]
- } else {
- set hath [lindex $DaysInRomanMonthInCommonYear $mm]
- }
- if { [dict get $date dayOfMonth] > $hath } {
- dict set date dayOfMonth $hath
- }
-
- # Reconvert to a number of seconds
-
- set date [GetJulianDayFromEraYearMonthDay \
- $date[set date {}]\
- $changeover]
- dict set date localSeconds [expr {
- -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay]
- }]
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
- $changeover]
-
- return [dict get $date seconds]
-}
-
-#----------------------------------------------------------------------
-#
-# AddDays --
-#
-# Add a given number of days to a given clock value in a given time
-# zone.
-#
-# Parameters:
-# days - Number of days to add (may be negative)
-# clockval - Seconds since the epoch before the operation
-# timezone - Time zone in which the operation is to be performed
-# changeover - Julian Day on which the Gregorian calendar was adopted
-# in the target locale.
-#
-# Results:
-# Returns the new clock value as a number of seconds since the epoch.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::AddDays { days clockval timezone changeover } {
- variable TZData
-
- # Convert the time to Julian Day
-
- set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr {
- [dict get $date localSeconds] % 86400
- }]
- dict set date tzName $timezone
-
- # Add the requisite number of days
-
- dict incr date julianDay $days
-
- # Reconvert to a number of seconds
-
- dict set date localSeconds [expr {
- -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay]
- }]
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
- $changeover]
-
- return [dict get $date seconds]
-}
-
-#----------------------------------------------------------------------
-#
-# mc --
-#
-# Wrapper around ::msgcat::mc that caches the result according to the
-# locale.
-#
-# Parameters:
-# Accepts the name of the message to retrieve.
-#
-# Results:
-# Returns the message text.
-#
-# Side effects:
-# Caches the message text.
-#
-# Notes:
-# Only the single-argument version of [mc] is supported.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::mc { name } {
- variable McLoaded
- set Locale [mclocale]
- if { [dict exists $McLoaded $Locale $name] } {
- return [dict get $McLoaded $Locale $name]
- }
- set val [::msgcat::mc $name]
- dict set McLoaded $Locale $name $val
- return $val
-}
-
-#----------------------------------------------------------------------
-#
-# ClearCaches --
-#
-# Clears all caches to reclaim the memory used in [clock]
-#
-# Parameters:
-# None.
-#
-# Results:
-# None.
-#
-# Side effects:
-# Caches are cleared.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::ClearCaches {} {
- variable FormatProc
- variable LocaleNumeralCache
- variable McLoaded
- variable CachedSystemTimeZone
- variable TimeZoneBad
-
- foreach p [info procs [namespace current]::scanproc'*] {
- rename $p {}
- }
- foreach p [info procs [namespace current]::formatproc'*] {
- rename $p {}
- }
-
- catch {unset FormatProc}
- set LocaleNumeralCache {}
- set McLoaded {}
- catch {unset CachedSystemTimeZone}
- set TimeZoneBad {}
- InitTZData
-}
OSDN Git Service
