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