diff options
| -rw-r--r-- | ChangeLog | 3 | ||||
| -rw-r--r-- | library/clock.tcl | 1203 | ||||
| -rw-r--r-- | library/msgcat/msgcat.tcl | 88 |
3 files changed, 688 insertions, 606 deletions
@@ -1,7 +1,8 @@ 2012-09-19 Harald Oehlmann <oehhar@users.sf.net> * library/msgcat/msgcat.tcl: dynamic locale change with mc file - load on locale change. + * library/clock.tcl: load on locale change. + clock uses new msgcat features. 2012-09-19 Jan Nijtmans <nijtmans@users.sf.net> diff --git a/library/clock.tcl b/library/clock.tcl index 0696c47..38394d2 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -2,9 +2,9 @@ # # clock.tcl -- # -# This file implements the portions of the [clock] ensemble that are -# coded in Tcl. Refer to the users' manual to see the description of -# the [clock] command and its subcommands. +# This file implements the portions of the [clock] ensemble that +# are coded in Tcl. Refer to the users' manual to see the description +# of the [clock] command and its subcommands. # # #---------------------------------------------------------------------- @@ -15,11 +15,11 @@ # #---------------------------------------------------------------------- -# We must have message catalogs that support the root locale, and we need -# access to the Registry on Windows systems. +# We must have message catalogs that support the root locale, and +# we need access to the Registry on Windows systems. uplevel \#0 { - package require msgcat 1.4 + package require msgcat 1.6 if { $::tcl_platform(platform) eq {windows} } { if { [catch { package require registry 1.1 }] } { namespace eval ::tcl::clock [list variable NoRegistry {}] @@ -27,8 +27,9 @@ uplevel \#0 { } } -# Put the library directory into the namespace for the ensemble so that the -# library code can find message catalogs and time zone definition files. +# Put the library directory into the namespace for the ensemble +# so that the library code can find message catalogs and time zone +# definition files. namespace eval ::tcl::clock \ [list variable LibDir [file dirname [info script]]] @@ -39,10 +40,10 @@ namespace eval ::tcl::clock \ # # Manipulate times. # -# The 'clock' command manipulates time. Refer to the user documentation for -# the available subcommands and what they do. +# The 'clock' command manipulates time. Refer to the user documentation +# for the available subcommands and what they do. # -#---------------------------------------------------------------------- +#---------------------------------------------------------------------- namespace eval ::tcl::clock { @@ -58,8 +59,8 @@ namespace eval ::tcl::clock { # Import the message catalog commands that we use. - namespace import ::msgcat::mcload - namespace import ::msgcat::mclocale + namespace import ::msgcat::mc + namespace import ::msgcat::mcpackagelocale } @@ -75,11 +76,11 @@ namespace eval ::tcl::clock { # Side effects: # Namespace variable in the 'clock' subsystem are initialized. # -# The '::tcl::clock::Initialize' procedure initializes the namespace variables -# and root locale message catalog for the 'clock' subsystem. It is broken -# into a procedure rather than simply evaluated as a script so that it will be -# able to use local variables, avoiding the dangers of 'creative writing' as -# in Bug 1185933. +# The '::tcl::clock::Initialize' procedure initializes the namespace +# variables and root locale message catalog for the 'clock' subsystem. +# It is broken into a procedure rather than simply evaluated as a script +# so that it will be able to use local variables, avoiding the dangers +# of 'creative writing' as in Bug 1185933. # #---------------------------------------------------------------------- @@ -106,6 +107,10 @@ proc ::tcl::clock::Initialize {} { } InitTZData + mcpackagelocale set {} + ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] + ::msgcat::mcpackageconfig set unknowncmd "" + # Define the message catalog for the root locale. ::msgcat::mcmset {} { @@ -171,8 +176,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 - # For Belgium, we follow Southern Netherlands; Liege Diocese changed - # several weeks later. + # For Belgium, we follow Southern Netherlands; Liege Diocese + # changed several weeks later. ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238 ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238 @@ -188,13 +193,13 @@ proc ::tcl::clock::Initialize {} { # Germany, Norway, Denmark (Catholic Germany changed earlier) ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032 - ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 + ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032 - # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at - # various times) + # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed + # at various times) ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 @@ -216,23 +221,23 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 - # Romania (Transylvania changed earler - perhaps de_RO should show the - # earlier date?) + # Romania (Transylvania changed earler - perhaps de_RO should show + # the earlier date?) ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063 # Greece ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480 - + #------------------------------------------------------------------ # # CONSTANTS # #------------------------------------------------------------------ - # Paths at which binary time zone data for the Olson libraries are known - # to reside on various operating systems + # Paths at which binary time zone data for the Olson libraries + # are known to reside on various operating systems variable ZoneinfoPaths {} foreach path { @@ -249,7 +254,6 @@ proc ::tcl::clock::Initialize {} { # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] - variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. @@ -281,10 +285,10 @@ proc ::tcl::clock::Initialize {} { variable FEB_28 58 - # Translation table to map Windows TZI onto cities, so that the Olson - # rules can apply. In some cases the mapping is ambiguous, so it's wise - # to specify $::env(TCL_TZ) rather than simply depending on the system - # time zone. + # Translation table to map Windows TZI onto cities, so that + # the Olson rules can apply. In some cases the mapping is ambiguous, + # so it's wise to specify $::env(TCL_TZ) rather than simply depending + # on the system time zone. # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: @@ -295,10 +299,10 @@ proc ::tcl::clock::Initialize {} { # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds - # The values are the names of time zones where those rules apply. There - # is considerable ambiguity in certain zones; an attempt has been made to - # make a reasonable guess, but this table needs to be taken with a grain - # of salt. + # 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 @@ -377,10 +381,10 @@ proc ::tcl::clock::Initialize {} { {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. + # 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 { @@ -484,8 +488,8 @@ proc ::tcl::clock::Initialize {} { } } - # Groups of fields that specify time of day, priorities, and code that - # processes them + # Groups of fields that specify time of day, priorities, + # and code that processes them variable TimeParseActions { @@ -623,11 +627,6 @@ proc ::tcl::clock::Initialize {} { # in the given locales and dictionaries # mapping the numerals to their numeric # values. - variable McLoaded {}; # Dictionary whose keys are locales - # in which [mcload] has been executed - # and whose values are second-level - # dictionaries indexed by message - # name and giving message text. # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, # it contains the value of the # system time zone, as determined from @@ -651,14 +650,16 @@ proc ::tcl::clock::Initialize {} { # # clock format -- # -# Formats a count of seconds since the Posix Epoch as a time of day. +# Formats a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command formats times of day for output. Refer to the -# user documentation to see what it does. +# The 'clock format' command formats times of day for output. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::format { args } { + variable FormatProc variable TZData @@ -667,7 +668,7 @@ proc ::tcl::clock::format { args } { set clockval [lindex $args 0] # Get the data for time changes in the given zone - + if {$timezone eq ""} { set timezone [GetSystemTimeZone] } @@ -677,11 +678,11 @@ proc ::tcl::clock::format { args } { return -options $opts $retval } } - - # Build a procedure to format the result. Cache the built procedure's name - # in the 'FormatProc' array to avoid losing its internal representation, - # which contains the name resolution. - + + # Build a procedure to format the result. Cache the built procedure's + # name in the 'FormatProc' array to avoid losing its internal + # representation, which contains the name resolution. + set procName formatproc'$format'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] if {[info exists FormatProc($procName)]} { @@ -690,8 +691,9 @@ proc ::tcl::clock::format { args } { set FormatProc($procName) \ [ParseClockFormatFormat $procName $format $locale] } - + return [$procName $clockval $timezone] + } #---------------------------------------------------------------------- @@ -710,31 +712,39 @@ proc ::tcl::clock::format { args } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { + if {[namespace which $procName] ne {}} { return $procName } # Map away the locale-dependent composite format groups - - EnterLocale $locale oldLocale + + EnterLocale $locale # Change locale if a fresh locale has been given on the command line. - try { - return [ParseClockFormatFormat2 $format $locale $procName] - } trap CLOCK {result opts} { - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + set status [catch { + + ParseClockFormatFormat2 $format $locale $procName - if { [info exists oldLocale] } { - mclocale $oldLocale + } result opts] + + # Return either the error or the proc name + + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result } + } else { + return $result } + } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { + set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -749,7 +759,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set formatString {} set substituents {} set state {} - + set format [LocalizeFormat $locale $format] foreach char [split $format {}] { @@ -776,7 +786,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [lindex @DAYS_OF_WEEK_ABBREV@ \ [expr {[dict get $date dayOfWeek] \ % 7}]]}] - } + } A { # Day of week, spelt out. append formatString %s append substituents \ @@ -877,7 +887,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { k { # Hour (0-23), no leading zero append formatString %2d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 3600 % 24 }]} } @@ -898,7 +908,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { M { # Minute of the hour, leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 60 % 60 }]} } @@ -939,7 +949,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [expr {(([dict get $date localSeconds] % 86400) < 43200) ? $am : $pm}]} - + } Q { # Hi, Jeff! append formatString %s @@ -949,11 +959,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents { [dict get $date seconds]} } - S { # Second of the minute, with + S { # Second of the minute, with # leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] % 60 }]} } t { # A literal tab character @@ -974,7 +984,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } incr dow set UweekNumber \ - [expr { ( [dict get $date dayOfYear] + [expr { ( [dict get $date dayOfYear] - $dow + 7 ) / 7 }] } @@ -997,7 +1007,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set WweekNumber \ [expr { ( [dict get $date dayOfYear] - [dict get $date dayOfWeek] - + 7 ) + + 7 ) / 7 }] } append formatString %02d @@ -1066,7 +1076,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { percentO { # Character following %O set state {} switch -exact -- $char { - d - e { # Day of the month in alternative + d - e { # Day of the month in alternative # numerals append formatString %s append substituents \ @@ -1078,7 +1088,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 3600 % 24 }]]} } @@ -1104,7 +1114,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 60 % 60 }]]} } @@ -1113,7 +1123,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] % 60 }]]} } u { # Day of the week (Monday=1,Sunday=7) @@ -1144,9 +1154,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } } - + # Clean up any improperly terminated groups - + switch -exact -- $state { percent { append formatString %% @@ -1173,14 +1183,16 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { # # clock scan -- # -# Inputs a count of seconds since the Posix Epoch as a time of day. +# Inputs a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command scans times of day on input. Refer to the user -# documentation to see what it does. +# The 'clock format' command scans times of day on input. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::scan { args } { + set format {} # Check the count of args @@ -1242,17 +1254,21 @@ proc ::tcl::clock::scan { args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($base) } } result] } { - return -code error "expected integer but got \"$base\"" + return -code error \ + "expected integer but got \"$base\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + 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)] } { - # Perhaps someday we'll localize the legacy code. Right now, it's not - # localized. + # Perhaps someday we'll localize the legacy code. Right now, + # it's not localized. if { [info exists saw(-locale)] } { return -code error \ -errorcode [list CLOCK flagWithLegacyFormat] \ @@ -1264,25 +1280,27 @@ proc ::tcl::clock::scan { args } { # Change locale if a fresh locale has been given on the command line. - EnterLocale $locale oldLocale + EnterLocale $locale + + set status [catch { - try { # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - return [$scanner $string $base $timezone] - } trap CLOCK {result opts} { - # Conceal location of generation of expected errors + $scanner $string $base $timezone - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + } result opts] - if { [info exists oldLocale] } { - mclocale $oldLocale + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result } + } else { + return $result } + } #---------------------------------------------------------------------- @@ -1298,50 +1316,52 @@ proc ::tcl::clock::scan { args } { # locale - (Unused) Name of the locale where the time will be scanned. # # Results: -# Returns the date and time extracted from the string in seconds from -# the epoch +# Returns the date and time extracted from the string in seconds +# from the epoch # #---------------------------------------------------------------------- proc ::tcl::clock::FreeScan { string base timezone locale } { + variable TZData # Get the data for time changes in the given zone - - try { - SetupTimeZone $timezone - } on error {retval opts} { + + if {[catch {SetupTimeZone $timezone} retval opts]} { dict unset opts -errorinfo return -options $opts $retval } - # Extract year, month and day from the base time for the parser to use as - # defaults + # Extract year, month and day from the base time for the + # parser to use as defaults - set date [GetDateFields $base $TZData($timezone) 2361222] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + set date [GetDateFields \ + $base \ + $TZData($timezone) \ + 2361222] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] - # Parse the date. The parser will return a list comprising date, time, - # time zone, relative month/day/seconds, relative weekday, ordinal month. - - try { - set scanned [Oldscan $string \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth]] - lassign $scanned \ - parseDate parseTime parseZone parseRel \ - parseWeekday parseOrdinalMonth - } on error message { - return -code error \ - "unable to convert date-time string \"$string\": $message" + # Parse the date. The parser will return a list comprising + # date, time, time zone, relative month/day/seconds, relative + # weekday, ordinal month. + + set status [catch { + Oldscan $string \ + [dict get $date year] \ + [dict get $date month] \ + [dict get $date dayOfMonth] + } result] + if { $status != 0 } { + return -code error "unable to convert date-time string \"$string\": $result" } - # If the caller supplied a date in the string, update the 'date' dict with - # the value. If the caller didn't specify a time with the date, default to - # midnight. + lassign $result parseDate parseTime parseZone parseRel \ + parseWeekday parseOrdinalMonth + + # If the caller supplied a date in the string, update the 'date' dict + # with the value. If the caller didn't specify a time with the date, + # default to midnight. if { [llength $parseDate] > 0 } { lassign $parseDate y m d @@ -1361,12 +1381,12 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } } - # If the caller supplied a time zone in the string, it comes back as a - # two-element list; the first element is the number of minutes east of - # Greenwich, and the second is a Daylight Saving Time indicator (1 == yes, - # 0 == no, -1 == unknown). We make it into a time zone indicator of - # +-hhmm. - + # If the caller supplied a time zone in the string, it comes back + # as a two-element list; the first element is the number of minutes + # east of Greenwich, and the second is a Daylight Saving Time + # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into + # a time zone indicator of +-hhmm. + if { [llength $parseZone] > 0 } { lassign $parseZone minEast dstFlag set timezone [FormatNumericTimeZone \ @@ -1380,19 +1400,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222] if { $parseTime ne {} } { dict set date secondOfDay $parseTime - } elseif { [llength $parseWeekday] != 0 - || [llength $parseOrdinalMonth] != 0 - || ( [llength $parseRel] != 0 + } elseif { [llength $parseWeekday] != 0 + || [llength $parseOrdinalMonth] != 0 + || ( [llength $parseRel] != 0 && ( [lindex $parseRel 0] != 0 || [lindex $parseRel 1] != 0 ) ) } { dict set date secondOfDay 0 } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] dict set date tzName $timezone set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] @@ -1404,17 +1423,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set seconds [add $seconds \ $relMonth months $relDay days $relSecond seconds \ -timezone $timezone -locale $locale] - } + } # Do relative weekday - + if { [llength $parseWeekday] > 0 } { + lassign $parseWeekday dayOrdinal dayOfWeek set date2 [GetDateFields $seconds $TZData($timezone) 2361222] dict set date2 era CE - set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr { - [dict get $date2 julianDay] + 6 - }]] + set jdwkday [WeekdayOnOrBefore $dayOfWeek \ + [expr { [dict get $date2 julianDay] + + 6 }]] incr jdwkday [expr { 7 * $dayOrdinal }] if { $dayOrdinal > 0 } { incr jdwkday -7 @@ -1422,20 +1442,21 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { dict set date2 secondOfDay \ [expr { [dict get $date2 localSeconds] % 86400 }] dict set date2 julianDay $jdwkday - dict set date2 localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date2 julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date2 localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date2 julianDay]) ) + + [dict get $date secondOfDay] }] dict set date2 tzName $timezone set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ 2361222] set seconds [dict get $date2 seconds] + } # Do relative month if { [llength $parseOrdinalMonth] > 0 } { + lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] @@ -1452,6 +1473,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] + } return $seconds @@ -1469,27 +1491,30 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # locale - The current locale # # Results: -# Constructs and returns a procedure that accepts the string being -# scanned, the base time, and the time zone. The procedure will either -# return the scanned time or else throw an error that should be rethrown -# to the caller of [clock scan] +# Constructs and returns a procedure that accepts the +# string being scanned, the base time, and the time zone. +# The procedure will either return the scanned time or +# else throw an error that should be rethrown to the caller +# of [clock scan] # # Side effects: -# The given procedure is defined in the ::tcl::clock namespace. Scan -# procedures are not deleted once installed. -# -# Why do we parse dates by defining a procedure to parse them? The reason is -# that by doing so, we have one convenient place to cache all the information: -# the regular expressions that match the patterns (which will be compiled), -# the code that assembles the date information, everything lands in one place. -# In this way, when a given format is reused at run time, all the information +# The given procedure is defined in the ::tcl::clock +# namespace. Scan procedures are not deleted once installed. +# +# Why do we parse dates by defining a procedure to parse them? +# The reason is that by doing so, we have one convenient place to +# cache all the information: the regular expressions that match the +# patterns (which will be compiled), the code that assembles the +# date information, everything lands in one place. In this way, +# when a given format is reused at run time, all the information # of how to apply it is available in a single place. # #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockScanFormat {formatString locale} { - # Check whether the format has been parsed previously, and return the - # existing recognizer if it has. + + # Check whether the format has been parsed previously, and return + # the existing recognizer if it has. set procName scanproc'$formatString'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] @@ -1533,8 +1558,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re "\\" - } + append re \\ + } append re $c } } @@ -1651,7 +1676,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "::scan \$field" [incr captureCount] " %ld" \ "\]\n" } - m - N { # Month number + m - N { # Month number append re \\s*(\\d\\d?) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1694,9 +1719,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { \] \n } s { # Seconds from Posix Epoch - # This next case is insanely difficult, because it's - # problematic to determine whether the field is - # actually within the range of a wide integer. + # This next case is insanely difficult, + # because it's problematic to determine + # whether the field is actually within + # the range of a wide integer. append re {\s*([-+]?\d+)} dict set fieldSet seconds [incr fieldCount] append postcode {dict set date seconds } \[ \ @@ -1729,13 +1755,14 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { dict set date dayOfWeek $dow } } - U { # Week of year. The first Sunday of - # the year is the first day of week - # 01. No scan rule uses this group. + U { # Week of year. The + # first Sunday of the year is the + # first day of week 01. No scan rule + # uses this group. append re \\s*\\d\\d? } V { # Week of ISO8601 year - + append re \\s*(\\d\\d?) dict set fieldSet iso8601Week [incr fieldCount] append postcode "dict set date iso8601Week \[" \ @@ -1907,7 +1934,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "day of week is greater than 7" } dict set date dayOfWeek $dow - } + } } y { lassign [LocaleNumeralMatcher $locale] regex lookup @@ -1953,11 +1980,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n - # Set up the time zone before doing anything with a default base date - # that might need a timezone to interpret it. + # Get time zone if needed - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + if { ![dict exists $fieldSet seconds] + && ![dict exists $fieldSet starDate] } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] @@ -1976,29 +2002,24 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # Assemble seconds from the Julian day and second of the day. - # Convert to local time unless epoch seconds or stardate are - # being processed - they're always absolute + # Assemble seconds, and convert local nominal time to UTC. - if { ![dict exists $fieldSet seconds] + if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { append procBody { if { [dict get $date julianDay] > 5373484 } { return -code error -errorcode [list CLOCK dateTooLarge] \ "requested date too large to represent" } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] } - - # Finally, convert the date to local time - append procBody { set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ - $TZData($timeZone) $changeover] + $TZData($timeZone) \ + $changeover] } } @@ -2012,29 +2033,31 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { return $procName } - + #---------------------------------------------------------------------- # # LocaleNumeralMatcher -- # -# Composes a regexp that captures the numerals in the given locale, and -# a dictionary to map them to conventional numerals. +# Composes a regexp that captures the numerals in the given +# locale, and a dictionary to map them to conventional numerals. # # Parameters: # locale - Name of the current locale # # Results: -# Returns a two-element list comprising the regexp and the dictionary. +# Returns a two-element list comprising the regexp and the +# dictionary. # # Side effects: # Caches the result. # #---------------------------------------------------------------------- -proc ::tcl::clock::LocaleNumeralMatcher {l} { +proc ::tcl::clock::LocaleNumeralMatcher {locale} { + variable LocaleNumeralCache - if { ![dict exists $LocaleNumeralCache $l] } { + if { ![dict exists $LocaleNumeralCache $locale] } { set d {} set i 0 set sep \( @@ -2046,20 +2069,20 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { incr i } append re \) - dict set LocaleNumeralCache $l [list $re $d] + dict set LocaleNumeralCache $locale [list $re $d] } - return [dict get $LocaleNumeralCache $l] + return [dict get $LocaleNumeralCache $locale] } - + #---------------------------------------------------------------------- # # UniquePrefixRegexp -- # -# Composes a regexp that performs unique-prefix matching. The RE -# matches one of a supplied set of strings, or any unique prefix -# thereof. +# Composes a regexp that performs unique-prefix matching. The +# RE matches one of a supplied set of strings, or any unique +# prefix thereof. # # Parameters: # data - List of alternating match-strings and values. @@ -2067,10 +2090,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { # distinct. # # Results: -# Returns a two-element list. The first is a regexp that matches any -# unique prefix of any of the strings. The second is a dictionary whose -# keys are match values from the regexp and whose values are the -# corresponding values from 'data'. +# Returns a two-element list. The first is a regexp that +# matches any unique prefix of any of the strings. The second +# is a dictionary whose keys are match values from the regexp +# and whose values are the corresponding values from 'data'. # # Side effects: # None. @@ -2078,10 +2101,11 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { #---------------------------------------------------------------------- proc ::tcl::clock::UniquePrefixRegexp { data } { - # The 'successors' dictionary will contain, for each string that is a - # prefix of any key, all characters that may follow that prefix. The - # 'prefixMapping' dictionary will have keys that are prefixes of keys and - # values that correspond to the keys. + + # The 'successors' dictionary will contain, for each string that + # is a prefix of any key, all characters that may follow that + # prefix. The 'prefixMapping' dictionary will have keys that + # are prefixes of keys and values that correspond to the keys. set prefixMapping [dict create] set successors [dict create {} {}] @@ -2089,7 +2113,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # Walk the key-value pairs foreach { key value } $data { - # Construct all prefixes of the key; + + # Construct all prefixes of the key; set prefix {} foreach char [split $key {}] { @@ -2107,8 +2132,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { } } - # Identify those prefixes that designate unique values, and those that are - # the full keys + # Identify those prefixes that designate unique values, and + # those that are the full keys set uniquePrefixMapping {} dict for { key valueList } $prefixMapping { @@ -2131,8 +2156,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # # MakeUniquePrefixRegexp -- # -# Service procedure for 'UniquePrefixRegexp' that constructs a regular -# expresison that matches the unique prefixes. +# Service procedure for 'UniquePrefixRegexp' that constructs +# a regular expresison that matches the unique prefixes. # # Parameters: # successors - Dictionary whose keys are all prefixes @@ -2144,17 +2169,18 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # prefixString - Current prefix being processed. # # Results: -# Returns a constructed regular expression that matches the set of -# unique prefixes beginning with the 'prefixString'. +# Returns a constructed regular expression that matches the set +# of unique prefixes beginning with the 'prefixString'. # # Side effects: # None. # #---------------------------------------------------------------------- -proc ::tcl::clock::MakeUniquePrefixRegexp { successors +proc ::tcl::clock::MakeUniquePrefixRegexp { successors uniquePrefixMapping prefixString } { + # Get the characters that may follow the current prefix string set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]] @@ -2162,15 +2188,13 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors return {} } - # If there is more than one successor character, or if the current prefix - # is a unique prefix, surround the generated re with non-capturing + # If there is more than one successor character, or if the current + # prefix is a unique prefix, surround the generated re with non-capturing # parentheses. set re {} - if { - [dict exists $uniquePrefixMapping $prefixString] - || [llength $schars] > 1 - } then { + if { [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 } { append re "(?:" } @@ -2192,7 +2216,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2203,8 +2227,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # # MakeParseCodeFromFields -- # -# Composes Tcl code to extract the Julian Day Number from a dictionary -# containing date fields. +# Composes Tcl code to extract the Julian Day Number from a +# dictionary containing date fields. # # Parameters: # dateFields -- Dictionary whose keys are fields of the date, @@ -2215,8 +2239,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # the list must be in ascending order by priority # # Results: -# Returns a burst of code that extracts the day number from the given -# date. +# Returns a burst of code that extracts the day number from the +# given date. # # Side effects: # None. @@ -2224,6 +2248,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors #---------------------------------------------------------------------- proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { + set currPrio 999 set currFieldPos [list] set currCodeBurst { @@ -2231,15 +2256,16 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { } foreach { fieldSet prio parseAction } $parseActions { - # If we've found an answer that's better than any that follow, quit - # now. + + # If we've found an answer that's better than any that follow, + # quit now. if { $prio > $currPrio } { break } - # Accumulate the field positions that are used in the current field - # grouping. + # Accumulate the field positions that are used in the current + # field grouping. set fieldPos [list] set ok true @@ -2262,11 +2288,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { - if { - ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos - } then { + if { ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos } { break } if { $newPos < $currPos } { @@ -2284,86 +2308,75 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction + } return $currCodeBurst + } #---------------------------------------------------------------------- # # EnterLocale -- # -# Switch [mclocale] to a given locale if necessary +# By shure given locale is loaded and set variable Locale # # 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. +# If necessary, uses [mcloadedlocales packageadd] to load the +# designated locale's files. # #---------------------------------------------------------------------- -proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { - upvar 1 $oldLocaleVar oldLocale - - variable MsgDir - variable McLoaded +proc ::tcl::clock::EnterLocale { locale } { - set oldLocale [mclocale] if { $locale eq {system} } { + if { $::tcl_platform(platform) ne {windows} } { - # On a non-windows platform, the 'system' locale is the same as - # the 'current' locale + + # On a non-windows platform, the 'system' locale is + # the same as the 'current' locale set locale current } else { - # On a windows platform, the 'system' locale is adapted from the - # 'current' locale by applying the date and time formats from the - # Control Panel. First, load the 'current' locale if it's not yet - # loaded - - 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 + # 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 - set locale ${oldLocale}_windows - if { ![dict exists $McLoaded $locale] } { + mcpackagelocale [mclocale] + + # Make a new locale string for the system locale, and + # get the Control Panel information + + # This will only load the current locale below, as it is a + # descent from <locale>_windows. + # The <locale>_windows will be remembered as current and as loaded. + set locale [mclocale]_windows + if { $locale ni [::msgcat::mcpackagelocale loaded] } { LoadWindowsDateTimeFormats $locale - dict set McLoaded $locale {} } } } if { $locale eq {current}} { - set locale $oldLocale - unset oldLocale - } elseif { $locale eq $oldLocale } { - unset oldLocale - } else { - mclocale $locale + set locale [mclocale] } - if { ![dict exists $McLoaded $locale] } { - mcload $MsgDir - dict set McLoaded $locale {} - } -} + # Eventually load the locale + mcpackagelocale set $locale +} #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows and -# convert them so that they're usable by Tcl. +# Load the date/time formats from the Control Panel in Windows +# and convert them so that they're usable by Tcl. # # Parameters: # locale - Name of the locale in whose message catalog @@ -2375,12 +2388,14 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { # Side effects: # Updates the given message catalog with the locale strings. # -# Presumes that on entry, [mclocale] is set to the current locale, so that -# default strings can be obtained if the Registry query fails. +# Presumes that on entry, [mclocale] is set to the current locale, +# so that default strings can be obtained if the Registry query +# fails. # #---------------------------------------------------------------------- proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { + # Bail out if we can't find the Registry variable NoRegistry @@ -2482,6 +2497,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { } return + } #---------------------------------------------------------------------- @@ -2496,8 +2512,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { # format -- Format supplied to [clock scan] or [clock format] # # Results: -# Returns the string with locale-dependent composite format groups -# substituted out. +# Returns the string with locale-dependent composite format +# groups substituted out. # # Side effects: # None. @@ -2505,18 +2521,18 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { #---------------------------------------------------------------------- proc ::tcl::clock::LocalizeFormat { locale format } { - variable McLoaded - if { [dict exists $McLoaded $locale FORMAT $format] } { - return [dict get $McLoaded $locale FORMAT $format] - } - set inFormat $format + # message catalog key to cache this format + set key FORMAT_$format + if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { + return [mc $key] + } # Handle locale-dependent format groups by mapping them out of the format # string. Note that the order of the [string map] operations is # significant because later formats can refer to later ones; for example # %c can refer to %X, which in turn can refer to %T. - + set list { %% %% %D %m/%d/%Y @@ -2533,8 +2549,8 @@ proc ::tcl::clock::LocalizeFormat { locale format } { lappend list %c [string map $list [mc DATE_TIME_FORMAT]] lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] set format [string map $list $format] - - dict set McLoaded $locale FORMAT $inFormat $format + + mcset $locale $key $format return $format } @@ -2556,6 +2572,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { + if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2570,6 +2587,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval + } #---------------------------------------------------------------------- @@ -2594,6 +2612,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { + variable Roddenberry # Get day of year, zero based @@ -2644,6 +2663,7 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { + variable Roddenberry # Build a tentative date from year and fraction. @@ -2659,8 +2679,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { set lp [IsGregorianLeapYear $date] - # Reconvert the fractional year according to whether the given year is a - # leap year + # Reconvert the fractional year according to whether the given + # year is a leap year if { $lp } { dict set date dayOfYear \ @@ -2673,11 +2693,10 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] - return [expr { - 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay - }] + return [expr { 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay }] + } #---------------------------------------------------------------------- @@ -2690,8 +2709,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { # str - String containing a decimal wide integer # # Results: -# Returns the string as a pure wide integer. Throws an error if the -# string is misformatted or out of range. +# Returns the string as a pure wide integer. Throws an error if +# the string is misformatted or out of range. # #---------------------------------------------------------------------- @@ -2712,8 +2731,8 @@ proc ::tcl::clock::ScanWide { str } { # # InterpretTwoDigitYear -- # -# Given a date that contains only the year of the century, determines -# the target value of a two-digit year. +# Given a date that contains only the year of the century, +# determines the target value of a two-digit year. # # Parameters: # date - Dictionary containing fields of the date. @@ -2730,17 +2749,18 @@ proc ::tcl::clock::ScanWide { str } { # Side effects: # None. # -# The current rule for interpreting a two-digit year is that the year shall be -# between 1937 and 2037, thus staying within the range of a 32-bit signed -# value for time. This rule may change to a sliding window in future -# versions, so the 'baseTime' parameter (which is currently ignored) is -# provided in the procedure signature. +# The current rule for interpreting a two-digit year is that the year +# shall be between 1937 and 2037, thus staying within the range of a +# 32-bit signed value for time. This rule may change to a sliding +# window in future versions, so the 'baseTime' parameter (which is +# currently ignored) is provided in the procedure signature. # #---------------------------------------------------------------------- -proc ::tcl::clock::InterpretTwoDigitYear { date baseTime +proc ::tcl::clock::InterpretTwoDigitYear { date baseTime { twoDigitField yearOfCentury } { fourDigitField year } } { + set yr [dict get $date $twoDigitField] if { $yr <= 37 } { dict set date $fourDigitField [expr { $yr + 2000 }] @@ -2748,6 +2768,7 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date + } #---------------------------------------------------------------------- @@ -2773,6 +2794,7 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time, and @@ -2786,6 +2808,7 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { dict set date year [dict get $date2 year] return $date + } #---------------------------------------------------------------------- @@ -2812,6 +2835,7 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2829,7 +2853,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { # # AssignBaseMonth -- # -# Places the number of the current year and month into a +# Places the number of the current year and month into a # dictionary. # # Parameters: @@ -2848,6 +2872,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { + variable TZData # Find the year and month corresponding to the base time @@ -2857,6 +2882,7 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] return $date + } #---------------------------------------------------------------------- @@ -2882,6 +2908,7 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2918,6 +2945,7 @@ proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2947,6 +2975,7 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { + set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 @@ -2956,6 +2985,7 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] + } #---------------------------------------------------------------------- @@ -2978,11 +3008,11 @@ proc ::tcl::clock::InterpretHMSP { date } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMS { date } { - return [expr { - ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 - + [dict get $date second] - }] + + return [expr { ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] }] + } #---------------------------------------------------------------------- @@ -3005,6 +3035,7 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { + variable CachedSystemTimeZone variable TimeZoneBad @@ -3037,69 +3068,76 @@ proc ::tcl::clock::GetSystemTimeZone {} { } else { return $timezone } + } #---------------------------------------------------------------------- # # ConvertLegacyTimeZone -- # -# Given an alphanumeric time zone identifier and the system time zone, -# convert the alphanumeric identifier to an unambiguous time zone. +# Given an alphanumeric time zone identifier and the system +# time zone, convert the alphanumeric identifier to an +# unambiguous time zone. # # Parameters: # tzname - Name of the time zone to convert # # Results: -# Returns a time zone name corresponding to tzname, but in an -# unambiguous form, generally +hhmm. +# Returns a time zone name corresponding to tzname, but +# in an unambiguous form, generally +hhmm. # -# This procedure is implemented primarily to allow the parsing of RFC822 -# date/time strings. Processing a time zone name on input is not recommended -# practice, because there is considerable room for ambiguity; for instance, is -# BST Brazilian Standard Time, or British Summer Time? +# This procedure is implemented primarily to allow the parsing of +# RFC822 date/time strings. Processing a time zone name on input +# is not recommended practice, because there is considerable room +# for ambiguity; for instance, is BST Brazilian Standard Time, or +# British Summer Time? # #---------------------------------------------------------------------- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { + variable LegacyTimeZone set tzname [string tolower $tzname] if { ![dict exists $LegacyTimeZone $tzname] } { return -code error -errorcode [list CLOCK badTZName $tzname] \ "time zone \"$tzname\" not found" + } else { + return [dict get $LegacyTimeZone $tzname] } - return [dict get $LegacyTimeZone $tzname] + } #---------------------------------------------------------------------- # # SetupTimeZone -- # -# Given the name or specification of a time zone, sets up its in-memory -# data. +# Given the name or specification of a time zone, sets up +# its in-memory data. # # Parameters: # tzname - Name of a time zone # # Results: -# Unless the time zone is ':localtime', sets the TZData array to contain -# the lookup table for local<->UTC conversion. Returns an error if the -# time zone cannot be parsed. +# Unless the time zone is ':localtime', sets the TZData array +# to contain the lookup table for local<->UTC conversion. +# Returns an error if the time zone cannot be parsed. # #---------------------------------------------------------------------- proc ::tcl::clock::SetupTimeZone { timezone } { + variable TZData if {! [info exists TZData($timezone)] } { variable MINWIDE if { $timezone eq {:localtime} } { + # Nothing to do, we'll convert using the localtime function - } elseif { - [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ - -> s hh mm ss] - } then { + } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] } { + # Make a fixed offset ::scan $hh %d hh @@ -3120,21 +3158,24 @@ proc ::tcl::clock::SetupTimeZone { timezone } { set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] } elseif { [string index $timezone 0] eq {:} } { + # Convert using a time zone file - if { + if { [catch { LoadTimeZoneFile [string range $timezone 1 end] - }] && [catch { + }] + && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] - } then { + } { return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" } - + } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } { + # This looks like a POSIX time zone - try to process it if { [catch {ProcessPosixTimeZone $tzfields} data opts] } { @@ -3147,8 +3188,9 @@ proc ::tcl::clock::SetupTimeZone { timezone } { } } else { - # We couldn't parse this as a POSIX time zone. Try again with a - # time zone file - this time without a colon + + # We couldn't parse this as a POSIX time zone. Try + # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] && [catch { LoadZoneinfoFile $timezone } - opts] } { @@ -3172,22 +3214,25 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # None. # # Results: -# Returns a time zone specifier that corresponds to the system time zone -# information found in the Registry. +# Returns a time zone specifier that corresponds to the system +# time zone information found in the Registry. # # Bugs: -# Fixed dates for DST change are unimplemented at present, because no -# time zone information supplied with Windows actually uses them! +# Fixed dates for DST change are unimplemented at present, because +# no time zone information supplied with Windows actually uses +# them! # -# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified, -# GuessWindowsTimeZone looks in the Registry for the system time zone -# information. It then attempts to find an entry in WinZoneInfo for a time -# zone that uses the same rules. If it finds one, it returns it; otherwise, -# it constructs a Posix-style time zone string and returns that. +# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is +# specified, GuessWindowsTimeZone looks in the Registry for the +# system time zone information. It then attempts to find an entry +# in WinZoneInfo for a time zone that uses the same rules. If +# it finds one, it returns it; otherwise, it constructs a Posix-style +# time zone string and returns that. # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { + variable WinZoneInfo variable NoRegistry variable TimeZoneBad @@ -3218,14 +3263,16 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { lappend data $val } }] } { + # Missing values in the Registry - bail out return :localtime } - # Make up a Posix time zone specifier if we can't find one. Check here - # that the tzdata file exists, in case we're running in an environment - # (e.g. starpack) where tzdata is incomplete. (Bug 1237907) + # Make up a Posix time zone specifier if we can't find one. + # Check here that the tzdata file exists, in case we're running + # in an environment (e.g. starpack) where tzdata is incomplete. + # (Bug 1237907) if { [dict exists $WinZoneInfo $data] } { set tzname [dict get $WinZoneInfo $data] @@ -3273,11 +3320,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $dstHour] \ @@ -3286,11 +3333,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $stdYear == 0 } { append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $stdHour] \ @@ -3298,9 +3345,10 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { : [::format %02d $stdSecond] } dict set WinZoneInfo $data $tzname - } + } return [dict get $WinZoneInfo $data] + } #---------------------------------------------------------------------- @@ -3329,18 +3377,18 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } - try { + if { [catch { source -encoding utf-8 [file join $DataDir $fileName] - } on error {} { + }] } { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" @@ -3358,8 +3406,8 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { # fileName - Relative path name of the file to load. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data @@ -3367,11 +3415,12 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { + variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ @@ -3400,14 +3449,15 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # fname - Absolute path name of the file. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- + proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData @@ -3426,8 +3476,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { set d [read $f] close $f - # The file begins with a magic number, sixteen reserved bytes, and then - # six 4-byte integers giving counts of fileds in the file. + # The file begins with a magic number, sixteen reserved bytes, + # and then six 4-byte integers giving counts of fileds in the file. binary scan $d a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar @@ -3445,19 +3495,18 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { return -code error "$fileName contains leap seconds" } - # In a version 2 file, we use the second part of the file, which contains - # 64-bit transition times. + # In a version 2 file, we use the second part of the file, which + # contains 64-bit transition times. if {$version eq "2"} { - set seek [expr { - 44 - + 5 * $nTime - + 6 * $nType - + 4 * $nLeap - + $nIsStd - + $nIsGMT - + $nChar - }] + set seek [expr {44 + + 5 * $nTime + + 6 * $nType + + 4 * $nLeap + + $nIsStd + + $nIsGMT + + $nChar + }] binary scan $d @${seek}a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar if {$magic ne {TZif}} { @@ -3481,9 +3530,9 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } set codes [linsert $codes 0 0] - # Next come ${nType} time type descriptions, each of which has an offset - # (seconds east of GMT), a DST indicator, and an index into the - # abbreviation text. + # Next come ${nType} time type descriptions, each of which has an + # offset (seconds east of GMT), a DST indicator, and an index into + # the abbreviation text. for { set i 0 } { $i < $nType } { incr i } { binary scan $d @${seek}Icc gmtOff isDst abbrInd @@ -3491,10 +3540,10 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { incr seek 6 } - # Next come $nChar characters of time zone name abbreviations, which are - # null-terminated. - # We build them up into a dictionary indexed by character index, because - # that's what's in the indices above. + # Next come $nChar characters of time zone name abbreviations, + # which are null-terminated. + # We build them up into a dictionary indexed by character index, + # because that's what's in the indices above. binary scan $d @${seek}a${nChar} abbrs incr seek ${nChar} @@ -3524,8 +3573,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } # In a version 2 file, there is also a POSIX-style time zone description - # at the very end of the file. To get to it, skip over nLeap leap second - # values (8 bytes each), + # at the very end of the file. To get to it, skip over + # nLeap leap second values (8 bytes each), # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. if {$version eq {2}} { @@ -3558,8 +3607,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # tz Time zone specifier to be interpreted # # Results: -# Returns a dictionary whose values contain the various pieces of the -# time zone specification. +# Returns a dictionary whose values contain the various pieces of +# the time zone specification. # # Side effects: # None. @@ -3570,7 +3619,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # The following keys are present in the dictionary: # stdName - Name of the time zone when Daylight Saving Time # is not in effect. -# stdSignum - Sign (+, -, or empty) of the offset from Greenwich +# stdSignum - Sign (+, -, or empty) of the offset from Greenwich # to the given (non-DST) time zone. + and the empty # string denote zones west of Greenwich, - denotes east # of Greenwich; this is contrary to the ISO convention @@ -3615,13 +3664,14 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # endHours, endMinutes, endSeconds - # Specify the end of DST in the same way that the start* fields # specify the beginning of DST. -# -# This procedure serves only to break the time specifier into fields. No -# attempt is made to canonicalize the fields or supply default values. +# +# This procedure serves only to break the time specifier into fields. +# No attempt is made to canonicalize the fields or supply default values. # #---------------------------------------------------------------------- proc ::tcl::clock::ParsePosixTimeZone { tz } { + if {[regexp -expanded -nocase -- { ^ # 1 - Standard time zone name @@ -3632,8 +3682,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 4 - Standard time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 5 - Standard time zone offset, seconds : ([[:digit:]]{1,2} ) )? @@ -3649,8 +3699,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 9 - DST time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 10 - DST time zone offset, seconds : ([[:digit:]]{1,2}) )? @@ -3663,8 +3713,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 13 - Month number 14 - Week of month 15 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3685,8 +3735,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 21 - Month number 22 - Week of month 23 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3713,21 +3763,27 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { x(endJ) x(endDayOfYear) \ x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ x(endHours) x(endMinutes) x(endSeconds)] } { + # it's a good timezone return [array get x] + + } else { + + return -code error\ + -errorcode [list CLOCK badTimeZone $tz] \ + "unable to parse time zone specification \"$tz\"" + } - return -code error\ - -errorcode [list CLOCK badTimeZone $tz] \ - "unable to parse time zone specification \"$tz\"" } #---------------------------------------------------------------------- # # ProcessPosixTimeZone -- # -# Handle a Posix time zone after it's been broken out into fields. +# Handle a Posix time zone after it's been broken out into +# fields. # # Parameters: # z - Dictionary returned from 'ParsePosixTimeZone' @@ -3741,6 +3797,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { + variable MINWIDE variable TZData @@ -3755,20 +3812,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set stdSignum -1 } - set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] + set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] if { [dict get $z stdMinutes] ne {} } { - set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] + set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] } else { set stdMinutes 0 } if { [dict get $z stdSeconds] ne {} } { - set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] + set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } else { set stdSeconds 0 } - set stdOffset [expr { - (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum - }] + set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes ) + * 60 + $stdSeconds ) + * $stdSignum }] set data [list [list $MINWIDE $stdOffset 0 $stdName]] # If there's no daylight zone, we're done @@ -3791,20 +3848,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { if { [dict get $z dstHours] eq {} } { set dstOffset [expr { 3600 + $stdOffset }] } else { - set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] + set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] if { [dict get $z dstMinutes] ne {} } { - set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] + set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] } else { set dstMinutes 0 } if { [dict get $z dstSeconds] ne {} } { - set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] + set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] } else { set dstSeconds 0 } - set dstOffset [expr { - (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum - }] + set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes ) + * 60 + $dstSeconds ) + * $dstSignum }] } # Fill in defaults for European or US DST rules @@ -3813,10 +3870,8 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # US end time is the first Sunday in November. # EU end time is the last Sunday in October - if { - [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} - } then { + if { [dict get $z startDayOfYear] eq {} + && [dict get $z startMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z startWeekOfMonth 5 @@ -3835,10 +3890,8 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { dict set z startMinutes 0 dict set z startSeconds 0 } - if { - [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} - } then { + if { [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z endMonth 10 @@ -3878,14 +3931,15 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } return $data -} + +} #---------------------------------------------------------------------- # # DeterminePosixDSTTime -- # -# Determines the time that Daylight Saving Time starts or ends from a -# Posix time zone specification. +# Determines the time that Daylight Saving Time starts or ends +# from a Posix time zone specification. # # Parameters: # z - Time zone data returned from ParsePosixTimeZone. @@ -3895,12 +3949,13 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # y - The year for which the transition time is to be determined. # # Results: -# Returns the transition time as a count of seconds from the epoch. The -# time is relative to the wall clock, not UTC. +# Returns the transition time as a count of seconds from +# the epoch. The time is relative to the wall clock, not UTC. # #---------------------------------------------------------------------- proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { + variable FEB_28 # Determine the start or end day of DST @@ -3908,16 +3963,18 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { set date [dict create era CE year $y] set doy [dict get $z ${bound}DayOfYear] if { $doy ne {} } { + # Time was specified as a day of the year if { [dict get $z ${bound}J] ne {} - && [IsGregorianLeapYear $y] + && [IsGregorianLeapYear $y] && ( $doy > $FEB_28 ) } { incr doy } dict set date dayOfYear $doy set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222] } else { + # Time was specified as a day of the week within a month dict set date month [dict get $z ${bound}Month] @@ -3932,9 +3989,8 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set jd [dict get $date julianDay] - set seconds [expr { - wide($jd) * wide(86400) - wide(210866803200) - }] + set seconds [expr { wide($jd) * wide(86400) + - wide(210866803200) }] set h [dict get $z ${bound}Hours] if { $h eq {} } { @@ -3956,6 +4012,7 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] + } #---------------------------------------------------------------------- @@ -3973,26 +4030,26 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # for the target locale. # # Results: -# Returns the dictionary, augmented with the keys, 'localeEra' and -# 'localeYear'. +# Returns the dictionary, augmented with the keys, 'localeEra' +# and 'localeYear'. # #---------------------------------------------------------------------- proc ::tcl::clock::GetLocaleEra { date etable } { + set index [BSearch $etable [dict get $date localSeconds]] if { $index < 0} { dict set date localeEra \ [::format %02d [expr { [dict get $date year] / 100 }]] - dict set date localeYear [expr { - [dict get $date year] % 100 - }] + dict set date localeYear \ + [expr { [dict get $date year] % 100 }] } else { dict set date localeEra [lindex $etable $index 1] - dict set date localeYear [expr { - [dict get $date year] - [lindex $etable $index 2] - }] + dict set date localeYear [expr { [dict get $date year] + - [lindex $etable $index 2] }] } return $date + } #---------------------------------------------------------------------- @@ -4010,9 +4067,10 @@ proc ::tcl::clock::GetLocaleEra { date etable } { # adopted in the current locale. # # Results: -# Returns the given dictionary augmented with a 'julianDay' key whose -# value is the desired Julian Day Number, and a 'gregorian' key that -# specifies whether the calendar is Gregorian (1) or Julian (0). +# Returns the given dictionary augmented with a 'julianDay' key +# whose value is the desired Julian Day Number, and a 'gregorian' +# key that specifies whether the calendar is Gregorian (1) or +# Julian (0). # # Side effects: # None. @@ -4023,6 +4081,7 @@ proc ::tcl::clock::GetLocaleEra { date etable } { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { + # Get absolute year number from the civil year switch -exact -- [dict get $date era] { @@ -4038,25 +4097,21 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # Try the Gregorian calendar first. dict set date gregorian 1 - set jd [expr { - 1721425 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) - }] - + set jd [expr { 1721425 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + - ( $ym1 / 100 ) + + ( $ym1 / 400 ) }] + # If the date is before the Gregorian change, use the Julian calendar. if { $jd < $changeover } { dict set date gregorian 0 - set jd [expr { - 1721423 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - }] + set jd [expr { 1721423 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) }] } dict set date julianDay $jd @@ -4067,8 +4122,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # # GetJulianDayFromEraYearMonthWeekDay -- # -# Determines the Julian Day number corresponding to the nth given -# day-of-the-week in a given month. +# Determines the Julian Day number corresponding to the nth +# given day-of-the-week in a given month. # # Parameters: # date - Dictionary containing the keys, 'era', 'year', 'month' @@ -4087,9 +4142,10 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { - # Come up with a reference day; either the zeroeth day of the given month - # (dayOfWeekInMonth >= 0) or the seventh day of the following month - # (dayOfWeekInMonth < 0) + + # Come up with a reference day; either the zeroeth day of the + # given month (dayOfWeekInMonth >= 0) or the seventh day of the + # following month (dayOfWeekInMonth < 0) set date2 $date set week [dict get $date dayOfWeekInMonth] @@ -4105,6 +4161,7 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date + } #---------------------------------------------------------------------- @@ -4127,8 +4184,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { + switch -exact -- [dict get $date era] { - BCE { + BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4146,14 +4204,15 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { } else { return 1 } + } #---------------------------------------------------------------------- # # WeekdayOnOrBefore -- # -# Determine the nearest day of week (given by the 'weekday' parameter, -# Sunday==0) on or before a given Julian Day. +# Determine the nearest day of week (given by the 'weekday' +# parameter, Sunday==0) on or before a given Julian Day. # # Parameters: # weekday -- Day of the week @@ -4168,16 +4227,18 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { #---------------------------------------------------------------------- proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { + set k [expr { ( $weekday + 6 ) % 7 }] return [expr { $j - ( $j - $k ) % 7 }] + } #---------------------------------------------------------------------- # # BSearch -- # -# Service procedure that does binary search in several places inside the -# 'clock' command. +# Service procedure that does binary search in several places +# inside the 'clock' command. # # Parameters: # list - List of lists, sorted in ascending order by the @@ -4185,8 +4246,8 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { # key - Value to search for # # Results: -# Returns the index of the greatest element in $list that is less than -# or equal to $key. +# Returns the index of the greatest element in $list that is less +# than or equal to $key. # # Side effects: # None. @@ -4194,6 +4255,7 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { + if {[llength $list] == 0} { return -1 } @@ -4205,12 +4267,13 @@ proc ::tcl::clock::BSearch { list key } { set u [expr { [llength $list] - 1 }] while { $l < $u } { + # At this point, we know that # $k >= [lindex $list $l 0] # Either $u == [llength $list] or else $k < [lindex $list $u+1 0] # We find the midpoint of the interval {l,u} rounded UP, compare - # against it, and set l or u to maintain the invariant. Note that the - # interval shrinks at each step, guaranteeing convergence. + # against it, and set l or u to maintain the invariant. Note + # that the interval shrinks at each step, guaranteeing convergence. set m [expr { ( $l + $u + 1 ) / 2 }] if { $key >= [lindex $list $m 0] } { @@ -4254,14 +4317,15 @@ proc ::tcl::clock::BSearch { list key } { # order. # # Notes: -# It is possible that adding a number of months or years will adjust the -# day of the month as well. For instance, the time at one month after -# 31 January is either 28 or 29 February, because February has fewer -# than 31 days. +# It is possible that adding a number of months or years will adjust +# the day of the month as well. For instance, the time at +# one month after 31 January is either 28 or 29 February, because +# February has fewer than 31 days. # #---------------------------------------------------------------------- proc ::tcl::clock::add { clockval args } { + if { [llength $args] % 2 != 0 } { set cmdName "clock add" return -code error \ @@ -4280,10 +4344,15 @@ proc ::tcl::clock::add { clockval args } { set timezone [GetSystemTimeZone] foreach { a b } $args { + if { [string is integer -strict $a] } { + lappend offsets $a $b + } else { + switch -exact -- $a { + -g - -gm - -gmt { set gmt $b } @@ -4295,7 +4364,8 @@ proc ::tcl::clock::add { clockval args } { set timezone $b } default { - throw [list CLOCK badSwitch $a] \ + return -code error \ + -errorcode [list CLOCK badSwitch $a] \ "bad switch \"$a\",\ must be -gmt, -locale or -timezone" } @@ -4311,16 +4381,20 @@ proc ::tcl::clock::add { clockval args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($clockval) } } result] } { - return -code error "expected integer but got \"$clockval\"" + return -code error \ + "expected integer but got \"$clockval\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } - EnterLocale $locale oldLocale - + EnterLocale $locale + set changeover [mc GREGORIAN_CHANGE_DATE] if {[catch {SetupTimeZone $timezone} retval opts]} { @@ -4328,25 +4402,29 @@ proc ::tcl::clock::add { clockval args } { return -options $opts $retval } - try { + set status [catch { + foreach { quantity unit } $offsets { + switch -exact -- $unit { + years - year { - set clockval [AddMonths [expr { 12 * $quantity }] \ - $clockval $timezone $changeover] + set clockval \ + [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { set clockval [AddMonths $quantity $clockval $timezone \ - $changeover] + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone $changeover] + $clockval $timezone $changeover] } days - day { set clockval [AddDays $quantity $clockval $timezone \ - $changeover] + $changeover] } hours - hour { @@ -4360,24 +4438,27 @@ proc ::tcl::clock::add { clockval args } { } default { - throw [list CLOCK badUnit $unit] \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" + 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] } } } - return $clockval - } trap CLOCK {result opts} { - # Conceal the innards of [clock] when it's an expected error - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + } result opts] + + # Restore the locale - if { [info exists oldLocale] } { - mclocale $oldLocale + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { + dict unset opts -errorinfo } + return -options $opts $result + } else { + return $clockval } + } #---------------------------------------------------------------------- @@ -4402,6 +4483,7 @@ proc ::tcl::clock::add { clockval args } { #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { + variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData @@ -4409,9 +4491,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # Convert the time to year, month, day, and fraction of day. set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of months @@ -4440,23 +4521,23 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { set date [GetJulianDayFromEraYearMonthDay \ $date[set date {}]\ $changeover] - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] + } #---------------------------------------------------------------------- # # AddDays -- # -# Add a given number of days to a given clock value in a given time -# zone. +# Add a given number of days to a given clock value in a given +# time zone. # # Parameters: # days - Number of days to add (may be negative) @@ -4466,7 +4547,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # in the target locale. # # Results: -# Returns the new clock value as a number of seconds since the epoch. +# Returns the new clock value as a number of seconds since +# the epoch. # # Side effects: # None. @@ -4474,14 +4556,14 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AddDays { days clockval timezone changeover } { + variable TZData # Convert the time to Julian Day set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of days @@ -4490,47 +4572,15 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { # Reconvert to a number of seconds - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] -} - -#---------------------------------------------------------------------- -# -# mc -- -# -# Wrapper around ::msgcat::mc that caches the result according to the -# locale. -# -# Parameters: -# Accepts the name of the message to retrieve. -# -# Results: -# Returns the message text. -# -# Side effects: -# Caches the message text. -# -# Notes: -# Only the single-argument version of [mc] is supported. -# -#---------------------------------------------------------------------- -proc ::tcl::clock::mc { name } { - variable McLoaded - set Locale [mclocale] - if { [dict exists $McLoaded $Locale $name] } { - return [dict get $McLoaded $Locale $name] - } - set val [::msgcat::mc $name] - dict set McLoaded $Locale $name $val - return $val } #---------------------------------------------------------------------- @@ -4551,9 +4601,9 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { + variable FormatProc variable LocaleNumeralCache - variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad @@ -4566,8 +4616,11 @@ proc ::tcl::clock::ClearCaches {} { catch {unset FormatProc} set LocaleNumeralCache {} - set McLoaded {} + # this removes many required keys and makes the module unusable + mcpackagelocale set "" + mcpackagelocale clear catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData + } diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index c35803f..92fb7f7 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -202,29 +202,27 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - variable PackageConfig set ns [uplevel 1 [list ::namespace current]] set loclist [PackagePreferences $ns] - while {$ns != ""} { + set nscur $ns + while {$nscur != ""} { foreach loc $loclist { - if {[dict exists $Msgs $ns $loc $src]} { - if {[llength $args] == 0} { - return [dict get $Msgs $ns $loc $src] - } else { - return [format [dict get $Msgs $ns $loc $src] {*}$args] - } + if {[dict exists $Msgs $nscur $loc $src]} { + return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\ + {*}$args] } } - set ns [namespace parent $ns] + set nscur [namespace parent $nscur] } # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] - if {[Invoke unknowncmd $args $ns result]} { - return $result + switch -exact -- [Invoke unknowncmd $args $ns result] { + 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 1 { return [DefaultUnknown {*}$args] } + default { return $result } } - return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } # msgcat::mcexists -- @@ -423,8 +421,8 @@ proc msgcat::mcloadedlocales {subcommand} { # Returns true, if a package locale is set # unset # Unset the package locale and activate the default locale. -# This may clear message catalog data and may load message catalog -# files +# This loads message catalog file which where missing in the package +# locale. # preferences # Return locale preference list valid for the package. # loaded @@ -518,18 +516,13 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { if { ![dict exists $PackageConfig loclist $ns] } { return } # unset package locale - set loadedlocales [dict get $PackageConfig loadedlocales $ns] + set loadLocales [ListComplement\ + [dict get $PackageConfig loadedlocales $ns] $LoadedLocales] dict unset PackageConfig loadedlocales $ns dict unset PackageConfig loclist $ns - # Remove unwanted locales - foreach locale [dict keys [dict get $Msgs $ns]] { - if { $locale ni $LoadedLocales } { - dict unset Msgs $ns $locale - } - } # Add missing locales - Load $ns [ListComplement $loadedlocales $LoadedLocales] + Load $ns $loadLocales } default { return -code error "unknown subcommand \"$subcommand\": must be\ @@ -598,6 +591,9 @@ proc msgcat::mcforgetpackage {} { # unknowncmd # Use a package locale mcunknown procedure instead the global one. # The appended arguments are identical to mcunknown. +# A default unknown handler is used if set to the empty string. +# This consists in returning the key if no arguments are given. +# With given arguments, format is used to process the arguments. # # Arguments: # subcommand Operation on the package @@ -855,7 +851,11 @@ proc msgcat::Load {ns locales {callbackonly 0}} { # callback to. May be set to "" to discard the result. # # Results: -# Returns true if at least one command was called +# Possible values: +# - 0: no valid command registered +# - 1: registered command was the empty string +# - 2: registered command called, resultname is set +# If multiple commands are called, the maximum of all results is returned. proc msgcat::Invoke {index arglist {ns ""} {resultname ""}} { variable PackageConfig @@ -868,15 +868,19 @@ proc msgcat::Invoke {index arglist {ns ""} {resultname ""}} { } else { set packageList [list $ns] } - set called 0 + set ret 0 foreach ns $packageList { if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} { - set result [namespace inscope $ns\ - [dict get $PackageConfig $index $ns] {*}$arglist] - set called 1 + set cmd [dict get $PackageConfig $index $ns] + if {"" eq $cmd} { + if {$ret == 0} {set ret 1} + } else { + set result [namespace inscope $ns $cmd {*}$arglist] + set ret 2 + } } } - return $called + return $ret } # msgcat::mcset -- @@ -983,7 +987,8 @@ proc msgcat::mcflmset {pairs} { # msgcat::mcunknown -- # # This routine is called by msgcat::mc if a translation cannot -# be found for a string. This routine is intended to be replaced +# be found for a string and no unknowncmd is set for the current +# package. This routine is intended to be replaced # by an application specific routine for error reporting # purposes. The default behavior is to return the source string. # If additional args are specified, the format command will be used @@ -997,7 +1002,30 @@ proc msgcat::mcflmset {pairs} { # Results: # Returns the translated value. -proc msgcat::mcunknown {locale src args} { +proc msgcat::mcunknown {args} { + return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] +} + +# msgcat::DefaultUnknown -- +# +# This routine is called by msgcat::mc if a translation cannot +# be found for a string in the following circumstances: +# - Default global handler, if mcunknown is not redefined. +# - Per package handler, if the package sets unknowncmd to the empty +# string. +# It returna the source string if the argument list is empty. +# If additional args are specified, the format command will be used +# to work them into the traslated string. +# +# Arguments: +# locale (unused) The current locale. +# src The string to be translated. +# args Args to pass to the format command +# +# Results: +# Returns the translated value. + +proc msgcat::DefaultUnknown {locale src args} { if {[llength $args]} { return [format $src {*}$args] } else { |