summaryrefslogtreecommitdiffstats
path: root/library/clock.tcl
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
committerKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
commitfab56e2415bbbc5e2355f500b28d26c5e907ef29 (patch)
tree0bfbd9e68acb81b08b317b956ce8ac4cca0824cd /library/clock.tcl
parentdcdb6368302f0bb38e0d11e8c2d346b684507b07 (diff)
downloadtcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.zip
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.gz
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.bz2
TIP #173 and #209 implementation - see ChangeLog for details
Diffstat (limited to 'library/clock.tcl')
-rw-r--r--library/clock.tcl4874
1 files changed, 4874 insertions, 0 deletions
diff --git a/library/clock.tcl b/library/clock.tcl
new file mode 100644
index 0000000..44e7d8c
--- /dev/null
+++ b/library/clock.tcl
@@ -0,0 +1,4874 @@
+#----------------------------------------------------------------------
+#
+# 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 by Kevin B. Kenny. All rights reserved.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: clock.tcl,v 1.1 2004/08/18 19:59:00 kennykb Exp $
+#
+#----------------------------------------------------------------------
+
+# We must have message catalogs that support the root locale, and
+# we need access to the Registry on Windows systems. We also need
+# Tcl 8.5 dictionaries.
+
+uplevel \#0 {
+ package require msgcat 1.4
+ if { $::tcl_platform(platform) eq {windows} } {
+ package require registry 1.1
+ }
+}
+
+# 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::mc
+ namespace import ::msgcat::mcload
+ namespace import ::msgcat::mclocale
+
+ # Define the Greenwich time zone
+
+ variable 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)
+
+ # 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 {}
+ proc ZoneinfoInit {} {
+ variable ZoneinfoPaths
+ rename ZoneinfoInit {}
+ foreach path {
+ /usr/share/zoneinfo
+ /usr/share/lib/zoneinfo
+ /usr/local/etc/zoneinfo
+ C:/Progra~1/cygwin/usr/local/etc/zoneinfo
+ } {
+ if { [file isdirectory $path] } {
+ lappend ZoneinfoPaths $path
+ }
+ }
+ }
+ ZoneinfoInit
+
+ # 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]
+ }
+ unset i j
+
+ # Julian day number of 0 January, 1 CE, in the proleptic Julian and
+ # Gregorian calendars.
+
+ variable JD0Jan1CEJul 1721423
+ variable JD0Jan1CEGreg 1721425
+ variable JD31Dec9999 5373484
+
+ # Posix epoch, expressed as seconds from the Julian epoch
+
+ variable PosixEpochAsJulianSeconds 210866803200
+
+ # Another epoch (Hi, Jeff!)
+
+ variable Roddenberry 1946
+
+ # Integer ranges
+
+ variable MINWIDE -9223372036854775808
+ variable MAXWIDE 9223372036854775807
+
+ # Day before Leap Day
+
+ variable FEB_28 58
+
+ # Conversion factors
+
+ variable DaysPer400Yr 146097; # Days per 400 year Gregorian cycle
+ variable DaysPerCentury 36524; # Days per common Gregorian century
+ variable DaysPer4Yr 1461; # Days per 4 year cycle
+ variable DaysPerYear 365; # Days per common year
+ variable DaysPerWeek 7;
+ variable SecondsPerDay 86400; # Seconds per day
+ variable SecondsPerHour 3600; # Seconds per hour
+ variable SecondsPerMinute 60; # Seconds per minute
+ variable MinutesPerHour 60; # Minutes per hour
+ variable HoursPerDay 24; # Hours per day
+
+ # 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 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Anchorage \
+ {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Los_Angeles \
+ {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Denver \
+ {-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 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chicago \
+ {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 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 0 0 0 0 0 10 6 2 0 0 0 0} :America/Santiago \
+ {-14400 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 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 \
+ {-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 9 3 5 2 0 0 0 0 5 5 1 2 0 0 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 0 0 0 0 0 0 0 0 0 0 0 0 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 \
+ {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 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 2 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 {}
+
+ { century yearOfCentury month dayOfMonth } 2 {
+ dict set date era CE
+ dict set date year [expr { 100 * [dict get $date century]
+ + [dict get $date yearOfCentury] }]
+ set date [GetJulianDayFromEraYearMonthDay [K $date [set date {}]]]
+ }
+ { century yearOfCentury dayOfYear } 2 {
+ dict set date era CE
+ dict set date year [expr { 100 * [dict get $date century]
+ + [dict get $date yearOfCentury] }]
+ set date [GetJulianDayFromEraYearDay [K $date [set date {}]]]
+ }
+ { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 2 {
+ dict set date era CE
+ dict set date iso8601Year \
+ [expr { 100 * [dict get $date iso8601Century]
+ + [dict get $date iso8601YearOfCentury] }]
+ set date [GetJulianDayFromEraYearWeekDay [K $date [set date {}]]]
+ }
+
+ { yearOfCentury month dayOfMonth } 3 {
+ set date [InterpretTwoDigitYear [K $date [set date {}]] $baseTime]
+ dict set date era CE
+ set date [GetJulianDayFromEraYearMonthDay [K $date [set date {}]]]
+ }
+ { yearOfCentury dayOfYear } 3 {
+ set date [InterpretTwoDigitYear [K $date [set date {}]] $baseTime]
+ dict set date era CE
+ set date [GetJulianDayFromEraYearDay [K $date [set date {}]]]
+ }
+ { iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
+ set date [InterpretTwoDigitYear \
+ [K $date [set date {}]] $baseTime \
+ iso8601YearOfCentury iso8601Year]
+ dict set date era CE
+ set date [GetJulianDayFromEraYearWeekDay [K $date [set date {}]]]
+ }
+
+ { month dayOfMonth } 4 {
+ set date [AssignBaseYear [K $date [set date {}]] \
+ $baseTime $timeZone]
+ set date [GetJulianDayFromEraYearMonthDay [K $date [set date {}]]]
+ }
+ { dayOfYear } 4 {
+ set date [AssignBaseYear [K $date [set date {}]] \
+ $baseTime $timeZone]
+ set date [GetJulianDayFromEraYearDay [K $date [set date {}]]]
+ }
+ { iso8601Week dayOfWeek } 4 {
+ set date [AssignBaseIso8601Year [K $date [set date {}]] \
+ $baseTime $timeZone]
+ set date [GetJulianDayFromEraYearWeekDay [K $date [set date {}]]]
+ }
+
+ { dayOfMonth } 5 {
+ set date [AssignBaseMonth [K $date [set date {}]] \
+ $baseTime $timeZone]
+ set date [GetJulianDayFromEraYearMonthDay [K $date [set date {}]]]
+ }
+
+ { dayOfWeek } 6 {
+ set date [AssignBaseWeek [K $date [set date {}]] \
+ $baseTime $timeZone]
+ set date [GetJulianDayFromEraYearWeekDay [K $date [set date {}]]]
+ }
+
+ {} 7 {
+ set date [AssignBaseJulianDay [K $date [set date {}]] \
+ $baseTime $timeZone]
+ }
+ }
+
+ # 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 \
+ cast +0930 \
+ 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 immaterial
+ # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
+ # it contains the value of the
+ # system time zone, as determined from
+ # the environment.
+ 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.
+}
+
+#----------------------------------------------------------------------
+#
+# K --
+#
+# The K combinator returns its first argument. It's used for
+# reference count management.
+#
+# Parameters:
+# x - Argument to be unreferenced.
+# y - Unused.
+#
+# Results:
+# Returns the first argument.
+#
+# Side effects:
+# None.
+#
+# The K combinator is used for its effect that [K $x [set x {}]]
+# reads out the value of x destructively, giving an unshared Tcl
+# object and avoiding 'copy on write'
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::K { x y } { return $x }
+
+#----------------------------------------------------------------------
+#
+# 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 SecondsPerDay
+ variable SecondsPerHour
+ variable SecondsPerMinute
+ variable MinutesPerHour
+ variable HoursPerDay
+ variable DaysPerYear
+ variable DaysPerWeek
+
+ set format {}
+
+ # Check the count of args
+
+ if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
+ return -code error \
+ -errorcode [list CLOCK wrongNumArgs] \
+ "wrong \# args: should be\
+ \"[lindex [info level 0] 0] clockval\
+ ?-format string? ?-gmt boolean?\
+ ?-locale LOCALE? ?-timezone ZONE?\""
+ }
+
+ # Set defaults
+
+ set clockval [lindex $args 0]
+ set format {%a %b %d %H:%M:%S %Z %Y}
+ 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 {
+ -format {
+ set format $value
+ }
+ -gmt {
+ set gmt $value
+ }
+ -locale {
+ set locale $value
+ }
+ -timezone {
+ set timezone $value
+ }
+ default {
+ return -code error \
+ -errorcode [list CLOCK badSwitch $flag] \
+ "bad switch \"$flag\",\
+ must be -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($clockval) } } result] } {
+ return -code error \
+ "expected integer but got \"$clockval\""
+ }
+ if { ![string is boolean $gmt] } {
+ return -code error \
+ "expected boolean value but got \"$gmt\""
+ } else {
+ if { $gmt } {
+ set timezone :GMT
+ }
+ }
+
+ EnterLocale $locale oldLocale
+
+ # Change locale if a fresh locale has been given on the command line.
+
+ set status [catch {
+
+ # Map away the locale-dependent composite format groups
+
+ set format [LocalizeFormat $format]
+
+ # Convert the given time to local time.
+
+ set date [dict create seconds $clockval]
+ set date [ConvertUTCToLocal [K $date [set date {}]] $timezone]
+
+ # Extract the fields of the date.
+
+ set date [GetJulianDay [K $date [set date {}]]]
+ set date [GetGregorianEraYearDay [K $date [set date {}]]]
+ set date [GetMonthDay [K $date [set date {}]]]
+ set date [GetYearWeekDay [K $date [set date {}]]]
+
+ # Format the result
+
+ set state {}
+ set retval {}
+ foreach char [split $format {}] {
+ switch -exact $state {
+ {} {
+ if { [string equal % $char] } {
+ set state percent
+ } else {
+ append retval $char
+ }
+ }
+ percent { # Character following a '%' character
+ set state {}
+ switch -exact -- $char {
+ % { # A literal character, '%'
+ append retval %
+ }
+ a { # Day of week, abbreviated
+ set dow [expr { [dict get $date dayOfWeek] % 7 }]
+ append retval \
+ [lindex [mc DAYS_OF_WEEK_ABBREV] $dow]
+ }
+ A { # Day of week, spelt out.
+ set dow [expr { [dict get $date dayOfWeek] % 7 }]
+ append retval [lindex [mc DAYS_OF_WEEK_FULL] $dow]
+ }
+ b - h { # Name of month, abbreviated.
+ set month [expr { [dict get $date month] - 1 }]
+ append retval [lindex [mc MONTHS_ABBREV] $month]
+ }
+ B { # Name of month, spelt out
+ set month [expr { [dict get $date month] - 1 }]
+ append retval [lindex [mc MONTHS_FULL] $month]
+ }
+ C { # Century number
+ set cent [expr { [dict get $date year] / 100 }]
+ append retval [::format %02d $cent]
+ }
+ d { # Day of month, with leading zero
+ append retval [::format %02d \
+ [dict get $date dayOfMonth]]
+ }
+ e { # Day of month, without leading zero
+ append retval [::format %2d \
+ [dict get $date dayOfMonth]]
+ }
+ E { # Format group in a locale-dependent
+ # alternative era
+ set state percentE
+ if { ![dict exists $date localeEra] } {
+ set date [GetLocaleEra [K $date [set date {}]]]
+ }
+ }
+ g { # Two-digit year relative to ISO8601
+ # week number
+ set year \
+ [expr { [dict get $date iso8601Year] % 100 }]
+ append retval [::format %02d $year]
+ }
+ G { # Four-digit year relative to ISO8601
+ # week number
+ append retval [::format %04d \
+ [dict get $date iso8601Year]]
+ }
+ H { # Hour in the 24-hour day, leading zero
+ append retval \
+ [::format %02d \
+ [expr { [dict get $date localSeconds]
+ / $SecondsPerHour
+ % $HoursPerDay }]]
+ }
+ I { # Hour AM/PM, with leading zero
+ set hour12 \
+ [expr { ( ( ( [dict get $date localSeconds]
+ % $SecondsPerDay )
+ + $SecondsPerDay
+ - $SecondsPerHour )
+ / $SecondsPerHour )
+ % 12 + 1 }]
+ append retval [::format %02d $hour12]
+ }
+ j { # Day of year (001-366)
+ append retval [::format %03d \
+ [dict get $date dayOfYear]]
+ }
+ J { # Julian Day Number
+ append retval [::format %07ld \
+ [dict get $date julianDay]]
+ }
+ k { # Hour (0-23), no leading zero
+ append retval \
+ [::format %2d \
+ [expr { [dict get $date localSeconds]
+ / $SecondsPerHour
+ % $HoursPerDay }]]
+ }
+ l { # Hour (12-11), no leading zero
+ set hour12 \
+ [expr { ( ( ( [dict get $date localSeconds]
+ % $SecondsPerDay )
+ + $SecondsPerDay
+ - $SecondsPerHour )
+ / $SecondsPerHour )
+ % 12 + 1 }]
+ append retval [::format %2d $hour12]
+ }
+ m { # Month number, leading zero
+ append retval [::format %02d \
+ [dict get $date month]]
+ }
+ M { # Minute of the hour, leading zero
+ append retval \
+ [::format %02d \
+ [expr { [dict get $date localSeconds]
+ / $SecondsPerMinute
+ % $MinutesPerHour }]]
+ }
+ n { # A literal newline
+ append retval \n
+ }
+ N { # Month number, no leading zero
+ append retval [::format %2d \
+ [dict get $date month]]
+ }
+ O { # A format group in the locale's
+ # alternative numerals
+ set state percentO
+ }
+ p { # Localized 'AM' or 'PM' indicator
+ # converted to uppercase
+ set tod [expr { [dict get $date localSeconds]
+ % $SecondsPerDay }]
+ if { $tod >= ( $SecondsPerDay / 2 ) } {
+ append retval [string toupper [mc PM]]
+ } else {
+ append retval [string toupper [mc AM]]
+ }
+ }
+ P { # Localized 'AM' or 'PM' indicator
+ set tod [expr { [dict get $date localSeconds]
+ % $SecondsPerDay }]
+ if { $tod >= ( $SecondsPerDay / 2 ) } {
+ append retval [mc PM]
+ } else {
+ append retval [mc AM]
+ }
+ }
+ Q { # Hi, Jeff!
+ append retval [FormatStarDate $date]
+ }
+ s { # Seconds from the Posix Epoch
+ append retval $clockval
+ }
+ S { # Second of the minute, with
+ # leading zero
+ append retval \
+ [::format %02d \
+ [expr { [dict get $date localSeconds]
+ % $SecondsPerMinute }]]
+ }
+ t { # A literal tab character
+ append retval \t
+ }
+ u { # Day of the week (1-Monday, 7-Sunday)
+ append retval [dict get $date dayOfWeek]
+ }
+ U { # Week of the year (00-53). The
+ # first Sunday of the year is the
+ # first day of week 01
+ set dow [dict get $date dayOfWeek]
+ if { $dow == 7 } {
+ set dow 0
+ }
+ incr dow
+ set weekNumber \
+ [expr { ( [dict get $date dayOfYear]
+ - $dow
+ + $DaysPerWeek )
+ / $DaysPerWeek }]
+ append retval [::format %02d $weekNumber]
+ }
+ V { # The ISO8601 week number
+ append retval [::format %02d \
+ [dict get $date iso8601Week]]
+ }
+ w { # Day of the week (0-Sunday,
+ # 6-Saturday)
+ append retval \
+ [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.
+ set weekNumber \
+ [expr { ( [dict get $date dayOfYear]
+ - [dict get $date dayOfWeek]
+ + $DaysPerWeek )
+ / $DaysPerWeek }]
+ append retval [::format %02d $weekNumber]
+ }
+ y { # The two-digit year of the century
+ append retval \
+ [::format %02d \
+ [expr { [dict get $date year] % 100 }]]
+ }
+ Y { # The four-digit year
+ append retval [::format %04d \
+ [dict get $date year]]
+ }
+ z { # The time zone as hours and minutes
+ # east (+) or west (-) of Greenwich
+ set z [dict get $date tzOffset]
+ if { $z < 0 } {
+ set z [expr { - $z }]
+ append retval -
+ } else {
+ append retval +
+ }
+ append retval [::format %02d \
+ [expr { $z / $SecondsPerHour }]]
+ set z [expr { $z % $SecondsPerHour }]
+ append retval \
+ [::format %02d \
+ [expr { $z / $SecondsPerMinute }]]
+ set z [expr { $z % $SecondsPerMinute }]
+ if { $z != 0 } {
+ append retval [::format %02d $z]
+ }
+ }
+ Z { # The name of the time zone
+ append retval [dict get $date tzName]
+ }
+ % { # A literal percent character
+ append retval %
+ }
+ default { # An unknown escape sequence
+ append retval % $char
+ }
+ }
+ }
+ percentE { # Character following %E
+ set state {}
+ switch -exact -- $char {
+ C { # Locale-dependent era
+ append retval [dict get $date localeEra]
+ }
+ y { # Locale-dependent year of the era
+ set y [dict get $date localeYear]
+ if { $y >= 0 && $y < 100 } {
+ append retval [lindex [mc LOCALE_NUMERALS] $y]
+ } else {
+ append retval $y
+ }
+ }
+ default { # Unknown format group
+ append retval %E $char
+ }
+ }
+ }
+ percentO { # Character following %O
+ set state {}
+ switch -exact -- $char {
+ d - e { # Day of the month in alternative
+ # numerals
+ append retval [lindex \
+ [mc LOCALE_NUMERALS] \
+ [dict get $date dayOfMonth]]
+ }
+ H - k { # Hour of the day in alternative
+ # numerals
+ set hour [expr { [dict get $date localSeconds]
+ / $SecondsPerHour
+ % $HoursPerDay }]
+ append retval [lindex [mc LOCALE_NUMERALS] $hour]
+ }
+ I - l { # Hour (12-11) AM/PM in alternative
+ # numerals
+ set hour12 \
+ [expr { ( ( ( [dict get $date localSeconds]
+ % $SecondsPerDay )
+ + $SecondsPerDay
+ - $SecondsPerHour )
+ / $SecondsPerHour )
+ % 12 + 1 }]
+ append retval [lindex [mc LOCALE_NUMERALS] $hour12]
+ }
+ m { # Month number in alternative numerals
+ append retval [lindex \
+ [mc LOCALE_NUMERALS] \
+ [dict get $date month]]
+ }
+ M { # Minute of the hour in alternative
+ # numerals
+ set minute [expr { [dict get $date localSeconds]
+ / $SecondsPerMinute
+ % $MinutesPerHour }]
+ append retval [lindex [mc LOCALE_NUMERALS] $minute]
+ }
+ S { # Second of the minute in alternative
+ # numerals
+ set second [expr { [dict get $date localSeconds]
+ % $SecondsPerMinute }]
+ append retval [lindex [mc LOCALE_NUMERALS] $second]
+ }
+ u { # Day of the week (Monday=1,Sunday=7)
+ # in alternative numerals
+ append retval [lindex \
+ [mc LOCALE_NUMERALS] \
+ [dict get $date dayOfWeek]]
+ }
+ w { # Day of the week (Sunday=0,Saturday=6)
+ # in alternative numerals
+ append retval \
+ [lindex \
+ [mc LOCALE_NUMERALS] \
+ [expr { [dict get $date dayOfWeek] % 7 }]]
+ }
+ y { # Year of the century in alternative
+ # numerals
+ append retval \
+ [lindex \
+ [mc LOCALE_NUMERALS] \
+ [expr { [dict get $date year] % 100 }]]
+ }
+ default { # Unknown format group
+ append retval %O $char
+ }
+ }
+ }
+ }
+ }
+
+ # Clean up any improperly terminated groups
+
+ switch -exact -- $state {
+ percent {
+ append retval %
+ }
+ percentE {
+ append retval %E
+ }
+ percentO {
+ append retval %O
+ }
+ }
+
+ set retval
+
+ } result]
+
+ # Restore the locale
+
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
+ }
+
+ if { $status == 1 } {
+ if { [lindex $::errorCode 0] eq {clock} } {
+ return -code error $result
+ } else {
+ return -code error \
+ -errorcode $::errorCode -errorinfo $::errorInfo \
+ $result
+ }
+ } else {
+ return $result
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# 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 } {
+ return -code error \
+ -errorcode [list CLOCK wrongNumArgs] \
+ "wrong \# args: should be\
+ \"[lindex [info level 0] 0] 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 {
+ -base {
+ set base $value
+ }
+ -format {
+ set format $value
+ }
+ -gmt {
+ set gmt $value
+ }
+ -locale {
+ set locale $value
+ }
+ -timezone {
+ set timezone $value
+ }
+ default {
+ return -code error \
+ -errorcode [list CLOCK badSwitch $flag] \
+ "bad switch \"$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 $gmt] } {
+ return -code error \
+ "expected boolean value but got \"$gmt\""
+ } else {
+ if { $gmt } {
+ set timezone :GMT
+ }
+ }
+
+ if { ![info exists saw(-format)] } {
+ if { [info exists saw(-timezone)] || [info exists saw(-locale)] } {
+ return -code error \
+ -errorcode [list CLOCK flagWithLegacyFormat] \
+ "legacy \[clock scan\] does not support -timezone or\
+ -locale"
+
+ }
+ if { [catch {
+ Oldscan $string -base $base -gmt $gmt
+ } retval] } {
+ return -code error \
+ -errorcode $::errorCode -errorinfo $::errorInfo \
+ $retval
+ } else {
+ return $retval
+ }
+ }
+
+ # Change locale if a fresh locale has been given on the command line.
+
+ EnterLocale $locale oldLocale
+
+ set status [catch {
+
+ # Map away the locale-dependent composite format groups
+
+ set format [LocalizeFormat $format]
+ set scanner [ParseClockScanFormat $format]
+ $scanner $string $base $timezone
+
+ } result]
+
+ # Restore the locale
+
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
+ }
+
+ if { $status == 1 } {
+ if { [lindex $::errorCode 0] eq {clock} } {
+ return -code error $result
+ } else {
+ return -code error \
+ -errorcode $::errorCode -errorinfo $::errorInfo \
+ $result
+ }
+ } else {
+ return $result
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ParseClockScanFormat --
+#
+# Parses a format string given to [clock scan -format]
+#
+# Parameters:
+# None.
+#
+# 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 } {
+
+ variable DateParseActions
+ variable TimeParseActions
+
+ # Condense whitespace
+
+ regsub -all {[[:space:]]+} $formatString { } formatString
+
+ # Check whether the format has been parsed previously, and return
+ # the existing recognizer if it has.
+
+ set procName [namespace current]::scanproc'$formatString'[mclocale]
+ if { [info procs $procName] != {} } {
+ return $procName
+ }
+
+ # 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 $abr $i
+ dict set l $full $i
+ incr i
+ }
+ foreach { regex lookup } [UniquePrefixRegexp $l] break
+ append re ( $regex )
+ dict set fieldSet dayOfWeek [incr fieldCount]
+ append postcode "dict set date dayOfWeek \[" \
+ "dict get " [list $lookup] " \$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 $abr $i
+ dict set l $full $i
+ }
+ foreach { regex lookup } [UniquePrefixRegexp $l] break
+ append re ( $regex )
+ dict set fieldSet month [incr fieldCount]
+ append postcode "dict set date month \[" \
+ "dict get " [list $lookup] " \$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 [mc AM] 0 [mc PM] 1]
+ foreach { regex lookup } [UniquePrefixRegexp $l] break
+ 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] {
+ foreach {t symbol year} $triple break
+ dict set d $symbol $year
+ }
+ foreach { regex lookup } [UniquePrefixRegexp $d] break
+ append re (?: $regex )
+
+ }
+ y { # Locale-dependent year of the era
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ append re $regex
+ incr fieldCount
+ }
+ default {
+ append re %E
+ if { ! [string is alnum $c] } {
+ append re \\
+ }
+ append re $c
+ }
+ }
+ set state {}
+ }
+ %O {
+ switch -exact -- $c {
+ d - e {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ 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 {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ 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 {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ append re $regex
+ dict set fieldSet hourAMPM [incr fieldCount]
+ append postcode "dict set date hourAMPM \[" \
+ "dict get " [list $lookup] " \$field" \
+ [incr captureCount] \
+ "\]\n"
+ }
+ m {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ append re $regex
+ dict set fieldSet month [incr fieldCount]
+ append postcode "dict set date month \[" \
+ "dict get " [list $lookup] " \$field" \
+ [incr captureCount] \
+ "\]\n"
+ }
+ M {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ append re $regex
+ dict set fieldSet minute [incr fieldCount]
+ append postcode "dict set date minute \[" \
+ "dict get " [list $lookup] " \$field" \
+ [incr captureCount] \
+ "\]\n"
+ }
+ S {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ 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 {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ 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 {
+ foreach {regex lookup} [LocaleNumeralMatcher] break
+ 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 \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
+
+ # 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, and convert local nominal time to UTC.
+
+ if { ![dict exists $fieldSet seconds]
+ && ![dict exists $fieldSet starDate] } {
+ append procBody {
+ if { [dict get $date julianDay] > $::tcl::clock::JD31Dec9999 } {
+ return -code error -errorcode [list CLOCK dateTooLarge] \
+ "requested date too large to represent"
+ }
+ dict set date localSeconds \
+ [expr { -$::tcl::clock::PosixEpochAsJulianSeconds
+ + ( $::tcl::clock::SecondsPerDay
+ * wide([dict get $date julianDay]) )
+ + [dict get $date secondOfDay] }]
+ }
+ }
+
+ if { ![dict exists $fieldSet seconds]
+ && ![dict exists $fieldSet starDate] } {
+ append procBody {
+ set date [::tcl::clock::ConvertLocalToUTC [K $date [set date {}]]]
+ }
+ }
+
+ # 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:
+# none.
+#
+# Results:
+# Returns a two-element list comprising the regexp and the
+# dictionary.
+#
+# Side effects:
+# Caches the result.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::LocaleNumeralMatcher {} {
+
+ variable LocaleNumeralCache
+
+ set l [mclocale]
+ 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 } {
+ 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 } {
+ 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 } {
+
+ 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:
+# 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 { format } {
+
+ # Handle locale-dependent format groups by mapping them out of
+ # the input string. Note that the order of the [string map]
+ # operations is significant because earlier formats can refer
+ # to later ones; for example %c can refer to %X, which in turn
+ # can refer to %T.
+
+ set format [string map [list %c [mc DATE_TIME_FORMAT] \
+ %Ec [mc LOCALE_DATE_TIME_FORMAT]] $format]
+ set format [string map [list %x [mc DATE_FORMAT] \
+ %Ex [mc LOCALE_DATE_FORMAT] \
+ %X [mc TIME_FORMAT] \
+ %EX [mc LOCALE_TIME_FORMAT]] $format]
+ set format [string map [list %r [mc TIME_FORMAT_12] \
+ %R [mc TIME_FORMAT_24] \
+ %T [mc TIME_FORMAT_24_SECS]] $format]
+ set format [string map [list %D %m/%d/%Y \
+ %EY [mc LOCALE_YEAR_FORMAT]\
+ %+ {%a %b %e %H:%M:%S %Z %Y}] $format]
+ return $format
+}
+
+#----------------------------------------------------------------------
+#
+# 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 DaysPerYear
+ variable SecondsPerDay
+ variable Roddenberry
+
+ # Get day of year, zero based
+
+ set doy [expr { [dict get $date dayOfYear] - 1 }]
+
+ # Determine whether the year is a leap year
+
+ if { [dict get $date gregorian] } {
+ set lp [IsGregorianLeapYear $date]
+ } else {
+ set lp [expr { [dict get $date year] % 4 == 0 }]
+ }
+
+ # Convert day of year to a fractional year
+
+ if { $lp } {
+ set fractYear [expr { 1000 * $doy / ( $DaysPerYear + 1 ) }]
+ } else {
+ set fractYear [expr { 1000 * $doy / $DaysPerYear }]
+ }
+
+ # Put together the StarDate
+
+ return [::format "Stardate %02d%03d.%1d" \
+ [expr { [dict get $date year] - $Roddenberry }] \
+ $fractYear \
+ [expr { [dict get $date localSeconds] % $SecondsPerDay
+ / ( $SecondsPerDay / 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
+ variable DaysPerYear
+ variable SecondsPerDay
+ variable PosixEpochAsJulianSeconds
+
+ # Build a tentative date from year and fraction.
+
+ set date [dict create \
+ era CE \
+ year [expr { $year + $Roddenberry }] \
+ dayOfYear [expr { $fractYear * $DaysPerYear / 1000 + 1 }]]
+ set date [GetJulianDayFromGregorianEraYearDay [K $date [set date {}]]]
+
+ # Determine whether the given year is a leap year
+
+ if { [dict get $date gregorian] } {
+ set lp [IsGregorianLeapYear $date]
+ } else {
+ set lp [expr { [dict get $date year] % 4 == 0 }]
+ }
+
+ # Reconvert the fractional year according to whether the given
+ # year is a leap year
+
+ if { $lp } {
+ dict set date dayOfYear \
+ [expr { $fractYear * ( $DaysPerYear + 1 ) / 1000 + 1 }]
+ } else {
+ dict set date dayOfYear \
+ [expr { $fractYear * $DaysPerYear / 1000 + 1 }]
+ }
+ dict unset date julianDay
+ dict unset date gregorian
+ set date [GetJulianDayFromGregorianEraYearDay [K $date [set date {}]]]
+
+ return [expr { $SecondsPerDay * [dict get $date julianDay]
+ - $PosixEpochAsJulianSeconds
+ + ( $SecondsPerDay / 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
+#
+# Results:
+# Returns the dictionary with the current year assigned.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Find the Julian Day Number corresponding to the base time, and
+ # find the Gregorian year corresponding to that Julian Day.
+
+ set date2 [dict create seconds $baseTime]
+ set date2 [ConvertUTCToLocal [K $date2 [set date2 {}]] $timeZone]
+ set date2 [GetJulianDay [K $date2 [set date2 {}]]]
+ set date2 [GetGregorianEraYearDay [K $date2 [set date2 {}]]]
+
+ # 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.
+#
+# Results:
+# Returns the given date with "iso8601Year" set to the
+# base year.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } {
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Find the Julian Day Number corresponding to the base time
+
+ set date2 [dict create seconds $baseTime]
+ set date2 [ConvertUTCToLocal [K $date2 [set date2 {}]] $timeZone]
+ set date2 [GetJulianDay [K $date2 [set date2 {}]]]
+
+ # Calculate the ISO8601 date and transfer the year
+
+ set date2 [GetYearWeekDay [K $date2 [set date2 {}]]]
+ 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.
+#
+# Results:
+# Returns the dictionary with the base year and month assigned.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Find the Julian Day Number corresponding to the base time
+
+ set date2 [dict create seconds $baseTime]
+ set date2 [ConvertUTCToLocal [K $date2 [set date2 {}]] $timeZone]
+ set date2 [GetJulianDay [K $date2 [set date2 {}]]]
+
+ # Find the Gregorian year corresponding to that Julian Day
+
+ set date2 [GetGregorianEraYearDay [K $date2 [set date2 {}]]]
+ set date2 [GetMonthDay [K $date2 [set date2 {}]]]
+ 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.
+#
+# 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 } {
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Find the Julian Day Number corresponding to the base time
+
+ set date2 [dict create seconds $baseTime]
+ set date2 [ConvertUTCToLocal [K $date2 [set date2 {}]] $timeZone]
+ set date2 [GetJulianDay [K $date2 [set date2 {}]]]
+
+ # Calculate the ISO8601 date and transfer the year
+
+ set date2 [GetYearWeekDay [K $date2 [set date2 {}]]]
+ 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
+#
+# 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 } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Find the Julian Day Number corresponding to the base time
+
+ set date2 [dict create seconds $baseTime]
+ set date2 [ConvertUTCToLocal [K $date2 [set date2 {}]] $timeZone]
+ set date2 [GetJulianDay [K $date2 [set date2 {}]]]
+ 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 [K $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 } {
+
+ variable SecondsPerMinute
+ variable MinutesPerHour
+
+ return [expr { ( [dict get $date hour] * $MinutesPerHour
+ + [dict get $date minute] ) * $SecondsPerMinute
+ + [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
+
+ if { [info exists ::env(TCL_TZ)] } {
+ set timezone $::env(TCL_TZ)
+ } elseif { [info exists ::env(TZ)] } {
+ set timezone $::env(TZ)
+ } elseif { $::tcl_platform(platform) eq {windows} } {
+ if { [info exists CachedSystemTimeZone] } {
+ set timezone $CachedSystemTimeZone
+ } else {
+ set timezone [GuessWindowsTimeZone]
+ set CachedSystemTimeZone $timezone
+ }
+ } else {
+ set timezone :localtime
+ }
+ if { [catch {SetupTimeZone $timezone}] } {
+ set timezone :localtime
+ }
+ 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"
+ } else {
+ return [dict get $LegacyTimeZone $tzname]
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ConvertLocalToUTC --
+#
+# Given a time zone and nominal local seconds, compute seconds
+# of UTC time from the Posix epoch.
+#
+# Parameters:
+# date - Dictionary populated with the 'localSeconds' and
+# 'tzName' fields
+#
+# Results:
+# Returns the given dictionary augmented with a 'seconds' field.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertLocalToUTC { date } {
+
+ variable TZData
+
+ set timezone [dict get $date tzName]
+ if { $timezone eq ":localtime" } {
+
+ # Convert using the mktime function if possible
+
+ if { [catch {
+ ConvertLocalToUTCViaC [dict get $date localSeconds]
+ } result] } {
+ return -code error -errorcode $::errorCode $result
+ }
+ dict set date seconds $result
+ return $date
+
+ } else {
+
+ # Get the time zone data
+
+ if { [catch { SetupTimeZone $timezone } retval] } {
+ return -code error -errorcode $::errorCode $retval
+ }
+
+ # Initially assume that local == UTC, and locate the last time
+ # conversion prior to that time. Get the offset from that,
+ # and look up again. If that lookup finds a different offset,
+ # continue looking until we find an offset that we found
+ # before. The check for "any offset previously found" rather
+ # than "the same offset" avoids an endless loop if we try to
+ # convert a non-existent time, for example 2:30am during the
+ # US spring DST change.
+
+ set localseconds [dict get $date localSeconds]
+ set utcseconds(0) $localseconds
+ set seconds $localseconds
+ while { 1 } {
+ set i [BSearch $TZData($timezone) $seconds]
+ set offset [lindex $TZData($timezone) $i 1]
+ if { [info exists utcseconds($offset)] } {
+ dict set date seconds $utcseconds($offset)
+ return $date
+ } else {
+ set seconds [expr { $localseconds - $offset }]
+ set utcseconds($offset) $seconds
+ }
+ }
+
+ # In the absolute worst case, the loop above can visit each tzdata
+ # row only once, so it's guaranteed to terminate.
+
+ error "in ConvertLocalToUTC, can't happen"
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ConvertLocalToUTCViaC --
+#
+# Given seconds of nominal local time, compute seconds from the
+# Posix epoch.
+#
+# Parameters:
+# localSeconds - Seconds of nominal local time
+#
+# Results:
+# Returns the seconds from the epoch. May throw an error if
+# the time is to large/small to represent, or if 'mktime' is
+# not present in the C library.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertLocalToUTCViaC { localSeconds } {
+
+ variable SecondsPerHour
+ variable SecondsPerMinute
+ variable MinutesPerHour
+ variable HoursPerDay
+
+ set date [dict create localSeconds $localSeconds]
+ set date [GetJulianDay [K $date [set date {}]]]
+ set date [GetGregorianEraYearDay [K $date [set date {}]]]
+ set date [GetMonthDay [K $date [set date {}]]]
+ set retval \
+ [Mktime \
+ [dict get $date year] \
+ [dict get $date month] \
+ [dict get $date dayOfMonth] \
+ [expr { $localSeconds / $SecondsPerHour % $HoursPerDay }] \
+ [expr { $localSeconds / $SecondsPerMinute % $MinutesPerHour }] \
+ [expr { $localSeconds % $SecondsPerMinute }]]
+ return $retval
+}
+
+#----------------------------------------------------------------------
+#
+# ConvertUTCToLocal --
+#
+# Given the seconds from the Posix epoch, compute seconds of
+# nominal local time.
+#
+# Parameters:
+# date - Dictionary populated on entry with the 'seconds' field
+#
+# Results:
+# The given dictionary is returned, augmented with 'localSeconds',
+# 'tzOffset', and 'tzName' fields.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertUTCToLocal { date timezone } {
+
+ variable TZData
+
+ # Get the data for time changes in the given zone
+
+ if { [catch { SetupTimeZone $timezone } retval] } {
+ return -code error -errorcode $::errorCode $retval
+ }
+
+ if { $timezone eq {:localtime} } {
+
+ # Convert using the localtime function
+
+ if { [catch {
+ ConvertUTCToLocalViaC $date
+ } retval] } {
+ return -code error -errorcode $::errorCode $retval
+ }
+ return $retval
+ }
+
+ # Find the most recent transition in the time zone data
+
+ set i [BSearch $TZData($timezone) [dict get $date seconds]]
+ set row [lindex $TZData($timezone) $i]
+ foreach { junk1 offset junk2 name } $row break
+
+ # Add appropriate offset to convert Greenwich to local, and return
+ # the local time
+
+ dict set date localSeconds [expr { [dict get $date seconds] + $offset }]
+ dict set date tzOffset $offset
+ dict set date tzName $name
+
+ return $date
+
+}
+
+#----------------------------------------------------------------------
+#
+# ConvertUTCToLocalViaC --
+#
+# Convert local time using the C localtime function
+#
+# Parameters:
+# date - Dictionary populated on entry with the 'seconds'
+# and 'timeZone' fields.
+#
+# Results:
+# The given dictionary is returned, augmented with 'localSeconds',
+# 'tzOffset', and 'tzName' fields.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::ConvertUTCToLocalViaC { date } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerMinute
+ variable SecondsPerHour
+ variable MinutesPerHour
+ variable HoursPerDay
+
+ # Get y-m-d-h-m-s from the C library
+
+ set gmtSeconds [dict get $date seconds]
+ set localFields [Localtime $gmtSeconds]
+ set date2 [dict create]
+ foreach key {
+ year month dayOfMonth hour minute second
+ } value $localFields {
+ dict set date2 $key $value
+ }
+ dict set date2 era CE
+
+ # Convert to Julian Day
+
+ set date2 [GetJulianDayFromEraYearMonthDay [K $date2 [set date2 {}]]]
+
+ # Reconvert to seconds from the epoch in local time.
+
+ set localSeconds [expr { ( ( ( wide([dict get $date2 julianDay])
+ * $HoursPerDay
+ + wide([dict get $date2 hour]) )
+ * $MinutesPerHour
+ + wide([dict get $date2 minute]) )
+ * $SecondsPerMinute
+ + wide([dict get $date2 second]) )
+ - $PosixEpochAsJulianSeconds }]
+
+ # Determine the name and offset of the timezone
+
+ set delta [expr { $localSeconds - $gmtSeconds }]
+ if { $delta <= 0 } {
+ set signum -
+ set delta [expr { - $delta }]
+ } else {
+ set signum +
+ }
+ set hh [::format %02d [expr { $delta / $SecondsPerHour }]]
+ set mm [::format %02d [expr { ($delta / $SecondsPerMinute )
+ % $MinutesPerHour }]]
+ set ss [::format %02d [expr { $delta % $SecondsPerMinute }]]
+
+ set zoneName $signum$hh$mm
+ if { $ss ne {00} } {
+ append zoneName $ss
+ }
+
+ # Fix the dictionary
+
+ dict set date localSeconds $localSeconds
+ dict set date tzOffset $delta
+ dict set date tzName $zoneName
+ return $date
+
+}
+
+#----------------------------------------------------------------------
+#
+# 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
+ variable MinutesPerHour
+ variable SecondsPerMinute
+ variable MINWIDE
+
+ if {! [info exists TZData($timezone)] } {
+ 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] } {
+
+ # Make a fixed offset
+
+ ::scan $hh %d hh
+ ::scan $mm %d mm
+ if { $ss eq {} } {
+ set ss 0
+ } else {
+ ::scan $ss %d ss
+ }
+ set offset [expr { ( $hh * $MinutesPerHour
+ + $mm ) * $SecondsPerMinute
+ + $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]
+ }]
+ } {
+ 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] } {
+ if { [lindex $::errorCode 0] eq {CLOCK} } {
+ return -code error -errorcode $::errorCode $data
+ } else {
+ error $tzfields $::errorInfo $::errorCode
+ }
+ } 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
+ } msg] } {
+ return -code error -errorcode $::errorCode $msg
+ }
+ 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 SecondsPerHour
+ variable SecondsPerMinute
+ variable MinutesPerHour
+
+ # Dredge time zone information out of the registry
+
+ set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
+ set data [list \
+ [expr { -$SecondsPerMinute * [registry get $rpath Bias] }] \
+ [expr { -$SecondsPerMinute \
+ * [registry get $rpath StandardBias] }] \
+ [expr { -$SecondsPerMinute \
+ * [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
+ }
+
+ # Make up a Posix time zone specifier if we can't find one
+
+ if { ! [dict exists $WinZoneInfo $data] } {
+ foreach {
+ bias stdBias dstBias
+ stdYear stdMonth stdDayOfWeek stdDayOfMonth
+ stdHour stdMinute stdSecond stdMillisec
+ dstYear dstMonth dstDayOfWeek dstDayOfMonth
+ dstHour dstMinute dstSecond dstMillisec
+ } $data break
+ set stdDelta [expr { $bias + $stdBias }]
+ set dstDelta [expr { $bias + $dstBias }]
+ if { $stdDelta <= 0 } {
+ set stdSignum +
+ set stdDelta [expr { - $stdDelta }]
+ } else {
+ set stdSignum -
+ }
+ set hh [::format %02d [expr { $stdDelta / $SecondsPerHour }]]
+ set mm [::format %02d [expr { ($stdDelta / $SecondsPerMinute )
+ % $MinutesPerHour }]]
+ set ss [::format %02d [expr { $stdDelta % $SecondsPerMinute }]]
+ append tzname < $stdSignum $hh $mm > $stdSignum $hh : $mm : $ss
+ if { $stdMonth >= 0 } {
+ if { $dstDelta <= 0 } {
+ set dstSignum +
+ set dstDelta [expr { - $dstDelta }]
+ } else {
+ set dstSignum -
+ }
+ set hh [::format %02d [expr { $dstDelta / $SecondsPerHour }]]
+ set mm [::format %02d [expr { ($dstDelta / $SecondsPerMinute )
+ % $MinutesPerHour }]]
+ set ss [::format %02d [expr { $dstDelta % $SecondsPerMinute }]]
+ append tzname < $dstSignum $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
+
+ # 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"
+ }
+ if { [catch {
+ source -encoding utf-8 [file join $DataDir $fileName]
+ }] } {
+ return -code error \
+ -errorcode [list CLOCK badTimeZone :$fileName] \
+ "time zone \":$fileName\" not found"
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# LoadZoneinfoFile --
+#
+# Loads a binary time zone information file in Olson format.
+#
+# Parameters:
+# fileName - 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 MINWIDE
+ variable TZData
+ 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
+ }
+ if { ![info 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 a4x16IIIIII magic nIsGMT mIsStd nLeap nTime nType nChar
+ set seek 44
+ 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"
+ }
+ if { $nLeap != 0 } {
+ return -code error "$fileName contains leap seconds"
+ }
+
+ # 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}I${nTime}c${nTime} times tempCodes
+ incr seek [expr { 5 * $nTime }]
+ set times [linsert $times 0 $MINWIDE]
+ 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 {
+ dict set abbrevs $i $a
+ incr i [expr { [string length $a] + 1 }]
+ }
+
+ # The rest of the data in the file are not used at present.
+ # 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
+ foreach { gmtoff isDst abbrInd } [lindex $types $c] break
+ set abbrev [dict get $abbrevs $abbrInd]
+ lappend r [list $t $gmtoff $isDst $abbrev]
+ }
+
+ set TZData(:$fileName) $r
+
+}
+
+#----------------------------------------------------------------------
+#
+# 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]
+
+ } else {
+
+ 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 SecondsPerMinute
+ variable MinutesPerHour
+ 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 * $MinutesPerHour + $stdMinutes )
+ * $SecondsPerMinute + $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 * $MinutesPerHour + $dstMinutes )
+ * $SecondsPerMinute + $dstSeconds )
+ * $dstSignum }]
+ }
+
+ # Fill in defaults for US DST rules
+
+ if { [dict get $z startDayOfYear] eq {}
+ && [dict get $z startMonth] eq {} } {
+ dict set z startMonth 4
+ dict set z startWeekOfMonth 1
+ dict set z startDayOfWeek 0
+ dict set z startHours 2
+ dict set z startMinutes 0
+ dict set z startSeconds 0
+ }
+ if { [dict get $z endDayOfYear] eq {}
+ && [dict get $z endMonth] eq {} } {
+ dict set z endMonth 10
+ dict set z endWeekOfMonth 5
+ dict set z endDayOfWeek 0
+ dict set z endHours 2
+ 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 < 2099 } { 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
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+ variable SecondsPerMinute
+ variable MinutesPerHour
+
+ # 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 [K $date [set date {}]]]
+ } 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 dayOfWeekInMonth [dict get $z ${bound}WeekOfMonth]
+ set dow [dict get $z ${bound}DayOfWeek]
+ if { $dow >= 5 } {
+ set dow -1
+ }
+ dict set date dayOfWeek $dow
+ set date [GetJulianDayFromEraYearMonthWeekDay [K $date [set date {}]]]
+
+ }
+
+ set jd [dict get $date julianDay]
+ set seconds [expr { wide($jd) * wide($SecondsPerDay)
+ - wide($PosixEpochAsJulianSeconds) }]
+
+ 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 * $MinutesPerHour + $m ) * $SecondsPerMinute + $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.
+#
+# Results:
+# Returns the dictionary, augmented with the keys, 'localeEra'
+# and 'localeYear'.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetLocaleEra { date } {
+
+ set etable [mc LOCALE_ERAS]
+ 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
+
+}
+#----------------------------------------------------------------------
+#
+# GetJulianDay --
+#
+# Given the seconds from the Posix epoch, derives the Julian
+# day number.
+#
+# Parameters:
+# date - Dictionary containing the date fields. On input,
+# populated with a 'localSeconds' field that gives the
+# nominal seconds from the epoch (in the local time zone,
+# rather than UTC).
+#
+# Results:
+# Returns the given dictionary, augmented by a 'julianDay'
+# field that gives the Julian Day Number at noon of the current
+# date.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetJulianDay { date } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ set secs [dict get $date localSeconds]
+
+ return [dict set date julianDay \
+ [expr { ( $secs + $PosixEpochAsJulianSeconds )
+ / $SecondsPerDay }]]
+
+}
+
+#----------------------------------------------------------------------
+#
+# GetGregorianEraYearDay --
+#
+# Given the time from the Posix epoch and the current time zone,
+# develops the era, year, and day of year in the Gregorian calendar.
+#
+# Parameters:
+# date - Dictionary containing the date fields. On input, populated
+# with the 'julianDay' key whose value is the Julian Day Number.
+#
+# Results:
+# Returns the given dictionary with the 'gregorian', 'era',
+# 'year', and 'dayOfYear' populated.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetGregorianEraYearDay { date } {
+
+ variable JD0Jan1CEGreg
+ variable JD0Jan1CEJul
+ variable DaysPer400Yr
+ variable DaysPerCentury
+ variable DaysPer4Yr
+ variable DaysPerYear
+
+ set jday [dict get $date julianDay]
+
+ set changeover [mc GREGORIAN_CHANGE_DATE]
+
+ if { $jday >= $changeover } {
+
+ # Gregorian date
+
+ dict set date gregorian 1
+
+ # Calculate number of days since 1 January, 1 CE
+
+ set day [expr { $jday - $JD0Jan1CEGreg - 1 }]
+
+ # Calculate number of 400 year cycles
+
+ set year 1
+ set n [expr { $day / $DaysPer400Yr }]
+ incr year [expr { 400 * $n }]
+ set day [expr { $day % $DaysPer400Yr }]
+
+ # Calculate number of centuries in the current cycle
+
+ set n [expr { $day / $DaysPerCentury }]
+ set day [expr { $day % $DaysPerCentury }]
+ if { $n > 3 } {
+ set n 3 ;# 31 December 2000, for instance
+ incr day $DaysPerCentury ;# is last day of 400 year cycle
+ }
+ incr year [expr { 100 * $n }]
+
+ } else {
+
+ # Julian date
+
+ dict set date gregorian 0
+
+ # Calculate days since 0 January, 1 CE Julian
+
+ set day [expr { $jday - $JD0Jan1CEJul - 1 }]
+ set year 1
+
+ }
+
+ # Calculate number of 4-year cycles in current century (or in
+ # the Common Era, if the calendar is Julian)
+
+ set n [expr { $day / $DaysPer4Yr }]
+ set day [expr { $day % $DaysPer4Yr }]
+ incr year [expr { 4 * $n }]
+
+ # Calculate number of years in current 4-year cycle
+
+ set n [expr { $day / $DaysPerYear }]
+ set day [expr { $day % $DaysPerYear }]
+ if { $n > 3 } {
+ set n 3 ;# 31 December in a leap year
+ incr day $DaysPerYear
+ }
+ incr year $n
+
+ # Calculate the era
+
+ if { $year <= 0 } {
+ dict set date year [expr { 1 - $year }]
+ dict set date era BCE
+ } else {
+ dict set date year $year
+ dict set date era CE
+ }
+
+ # Return day of the year
+
+ dict set date dayOfYear [expr { $day + 1 }]
+
+ return $date
+
+}
+
+#----------------------------------------------------------------------
+#
+# GetMonthDay --
+#
+# Given the ordinal number of the day within the year, determines
+# month and day of month in the Gregorian calendar.
+#
+# Parameters:
+# date - Dictionary containing the date fields. On input, populated
+# with the 'era', 'gregorian', 'year' and 'dayOfYear' fields.
+#
+# Results:
+# Returns the given dictionary with the 'month' and 'dayOfMonth'
+# fields populated.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetMonthDay { date } {
+
+ variable DaysInRomanMonthInCommonYear
+ variable DaysInRomanMonthInLeapYear
+
+ set day [dict get $date dayOfYear]
+ if { [IsGregorianLeapYear $date] } {
+ set hath $DaysInRomanMonthInLeapYear
+ } else {
+ set hath $DaysInRomanMonthInCommonYear
+ }
+ set month 1
+ foreach n $hath {
+ if { $day <= $n } {
+ break
+ }
+ incr month
+ incr day [expr { -$n }]
+ }
+ dict set date month $month
+ dict set date dayOfMonth $day
+
+ return $date
+
+}
+
+#----------------------------------------------------------------------
+#
+# GetYearWeekDay
+#
+# Given a julian day number, fiscal year, fiscal week,
+# and day of week in the ISO8601 calendar.
+#
+# Parameters:
+#
+# date - Dictionary where the 'julianDay' field is populated.
+# daysInFirstWeek - (Optional) Parameter giving the minimum number
+# of days in the first week of a year. Default is 4.
+#
+# Results:
+# Returns the given dictionary with values filled in for the
+# three given keys.
+#
+# Side effects:
+# None.
+#
+# Bugs:
+# Since ISO8601 week numbering is defined only for the Gregorian
+# calendar, dates on the Julian calendar or before the Common
+# Era may yield unexpected results. In particular, the year of
+# the Julian-to-Gregorian change may be up to three weeks short.
+# The era is not managed separately, so if the Common Era begins
+# (or the period Before the Common Era ends) with a partial week,
+# the few days at the beginning or end of the era may show up
+# as incorrectly belonging to the year zero.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetYearWeekDay { date
+ { keys { iso8601Year iso8601Week dayOfWeek } } } {
+
+ set daysInFirstWeek 4
+ set firstDayOfWeek 1
+
+ # Determine the calendar year of $j - $daysInFirstWeek + 1.
+ # Compute an upper bound of the fiscal year as being one year
+ # past the day on which the current week begins. Find the start
+ # of that year.
+
+ set j [dict get $date julianDay]
+ set jd [expr { $j - $daysInFirstWeek + 1 }]
+ set date1 [GetGregorianEraYearDay [dict create julianDay $jd]]
+ switch -exact -- [dict get $date1 era] {
+ BCE {
+ dict set date1 fiscalYear [expr { [dict get $date1 year] - 1}]
+ }
+ CE {
+ dict set date1 fiscalYear [expr { [dict get $date1 year] + 1}]
+ }
+ }
+ dict unset date1 year
+ dict unset date1 dayOfYear
+ dict set date1 weekOfFiscalYear 1
+ dict set date1 dayOfWeek $firstDayOfWeek
+
+ set date1 [GetJulianDayFromEraYearWeekDay \
+ [K $date1 [set date1 {}]] \
+ $daysInFirstWeek \
+ $firstDayOfWeek \
+ { fiscalYear weekOfFiscalYear dayOfWeek }]
+ set startOfFiscalYear [dict get $date1 julianDay]
+
+ # If we guessed high, move one year earlier.
+
+ if { $j < $startOfFiscalYear } {
+ switch -exact -- [dict get $date1 era] {
+ BCE {
+ dict incr date1 fiscalYear
+ }
+ CE {
+ dict incr date1 fiscalYear -1
+ }
+ }
+ set date1 [GetJulianDayFromEraYearWeekDay \
+ [K $date1 [set date1 {}]] \
+ $daysInFirstWeek \
+ $firstDayOfWeek \
+ {fiscalYear weekOfFiscalYear dayOfWeek }]
+ set startOfFiscalYear [dict get $date1 julianDay]
+ }
+
+ # Get the week number and the day within the week
+
+ set fiscalYear [dict get $date1 fiscalYear]
+ set dayOfFiscalYear [expr { $j - $startOfFiscalYear }]
+ set weekOfFiscalYear [expr { ( $dayOfFiscalYear / 7 ) + 1 }]
+ set dayOfWeek [expr { ( $dayOfFiscalYear + 1 ) % 7 }]
+ if { $dayOfWeek < $firstDayOfWeek } {
+ incr dayOfWeek 7
+ }
+
+ # Store the fiscal year, week, and day in the given slots in the
+ # given dictionary.
+
+ foreach key $keys \
+ value [list $fiscalYear $weekOfFiscalYear $dayOfWeek] {
+ dict set date $key $value
+ }
+
+ return $date
+}
+
+#----------------------------------------------------------------------
+#
+# GetJulianDayFromEraYearWeekDay --
+#
+# Finds the Julian Day Number corresponding to the given era,
+# year, week and day.
+#
+# Parameters:
+# date -- A dictionary populated with fields whose keys are given
+# by the 'keys' parameter below, plus the 'era' field.
+# daysInFirstWeek -- (Optional) The minimum number of days in
+# the first week of the year. Default is 4.
+# firstDayOfWeek -- (Optional) The ordinal number of the first
+# day of the week. Default is 1 (Monday);
+# 0 (Sunday) is an alternative.
+# keys -- (Optional) Keys in the dictionary for looking up the
+# fiscal year, fiscal week, and day of week. The
+# default is { iso8601Year iso8601Week dayOfWeek }.
+#
+# Results:
+# Returns the dictionary augmented with a 'julianDay' field
+# that gives the Julian Day Number corresponding to the given
+# date.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetJulianDayFromEraYearWeekDay {
+ date
+ { daysInFirstWeek 4 }
+ { firstDayOfWeek 1 }
+ { keys { iso8601Year iso8601Week dayOfWeek } }
+} {
+
+ foreach var { fiscalYear fiscalWeek dayOfWeek } key $keys {
+ set $var [dict get $date $key]
+ }
+
+ # Find a day of the first week of the year.
+
+ set date2 [dict create \
+ era [dict get $date era] \
+ year $fiscalYear \
+ month 1 \
+ dayOfMonth $daysInFirstWeek]
+ set date2 [GetJulianDayFromEraYearMonthDay [K $date2 [set date2 {}]]]
+
+ # Find the Julian Day Number of the start of that week.
+
+ set jd [WeekdayOnOrBefore $firstDayOfWeek [dict get $date2 julianDay]]
+
+ # Add the required number of weeks and days
+
+ dict set date julianDay \
+ [expr { $jd
+ + ( 7 * ( $fiscalWeek - 1 ) )
+ + $dayOfWeek - $firstDayOfWeek }]
+
+ return $date
+
+}
+
+#----------------------------------------------------------------------
+#
+# GetJulianDayFromEraYearMonthDay --
+#
+# 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', 'month', and
+# 'dayOfMonth' slots are populated. The calendar in use
+# is determined by the date itself relative to
+# [mc GREGORIAN_CHANGE_DATE] 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.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } {
+
+ variable JD0Jan1CEJul
+ variable JD0Jan1CEGreg
+ variable DaysInPriorMonthsInCommonYear
+ variable DaysInPriorMonthsInLeapYear
+
+ # 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 { $JD0Jan1CEGreg
+ + [dict get $date dayOfMonth]
+ + ( [IsGregorianLeapYear $date] ?
+ [lindex $DaysInPriorMonthsInLeapYear \
+ [expr { [dict get $date month] - 1}]]
+ : [lindex $DaysInPriorMonthsInCommonYear \
+ [expr { [dict get $date month] - 1}]] )
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 )
+ - ( $ym1 / 100 )
+ + ( $ym1 / 400 ) }]
+
+ # If the date is before the Gregorian change, use the Julian calendar.
+
+ if { $jd < [mc GREGORIAN_CHANGE_DATE] } {
+
+ dict set date gregorian 0
+ set jd [expr { $JD0Jan1CEJul
+ + [dict get $date dayOfMonth]
+ + ( ( $year % 4 == 0 ) ?
+ [lindex $DaysInPriorMonthsInLeapYear \
+ [expr { [dict get $date month] - 1}]]
+ : [lindex $DaysInPriorMonthsInCommonYear \
+ [expr { [dict get $date month] - 1}]] )
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 ) }]
+ }
+
+ dict set date julianDay $jd
+ 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
+# [mc GREGORIAN_CHANGE_DATE] 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.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetJulianDayFromEraYearDay { date } {
+
+ variable JD0Jan1CEJul
+ variable JD0Jan1CEGreg
+ variable DaysInPriorMonthsInCommonYear
+ variable DaysInPriorMonthsInLeapYear
+
+ # 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 { $JD0Jan1CEGreg
+ + [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 < [mc GREGORIAN_CHANGE_DATE] } {
+ dict set date gregorian 0
+ set jd [expr { $JD0Jan1CEJul
+ + [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'.
+#
+# Results:
+# Returns the given dictionary, augmented with a 'julianDay' key.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay { date } {
+
+ variable DaysPerWeek
+
+ # 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 [K $date2 [set date2 {}]]]
+ set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
+ [dict get $date2 julianDay]]
+ dict set date julianDay [expr { $wd0 + $DaysPerWeek * $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 { $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 } {
+ return -code error \
+ -errorcode [list CLOCK wrongNumArgs] \
+ "wrong \# args: should be\
+ \"[lindex [info level 0] 0] 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 {
+
+ -gmt {
+ set gmt $b
+ }
+ -locale {
+ set locale $b
+ }
+ -timezone {
+ set timezone $b
+ }
+ default {
+ return -code error \
+ -errorcode [list CLOCK badSwitch $flag] \
+ "bad switch \"$flag\",\
+ 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 $gmt] } {
+ return -code error \
+ "expected boolean value but got \"$gmt\""
+ } else {
+ if { $gmt } {
+ set timezone :GMT
+ }
+ }
+
+ EnterLocale $locale oldLocale
+
+ set status [catch {
+
+ foreach { quantity unit } $offsets {
+
+ switch -exact -- $unit {
+
+ years - year {
+ set clockval \
+ [AddMonths [expr { 12 * $quantity }] \
+ $clockval $timezone]
+ }
+ months - month {
+ set clockval [AddMonths $quantity $clockval $timezone]
+ }
+
+ weeks - week {
+ set clockval [AddDays [expr { 7 * $quantity }] \
+ $clockval $timezone]
+ }
+ days - day {
+ set clockval [AddDays $quantity $clockval $timezone]
+ }
+
+ hours - hour {
+ set clockval [expr { 3600 * $quantity + $clockval }]
+ }
+ minutes - minute {
+ set clockval [expr { 60 * $quantity + $clockval }]
+ }
+ seconds - second {
+ set clockval [expr { $quantity + $clockval }]
+ }
+
+ default {
+ error "unknown unit \"$unit\", must be \
+ years, months, weeks, days, hours, minutes or seconds" \
+ "unknown unit \"$unit\", must be \
+ years, months, weeks, days, hours, minutes or seconds" \
+ [list CLOCK badUnit $unit]
+ }
+ }
+ }
+ } result]
+
+ # Restore the locale
+
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
+ }
+
+ if { $status == 1 } {
+ if { [lindex $::errorCode 0] eq {CLOCK} } {
+ return -code error -errorcode $::errorCode $result
+ } else {
+ error $result $::errorInfo $::errorCode
+ }
+ } else {
+ return $clockval
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# 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 } {
+
+ variable DaysInRomanMonthInCommonYear
+ variable DaysInRomanMonthInLeapYear
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Convert the time to year, month, day, and fraction of day.
+
+ set date [GetMonthDay \
+ [GetGregorianEraYearDay \
+ [GetJulianDay \
+ [ConvertUTCToLocal \
+ [dict create seconds $clockval] \
+ $timezone]]]]
+ dict set date secondOfDay [expr { [dict get $date localSeconds]
+ % $SecondsPerDay }]
+ 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 \
+ [K $date [set date {}]]]
+ dict set date localSeconds \
+ [expr { -$PosixEpochAsJulianSeconds
+ + ( $SecondsPerDay * wide([dict get $date julianDay]) )
+ + [dict get $date secondOfDay] }]
+ set date [ConvertLocalToUTC [K $date [set date {}]]]
+
+ 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
+#
+# Results:
+# Returns the new clock value as a number of seconds since
+# the epoch.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::tcl::clock::AddDays { days clockval timezone } {
+
+ variable PosixEpochAsJulianSeconds
+ variable SecondsPerDay
+
+ # Convert the time to Julian Day
+
+ set date [GetJulianDay \
+ [ConvertUTCToLocal \
+ [dict create seconds $clockval] \
+ $timezone]]
+ dict set date secondOfDay [expr { [dict get $date localSeconds]
+ % $SecondsPerDay }]
+ 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 { -$PosixEpochAsJulianSeconds
+ + ( $SecondsPerDay * wide([dict get $date julianDay]) )
+ + [dict get $date secondOfDay] }]
+ set date [ConvertLocalToUTC [K $date [set date {}]]]
+
+ return [dict get $date seconds]
+
+}
+
+#----------------------------------------------------------------------
+#
+# 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 LocaleNumeralCache
+ variable McLoaded
+ variable CachedSystemTimeZone
+ variable TZData
+
+ foreach p [info procs [namespace current]::scanproc'*] {
+ rename $p {}
+ }
+
+ set LocaleNumeralCache {}
+ set McLoaded {}
+ catch {unset CachedSystemTimeZone}
+ array unset TZData
+
+}