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