diff options
Diffstat (limited to 'library/clock.tcl')
| -rw-r--r-- | library/clock.tcl | 3291 |
1 files changed, 1390 insertions, 1901 deletions
diff --git a/library/clock.tcl b/library/clock.tcl index 5ff786f..1e652b4 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -2,54 +2,33 @@ # # 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. +# This file implements the portions of the [clock] ensemble that are +# coded in Tcl. Refer to the users' manual to see the description of +# the [clock] command and its subcommands. # # #---------------------------------------------------------------------- # -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# 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. # -# RCS: @(#) $Id: clock.tcl,v 1.17 2005/07/15 22:32:24 kennykb Exp $ -# #---------------------------------------------------------------------- -# We must have message catalogs that support the root locale, and -# we need access to the Registry on Windows systems. We also need -# Tcl 8.5 dictionaries. +# We must have message catalogs that support the root locale, and we need +# access to the Registry on Windows systems. uplevel \#0 { package require msgcat 1.4 if { $::tcl_platform(platform) eq {windows} } { if { [catch { package require registry 1.1 }] } { - - # HIDEOUS KLUDGE: [package require registry 1.1] has failed. - # This failure likely means that we're running in Tcl's build - # directory instead of the install directory. We recover by - # trying to load tclreg*.dll directly. - - if { [catch { - load [lindex \ - [glob -directory \ - [file join \ - [pwd] \ - [file dirname [info nameofexecutable]]] \ - tclReg*.dll] \ - 0] registry - }] } { - # Still no registry! - namespace eval ::tcl::clock [list variable NoRegistry {}] - } + 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. +# 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]]] @@ -60,10 +39,10 @@ namespace eval ::tcl::clock \ # # Manipulate times. # -# The 'clock' command manipulates time. Refer to the user documentation -# for the available subcommands and what they do. +# The 'clock' command manipulates time. Refer to the user documentation for +# the available subcommands and what they do. # -#---------------------------------------------------------------------- +#---------------------------------------------------------------------- namespace eval ::tcl::clock { @@ -96,11 +75,11 @@ namespace eval ::tcl::clock { # 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. +# 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. # #---------------------------------------------------------------------- @@ -123,6 +102,7 @@ proc ::tcl::clock::Initialize {} { {-9223372036854775808 0 0 UTC} } set TZData(:UTC) $TZData(:Etc/UTC) + set TZData(:localtime) {} } InitTZData @@ -191,8 +171,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 - # For Belgium, we follow Southern Netherlands; Liege Diocese - # changed several weeks later. + # 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 @@ -208,13 +188,13 @@ proc ::tcl::clock::Initialize {} { # Germany, Norway, Denmark (Catholic Germany changed earlier) ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032 - ::msgcat::mcset nb 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) + # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at + # various times) ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 @@ -236,30 +216,30 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 - # Romania (Transylvania changed earler - perhaps de_RO should show - # the earlier date?) + # 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 + # 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 - C:/Progra~1/cygwin/usr/local/etc/zoneinfo } { if { [file isdirectory $path] } { lappend ZoneinfoPaths $path @@ -301,10 +281,10 @@ proc ::tcl::clock::Initialize {} { 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. + # 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: @@ -315,77 +295,92 @@ proc ::tcl::clock::Initialize {} { # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds - # The values are the names of time zones where those rules apply. - # There is considerable ambiguity in certain zones; an attempt has - # been made to make a reasonable guess, but this table needs to be - # taken with a grain of salt. - - variable WinZoneInfo [dict create \ - {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein \ - {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway \ - {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu \ - {-32400 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Anchorage \ - {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Los_Angeles \ - {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Denver \ - {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix \ - {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina \ - {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chicago \ - {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/New_York \ - {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis \ - {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas \ - {-14400 0 3600 0 3 6 2 0 0 0 0 0 10 6 2 0 0 0 0} :America/Santiago \ - {-14400 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Halifax \ - {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns \ - {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo \ - {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab \ - {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires \ - {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha \ - {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores \ - {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde \ - {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC \ - {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London \ - {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa \ - {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET \ - {7200 0 3600 0 9 3 5 2 0 0 0 0 5 5 1 2 0 0 0} :Africa/Cairo \ - {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki \ - {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Jerusalem \ - {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest \ - {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens \ - {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh \ - {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad \ - {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow \ - {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran \ - {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat \ - {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi \ - {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul \ - {18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi \ - {18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg \ - {19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta \ - {20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu \ - {21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka \ - {21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk \ - {23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon \ - {25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok \ - {25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk \ - {28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing \ - {28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk \ - {32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo \ - {32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk \ - {34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide \ - {34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin \ - {36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane \ - {36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok \ - {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart \ - {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney \ - {39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea \ - {43200 0 3600 0 3 0 3 2 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland \ - {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji \ - {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu] - - # Groups of fields that specify the date, priorities, and - # code bursts that determine Julian Day Number given those groups. - # The code in [clock scan] will choose the highest priority - # (lowest numbered) set of fields that determines the date. + # 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 { @@ -393,80 +388,104 @@ proc ::tcl::clock::Initialize {} { { julianDay } 1 {} - { century yearOfCentury month dayOfMonth } 2 { + { 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 {}]] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] } - { century yearOfCentury dayOfYear } 2 { + { 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 {}]] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] } - { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 2 { + { 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 {}]] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] } - { yearOfCentury month dayOfMonth } 3 { + { yearOfCentury month dayOfMonth } 4 { set date [InterpretTwoDigitYear $date[set date {}] $baseTime] dict set date era CE - set date [GetJulianDayFromEraYearMonthDay $date[set date {}]] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] } - { yearOfCentury dayOfYear } 3 { + { yearOfCentury dayOfYear } 4 { set date [InterpretTwoDigitYear $date[set date {}] $baseTime] dict set date era CE - set date [GetJulianDayFromEraYearDay $date[set date {}]] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] } - { iso8601YearOfCentury iso8601Week dayOfWeek } 3 { + { iso8601YearOfCentury iso8601Week dayOfWeek } 4 { set date [InterpretTwoDigitYear \ $date[set date {}] $baseTime \ iso8601YearOfCentury iso8601Year] dict set date era CE - set date [GetJulianDayFromEraYearWeekDay $date[set date {}]] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] } - { month dayOfMonth } 4 { + { month dayOfMonth } 5 { set date [AssignBaseYear $date[set date {}] \ - $baseTime $timeZone] - set date [GetJulianDayFromEraYearMonthDay $date[set date {}]] + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] } - { dayOfYear } 4 { + { dayOfYear } 5 { set date [AssignBaseYear $date[set date {}] \ - $baseTime $timeZone] - set date [GetJulianDayFromEraYearDay $date[set date {}]] + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] } - { iso8601Week dayOfWeek } 4 { + { iso8601Week dayOfWeek } 5 { set date [AssignBaseIso8601Year $date[set date {}] \ - $baseTime $timeZone] - set date [GetJulianDayFromEraYearWeekDay $date[set date {}]] + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] } - { dayOfMonth } 5 { + { dayOfMonth } 6 { set date [AssignBaseMonth $date[set date {}] \ - $baseTime $timeZone] - set date [GetJulianDayFromEraYearMonthDay $date[set date {}]] + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] } - { dayOfWeek } 6 { + { dayOfWeek } 7 { set date [AssignBaseWeek $date[set date {}] \ - $baseTime $timeZone] - set date [GetJulianDayFromEraYearWeekDay $date[set date {}]] + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] } - {} 7 { + {} 8 { set date [AssignBaseJulianDay $date[set date {}] \ - $baseTime $timeZone] + $baseTime $timeZone $changeover] } } - # Groups of fields that specify time of day, priorities, - # and code that processes them + # Groups of fields that specify time of day, priorities, and code that + # processes them variable TimeParseActions { @@ -557,7 +576,10 @@ proc ::tcl::clock::Initialize {} { jt +0730 \ cct +0800 \ jst +0900 \ + kst +0900 \ cast +0930 \ + jdt +1000 \ + kdt +1000 \ cadt +1030 \ east +1000 \ eadt +1030 \ @@ -619,6 +641,9 @@ proc ::tcl::clock::Initialize {} { # 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 @@ -626,482 +651,546 @@ proc ::tcl::clock::Initialize {} { # # clock format -- # -# Formats a count of seconds since the Posix Epoch as a time -# of day. +# 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. +# 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 - set format {} - - # Check the count of args - - if { [llength $args] < 1 || [llength $args] % 2 != 1 } { - return -code error \ - -errorcode [list CLOCK wrongNumArgs] \ - "wrong \# args: should be\ - \"[lindex [info level 0] 0] clockval\ - ?-format string? ?-gmt boolean?\ - ?-locale LOCALE? ?-timezone ZONE?\"" - } - - # Set defaults - + lassign [ParseFormatArgs {*}$args] format locale timezone + set locale [string tolower $locale] set clockval [lindex $args 0] - set format {%a %b %d %H:%M:%S %z %Y} - set gmt 0 - set locale C - set timezone [GetSystemTimeZone] - # Pick up command line options. + # Get the data for time changes in the given zone - foreach { flag value } [lreplace $args 0 0] { - set saw($flag) {} - switch -exact -- $flag { - -format { - set format $value - } - -gmt { - set gmt $value - } - -locale { - set locale $value - } - -timezone { - set timezone $value - } - default { - return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ - must be -format, -gmt, -locale or -timezone" - } + 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 } } - # Check options for validity + # 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. - if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } { - return -code error \ - -errorcode [list CLOCK gmtWithTimezone] \ - "cannot use -gmt and -timezone in same call" - } - if { [catch { expr { wide($clockval) } } result] } { - return -code error \ - "expected integer but got \"$clockval\"" - } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" + set procName formatproc'$format'$locale + set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] + if {[info exists FormatProc($procName)]} { + set procName $FormatProc($procName) } else { - if { $gmt } { - set timezone :GMT - } + set FormatProc($procName) \ + [ParseClockFormatFormat $procName $format $locale] } + return [$procName $clockval $timezone] +} + +#---------------------------------------------------------------------- +# +# ParseClockFormatFormat -- +# +# Builds and caches a procedure that formats a time value. +# +# Parameters: +# format -- Format string to use +# locale -- Locale in which the format string is to be interpreted +# +# Results: +# Returns the name of the newly-built procedure. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { + if {[namespace which $procName] ne {}} { + return $procName + } + + # Map away the locale-dependent composite format groups + EnterLocale $locale oldLocale # Change locale if a fresh locale has been given on the command line. - set status [catch { + try { + return [ParseClockFormatFormat2 $format $locale $procName] + } trap CLOCK {result opts} { + dict unset opts -errorinfo + return -options $opts $result + } finally { + # Restore the locale - # Map away the locale-dependent composite format groups + if { [info exists oldLocale] } { + mclocale $oldLocale + } + } +} - set format [LocalizeFormat $locale $format] - - # Convert the given time to local time. - - set date [dict create seconds $clockval] - set date [ConvertUTCToLocal $date[set date {}] $timezone] - - # Extract the fields of the date. - - set date [GetJulianDay $date[set date {}]] - set date [GetGregorianEraYearDay $date[set date {}]] - set date [GetMonthDay $date[set date {}]] - set date [GetYearWeekDay $date[set date {}]] - - # Format the result - - set state {} - set retval {} - foreach char [split $format {}] { - switch -exact -- $state { - {} { - if { [string equal % $char] } { - set state percent - } else { - append retval $char - } +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 retval % - } - a { # Day of week, abbreviated - set dow [expr { [dict get $date dayOfWeek] % 7 }] - append retval \ - [lindex [mc DAYS_OF_WEEK_ABBREV] $dow] - } - A { # Day of week, spelt out. - set dow [expr { [dict get $date dayOfWeek] % 7 }] - append retval [lindex [mc DAYS_OF_WEEK_FULL] $dow] - } - b - h { # Name of month, abbreviated. - set month [expr { [dict get $date month] - 1 }] - append retval [lindex [mc MONTHS_ABBREV] $month] - } - B { # Name of month, spelt out - set month [expr { [dict get $date month] - 1 }] - append retval [lindex [mc MONTHS_FULL] $month] - } - C { # Century number - set cent [expr { [dict get $date year] / 100 }] - append retval [::format %02d $cent] - } - d { # Day of month, with leading zero - append retval [::format %02d \ - [dict get $date dayOfMonth]] - } - e { # Day of month, without leading zero - append retval [::format %2d \ - [dict get $date dayOfMonth]] - } - E { # Format group in a locale-dependent + } + 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 { ![dict exists $date localeEra] } { - set date [GetLocaleEra $date[set date {}]] - } + 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 } - g { # Two-digit year relative to ISO8601 - # week number - set year \ - [expr { [dict get $date iso8601Year] % 100 }] - append retval [::format %02d $year] + if {!$didLocaleNumerals} { + append preFormatCode \ + [list set localeNumerals \ + [mc LOCALE_NUMERALS]] \n + set didLocaleNumerals 1 } - G { # Four-digit year relative to ISO8601 + } + g { # Two-digit year relative to ISO8601 # week number - append retval [::format %04d \ - [dict get $date iso8601Year]] - } - H { # Hour in the 24-hour day, leading zero - append retval \ - [::format %02d \ - [expr { [dict get $date localSeconds] - / 3600 - % 24 }]] - } - I { # Hour AM/PM, with leading zero - set hour12 \ - [expr { ( ( ( [dict get $date localSeconds] - % 86400 ) - + 86400 - - 3600 ) - / 3600 ) - % 12 + 1 }] - append retval [::format %02d $hour12] - } - j { # Day of year (001-366) - append retval [::format %03d \ - [dict get $date dayOfYear]] - } - J { # Julian Day Number - append retval [::format %07ld \ - [dict get $date julianDay]] - } - k { # Hour (0-23), no leading zero - append retval \ - [::format %2d \ - [expr { [dict get $date localSeconds] - / 3600 - % 24 }]] - } - l { # Hour (12-11), no leading zero - set hour12 \ - [expr { ( ( ( [dict get $date localSeconds] - % 86400 ) - + 86400 - - 3600 ) - / 3600 ) - % 12 + 1 }] - append retval [::format %2d $hour12] - } - m { # Month number, leading zero - append retval [::format %02d \ - [dict get $date month]] - } - M { # Minute of the hour, leading zero - append retval \ - [::format %02d \ - [expr { [dict get $date localSeconds] - / 60 - % 60 }]] - } - n { # A literal newline - append retval \n - } - N { # Month number, no leading zero - append retval [::format %2d \ - [dict get $date month]] - } - O { # A format group in the locale's + 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 + set state percentO + if {!$didLocaleNumerals} { + append preFormatCode \ + [list set localeNumerals \ + [mc LOCALE_NUMERALS]] \n + set didLocaleNumerals 1 } - p { # Localized 'AM' or 'PM' indicator + } + p { # Localized 'AM' or 'PM' indicator # converted to uppercase - set tod [expr { [dict get $date localSeconds] - % 86400 }] - if { $tod >= ( 86400 / 2 ) } { - append retval [string toupper [mc PM]] - } else { - append retval [string toupper [mc AM]] - } - } - P { # Localized 'AM' or 'PM' indicator - set tod [expr { [dict get $date localSeconds] - % 86400 }] - if { $tod >= ( 86400 / 2 ) } { - append retval [mc PM] - } else { - append retval [mc AM] - } - } - Q { # Hi, Jeff! - append retval [FormatStarDate $date] - } - s { # Seconds from the Posix Epoch - append retval $clockval - } - S { # Second of the minute, with - # leading zero - append retval \ - [::format %02d \ - [expr { [dict get $date localSeconds] - % 60 }]] - } - t { # A literal tab character - append retval \t - } - u { # Day of the week (1-Monday, 7-Sunday) - append retval [dict get $date dayOfWeek] - } - U { # Week of the year (00-53). The + 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 weekNumber \ - [expr { ( [dict get $date dayOfYear] + set UweekNumber \ + [expr { ( [dict get $date dayOfYear] - $dow + 7 ) / 7 }] - append retval [::format %02d $weekNumber] - } - V { # The ISO8601 week number - append retval [::format %02d \ - [dict get $date iso8601Week]] } - w { # Day of the week (0-Sunday, + 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 retval \ - [expr { [dict get $date dayOfWeek] % 7 }] - } - W { # Week of the year (00-53). The first + 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. - set weekNumber \ + append preFormatCode { + set WweekNumber \ [expr { ( [dict get $date dayOfYear] - [dict get $date dayOfWeek] - + 7 ) + + 7 ) / 7 }] - append retval [::format %02d $weekNumber] - } - y { # The two-digit year of the century - append retval \ - [::format %02d \ - [expr { [dict get $date year] % 100 }]] - } - Y { # The four-digit year - append retval [::format %04d \ - [dict get $date year]] } - z { # The time zone as hours and minutes + 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 retval [FormatNumericTimeZone \ - [dict get $date tzOffset]] - } - Z { # The name of the time zone - append retval [dict get $date tzName] - } - % { # A literal percent character - append retval % - } - default { # An unknown escape sequence - append retval % $char - } + 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 { - C { # Locale-dependent era - append retval [dict get $date localeEra] - } - y { # Locale-dependent year of the era + } + 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 } { - append retval [lindex [mc LOCALE_NUMERALS] $y] + set Eyear [lindex $localeNumerals $y] } else { - append retval $y + set Eyear $y } } - default { # Unknown format group - append retval %E $char - } + 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 retval [lindex \ - [mc LOCALE_NUMERALS] \ - [dict get $date dayOfMonth]] - } - H - k { # Hour of the day in alternative + } + 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 - set hour [expr { [dict get $date localSeconds] - / 3600 - % 24 }] - append retval [lindex [mc LOCALE_NUMERALS] $hour] - } - I - l { # Hour (12-11) AM/PM in alternative + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date localSeconds] + / 3600 + % 24 }]]} + } + I - l { # Hour (12-11) AM/PM in alternative # numerals - set hour12 \ - [expr { ( ( ( [dict get $date localSeconds] - % 86400 ) - + 86400 - - 3600 ) - / 3600 ) - % 12 + 1 }] - append retval [lindex [mc LOCALE_NUMERALS] $hour12] - } - m { # Month number in alternative numerals - append retval [lindex \ - [mc LOCALE_NUMERALS] \ - [dict get $date month]] - } - M { # Minute of the hour in alternative + 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 - set minute [expr { [dict get $date localSeconds] - / 60 - % 60 }] - append retval [lindex [mc LOCALE_NUMERALS] $minute] - } - S { # Second of the minute in alternative + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date localSeconds] + / 60 + % 60 }]]} + } + S { # Second of the minute in alternative # numerals - set second [expr { [dict get $date localSeconds] - % 60 }] - append retval [lindex [mc LOCALE_NUMERALS] $second] - } - u { # Day of the week (Monday=1,Sunday=7) + 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 retval [lindex \ - [mc LOCALE_NUMERALS] \ - [dict get $date dayOfWeek]] + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [dict get $date dayOfWeek]]} } - w { # Day of the week (Sunday=0,Saturday=6) + w { # Day of the week (Sunday=0,Saturday=6) # in alternative numerals - append retval \ - [lindex \ - [mc LOCALE_NUMERALS] \ - [expr { [dict get $date dayOfWeek] % 7 }]] - } - y { # Year of the century in alternative + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date dayOfWeek] % 7 }]]} + } + y { # Year of the century in alternative # numerals - append retval \ - [lindex \ - [mc LOCALE_NUMERALS] \ - [expr { [dict get $date year] % 100 }]] - } - default { # Unknown format group - append retval %O $char - } + 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 retval % - } - percentE { - append retval %E - } - percentO { - append retval %O - } - } - - set retval - - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale } - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { - return -code error $result - } else { - return -options $opts $result + # Clean up any improperly terminated groups + + switch -exact -- $state { + percent { + append formatString %% + } + percentE { + append retval %%E + } + percentO { + append retval %%O } - } else { - return $result } + 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. +# 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. +# 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\ - \"[lindex [info level 0] 0] string\ + \"$cmdName string\ ?-base seconds?\ ?-format string? ?-gmt boolean?\ ?-locale LOCALE? ?-timezone ZONE?\"" @@ -1113,7 +1202,7 @@ proc ::tcl::clock::scan { args } { set string [lindex $args 0] set format {} set gmt 0 - set locale C + set locale c set timezone [GetSystemTimeZone] # Pick up command line options. @@ -1121,19 +1210,19 @@ proc ::tcl::clock::scan { args } { foreach { flag value } [lreplace $args 0 0] { set saw($flag) {} switch -exact -- $flag { - -base { + -b - -ba - -bas - -base { set base $value } - -format { + -f - -fo - -for - -form - -forma - -format { set format $value } - -gmt { + -g - -gm - -gmt { set gmt $value } - -locale { - set locale $value + -l - -lo - -loc - -loca - -local - -locale { + set locale [string tolower $value] } - -timezone { + -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { set timezone $value } default { @@ -1153,21 +1242,17 @@ proc ::tcl::clock::scan { args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($base) } } result] } { - return -code error \ - "expected integer but got \"$base\"" + return -code error "expected integer but got \"$base\"" } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } + if { ![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. + # 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] \ @@ -1181,32 +1266,23 @@ proc ::tcl::clock::scan { args } { EnterLocale $locale oldLocale - set status [catch { - + try { # Map away the locale-dependent composite format groups - set format [LocalizeFormat $locale $format] - set scanner [ParseClockScanFormat $format] - $scanner $string $base $timezone - - } result opts] - - # Restore the locale + set scanner [ParseClockScanFormat $format $locale] + return [$scanner $string $base $timezone] + } trap CLOCK {result opts} { + # Conceal location of generation of expected errors - if { [info exists oldLocale] } { - mclocale $oldLocale - } + dict unset opts -errorinfo + return -options $opts $result + } finally { + # Restore the locale - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { - return -code error $result - } else { - return -options $opts $result + if { [info exists oldLocale] } { + mclocale $oldLocale } - } else { - return $result } - } #---------------------------------------------------------------------- @@ -1222,48 +1298,53 @@ proc ::tcl::clock::scan { args } { # 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 +# 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 - # Extract year, month and day from the base time for the - # parser to use as defaults + try { + SetupTimeZone $timezone + } on error {retval opts} { + dict unset opts -errorinfo + return -options $opts $retval + } - set date [GetMonthDay \ - [GetGregorianEraYearDay \ - [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $base] \ - $timezone]]]] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + # Extract year, month and day from the base time for the parser to use as + # defaults - # Parse the date. The parser will return a list comprising - # date, time, time zone, relative month/day/seconds, relative - # weekday, ordinal month. + set date [GetDateFields $base $TZData($timezone) 2361222] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] - set status [catch { - Oldscan $string \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth] - } result] - if { $status != 0 } { - return -code error "unable to convert date-time string \"$string\"" - } + # Parse the date. The parser will return a list comprising date, time, + # time zone, relative month/day/seconds, relative weekday, ordinal month. - foreach { parseDate parseTime parseZone parseRel - parseWeekday parseOrdinalMonth } $result break + 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 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 } { - foreach { y m d } $parseDate break + lassign $parseDate y m d if { $y < 100 } { if { $y >= 39 } { incr y 1900 @@ -1280,62 +1361,60 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } } - # 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 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 } { - foreach { minEast dstFlag } $parseZone break + 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 {}]] + 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 + } 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 localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] dict set date tzName $timezone - set date [ConvertLocalToUTC $date[set date {}]] + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] # Do relative times if { [llength $parseRel] > 0 } { - foreach { relMonth relDay relSecond } $parseRel break + 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 } { - foreach {dayOrdinal dayOfWeek} $parseWeekday break - set date2 [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $seconds] \ - $timezone]] + 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 }]] + set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr { + [dict get $date2 julianDay] + 6 + }]] incr jdwkday [expr { 7 * $dayOrdinal }] if { $dayOrdinal > 0 } { incr jdwkday -7 @@ -1343,21 +1422,21 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { 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 localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date2 julianDay]) ) + + [dict get $date secondOfDay] + }] dict set date2 tzName $timezone - set date2 [ConvertLocalToUTC $date2[set date2 {}]] + set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ + 2361222] set seconds [dict get $date2 seconds] - } # Do relative month if { [llength $parseOrdinalMonth] > 0 } { - - foreach {monthOrdinal monthNumber} $parseOrdinalMonth break + lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] if { $monthDiff <= 0 } { @@ -1373,7 +1452,6 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] - } return $seconds @@ -1387,45 +1465,48 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Parses a format string given to [clock scan -format] # # Parameters: -# None. +# 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] +# 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 +# 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 } { +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 - # Condense whitespace + # Localize the %x, %X, etc. groups - regsub -all {[[:space:]]+} $formatString { } formatString + set formatString [LocalizeFormat $locale $formatString] - # Check whether the format has been parsed previously, and return - # the existing recognizer if it has. + # Condense whitespace - set procName [namespace current]::scanproc'$formatString'[mclocale] - if { [info procs $procName] != {} } { - return $procName - } + regsub -all {[[:space:]]+} $formatString { } formatString # Walk through the groups of the format string. In this loop, we # accumulate: @@ -1452,8 +1533,8 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re \\ - } + append re "\\" + } append re $c } } @@ -1472,16 +1553,16 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { i {7 1 2 3 4 5 6} \ abr [mc DAYS_OF_WEEK_ABBREV] \ full [mc DAYS_OF_WEEK_FULL] { - dict set l $abr $i - dict set l $full $i + dict set l [string tolower $abr] $i + dict set l [string tolower $full] $i incr i } - foreach { regex lookup } [UniquePrefixRegexp $l] break + lassign [UniquePrefixRegexp $l] regex lookup append re ( $regex ) dict set fieldSet dayOfWeek [incr fieldCount] append postcode "dict set date dayOfWeek \[" \ - "dict get " [list $lookup] " \$field" \ - [incr captureCount] \ + "dict get " [list $lookup] " " \ + \[ {string tolower $field} [incr captureCount] \] \ "\]\n" } b - B - h { # Name of month @@ -1491,15 +1572,16 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { abr [mc MONTHS_ABBREV] \ full [mc MONTHS_FULL] { incr i - dict set l $abr $i - dict set l $full $i + dict set l [string tolower $abr] $i + dict set l [string tolower $full] $i } - foreach { regex lookup } [UniquePrefixRegexp $l] break + lassign [UniquePrefixRegexp $l] regex lookup append re ( $regex ) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ - "dict get " [list $lookup] " \$field" \ - [incr captureCount] \ + "dict get " [list $lookup] \ + " " \[ {string tolower $field} \ + [incr captureCount] \] \ "\]\n" } C { # Gregorian century @@ -1569,7 +1651,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "::scan \$field" [incr captureCount] " %ld" \ "\]\n" } - m - N { # Month number + m - N { # Month number append re \\s*(\\d\\d?) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1590,8 +1672,9 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { set state %O } p - P { # AM/PM indicator - set l [list [mc AM] 0 [mc PM] 1] - foreach { regex lookup } [UniquePrefixRegexp $l] break + 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 \[" \ @@ -1611,10 +1694,9 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { \] \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. + # 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 } \[ \ @@ -1647,14 +1729,13 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { 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. + 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 \[" \ @@ -1717,17 +1798,33 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { C { # Locale-dependent era set d {} foreach triple [mc LOCALE_ERAS] { - foreach {t symbol year} $triple break - dict set d $symbol $year + lassign $triple t symbol year + dict set d [string tolower $symbol] $year } - foreach { regex lookup } [UniquePrefixRegexp $d] break + 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 - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex - incr fieldCount + incr captureCount } default { append re %E @@ -1742,7 +1839,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { %O { switch -exact -- $c { d - e { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet dayOfMonth [incr fieldCount] append postcode "dict set date dayOfMonth \[" \ @@ -1751,7 +1848,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } H - k { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet hour [incr fieldCount] append postcode "dict set date hour \[" \ @@ -1760,7 +1857,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } I - l { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet hourAMPM [incr fieldCount] append postcode "dict set date hourAMPM \[" \ @@ -1769,7 +1866,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } m { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1778,7 +1875,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } M { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet minute [incr fieldCount] append postcode "dict set date minute \[" \ @@ -1787,7 +1884,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } S { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet second [incr fieldCount] append postcode "dict set date second \[" \ @@ -1796,7 +1893,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "\]\n" } u - w { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet dayOfWeek [incr fieldCount] append postcode "set dow \[dict get " [list $lookup] \ @@ -1810,10 +1907,10 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { "day of week is greater than 7" } dict set date dayOfWeek $dow - } + } } y { - foreach {regex lookup} [LocaleNumeralMatcher] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet yearOfCentury [incr fieldCount] append postcode {dict set date yearOfCentury } \[ \ @@ -1840,6 +1937,7 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { # 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 @@ -1853,6 +1951,22 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { 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. @@ -1862,26 +1976,29 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # Assemble seconds, and convert local nominal time to UTC. + # 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] + 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] }] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] } - } - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + # Finally, convert the date to local time + append procBody { - set date [::tcl::clock::ConvertLocalToUTC $date[set date {}]] + set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ + $TZData($timeZone) $changeover] } } @@ -1895,31 +2012,28 @@ proc ::tcl::clock::ParseClockScanFormat { formatString } { return $procName } - + #---------------------------------------------------------------------- # # LocaleNumeralMatcher -- # -# Composes a regexp that captures the numerals in the given -# locale, and a dictionary to map them to conventional numerals. +# Composes a regexp that captures the numerals in the given locale, and +# a dictionary to map them to conventional numerals. # # Parameters: -# none. +# locale - Name of the current locale # # Results: -# Returns a two-element list comprising the regexp and the -# dictionary. +# Returns a two-element list comprising the regexp and the dictionary. # # Side effects: # Caches the result. # #---------------------------------------------------------------------- -proc ::tcl::clock::LocaleNumeralMatcher {} { - +proc ::tcl::clock::LocaleNumeralMatcher {l} { variable LocaleNumeralCache - set l [mclocale] if { ![dict exists $LocaleNumeralCache $l] } { set d {} set i 0 @@ -1936,16 +2050,16 @@ proc ::tcl::clock::LocaleNumeralMatcher {} { } 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. +# 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. @@ -1953,10 +2067,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {} { # 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'. +# 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. @@ -1964,11 +2078,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {} { #---------------------------------------------------------------------- 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. + # 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 {} {}] @@ -1976,8 +2089,7 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # Walk the key-value pairs foreach { key value } $data { - - # Construct all prefixes of the key; + # Construct all prefixes of the key; set prefix {} foreach char [split $key {}] { @@ -1995,8 +2107,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { } } - # Identify those prefixes that designate unique values, and - # those that are the full keys + # Identify those prefixes that designate unique values, and those that are + # the full keys set uniquePrefixMapping {} dict for { key valueList } $prefixMapping { @@ -2019,8 +2131,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # # MakeUniquePrefixRegexp -- # -# Service procedure for 'UniquePrefixRegexp' that constructs -# a regular expresison that matches the unique prefixes. +# Service procedure for 'UniquePrefixRegexp' that constructs a regular +# expresison that matches the unique prefixes. # # Parameters: # successors - Dictionary whose keys are all prefixes @@ -2032,18 +2144,17 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # prefixString - Current prefix being processed. # # Results: -# Returns a constructed regular expression that matches the set -# of unique prefixes beginning with the 'prefixString'. +# Returns a constructed regular expression that matches the set of +# unique prefixes beginning with the 'prefixString'. # # Side effects: # None. # #---------------------------------------------------------------------- -proc ::tcl::clock::MakeUniquePrefixRegexp { successors +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]]] @@ -2051,13 +2162,15 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors 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 + # 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 } { + if { + [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 + } then { append re "(?:" } @@ -2079,7 +2192,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2090,8 +2203,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # # MakeParseCodeFromFields -- # -# Composes Tcl code to extract the Julian Day Number from a -# dictionary containing date fields. +# 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, @@ -2102,8 +2215,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # the list must be in ascending order by priority # # Results: -# Returns a burst of code that extracts the day number from the -# given date. +# Returns a burst of code that extracts the day number from the given +# date. # # Side effects: # None. @@ -2111,7 +2224,6 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors #---------------------------------------------------------------------- proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { - set currPrio 999 set currFieldPos [list] set currCodeBurst { @@ -2119,16 +2231,15 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { } foreach { fieldSet prio parseAction } $parseActions { - - # If we've found an answer that's better than any that follow, - # quit now. + # 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. + # Accumulate the field positions that are used in the current field + # grouping. set fieldPos [list] set ok true @@ -2151,9 +2262,11 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { - if { ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos } { + if { + ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos + } then { break } if { $newPos < $currPos } { @@ -2171,11 +2284,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction - } return $currCodeBurst - } #---------------------------------------------------------------------- @@ -2193,14 +2304,13 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { # Returns the locale that was previously current. # # Side effects: -# Does [mclocale]. If necessary, uses [mcload] to load the -# designated locale's files, and tracks that it has done so -# in the 'McLoaded' variable. +# Does [mclocale]. If necessary, uses [mcload] to load the designated +# locale's files, and tracks that it has done so in the 'McLoaded' +# variable. # #---------------------------------------------------------------------- proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { - upvar 1 $oldLocaleVar oldLocale variable MsgDir @@ -2208,32 +2318,29 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { set oldLocale [mclocale] if { $locale eq {system} } { - if { $::tcl_platform(platform) ne {windows} } { - - # On a non-windows platform, the 'system' locale is - # the same as the 'current' locale + # 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 + # On a windows platform, the 'system' locale is adapted from the + # 'current' locale by applying the date and time formats from the + # Control Panel. First, load the 'current' locale if it's not yet + # loaded if {![dict exists $McLoaded $oldLocale] } { mcload $MsgDir dict set McLoaded $oldLocale {} } - # Make a new locale string for the system locale, and - # get the Control Panel information + # Make a new locale string for the system locale, and get the + # Control Panel information set locale ${oldLocale}_windows if { ![dict exists $McLoaded $locale] } { LoadWindowsDateTimeFormats $locale - dict set mcloaded $locale {} + dict set McLoaded $locale {} } } } @@ -2249,15 +2356,14 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { mcload $MsgDir dict set McLoaded $locale {} } - -} +} #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows -# and convert them so that they're usable by Tcl. +# 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 @@ -2269,14 +2375,12 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { # 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. +# 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 @@ -2378,7 +2482,6 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { } return - } #---------------------------------------------------------------------- @@ -2393,8 +2496,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { # format -- Format supplied to [clock scan] or [clock format] # # Results: -# Returns the string with locale-dependent composite format -# groups substituted out. +# Returns the string with locale-dependent composite format groups +# substituted out. # # Side effects: # None. @@ -2402,7 +2505,6 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { #---------------------------------------------------------------------- proc ::tcl::clock::LocalizeFormat { locale format } { - variable McLoaded if { [dict exists $McLoaded $locale FORMAT $format] } { @@ -2410,26 +2512,29 @@ proc ::tcl::clock::LocalizeFormat { locale format } { } set inFormat $format - # Handle locale-dependent format groups by mapping them out of - # the input string. Note that the order of the [string map] - # operations is significant because earlier formats can refer - # to later ones; for example %c can refer to %X, which in turn - # can refer to %T. - - set format [string map [list %c [mc DATE_TIME_FORMAT] \ - %Ec [mc LOCALE_DATE_TIME_FORMAT]] $format] - set format [string map [list %x [mc DATE_FORMAT] \ - %Ex [mc LOCALE_DATE_FORMAT] \ - %X [mc TIME_FORMAT] \ - %EX [mc LOCALE_TIME_FORMAT]] $format] - set format [string map [list %r [mc TIME_FORMAT_12] \ - %R [mc TIME_FORMAT_24] \ - %T [mc TIME_FORMAT_24_SECS]] $format] - set format [string map [list %D %m/%d/%Y \ - %EY [mc LOCALE_YEAR_FORMAT]\ - %+ {%a %b %e %H:%M:%S %Z %Y}] $format] - - dict set McLoaded $locale FORMAT $format $inFormat + # Handle locale-dependent format groups by mapping them out of the format + # string. Note that the order of the [string map] operations is + # significant because later formats can refer to later ones; for example + # %c can refer to %X, which in turn can refer to %T. + + set list { + %% %% + %D %m/%d/%Y + %+ {%a %b %e %H:%M:%S %Z %Y} + } + lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]] + lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]] + lappend list %R [string map $list [mc TIME_FORMAT_24]] + lappend list %r [string map $list [mc TIME_FORMAT_12]] + lappend list %X [string map $list [mc TIME_FORMAT]] + lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]] + lappend list %x [string map $list [mc DATE_FORMAT]] + lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]] + lappend list %c [string map $list [mc DATE_TIME_FORMAT]] + lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] + set format [string map $list $format] + + dict set McLoaded $locale FORMAT $inFormat $format return $format } @@ -2451,7 +2556,6 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { - if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2466,10 +2570,8 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval - } - #---------------------------------------------------------------------- # # FormatStarDate -- @@ -2492,7 +2594,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { - variable Roddenberry # Get day of year, zero based @@ -2501,11 +2602,7 @@ proc ::tcl::clock::FormatStarDate { date } { # Determine whether the year is a leap year - if { [dict get $date gregorian] } { - set lp [IsGregorianLeapYear $date] - } else { - set lp [expr { [dict get $date year] % 4 == 0 }] - } + set lp [IsGregorianLeapYear $date] # Convert day of year to a fractional year @@ -2547,12 +2644,12 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- 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 }]] @@ -2560,14 +2657,10 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { # Determine whether the given year is a leap year - if { [dict get $date gregorian] } { - set lp [IsGregorianLeapYear $date] - } else { - set lp [expr { [dict get $date year] % 4 == 0 }] - } + set lp [IsGregorianLeapYear $date] - # Reconvert the fractional year according to whether the given - # year is a leap year + # Reconvert the fractional year according to whether the given year is a + # leap year if { $lp } { dict set date dayOfYear \ @@ -2580,10 +2673,11 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] - return [expr { 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay }] - + return [expr { + 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay + }] } #---------------------------------------------------------------------- @@ -2596,8 +2690,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { # 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. +# Returns the string as a pure wide integer. Throws an error if the +# string is misformatted or out of range. # #---------------------------------------------------------------------- @@ -2618,8 +2712,8 @@ proc ::tcl::clock::ScanWide { str } { # # InterpretTwoDigitYear -- # -# Given a date that contains only the year of the century, -# determines the target value of a two-digit year. +# 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. @@ -2636,18 +2730,17 @@ proc ::tcl::clock::ScanWide { str } { # 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. +# 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 +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 }] @@ -2655,7 +2748,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date - } #---------------------------------------------------------------------- @@ -2668,6 +2760,9 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime # 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. @@ -2677,15 +2772,13 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { +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 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] - set date2 [GetGregorianEraYearDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timezone) $changeover] # Store the converted year @@ -2693,7 +2786,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { dict set date year [dict get $date2 year] return $date - } #---------------------------------------------------------------------- @@ -2706,6 +2798,9 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { # 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 @@ -2716,17 +2811,15 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timeZone } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } { +proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] # Calculate the ISO8601 date and transfer the year - set date2 [GetYearWeekDay $date2[set date2 {}]] dict set date era CE dict set date iso8601Year [dict get $date2 iso8601Year] return $date @@ -2736,13 +2829,15 @@ proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } { # # AssignBaseMonth -- # -# Places the number of the current year and month into a +# 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. @@ -2752,23 +2847,16 @@ proc ::tcl::clock::AssignBaseIso8601Year { date baseTime timeZone } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } { - - # Find the Julian Day Number corresponding to the base time - - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] +proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { + variable TZData - # Find the Gregorian year corresponding to that Julian Day + # Find the year and month corresponding to the base time - set date2 [GetGregorianEraYearDay $date2[set date2 {}]] - set date2 [GetMonthDay $date2[set date2 {}]] + 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 - } #---------------------------------------------------------------------- @@ -2781,6 +2869,8 @@ proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } { # 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 @@ -2791,17 +2881,15 @@ proc ::tcl::clock::AssignBaseMonth { date baseTime timeZone } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseWeek { date baseTime timeZone } { +proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] # Calculate the ISO8601 date and transfer the year - set date2 [GetYearWeekDay $date2[set date2 {}]] dict set date era CE dict set date iso8601Year [dict get $date2 iso8601Year] dict set date iso8601Week [dict get $date2 iso8601Week] @@ -2817,6 +2905,8 @@ proc ::tcl::clock::AssignBaseWeek { date baseTime timeZone } { # 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 @@ -2827,13 +2917,12 @@ proc ::tcl::clock::AssignBaseWeek { date baseTime timeZone } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone } { +proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time - set date2 [dict create seconds $baseTime] - set date2 [ConvertUTCToLocal $date2[set date2 {}] $timeZone] - set date2 [GetJulianDay $date2[set date2 {}]] + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] dict set date julianDay [dict get $date2 julianDay] return $date @@ -2858,7 +2947,6 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { - set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 @@ -2868,7 +2956,6 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] - } #---------------------------------------------------------------------- @@ -2891,11 +2978,11 @@ proc ::tcl::clock::InterpretHMSP { date } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMS { date } { - - return [expr { ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 - + [dict get $date second] }] - + return [expr { + ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] + }] } #---------------------------------------------------------------------- @@ -2918,25 +3005,29 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { - variable CachedSystemTimeZone variable TimeZoneBad - if { ![catch {getenv TCL_TZ} result] } { + if {[set result [getenv TCL_TZ]] ne {}} { set timezone $result - } elseif { ![catch {getenv TZ} result] } { + } elseif {[set result [getenv TZ]] ne {}} { set timezone $result - } else { - if { [info exists CachedSystemTimeZone] } { - set timezone $CachedSystemTimeZone - } else { - if { $::tcl_platform(platform) eq {windows} } { - set timezone [GuessWindowsTimeZone] - } else { - set timezone :localtime - } - set CachedSystemTimeZone $timezone - } + } + 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}] @@ -2946,319 +3037,69 @@ proc ::tcl::clock::GetSystemTimeZone {} { } else { return $timezone } - } #---------------------------------------------------------------------- # # ConvertLegacyTimeZone -- # -# Given an alphanumeric time zone identifier and the system -# time zone, convert the alphanumeric identifier to an -# unambiguous time zone. +# 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. +# 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? +# This procedure is implemented primarily to allow the parsing of RFC822 +# date/time strings. Processing a time zone name on input is not recommended +# practice, because there is considerable room for ambiguity; for instance, is +# BST Brazilian Standard Time, or British Summer Time? # #---------------------------------------------------------------------- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { - variable LegacyTimeZone set tzname [string tolower $tzname] if { ![dict exists $LegacyTimeZone $tzname] } { return -code error -errorcode [list CLOCK badTZName $tzname] \ "time zone \"$tzname\" not found" - } else { - return [dict get $LegacyTimeZone $tzname] - } - -} - -#---------------------------------------------------------------------- -# -# ConvertLocalToUTC -- -# -# Given a time zone and nominal local seconds, compute seconds -# of UTC time from the Posix epoch. -# -# Parameters: -# date - Dictionary populated with the 'localSeconds' and -# 'tzName' fields -# -# Results: -# Returns the given dictionary augmented with a 'seconds' field. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertLocalToUTC { date } { - - variable TZData - - set timezone [dict get $date tzName] - if { $timezone eq ":localtime" } { - - # Convert using the mktime function if possible - - if { [catch { - ConvertLocalToUTCViaC [dict get $date localSeconds] - } result opts] } { - dict unset opts -errorinfo - return -options $opts $result - } - dict set date seconds $result - return $date - - } else { - - # Get the time zone data - - if { [catch { SetupTimeZone $timezone } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - - # Initially assume that local == UTC, and locate the last time - # conversion prior to that time. Get the offset from that, - # and look up again. If that lookup finds a different offset, - # continue looking until we find an offset that we found - # before. The check for "any offset previously found" rather - # than "the same offset" avoids an endless loop if we try to - # convert a non-existent time, for example 2:30am during the - # US spring DST change. - - set localseconds [dict get $date localSeconds] - set utcseconds(0) $localseconds - set seconds $localseconds - while { 1 } { - set i [BSearch $TZData($timezone) $seconds] - set offset [lindex $TZData($timezone) $i 1] - if { [info exists utcseconds($offset)] } { - dict set date seconds $utcseconds($offset) - return $date - } else { - set seconds [expr { $localseconds - $offset }] - set utcseconds($offset) $seconds - } - } - - # In the absolute worst case, the loop above can visit each tzdata - # row only once, so it's guaranteed to terminate. - - error "in ConvertLocalToUTC, can't happen" } - -} - -#---------------------------------------------------------------------- -# -# ConvertLocalToUTCViaC -- -# -# Given seconds of nominal local time, compute seconds from the -# Posix epoch. -# -# Parameters: -# localSeconds - Seconds of nominal local time -# -# Results: -# Returns the seconds from the epoch. May throw an error if -# the time is to large/small to represent, or if 'mktime' is -# not present in the C library. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertLocalToUTCViaC { localSeconds } { - - set date [dict create localSeconds $localSeconds] - set date [GetJulianDay $date[set date {}]] - set date [GetGregorianEraYearDay $date[set date {}]] - set date [GetMonthDay $date[set date {}]] - set retval \ - [Mktime \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth] \ - [expr { $localSeconds / 3600 % 24 }] \ - [expr { $localSeconds / 60 % 60 }] \ - [expr { $localSeconds % 60 }]] - return $retval -} - -#---------------------------------------------------------------------- -# -# ConvertUTCToLocal -- -# -# Given the seconds from the Posix epoch, compute seconds of -# nominal local time. -# -# Parameters: -# date - Dictionary populated on entry with the 'seconds' field -# -# Results: -# The given dictionary is returned, augmented with 'localSeconds', -# 'tzOffset', and 'tzName' fields. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertUTCToLocal { date timezone } { - - variable TZData - - # Get the data for time changes in the given zone - - if { [catch { SetupTimeZone $timezone } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - - if { $timezone eq {:localtime} } { - - # Convert using the localtime function - - if { [catch { - ConvertUTCToLocalViaC $date - } retval opts] } { - dict unset opts -errorinfo - return -options $opts $retval - } - return $retval - } - - # Find the most recent transition in the time zone data - - set i [BSearch $TZData($timezone) [dict get $date seconds]] - set row [lindex $TZData($timezone) $i] - foreach { junk1 offset junk2 name } $row break - - # Add appropriate offset to convert Greenwich to local, and return - # the local time - - dict set date localSeconds [expr { [dict get $date seconds] + $offset }] - dict set date tzOffset $offset - dict set date tzName $name - - return $date - -} - -#---------------------------------------------------------------------- -# -# ConvertUTCToLocalViaC -- -# -# Convert local time using the C localtime function -# -# Parameters: -# date - Dictionary populated on entry with the 'seconds' -# and 'timeZone' fields. -# -# Results: -# The given dictionary is returned, augmented with 'localSeconds', -# 'tzOffset', and 'tzName' fields. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::ConvertUTCToLocalViaC { date } { - - # Get y-m-d-h-m-s from the C library - - set gmtSeconds [dict get $date seconds] - set localFields [Localtime $gmtSeconds] - set date2 [dict create] - foreach key { - year month dayOfMonth hour minute second - } value $localFields { - dict set date2 $key $value - } - dict set date2 era CE - - # Convert to Julian Day - - set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}]] - - # Reconvert to seconds from the epoch in local time. - - set localSeconds [expr { ( ( ( wide([dict get $date2 julianDay]) - * 24 - + wide([dict get $date2 hour]) ) - * 60 - + wide([dict get $date2 minute]) ) - * 60 - + wide([dict get $date2 second]) ) - - 210866803200 }] - - # Determine the name and offset of the timezone - - set diff [expr { $localSeconds - $gmtSeconds }] - if { $diff <= 0 } { - set signum - - set delta [expr { - $diff }] - } else { - set signum + - set delta $diff - } - set hh [::format %02d [expr { $delta / 3600 }]] - set mm [::format %02d [expr { ($delta / 60 ) - % 60 }]] - set ss [::format %02d [expr { $delta % 60 }]] - - set zoneName $signum$hh$mm - if { $ss ne {00} } { - append zoneName $ss - } - - # Fix the dictionary - - dict set date localSeconds $localSeconds - dict set date tzOffset $diff - dict set date tzName $zoneName - return $date - + return [dict get $LegacyTimeZone $tzname] } #---------------------------------------------------------------------- # # SetupTimeZone -- # -# Given the name or specification of a time zone, sets up -# its in-memory data. +# 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. +# 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] } { - + } elseif { + [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] + } then { # Make a fixed offset ::scan $hh %d hh @@ -3279,24 +3120,21 @@ proc ::tcl::clock::SetupTimeZone { timezone } { set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] } elseif { [string index $timezone 0] eq {:} } { - # Convert using a time zone file - if { + if { [catch { LoadTimeZoneFile [string range $timezone 1 end] - }] - && [catch { + }] && [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] } { @@ -3309,9 +3147,8 @@ proc ::tcl::clock::SetupTimeZone { timezone } { } } else { - - # We couldn't parse this as a POSIX time zone. Try - # again with a time zone file - this time without a colon + # 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] } { @@ -3335,25 +3172,22 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # None. # # Results: -# Returns a time zone specifier that corresponds to the system -# time zone information found in the Registry. +# 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! +# 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. +# 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 @@ -3384,16 +3218,14 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { 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) + # 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] @@ -3404,13 +3236,12 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { set tzname {} } if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { - foreach { - bias stdBias dstBias - stdYear stdMonth stdDayOfWeek stdDayOfMonth - stdHour stdMinute stdSecond stdMillisec - dstYear dstMonth dstDayOfWeek dstDayOfMonth + lassign $data \ + bias stdBias dstBias \ + stdYear stdMonth stdDayOfWeek stdDayOfMonth \ + stdHour stdMinute stdSecond stdMillisec \ + dstYear dstMonth dstDayOfWeek dstDayOfMonth \ dstHour dstMinute dstSecond dstMillisec - } $data break set stdDelta [expr { $bias + $stdBias }] set dstDelta [expr { $bias + $dstBias }] if { $stdDelta <= 0 } { @@ -3442,11 +3273,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { 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. + # 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] \ @@ -3455,11 +3286,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { 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. + # 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] \ @@ -3467,10 +3298,9 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { : [::format %02d $stdSecond] } dict set WinZoneInfo $data $tzname - } + } return [dict get $WinZoneInfo $data] - } #---------------------------------------------------------------------- @@ -3499,18 +3329,18 @@ proc ::tcl::clock::LoadTimeZoneFile { 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. + # Since an unsafe interp uses the [clock] command in the master, this code + # is security sensitive. Make sure that the path name cannot escape the + # given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } - if { [catch { + try { source -encoding utf-8 [file join $DataDir $fileName] - }] } { + } on error {} { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" @@ -3525,11 +3355,11 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { # Loads a binary time zone information file in Olson format. # # Parameters: -# fileName - Path name of the file to load. +# 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. +# 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 @@ -3537,14 +3367,11 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { - - variable MINWIDE - variable TZData variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, - # this code is security sensitive. Make sure that the path name - # cannot escape the given directory. + # 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 \ @@ -3558,7 +3385,33 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { } unset fname } - if { ![info exists 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" } @@ -3573,27 +3426,54 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { 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. + # The file begins with a magic number, sixteen reserved bytes, and then + # six 4-byte integers giving counts of fileds in the file. - binary scan $d a4x16IIIIII magic nIsGMT mIsStd nLeap nTime nType nChar + 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}I${nTime}c${nTime} times tempCodes - incr seek [expr { 5 * $nTime }] + 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 { @@ -3601,9 +3481,9 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { } 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. + # 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 @@ -3611,10 +3491,10 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { 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. + # 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} @@ -3622,11 +3502,12 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { set i 0 set abbrevs {} foreach a $abbrList { - dict set abbrevs $i $a - incr i [expr { [string length $a] + 1 }] + for {set j 0} {$j <= [string length $a]} {incr j} { + dict set abbrevs $i [string range $a $j end] + incr i + } } - # The rest of the data in the file are not used at present. # Package up a list of tuples, each of which contains transition time, # seconds east of Greenwich, DST flag and time zone abbreviation. @@ -3637,13 +3518,34 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { return -code error "$fileName has times out of order" } set lastTime $t - foreach { gmtoff isDst abbrInd } [lindex $types $c] break + 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 } #---------------------------------------------------------------------- @@ -3656,8 +3558,8 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # tz Time zone specifier to be interpreted # # Results: -# Returns a dictionary whose values contain the various pieces of -# the time zone specification. +# Returns a dictionary whose values contain the various pieces of the +# time zone specification. # # Side effects: # None. @@ -3668,7 +3570,7 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # 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 +# 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 @@ -3713,14 +3615,13 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # 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. +# +# 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 @@ -3731,8 +3632,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 4 - Standard time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 5 - Standard time zone offset, seconds : ([[:digit:]]{1,2} ) )? @@ -3748,8 +3649,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 9 - DST time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 10 - DST time zone offset, seconds : ([[:digit:]]{1,2}) )? @@ -3762,8 +3663,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 13 - Month number 14 - Week of month 15 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3784,8 +3685,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 21 - Month number 22 - Week of month 23 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3812,27 +3713,21 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { x(endJ) x(endDayOfYear) \ x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ x(endHours) x(endMinutes) x(endSeconds)] } { - # it's a good timezone return [array get x] - - } else { - - return -code error\ - -errorcode [list CLOCK badTimeZone $tz] \ - "unable to parse time zone specification \"$tz\"" - } + 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. +# Handle a Posix time zone after it's been broken out into fields. # # Parameters: # z - Dictionary returned from 'ParsePosixTimeZone' @@ -3846,7 +3741,6 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { - variable MINWIDE variable TZData @@ -3861,20 +3755,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set stdSignum -1 } - set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] + 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] + 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] + set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } else { set stdSeconds 0 } - set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes ) - * 60 + $stdSeconds ) - * $stdSignum }] + 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 @@ -3897,46 +3791,77 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { if { [dict get $z dstHours] eq {} } { set dstOffset [expr { 3600 + $stdOffset }] } else { - set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] + 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] + 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] + 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 US DST rules - - if { [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} } { - dict set z startMonth 4 - dict set z startWeekOfMonth 1 + 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 startHours 2 dict set z startMinutes 0 dict set z startSeconds 0 } - if { [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} } { - dict set z endMonth 10 - dict set z endWeekOfMonth 5 + 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 endHours 2 dict set z endMinutes 0 dict set z endSeconds 0 } # Put DST in effect in all years from 1916 to 2099. - for { set y 1916 } { $y < 2099 } { incr y } { + 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] @@ -3953,15 +3878,14 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } return $data - -} +} #---------------------------------------------------------------------- # # DeterminePosixDSTTime -- # -# Determines the time that Daylight Saving Time starts or ends -# from a Posix time zone specification. +# Determines the time that Daylight Saving Time starts or ends from a +# Posix time zone specification. # # Parameters: # z - Time zone data returned from ParsePosixTimeZone. @@ -3971,13 +3895,12 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # 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. +# 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 @@ -3985,34 +3908,33 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { 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] + && [IsGregorianLeapYear $y] && ( $doy > $FEB_28 ) } { incr doy } dict set date dayOfYear $doy - set date [GetJulianDayFromEraYearDay $date[set date {}]] + 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 dayOfWeekInMonth [dict get $z ${bound}WeekOfMonth] - set dow [dict get $z ${bound}DayOfWeek] - if { $dow >= 5 } { - set dow -1 + 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 dayOfWeek $dow - set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}]] + 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 seconds [expr { + wide($jd) * wide(86400) - wide(210866803200) + }] set h [dict get $z ${bound}Hours] if { $h eq {} } { @@ -4034,7 +3956,6 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] - } #---------------------------------------------------------------------- @@ -4048,457 +3969,30 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # 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'. +# Returns the dictionary, augmented with the keys, 'localeEra' and +# 'localeYear'. # #---------------------------------------------------------------------- -proc ::tcl::clock::GetLocaleEra { date } { - - set etable [mc LOCALE_ERAS] +proc ::tcl::clock::GetLocaleEra { date etable } { set index [BSearch $etable [dict get $date localSeconds]] - if { $index < 0 } { + 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 }] + dict set date localeYear [expr { + [dict get $date year] % 100 + }] } else { dict set date localeEra [lindex $etable $index 1] - dict set date localeYear [expr { [dict get $date year] - - [lindex $etable $index 2] }] - } - return $date - -} -#---------------------------------------------------------------------- -# -# GetJulianDay -- -# -# Given the seconds from the Posix epoch, derives the Julian -# day number. -# -# Parameters: -# date - Dictionary containing the date fields. On input, -# populated with a 'localSeconds' field that gives the -# nominal seconds from the epoch (in the local time zone, -# rather than UTC). -# -# Results: -# Returns the given dictionary, augmented by a 'julianDay' -# field that gives the Julian Day Number at noon of the current -# date. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetJulianDay { date } { - - set secs [dict get $date localSeconds] - - return [dict set date julianDay \ - [expr { ( $secs + 210866803200 ) - / 86400 }]] - -} - -#---------------------------------------------------------------------- -# -# GetGregorianEraYearDay -- -# -# Given the time from the Posix epoch and the current time zone, -# develops the era, year, and day of year in the Gregorian calendar. -# -# Parameters: -# date - Dictionary containing the date fields. On input, populated -# with the 'julianDay' key whose value is the Julian Day Number. -# -# Results: -# Returns the given dictionary with the 'gregorian', 'era', -# 'year', and 'dayOfYear' populated. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetGregorianEraYearDay { date } { - - set jday [dict get $date julianDay] - - set changeover [mc GREGORIAN_CHANGE_DATE] - - if { $jday >= $changeover } { - - # Gregorian date - - dict set date gregorian 1 - - # Calculate number of days since 1 January, 1 CE - - set day [expr { $jday - 1721425 - 1 }] - - # Calculate number of 400 year cycles - - set year 1 - set n [expr { $day / 146097 }] - incr year [expr { 400 * $n }] - set day [expr { $day % 146097 }] - - # Calculate number of centuries in the current cycle - - set n [expr { $day / 36524 }] - set day [expr { $day % 36524 }] - if { $n > 3 } { - set n 3 ; # 31 December 2000, for instance - incr day 36524 ; # is last day of 400 year cycle - } - incr year [expr { 100 * $n }] - - } else { - - # Julian date - - dict set date gregorian 0 - - # Calculate days since 0 January, 1 CE Julian - - set day [expr { $jday - 1721423 - 1 }] - set year 1 - - } - - # Calculate number of 4-year cycles in current century (or in - # the Common Era, if the calendar is Julian) - - set n [expr { $day / 1461 }] - set day [expr { $day % 1461 }] - incr year [expr { 4 * $n }] - - # Calculate number of years in current 4-year cycle - - set n [expr { $day / 365 }] - set day [expr { $day % 365 }] - if { $n > 3 } { - set n 3 ;# 31 December in a leap year - incr day 365 - } - incr year $n - - # Calculate the era - - if { $year <= 0 } { - dict set date year [expr { 1 - $year }] - dict set date era BCE - } else { - dict set date year $year - dict set date era CE - } - - # Return day of the year - - dict set date dayOfYear [expr { $day + 1 }] - - return $date - -} - -#---------------------------------------------------------------------- -# -# GetMonthDay -- -# -# Given the ordinal number of the day within the year, determines -# month and day of month in the Gregorian calendar. -# -# Parameters: -# date - Dictionary containing the date fields. On input, populated -# with the 'era', 'gregorian', 'year' and 'dayOfYear' fields. -# -# Results: -# Returns the given dictionary with the 'month' and 'dayOfMonth' -# fields populated. -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetMonthDay { date } { - - variable DaysInRomanMonthInCommonYear - variable DaysInRomanMonthInLeapYear - - set day [dict get $date dayOfYear] - if { [IsGregorianLeapYear $date] } { - set hath $DaysInRomanMonthInLeapYear - } else { - set hath $DaysInRomanMonthInCommonYear - } - set month 1 - foreach n $hath { - if { $day <= $n } { - break - } - incr month - incr day [expr { -$n }] - } - dict set date month $month - dict set date dayOfMonth $day - - return $date - -} - -#---------------------------------------------------------------------- -# -# GetYearWeekDay -# -# Given a julian day number, fiscal year, fiscal week, -# and day of week in the ISO8601 calendar. -# -# Parameters: -# -# date - Dictionary where the 'julianDay' field is populated. -# daysInFirstWeek - (Optional) Parameter giving the minimum number -# of days in the first week of a year. Default is 4. -# -# Results: -# Returns the given dictionary with values filled in for the -# three given keys. -# -# Side effects: -# None. -# -# Bugs: -# Since ISO8601 week numbering is defined only for the Gregorian -# calendar, dates on the Julian calendar or before the Common -# Era may yield unexpected results. In particular, the year of -# the Julian-to-Gregorian change may be up to three weeks short. -# The era is not managed separately, so if the Common Era begins -# (or the period Before the Common Era ends) with a partial week, -# the few days at the beginning or end of the era may show up -# as incorrectly belonging to the year zero. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetYearWeekDay { date - { keys { iso8601Year iso8601Week dayOfWeek } } } { - - set daysInFirstWeek 4 - set firstDayOfWeek 1 - - # Determine the calendar year of $j - $daysInFirstWeek + 1. - # Compute an upper bound of the fiscal year as being one year - # past the day on which the current week begins. Find the start - # of that year. - - set j [dict get $date julianDay] - set jd [expr { $j - $daysInFirstWeek + 1 }] - set date1 [GetGregorianEraYearDay [dict create julianDay $jd]] - switch -exact -- [dict get $date1 era] { - BCE { - dict set date1 fiscalYear [expr { [dict get $date1 year] - 1}] - } - CE { - dict set date1 fiscalYear [expr { [dict get $date1 year] + 1}] - } - } - dict unset date1 year - dict unset date1 dayOfYear - dict set date1 weekOfFiscalYear 1 - dict set date1 dayOfWeek $firstDayOfWeek - - set date1 [GetJulianDayFromEraYearWeekDay \ - $date1[set date1 {}] \ - $daysInFirstWeek \ - $firstDayOfWeek \ - { fiscalYear weekOfFiscalYear dayOfWeek }] - set startOfFiscalYear [dict get $date1 julianDay] - - # If we guessed high, move one year earlier. - - if { $j < $startOfFiscalYear } { - switch -exact -- [dict get $date1 era] { - BCE { - dict incr date1 fiscalYear - } - CE { - dict incr date1 fiscalYear -1 - } - } - set date1 [GetJulianDayFromEraYearWeekDay \ - $date1[set date1 {}] \ - $daysInFirstWeek \ - $firstDayOfWeek \ - {fiscalYear weekOfFiscalYear dayOfWeek }] - set startOfFiscalYear [dict get $date1 julianDay] - } - - # Get the week number and the day within the week - - set fiscalYear [dict get $date1 fiscalYear] - set dayOfFiscalYear [expr { $j - $startOfFiscalYear }] - set weekOfFiscalYear [expr { ( $dayOfFiscalYear / 7 ) + 1 }] - set dayOfWeek [expr { ( $dayOfFiscalYear + 1 ) % 7 }] - if { $dayOfWeek < $firstDayOfWeek } { - incr dayOfWeek 7 - } - - # Store the fiscal year, week, and day in the given slots in the - # given dictionary. - - foreach key $keys \ - value [list $fiscalYear $weekOfFiscalYear $dayOfWeek] { - dict set date $key $value - } - - return $date -} - -#---------------------------------------------------------------------- -# -# GetJulianDayFromEraYearWeekDay -- -# -# Finds the Julian Day Number corresponding to the given era, -# year, week and day. -# -# Parameters: -# date -- A dictionary populated with fields whose keys are given -# by the 'keys' parameter below, plus the 'era' field. -# daysInFirstWeek -- (Optional) The minimum number of days in -# the first week of the year. Default is 4. -# firstDayOfWeek -- (Optional) The ordinal number of the first -# day of the week. Default is 1 (Monday); -# 0 (Sunday) is an alternative. -# keys -- (Optional) Keys in the dictionary for looking up the -# fiscal year, fiscal week, and day of week. The -# default is { iso8601Year iso8601Week dayOfWeek }. -# -# Results: -# Returns the dictionary augmented with a 'julianDay' field -# that gives the Julian Day Number corresponding to the given -# date. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetJulianDayFromEraYearWeekDay { - date - { daysInFirstWeek 4 } - { firstDayOfWeek 1 } - { keys { iso8601Year iso8601Week dayOfWeek } } -} { - - foreach var { fiscalYear fiscalWeek dayOfWeek } key $keys { - set $var [dict get $date $key] - } - - # Find a day of the first week of the year. - - set date2 [dict create \ - era [dict get $date era] \ - year $fiscalYear \ - month 1 \ - dayOfMonth $daysInFirstWeek] - set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}]] - - # Find the Julian Day Number of the start of that week. - - set jd [WeekdayOnOrBefore $firstDayOfWeek [dict get $date2 julianDay]] - - # Add the required number of weeks and days - - dict set date julianDay \ - [expr { $jd - + ( 7 * ( $fiscalWeek - 1 ) ) - + $dayOfWeek - $firstDayOfWeek }] - - return $date - -} - -#---------------------------------------------------------------------- -# -# GetJulianDayFromEraYearMonthDay -- -# -# Given a year, month and day on the Gregorian calendar, determines -# the Julian Day Number beginning at noon on that date. -# -# Parameters: -# date -- A dictionary in which the 'era', 'year', 'month', and -# 'dayOfMonth' slots are populated. The calendar in use -# is determined by the date itself relative to -# [mc GREGORIAN_CHANGE_DATE] in the current locale. -# -# Results: -# Returns the given dictionary augmented with a 'julianDay' key -# whose value is the desired Julian Day Number, and a 'gregorian' -# key that specifies whether the calendar is Gregorian (1) or -# Julian (0). -# -# Side effects: -# None. -# -#---------------------------------------------------------------------- - -proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { - - variable DaysInPriorMonthsInCommonYear - variable DaysInPriorMonthsInLeapYear - - # Get absolute year number from the civil year - - switch -exact -- [dict get $date era] { - BCE { - set year [expr { 1 - [dict get $date year] }] - } - CE { - set year [dict get $date year] - } + dict set date localeYear [expr { + [dict get $date year] - [lindex $etable $index 2] + }] } - - # If month is out of range, reduce modulo 12 and adjust year accordingly. - - set month [expr { [dict get $date month] - 1 }] - incr year [expr { $month / 12 }] - set month [expr { ( $month % 12 ) + 1 }] - dict set date era CE; dict set date year $year; dict set date month $month - - set ym1 [expr { $year - 1 }] - - # Try the Gregorian calendar first. - - dict set date gregorian 1 - set jd [expr { 1721425 - + [dict get $date dayOfMonth] - + ( [IsGregorianLeapYear $date] ? - [lindex $DaysInPriorMonthsInLeapYear \ - [expr { $month - 1}]] - : [lindex $DaysInPriorMonthsInCommonYear \ - [expr { $month - 1}]] ) - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) }] - - # If the date is before the Gregorian change, use the Julian calendar. - - if { $jd < [mc GREGORIAN_CHANGE_DATE] } { - - dict set date gregorian 0 - set jd [expr { 1721423 - + [dict get $date dayOfMonth] - + ( ( $year % 4 == 0 ) ? - [lindex $DaysInPriorMonthsInLeapYear \ - [expr { $month - 1}]] - : [lindex $DaysInPriorMonthsInCommonYear \ - [expr { $month - 1}]] ) - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) }] - } - - dict set date julianDay $jd return $date - } #---------------------------------------------------------------------- @@ -4511,22 +4005,24 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { # Parameters: # date -- A dictionary in which the 'era', 'year', and # 'dayOfYear' slots are populated. The calendar in use -# is determined by the date itself relative to -# [mc GREGORIAN_CHANGE_DATE] in the current locale. +# 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). +# 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 } { - +proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # Get absolute year number from the civil year switch -exact -- [dict get $date era] { @@ -4542,21 +4038,25 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { # 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 ) }] - + 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 < [mc GREGORIAN_CHANGE_DATE] } { + if { $jd < $changeover } { dict set date gregorian 0 - set jd [expr { 1721423 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) }] + set jd [expr { + 1721423 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + }] } dict set date julianDay $jd @@ -4567,12 +4067,13 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { # # GetJulianDayFromEraYearMonthWeekDay -- # -# Determines the Julian Day number corresponding to the nth -# given day-of-the-week in a given month. +# 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. @@ -4580,13 +4081,15 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { # Side effects: # None. # +# Bugs: +# This code needs to be moved to the C layer. +# #---------------------------------------------------------------------- -proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay { date } { - - # 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) +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] @@ -4596,12 +4099,12 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay { date } { dict incr date2 month dict set date2 dayOfMonth 7 } - set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}]] + 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 - } #---------------------------------------------------------------------- @@ -4624,9 +4127,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay { date } { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { - switch -exact -- [dict get $date era] { - BCE { + BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4644,15 +4146,14 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { } else { return 1 } - } #---------------------------------------------------------------------- # # WeekdayOnOrBefore -- # -# Determine the nearest day of week (given by the 'weekday' -# parameter, Sunday==0) on or before a given Julian Day. +# 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 @@ -4667,18 +4168,16 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { #---------------------------------------------------------------------- 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. +# Service procedure that does binary search in several places inside the +# 'clock' command. # # Parameters: # list - List of lists, sorted in ascending order by the @@ -4686,8 +4185,8 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { # key - Value to search for # # Results: -# Returns the index of the greatest element in $list that is less -# than or equal to $key. +# Returns the index of the greatest element in $list that is less than +# or equal to $key. # # Side effects: # None. @@ -4695,7 +4194,9 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { - + if {[llength $list] == 0} { + return -1 + } if { $key < [lindex $list 0 0] } { return -1 } @@ -4704,13 +4205,12 @@ proc ::tcl::clock::BSearch { list key } { 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. + # 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] } { @@ -4754,55 +4254,49 @@ proc ::tcl::clock::BSearch { list key } { # 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. +# 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\ - \"[lindex [info level 0] 0] clockval\ - ?number units?...\ + \"$cmdName clockval ?number units?...\ ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" } - if { [catch { expr wide($clockval) } result] } { + if { [catch { expr {wide($clockval)} } result] } { return -code error $result } set offsets {} set gmt 0 - set locale C + set locale c set timezone [GetSystemTimeZone] foreach { a b } $args { - if { [string is integer -strict $a] } { - lappend offsets $a $b - } else { - switch -exact -- $a { - - -gmt { + -g - -gm - -gmt { set gmt $b } - -locale { - set locale $b + -l - -lo - -loc - -loca - -local - -locale { + set locale [string tolower $b] } + -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { set timezone $b } default { - return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ + throw [list CLOCK badSwitch $a] \ + "bad switch \"$a\",\ must be -gmt, -locale or -timezone" } } @@ -4817,41 +4311,42 @@ proc ::tcl::clock::add { clockval args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($clockval) } } result] } { - return -code error \ - "expected integer but got \"$clockval\"" + return -code error "expected integer but got \"$clockval\"" } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } + if { ![string is boolean -strict $gmt] } { + return -code error "expected boolean value but got \"$gmt\"" + } elseif { $gmt } { + set timezone :GMT } EnterLocale $locale oldLocale - set status [catch { + set changeover [mc GREGORIAN_CHANGE_DATE] - foreach { quantity unit } $offsets { + 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] + set clockval [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { - set clockval [AddMonths $quantity $clockval $timezone] + set clockval [AddMonths $quantity $clockval $timezone \ + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone] + $clockval $timezone $changeover] } days - day { - set clockval [AddDays $quantity $clockval $timezone] + set clockval [AddDays $quantity $clockval $timezone \ + $changeover] } hours - hour { @@ -4865,31 +4360,24 @@ proc ::tcl::clock::add { clockval args } { } default { - error "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" \ - [list CLOCK badUnit $unit] + throw [list CLOCK badUnit $unit] \ + "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" } } } - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale - } + return $clockval + } trap CLOCK {result opts} { + # Conceal the innards of [clock] when it's an expected error + dict unset opts -errorinfo + return -options $opts $result + } finally { + # Restore the locale - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { - dict unset opts -errorinfo + if { [info exists oldLocale] } { + mclocale $oldLocale } - return -options $opts $result - } else { - return $clockval } - } #---------------------------------------------------------------------- @@ -4913,21 +4401,17 @@ proc ::tcl::clock::add { clockval args } { # #---------------------------------------------------------------------- -proc ::tcl::clock::AddMonths { months clockval timezone } { - +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 [GetMonthDay \ - [GetGregorianEraYearDay \ - [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $clockval] \ - $timezone]]]] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + 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 @@ -4954,48 +4438,50 @@ proc ::tcl::clock::AddMonths { months clockval timezone } { # Reconvert to a number of seconds set date [GetJulianDayFromEraYearMonthDay \ - $date[set date {}]] - dict set date localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] }] - set date [ConvertLocalToUTC $date[set date {}]] + $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. +# 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. +# Returns the new clock value as a number of seconds since the epoch. # # Side effects: # None. # #---------------------------------------------------------------------- -proc ::tcl::clock::AddDays { days clockval timezone } { +proc ::tcl::clock::AddDays { days clockval timezone changeover } { + variable TZData # Convert the time to Julian Day - set date [GetJulianDay \ - [ConvertUTCToLocal \ - [dict create seconds $clockval] \ - $timezone]] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + 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 @@ -5004,22 +4490,23 @@ proc ::tcl::clock::AddDays { days clockval timezone } { # 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 {}]] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ + $changeover] return [dict get $date seconds] - } #---------------------------------------------------------------------- # # mc -- # -# Wrapper around ::msgcat::mc that caches the result according -# to the locale. +# Wrapper around ::msgcat::mc that caches the result according to the +# locale. # # Parameters: # Accepts the name of the message to retrieve. @@ -5040,11 +4527,10 @@ proc ::tcl::clock::mc { name } { set Locale [mclocale] if { [dict exists $McLoaded $Locale $name] } { return [dict get $McLoaded $Locale $name] - } else { - set val [::msgcat::mc $name] - dict set McLoaded $Locale $name $val - return $val } + set val [::msgcat::mc $name] + dict set McLoaded $Locale $name $val + return $val } #---------------------------------------------------------------------- @@ -5065,7 +4551,7 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { - + variable FormatProc variable LocaleNumeralCache variable McLoaded variable CachedSystemTimeZone @@ -5074,11 +4560,14 @@ proc ::tcl::clock::ClearCaches {} { foreach p [info procs [namespace current]::scanproc'*] { rename $p {} } + foreach p [info procs [namespace current]::formatproc'*] { + rename $p {} + } + catch {unset FormatProc} set LocaleNumeralCache {} set McLoaded {} catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData - } |