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