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