diff options
Diffstat (limited to 'library/clock.tcl')
| -rwxr-xr-x[-rw-r--r--] | library/clock.tcl | 1880 |
1 files changed, 927 insertions, 953 deletions
diff --git a/library/clock.tcl b/library/clock.tcl index 1d75b7d..535a67d 100644..100755 --- 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.29 2005/12/27 17:39:02 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 + package require msgcat 1.6 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 { @@ -81,6 +60,8 @@ namespace eval ::tcl::clock { namespace import ::msgcat::mcload namespace import ::msgcat::mclocale + namespace import ::msgcat::mc + namespace import ::msgcat::mcpackagelocale } @@ -96,11 +77,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. # #---------------------------------------------------------------------- @@ -127,6 +108,11 @@ proc ::tcl::clock::Initialize {} { } InitTZData + mcpackagelocale set {} + ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] + ::msgcat::mcpackageconfig set unknowncmd "" + ::msgcat::mcpackageconfig set changecmd ChangeCurrentLocale + # Define the message catalog for the root locale. ::msgcat::mcmset {} { @@ -192,8 +178,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 @@ -209,13 +195,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 @@ -237,23 +223,23 @@ 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 { @@ -261,7 +247,6 @@ proc ::tcl::clock::Initialize {} { /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 @@ -271,7 +256,6 @@ proc ::tcl::clock::Initialize {} { # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] - variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. @@ -303,10 +287,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: @@ -317,77 +301,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 { @@ -395,21 +394,34 @@ 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 {}] \ $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 {}] \ $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] @@ -418,19 +430,19 @@ proc ::tcl::clock::Initialize {} { $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 {}] \ $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 {}] \ $changeover] } - { iso8601YearOfCentury iso8601Week dayOfWeek } 3 { + { iso8601YearOfCentury iso8601Week dayOfWeek } 4 { set date [InterpretTwoDigitYear \ $date[set date {}] $baseTime \ iso8601YearOfCentury iso8601Year] @@ -439,47 +451,47 @@ proc ::tcl::clock::Initialize {} { $changeover] } - { month dayOfMonth } 4 { + { month dayOfMonth } 5 { set date [AssignBaseYear $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 $changeover] set date [GetJulianDayFromEraYearDay $date[set date {}] \ $changeover] } - { iso8601Week dayOfWeek } 4 { + { iso8601Week dayOfWeek } 5 { set date [AssignBaseIso8601Year $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 $changeover] set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ $changeover] } - { dayOfWeek } 6 { + { dayOfWeek } 7 { set date [AssignBaseWeek $date[set date {}] \ $baseTime $timeZone $changeover] set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ $changeover] } - {} 7 { + {} 8 { set date [AssignBaseJulianDay $date[set date {}] \ $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 { @@ -617,11 +629,6 @@ proc ::tcl::clock::Initialize {} { # in the given locales and dictionaries # mapping the numerals to their numeric # values. - variable McLoaded {}; # Dictionary whose keys are locales - # in which [mcload] has been executed - # and whose values are second-level - # dictionaries indexed by message - # name and giving message text. # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, # it contains the value of the # system time zone, as determined from @@ -635,6 +642,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 @@ -642,86 +652,24 @@ 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 {} - - # Pick up command line options. - - foreach { flag value } [lreplace $args 0 0] { - set saw($flag) {} - switch -exact -- $flag { - -format { - set format $value - } - -gmt { - set gmt $value - } - -locale { - set locale $value - } - -timezone { - set timezone $value - } - default { - return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ - must be -format, -gmt, -locale or -timezone" - } - } - } - - # Check options for validity - - if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } { - return -code error \ - -errorcode [list CLOCK gmtWithTimezone] \ - "cannot use -gmt and -timezone in same call" - } - if { ![string is wide -strict $clockval] } { - return -code error \ - "expected integer but got \"$clockval\"" - } - if { ![string is boolean -strict $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } - } # Get the data for time changes in the given zone - + if {$timezone eq ""} { set timezone [GetSystemTimeZone] } @@ -731,11 +679,21 @@ proc ::tcl::clock::format { args } { return -options $opts $retval } } - - # Format the result - - set formatter [ParseClockFormatFormat $format $locale] - return [$formatter $clockval $timezone] + + # Build a procedure to format the result. Cache the built procedure's name + # in the 'FormatProc' array to avoid losing its internal representation, + # which contains the name resolution. + + set procName formatproc'$format'$locale + set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] + if {[info exists FormatProc($procName)]} { + set procName $FormatProc($procName) + } else { + set FormatProc($procName) \ + [ParseClockFormatFormat $procName $format $locale] + } + + return [$procName $clockval $timezone] } @@ -754,47 +712,27 @@ proc ::tcl::clock::format { args } { # #---------------------------------------------------------------------- -proc ::tcl::clock::ParseClockFormatFormat {format locale} { +proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { - set procName [namespace current]::formatproc'$format'$locale - if {[info procs $procName] != {}} { + 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 { - - ParseClockFormatFormat2 $format $locale $procName - - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale - } + EnterLocale $locale - # Return either the error or the proc name + # Change locale if a fresh locale has been given on the command line. - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { - return -code error $result - } else { - return -options $opts $result - } - } else { - return $result + try { + return [ParseClockFormatFormat2 $format $locale $procName] + } trap CLOCK {result opts} { + dict unset opts -errorinfo + return -options $opts $result } - } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { - set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -809,7 +747,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set formatString {} set substituents {} set state {} - + set format [LocalizeFormat $locale $format] foreach char [split $format {}] { @@ -836,7 +774,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [lindex @DAYS_OF_WEEK_ABBREV@ \ [expr {[dict get $date dayOfWeek] \ % 7}]]}] - } + } A { # Day of week, spelt out. append formatString %s append substituents \ @@ -889,7 +827,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { set date [GetLocaleEra \ $date[set date {}] \ - @LOCALE_ERAS@]}] + @LOCALE_ERAS@]}] \n set didLocaleEra 1 } if {!$didLocaleNumerals} { @@ -937,7 +875,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { k { # Hour (0-23), no leading zero append formatString %2d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 3600 % 24 }]} } @@ -958,7 +896,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { M { # Minute of the hour, leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 60 % 60 }]} } @@ -999,7 +937,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [expr {(([dict get $date localSeconds] % 86400) < 43200) ? $am : $pm}]} - + } Q { # Hi, Jeff! append formatString %s @@ -1009,11 +947,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents { [dict get $date seconds]} } - S { # Second of the minute, with + S { # Second of the minute, with # leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] % 60 }]} } t { # A literal tab character @@ -1034,7 +972,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } incr dow set UweekNumber \ - [expr { ( [dict get $date dayOfYear] + [expr { ( [dict get $date dayOfYear] - $dow + 7 ) / 7 }] } @@ -1057,11 +995,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set WweekNumber \ [expr { ( [dict get $date dayOfYear] - [dict get $date dayOfWeek] - + 7 ) + + 7 ) / 7 }] } append formatString %02d - append substituents { $Wweeknumber} + append substituents { $WweekNumber} } y { # The two-digit year of the century append formatString %02d @@ -1093,6 +1031,15 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { 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]} @@ -1117,7 +1064,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { percentO { # Character following %O set state {} switch -exact -- $char { - d - e { # Day of the month in alternative + d - e { # Day of the month in alternative # numerals append formatString %s append substituents \ @@ -1129,7 +1076,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 3600 % 24 }]]} } @@ -1155,7 +1102,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 60 % 60 }]]} } @@ -1164,7 +1111,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] % 60 }]]} } u { # Day of the week (Monday=1,Sunday=7) @@ -1195,9 +1142,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } } - + # Clean up any improperly terminated groups - + switch -exact -- $state { percent { append formatString %% @@ -1224,11 +1171,10 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale 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. # #---------------------------------------------------------------------- @@ -1239,10 +1185,11 @@ proc ::tcl::clock::scan { args } { # 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?\"" @@ -1254,7 +1201,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. @@ -1262,25 +1209,25 @@ 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 { return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ + -errorcode [list CLOCK badOption $flag] \ + "bad option \"$flag\",\ must be -base, -format, -gmt, -locale or -timezone" } } @@ -1294,21 +1241,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] \ @@ -1320,33 +1263,18 @@ proc ::tcl::clock::scan { args } { # Change locale if a fresh locale has been given on the command line. - EnterLocale $locale oldLocale - - set status [catch { + EnterLocale $locale + try { # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - $scanner $string $base $timezone - - } 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 - } - } else { - return $result + return [$scanner $string $base $timezone] + } trap CLOCK {result opts} { + # Conceal location of generation of expected errors + dict unset opts -errorinfo + return -options $opts $result } - } #---------------------------------------------------------------------- @@ -1362,8 +1290,8 @@ 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 # #---------------------------------------------------------------------- @@ -1372,45 +1300,44 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { variable TZData # Get the data for time changes in the given zone - - if {[catch {SetupTimeZone $timezone} retval opts]} { + + try { + SetupTimeZone $timezone + } on error {retval opts} { dict unset opts -errorinfo return -options $opts $retval } - # Extract year, month and day from the base time for the - # parser to use as defaults + # Extract year, month and day from the base time for the parser to use as + # defaults - set date [GetDateFields \ - $base \ - $TZData($timezone) \ - 2361222] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + set date [GetDateFields $base $TZData($timezone) 2361222] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] - # Parse the date. The parser will return a list comprising - # date, time, time zone, relative month/day/seconds, relative - # weekday, ordinal month. + # Parse the date. The parser will return a list comprising date, time, + # time zone, relative month/day/seconds, relative weekday, ordinal month. - 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\"" + 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" } - foreach { parseDate parseTime parseZone parseRel - parseWeekday parseOrdinalMonth } $result break - - # 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 @@ -1427,14 +1354,14 @@ 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 @@ -1446,18 +1373,19 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { 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 {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] @@ -1465,22 +1393,21 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # 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 + 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 @@ -1488,10 +1415,11 @@ 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 {}] $TZData($timezone) \ 2361222] @@ -1502,8 +1430,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # 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 } { @@ -1519,7 +1446,6 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] - } return $seconds @@ -1537,33 +1463,31 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # 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 locale} { + # Check whether the format has been parsed previously, and return the + # existing recognizer if it has. - # Check whether the format has been parsed previously, and return - # the existing recognizer if it has. - - set procName [namespace current]::scanproc'$formatString'$locale - if { [info procs $procName] != {} } { + set procName scanproc'$formatString'$locale + set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] + if { [namespace which $procName] != {} } { return $procName } @@ -1603,8 +1527,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re \\ - } + append re "\\" + } append re $c } } @@ -1623,16 +1547,16 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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 @@ -1642,15 +1566,16 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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 @@ -1720,7 +1645,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "::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 \[" \ @@ -1741,8 +1666,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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 \[" \ @@ -1762,10 +1688,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { \] \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 } \[ \ @@ -1798,14 +1723,13 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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 \[" \ @@ -1868,18 +1792,33 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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 $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex - incr fieldCount + incr captureCount } default { append re %E @@ -1894,8 +1833,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { %O { switch -exact -- $c { d - e { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet dayOfMonth [incr fieldCount] append postcode "dict set date dayOfMonth \[" \ @@ -1904,8 +1842,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } H - k { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet hour [incr fieldCount] append postcode "dict set date hour \[" \ @@ -1914,8 +1851,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } I - l { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet hourAMPM [incr fieldCount] append postcode "dict set date hourAMPM \[" \ @@ -1924,8 +1860,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } m { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1934,8 +1869,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } M { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet minute [incr fieldCount] append postcode "dict set date minute \[" \ @@ -1944,8 +1878,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } S { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet second [incr fieldCount] append postcode "dict set date second \[" \ @@ -1954,8 +1887,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "\]\n" } u - w { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet dayOfWeek [incr fieldCount] append postcode "set dow \[dict get " [list $lookup] \ @@ -1969,11 +1901,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "day of week is greater than 7" } dict set date dayOfWeek $dow - } + } } y { - foreach {regex lookup} \ - [LocaleNumeralMatcher $locale] break + lassign [LocaleNumeralMatcher $locale] regex lookup append re $regex dict set fieldSet yearOfCentury [incr fieldCount] append postcode {dict set date yearOfCentury } \[ \ @@ -2016,6 +1947,21 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n + # Set up the time zone before doing anything with a default base date + # that might need a timezone to interpret it. + + if { ![dict exists $fieldSet seconds] + && ![dict exists $fieldSet starDate] } { + if { [dict exists $fieldSet tzName] } { + append procBody { + set timeZone [dict get $date tzName] + } + } + append procBody { + ::tcl::clock::SetupTimeZone $timeZone + } + } + # Add code that gets Julian Day Number from the fields. append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions] @@ -2024,34 +1970,29 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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] } { - if { [dict exists $fieldSet tzName] } { - append procBody { - set timeZone [dict get $date tzName] - } - } + # Finally, convert the date to local time + append procBody { - ::tcl::clock::SetupTimeZone $timeZone set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ - $TZData($timeZone) \ - $changeover] + $TZData($timeZone) $changeover] } } @@ -2065,20 +2006,19 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { 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: # 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. @@ -2086,7 +2026,6 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { #---------------------------------------------------------------------- proc ::tcl::clock::LocaleNumeralMatcher {l} { - variable LocaleNumeralCache if { ![dict exists $LocaleNumeralCache $l] } { @@ -2105,16 +2044,16 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { } 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. @@ -2122,10 +2061,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { # 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. @@ -2133,11 +2072,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { #---------------------------------------------------------------------- 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 {} {}] @@ -2145,8 +2083,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 {}] { @@ -2164,8 +2101,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 { @@ -2188,8 +2125,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 @@ -2201,15 +2138,15 @@ 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 } { @@ -2220,13 +2157,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 "(?:" } @@ -2248,7 +2187,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2259,8 +2198,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, @@ -2271,8 +2210,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. @@ -2288,16 +2227,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 @@ -2320,9 +2258,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 } { @@ -2340,11 +2280,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction - } return $currCodeBurst - } #---------------------------------------------------------------------- @@ -2355,78 +2293,52 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { # # Parameters: # locale -- Desired locale -# oldLocaleVar -- Name of a variable in caller's scope that -# tracks the previous locale name. # # Results: # Returns the locale that was previously current. # # Side effects: -# Does [mclocale]. If necessary, uses [mcload] to load the -# designated locale's files, and tracks that it has done so -# in the 'McLoaded' variable. +# Does [mclocale]. If necessary, loades the designated locale's files. # #---------------------------------------------------------------------- -proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { - - upvar 1 $oldLocaleVar oldLocale - - variable MsgDir - variable McLoaded - - set oldLocale [mclocale] +proc ::tcl::clock::EnterLocale { locale } { if { $locale eq {system} } { - if { $::tcl_platform(platform) ne {windows} } { - - # On a non-windows platform, the 'system' locale is - # the same as the 'current' locale + # 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 {} - } + mcpackagelocale set [mclocale] - # 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] } { + set locale [mclocale]_windows + if { ! [mcpackagelocale present $locale] } { LoadWindowsDateTimeFormats $locale - dict set mcloaded $locale {} } } } if { $locale eq {current}} { - set locale $oldLocale - unset oldLocale - } elseif { $locale eq $oldLocale } { - unset oldLocale - } else { - mclocale $locale - } - if { ![dict exists $McLoaded $locale] } { - mcload $MsgDir - dict set McLoaded $locale {} + set locale [mclocale] } - -} + # Eventually load the locale + mcpackagelocale set $locale +} #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows -# and convert them so that they're usable by Tcl. +# 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 @@ -2438,14 +2350,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 @@ -2562,8 +2472,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. @@ -2572,33 +2482,35 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { proc ::tcl::clock::LocalizeFormat { locale format } { - variable McLoaded - - if { [dict exists $McLoaded $locale FORMAT $format] } { - return [dict get $McLoaded $locale FORMAT $format] - } - set inFormat $format - - # Handle locale-dependent format groups by mapping them out of - # the 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 + # message catalog key to cache this format + set key FORMAT_$format + + if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { + return [mc $key] + } + # Handle locale-dependent format groups by mapping them out of the format + # string. Note that the order of the [string map] operations is + # significant because later formats can refer to later ones; for example + # %c can refer to %X, which in turn can refer to %T. + + set list { + %% %% + %D %m/%d/%Y + %+ {%a %b %e %H:%M:%S %Z %Y} + } + lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]] + lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]] + lappend list %R [string map $list [mc TIME_FORMAT_24]] + lappend list %r [string map $list [mc TIME_FORMAT_12]] + lappend list %X [string map $list [mc TIME_FORMAT]] + lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]] + lappend list %x [string map $list [mc DATE_FORMAT]] + lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]] + lappend list %c [string map $list [mc DATE_TIME_FORMAT]] + lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] + set format [string map $list $format] + + ::msgcat::mcset $locale $key $format return $format } @@ -2620,7 +2532,6 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { - if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2635,7 +2546,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval - } #---------------------------------------------------------------------- @@ -2660,7 +2570,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { - variable Roddenberry # Get day of year, zero based @@ -2711,7 +2620,6 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { - variable Roddenberry # Build a tentative date from year and fraction. @@ -2727,8 +2635,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { 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 \ @@ -2741,10 +2649,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 + }] } #---------------------------------------------------------------------- @@ -2757,8 +2666,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. # #---------------------------------------------------------------------- @@ -2779,8 +2688,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. @@ -2797,18 +2706,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 }] @@ -2816,7 +2724,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date - } #---------------------------------------------------------------------- @@ -2842,7 +2749,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { - variable TZData # Find the Julian Day Number corresponding to the base time, and @@ -2856,7 +2762,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { dict set date year [dict get $date2 year] return $date - } #---------------------------------------------------------------------- @@ -2883,7 +2788,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -2901,7 +2805,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { # # 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: @@ -2920,7 +2824,6 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { - variable TZData # Find the year and month corresponding to the base time @@ -2930,7 +2833,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] return $date - } #---------------------------------------------------------------------- @@ -2956,7 +2858,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -2993,7 +2894,6 @@ proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -3023,7 +2923,6 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { - set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 @@ -3033,7 +2932,6 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] - } #---------------------------------------------------------------------- @@ -3056,11 +2954,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] + }] } #---------------------------------------------------------------------- @@ -3083,7 +2981,6 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { - variable CachedSystemTimeZone variable TimeZoneBad @@ -3091,18 +2988,23 @@ proc ::tcl::clock::GetSystemTimeZone {} { set timezone $result } elseif {[set result [getenv TZ]] ne {}} { set timezone $result - } elseif { [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 {![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}] } @@ -3111,76 +3013,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] } - + 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 @@ -3201,24 +3096,20 @@ 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] } { @@ -3231,12 +3122,11 @@ 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 { ZoneinfoFile $timezone } - opts] } { + && [catch { LoadZoneinfoFile $timezone } - opts] } { dict unset opts -errorinfo return -options $opts "time zone $timezone not found" } @@ -3257,25 +3147,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 @@ -3306,16 +3193,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] @@ -3326,13 +3211,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 } { @@ -3364,11 +3248,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] \ @@ -3377,11 +3261,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] \ @@ -3389,10 +3273,9 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { : [::format %02d $stdSecond] } dict set WinZoneInfo $data $tzname - } + } return [dict get $WinZoneInfo $data] - } #---------------------------------------------------------------------- @@ -3421,18 +3304,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" @@ -3450,8 +3333,8 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { # 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 @@ -3459,12 +3342,11 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { - variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, - # this code is security sensitive. Make sure that the path name - # cannot escape the given directory. + # 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 \ @@ -3483,7 +3365,7 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { #---------------------------------------------------------------------- # -# LoadZoneinfoFile -- +# ReadZoneinfoFile -- # # Loads a binary time zone information file in Olson format. # @@ -3493,19 +3375,18 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # 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. +# 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 ReadZoneinfoFile {fileName fname} { +proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData - if { ![info exists fname] } { + if { ![file exists $fname] } { return -code error "$fileName not found" } @@ -3520,27 +3401,54 @@ proc ReadZoneinfoFile {fileName fname} { 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 { @@ -3548,9 +3456,9 @@ proc ReadZoneinfoFile {fileName fname} { } 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 @@ -3558,10 +3466,10 @@ proc ReadZoneinfoFile {fileName fname} { 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} @@ -3569,11 +3477,12 @@ proc ReadZoneinfoFile {fileName fname} { 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. @@ -3584,12 +3493,33 @@ proc ReadZoneinfoFile {fileName fname} { 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 } @@ -3603,8 +3533,8 @@ proc ReadZoneinfoFile {fileName fname} { # 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. @@ -3615,7 +3545,7 @@ proc ReadZoneinfoFile {fileName fname} { # 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 @@ -3660,14 +3590,13 @@ proc ReadZoneinfoFile {fileName fname} { # 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 @@ -3678,8 +3607,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} ) )? @@ -3695,8 +3624,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}) )? @@ -3709,8 +3638,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:]] + ) ) (?: @@ -3731,8 +3660,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:]] + ) ) (?: @@ -3759,27 +3688,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' @@ -3793,7 +3716,6 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { - variable MINWIDE variable TZData @@ -3808,20 +3730,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 @@ -3844,46 +3766,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] @@ -3900,15 +3853,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. @@ -3918,8 +3870,8 @@ 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. # #---------------------------------------------------------------------- @@ -3936,30 +3888,30 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # 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 {}] 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 + 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 {} } { @@ -3981,7 +3933,6 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] - } #---------------------------------------------------------------------- @@ -3999,26 +3950,26 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # 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 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] }] + dict set date localeYear [expr { + [dict get $date year] - [lindex $etable $index 2] + }] } return $date - } #---------------------------------------------------------------------- @@ -4036,10 +3987,9 @@ proc ::tcl::clock::GetLocaleEra { date etable } { # 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. @@ -4050,7 +4000,6 @@ proc ::tcl::clock::GetLocaleEra { date etable } { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { - # Get absolute year number from the civil year switch -exact -- [dict get $date era] { @@ -4066,21 +4015,25 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # 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 < $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 @@ -4091,8 +4044,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # # 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' @@ -4111,10 +4064,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { #---------------------------------------------------------------------- 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) + # 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] @@ -4130,7 +4082,6 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date - } #---------------------------------------------------------------------- @@ -4153,9 +4104,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { - switch -exact -- [dict get $date era] { - BCE { + BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4173,15 +4123,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 @@ -4196,18 +4145,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 @@ -4215,8 +4162,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. @@ -4224,7 +4171,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 } @@ -4233,13 +4182,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] } { @@ -4283,55 +4231,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] } { - return -code error $result + if { [catch { expr {wide($clockval)} } result] } { + return -code error "expected integer but got \"$clockval\"" } 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 badOption $a] \ + "bad option \"$a\",\ must be -gmt, -locale or -timezone" } } @@ -4345,21 +4287,14 @@ proc ::tcl::clock::add { clockval args } { -errorcode [list CLOCK gmtWithTimezone] \ "cannot use -gmt and -timezone in same call" } - if { [catch { expr { wide($clockval) } } result] } { - return -code error \ - "expected integer but got \"$clockval\"" - } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } + if { ![string is boolean -strict $gmt] } { + return -code error "expected boolean value but got \"$gmt\"" + } elseif { $gmt } { + set timezone :GMT } - EnterLocale $locale oldLocale - + EnterLocale $locale + set changeover [mc GREGORIAN_CHANGE_DATE] if {[catch {SetupTimeZone $timezone} retval opts]} { @@ -4367,29 +4302,30 @@ proc ::tcl::clock::add { clockval args } { return -options $opts $retval } - set status [catch { - + try { foreach { quantity unit } $offsets { - switch -exact -- $unit { - years - year { - set clockval \ - [AddMonths [expr { 12 * $quantity }] \ - $clockval $timezone $changeover] + set clockval [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { set clockval [AddMonths $quantity $clockval $timezone \ - $changeover] + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone $changeover] + $clockval $timezone $changeover] } days - day { set clockval [AddDays $quantity $clockval $timezone \ - $changeover] + $changeover] + } + + weekdays - weekday { + set clockval [AddWeekDays $quantity $clockval $timezone \ + $changeover] } hours - hour { @@ -4403,31 +4339,18 @@ 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 - } - - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { - dict unset opts -errorinfo - } - return -options $opts $result - } else { 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 } - } #---------------------------------------------------------------------- @@ -4452,7 +4375,6 @@ proc ::tcl::clock::add { clockval args } { #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { - variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData @@ -4460,8 +4382,9 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # Convert the time to year, month, day, and fraction of day. set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] dict set date tzName $timezone # Add the requisite number of months @@ -4490,10 +4413,11 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { set date [GetJulianDayFromEraYearMonthDay \ $date[set date {}]\ $changeover] - 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] + }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] @@ -4503,10 +4427,60 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { #---------------------------------------------------------------------- # +# AddWeekDays -- +# +# Add a given number of week days (skipping Saturdays and Sundays) +# to a given clock value in a given time zone. +# +# Parameters: +# days - Number of days to add (may be negative) +# clockval - Seconds since the epoch before the operation +# timezone - Time zone in which the operation is to be performed +# changeover - Julian Day on which the Gregorian calendar was adopted +# in the target locale. +# +# Results: +# Returns the new clock value as a number of seconds since the epoch. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AddWeekDays { days clockval timezone changeover } { + + if {$days == 0} { + return $clockval + } + + set day [format $clockval -format %u] + + set weeks [expr {$days / 5}] + set rdays [expr {$days % 5}] + set toAdd [expr {7 * $weeks + $rdays}] + set resDay [expr {$day + ($toAdd % 7)}] + + # Adjust if we start from a weekend + if {$day > 5} { + set adj [expr {5 - $day}] + incr toAdd $adj + incr resDay $adj + } + + # Adjust if we end up on a weekend + if {$resDay > 5} { + incr toAdd 2 + } + + AddDays $toAdd $clockval $timezone $changeover +} + +#---------------------------------------------------------------------- +# # 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) @@ -4516,8 +4490,7 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # 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. @@ -4525,14 +4498,14 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AddDays { days clockval timezone changeover } { - variable TZData # Convert the time to Julian Day set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] dict set date tzName $timezone # Add the requisite number of days @@ -4541,10 +4514,11 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { # Reconvert to a number of seconds - 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] + }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] @@ -4554,35 +4528,37 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { #---------------------------------------------------------------------- # -# mc -- +# ChangeCurrentLocale -- # -# Wrapper around ::msgcat::mc that caches the result according -# to the locale. +# The global locale was changed within msgcat. +# Clears the buffered parse functions of the current locale. # # Parameters: -# Accepts the name of the message to retrieve. +# loclist (ignored) # # Results: -# Returns the message text. +# None. # # Side effects: -# Caches the message text. -# -# Notes: -# Only the single-argument version of [mc] is supported. +# Buffered parse functions are cleared. # #---------------------------------------------------------------------- -proc ::tcl::clock::mc { name } { - variable McLoaded - 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 +proc ::tcl::clock::ChangeCurrentLocale {args} { + variable FormatProc + variable LocaleNumeralCache + variable CachedSystemTimeZone + variable TimeZoneBad + + foreach p [info procs [namespace current]::scanproc'*'current] { + rename $p {} } + foreach p [info procs [namespace current]::formatproc'*'current] { + rename $p {} + } + + catch {array unset FormatProc *'current} + set LocaleNumeralCache {} } #---------------------------------------------------------------------- @@ -4603,9 +4579,8 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { - + variable FormatProc variable LocaleNumeralCache - variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad @@ -4616,10 +4591,9 @@ proc ::tcl::clock::ClearCaches {} { rename $p {} } + catch {unset FormatProc} set LocaleNumeralCache {} - set McLoaded {} catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData - } |