diff options
Diffstat (limited to 'tools/tclZIC.tcl')
| -rwxr-xr-x | tools/tclZIC.tcl | 1440 |
1 files changed, 1440 insertions, 0 deletions
diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl new file mode 100755 index 0000000..e6bbb5a --- /dev/null +++ b/tools/tclZIC.tcl @@ -0,0 +1,1440 @@ +#---------------------------------------------------------------------- +# +# tclZIC.tcl -- +# +# Take the time zone data source files from Arthur Olson's +# repository at elsie.nci.nih.gov, and prepare time zone +# information files for Tcl. +# +# Usage: +# tclsh tclZIC.tcl inputDir outputDir +# +# Parameters: +# inputDir - Directory (e.g., tzdata2003e) where Olson's source +# files are to be found. +# outputDir - Directory (e.g., ../library/clock/tzdata) where +# the time zone information files are to be placed. +# +# Results: +# May produce error messages on the standard error. An exit +# code of zero denotes success; any other exit code is failure. +# +# This program parses the timezone data in a means analogous to the +# 'zic' command, and produces Tcl time zone information files suitable +# for loading into the 'clock' namespace. +# +#---------------------------------------------------------------------- +# +# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tclZIC.tcl,v 1.1 2004/08/18 19:59:09 kennykb Exp $ +# +#---------------------------------------------------------------------- + +# Define the names of the Olson files that we need to load. +# We avoid the solar time files and the leap seconds. + +set olsonFiles { + africa antarctica asia australasia + backward etcetera europe northamerica + pacificnew southamerica systemv +} + +# Temporary scaffolding - load up the new 'clock' package. + +source [file join [file dirname [info script]] .. library clock.tcl] + +# Define the year at which the DST information will stop. + +set maxyear 2100 + +# Determine how big a wide integer is. + +set MAXWIDE [expr { wide(1) }] +while 1 { + set next [expr { $MAXWIDE + $MAXWIDE + 1}] + if { $next < 0 } { + break + } + set MAXWIDE $next +} +set MINWIDE [expr { - $MAXWIDE - 1 }] + +#---------------------------------------------------------------------- +# +# K -- +# +# The K combinator returns its first argument. It's used for +# reference count management. +# +# Parameters: +# x - Argument to be unreferenced. +# y - Unused. +# +# Results: +# Returns the first argument. +# +# Side effects: +# None. +# +# The K combinator is used for its effect that [K $x [set x {}]] +# reads out the value of x destructively, giving an unshared Tcl +# object and avoiding 'copy on write' +# +#---------------------------------------------------------------------- + +proc K {x y} {return $x} + +#---------------------------------------------------------------------- +# +# loadFiles -- +# +# Loads the time zone files for each continent into memory +# +# Parameters: +# dir - Directory where the time zone source files are found +# +# Results: +# None. +# +# Side effects: +# Calls 'loadZIC' for each continent's data file in turn. +# Reports progress on stdout. +# +#---------------------------------------------------------------------- + +proc loadFiles { dir } { + variable olsonFiles + foreach file $olsonFiles { + puts "loading: [file join $dir $file]" + loadZIC [file join $dir $file] + } + return +} + +#---------------------------------------------------------------------- +# +# checkForwardRuleRefs -- +# +# Checks to make sure that all references to Daylight Saving +# Time rules designate defined rules. +# +# Parameters: +# None. +# +# Results: +# None. +# +# Side effects: +# Produces an error message and increases the error count if +# any undefined rules are present. +# +#---------------------------------------------------------------------- + +proc checkForwardRuleRefs {} { + variable forwardRuleRefs + variable rules + foreach { rule where } [array get forwardRuleRefs] { + if { ![info exists rules($rule)] } { + foreach { fileName lno } $where { + puts stderr "$fileName:$lno:can't locate rule \"$rule\"" + incr errorCount + } + } + } +} + +#---------------------------------------------------------------------- +# +# loadZIC -- +# +# Load one continent's data into memory. +# +# Parameters: +# fileName -- Name of the time zone source file. +# +# Results: +# None. +# +# Side effects: +# The global variable, 'errorCount' counts the number of errors. +# The global array, 'links', contains a distillation of the +# 'Link' directives in the file. The keys are 'links to' and +# the values are 'links from'. The 'parseRule' and 'parseZone' +# procedures are called to handle 'Rule' and 'Zone' directives. +# +#---------------------------------------------------------------------- + +proc loadZIC { fileName } { + + variable errorCount + variable links + + # Suck the text into memory. + + set f [open $fileName r] + set data [read $f] + close $f + + # Break the input into lines, and count line numbers. + + set lno 0 + foreach line [split $data \n] { + incr lno + + # Break a line of input into words. + + regsub {[[:space:]]*(\#.*)?$} $line {} line + if { $line eq {} } { + continue + } + set words {} + if { [regexp {^[[:space:]]+(.*)} $line -> l] } { + lappend words {} + set line $l + } + while {[regexp {^([^[:space:]]+)[[:space:]]*(.*)} $line -> \ + word line]} { + lappend words $word + } + + # Switch on the directive + + switch -exact -- [lindex $words 0] { + Rule { + parseRule $fileName $lno $words + } + Link { + set links([lindex $words 2]) [lindex $words 1] + } + Zone { + set lastZone [lindex $words 1] + set until [parseZone $fileName $lno \ + $lastZone [lrange $words 2 end] minimum] + } + {} { # Continuation of a Zone + set i 0 + foreach word $words { + if { [lindex $words $i] ne {} } break + incr i + } + set words [lrange $words $i end] + set until [parseZone $fileName $lno $lastZone $words $until] + } + default { + incr errorCount + puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\"" + } + } + } + + return + +} + +#---------------------------------------------------------------------- +# +# parseRule -- +# +# Parses a Rule directive in an Olson file. +# +# Parameters: +# fileName -- Name of the file being parsed. +# lno - Line number within the file +# words - The line itself, broken into words. +# +# Results: +# None. +# +# Side effects: +# The rule is analyzed and added to the 'rules' array. +# Errors are reported and counted. +# +#---------------------------------------------------------------------- + +proc parseRule { fileName lno words } { + + variable rules + variable errorCount + + # Break out the columns + + foreach { Rule name from to type in on at save letter } $words {} + + # Handle the 'only' keyword + + if { $to eq {only} } { + set to $from + } + + # Process the start year + + set l [string length $from] + if { ![string is integer $from] } { + if { $from ne [string range {minumum} 0 [expr { $l - 1 }]] } { + puts stderr "$fileName:$lno:FROM field \"$from\" not an integer." + incr errorCount + return + } else { + set from minimum + } + } + + # Process the end year + + set l [string length $to] + if { ![string is integer $to] } { + if { $to ne [string range {maximum} 0 [expr { $l - 1 }]] } { + puts stderr "$fileName:$lno:TO field \"$to\" not an integer." + incr errorCount + return + } else { + set to maximum + } + } + + # Process the type of year in which the rule applies + + if { $type ne {-} } { + puts stderr "$fileName:$lno:year types are not yet supported." + incr errorCount + return + } + + # Process the month in which the rule starts + + if { [catch {lookupMonth $in} in] } { + puts stderr "$fileName:$lno:$in" + incr errorCount + return + } + + # Process the day of the month on which the rule starts + + if { [catch {parseON $on} on] } { + puts stderr "$fileName:$lno:$on" + incr errorCount + return + } + + # Process the time of day on which the rule starts + + if { [catch {parseTOD $at} at] } { + puts stderr "$fileName:$lno:$at" + incr errorCount + return + } + + # Process the DST adder + + if { [catch {parseOffsetTime $save} save] } { + puts stderr "$fileName:$lno:$save" + incr errorCount + return + } + + # Process the letter to use for summer time + + if { $letter eq {-} } { + set letter {} + } + + # Accumulate all the data. + + lappend rules($name) $from $to $type $in $on $at $save $letter + return + +} + +#---------------------------------------------------------------------- +# +# parseON -- +# +# Parse a specification for a day of the month +# +# Parameters: +# on - the ON field from a line in an Olson file. +# +# Results: +# Returns a partial Tcl command. When the year and number of the +# month are appended, the command will return the Julian Day Number +# of the desired date. +# +# Side effects: +# None. +# +# The specification can be: +# - a simple number, which designates a constant date. +# - The name of a weekday, followed by >= or <=, followed by a number. +# This designates the nearest occurrence of the given weekday on +# or before (on or after) the given day of the month. +# - The word 'last' followed by a weekday name with no intervening +# space. This designates the last occurrence of the given weekday +# in the month. +# +#---------------------------------------------------------------------- + +proc parseON { on } { + if { ! [regexp -expanded { + ^(?: + # first possibility - simple number - field 1 + ([[:digit:]]+) + | + # second possibility - weekday >= (or <=) number + # field 2 - weekday + ([[:alpha:]]+) + # field 3 - direction + ([<>]=) + # field 4 - number + ([[:digit:]]+) + | + # third possibility - lastWeekday - field 5 + last([[:alpha:]]+) + )$ + } $on -> dom1 wday2 dir2 num2 wday3] } { + error "can't parse ON field \"$on\"" + } + if { $dom1 ne {} } { + return [list onDayOfMonth $dom1] + } elseif { $wday2 ne {} } { + set wday2 [lookupDayOfWeek $wday2] + return [list onWeekdayInMonth $wday2 $dir2 $num2] + } elseif { $wday3 ne {} } { + set wday3 [lookupDayOfWeek $wday3] + return [list onLastWeekdayInMonth $wday3] + } else { + error "in parseOn \"$on\": can't happen" + } +} + +#---------------------------------------------------------------------- +# +# onDayOfMonth -- +# +# Find a given day of a given month +# +# Parameters: +# day - Day of the month +# year - Gregorian year +# month - Number of the month (1-12) +# +# Results: +# Returns the Julian Day Number of the desired day. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc onDayOfMonth { day year month } { + set date [dict create era CE year $year month $month dayOfMonth $day] + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ + [K $date [set date {}]]] + return [dict get $date julianDay] +} + +#---------------------------------------------------------------------- +# +# onWeekdayInMonth -- +# +# Find the weekday falling on or after (on or before) a +# given day of the month +# +# Parameters: +# dayOfWeek - Day of the week (Monday=1, Sunday=7) +# relation - <= for the weekday on or before a given date, >= for +# the weekday on or after the given date. +# dayOfMonth - Day of the month +# year - Gregorian year +# month - Number of the month (1-12) +# +# Results: +# Returns the Juloan Day Number of the desired day. +# +# Side effects: +# None. +# +# onWeekdayInMonth is used to compute Daylight Saving Time rules +# like 'Sun>=1' (for the nearest Sunday on or after the first of the month) +# or "Mon<=4' (for the Monday on or before the fourth of the month). +# +#---------------------------------------------------------------------- + +proc onWeekdayInMonth { dayOfWeek relation dayOfMonth year month } { + set date [dict create \ + era CE year $year month $month dayOfMonth $dayOfMonth] + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ + [K $date [set date {}]]] + switch -exact -- $relation { + <= { + return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ + [dict get $date julianDay]] + } + >= { + return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ + [expr { [dict get $date julianDay] + 6 }]] + } + } +} + +#---------------------------------------------------------------------- +# +# onLastWeekdayInMonth -- +# +# Find the last instance of a given weekday in a month. +# +# Parameters: +# dayOfWeek - Weekday to find (Monday=1, Sunday=7) +# year - Gregorian year +# month - Month (1-12) +# +# Results: +# Returns the Julian Day number of the last instance of +# the given weekday in the given month +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc onLastWeekdayInMonth { dayOfWeek year month } { + incr month + # Find day 0 of the following month, which is the last day of + # the current month. Yes, it works to ask for day 0 of month 13! + set date [dict create \ + era CE year $year month $month dayOfMonth 0] + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ + [K $date [set date {}]]] + return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ + [dict get $date julianDay]] +} + +#---------------------------------------------------------------------- +# +# parseTOD -- +# +# Parses the specification of a time of day in an Olson file. +# +# Parameters: +# tod - Time of day, which may be followed by 'w', 's', 'u', 'g' +# or 'z'. 'w' (or no letter) designates a wall clock time, +# 's' designates Standard Time in the given zone, and +# 'u', 'g', and 'z' all designate UTC. +# +# Results: +# Returns a two element list containing a count of seconds from +# midnight and the letter that followed the time. +# +# Side effects: +# Reports and counts an error if the time cannot be parsed. +# +#---------------------------------------------------------------------- + +proc parseTOD { tod } { + if { ![regexp -expanded { + ^ + # field 1 - hour + ([[:digit:]]{1,2}) + (?: + # field 2 - minute + :([[:digit:]]{2}) + (?: + # field 3 - second + :([[:digit:]]{2}) + )? + )? + (?: + # field 4 - type indicator + ([wsugz]) + )? + } $tod -> hour minute second ind] } { + puts stderr "$fileName:$lno:can't parse time field \"$tod\"" + incr errorCount + } + scan $hour %d hour + if { $minute ne {} } { + scan $minute %d minute + } else { + set minute 0 + } + if { $second ne {} } { + scan $second %d second + } else { + set second 0 + } + if { $ind eq {} } { + set ind w + } + return [list [expr { ( $hour * 60 + $minute ) * 60 + $second }] $ind] +} + +#---------------------------------------------------------------------- +# +# parseOffsetTime -- +# +# Parses the specification of an offset time in an Olson file. +# +# Parameters: +# offset - Offset time as [+-]hh:mm:ss +# +# Results: +# Returns the offset time as a count of seconds. +# +# Side effects: +# Reports and counts an error if the time cannot be parsed. +# +#---------------------------------------------------------------------- + +proc parseOffsetTime { offset } { + if { ![regexp -expanded { + ^ + # field 1 - signum + ([-+])? + # field 2 - hour + ([[:digit:]]{1,2}) + (?: + # field 3 - minute + :([[:digit:]]{2}) + (?: + # field 4 - second + :([[:digit:]]{2}) + )? + )? + } $offset -> signum hour minute second] } { + puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" + incr errorCount + } + append signum 1 + scan $hour %d hour + if { $minute ne {} } { + scan $minute %d minute + } else { + set minute 0 + } + if { $second ne {} } { + scan $second %d second + } else { + set second 0 + } + return [expr { ( ( $hour * 60 + $minute ) * 60 + $second ) * $signum }] + +} + +#---------------------------------------------------------------------- +# +# lookupMonth - +# Looks up a month by name +# +# Parameters: +# month - Name of a month. +# +# Results: +# Returns the number of the month. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc lookupMonth { month } { + + set indx [lsearch -regexp { + {} January February March April May June + July August September October November December + } ${month}.*] + if { $indx < 1 } { + error "unknown month name \"$month\"" + } + return $indx +} + +#---------------------------------------------------------------------- +# +# lookupDayOfWeek -- +# +# Looks up the name of a weekday. +# +# Parameters: +# wday - Weekday name (or a unique prefix). +# +# Results: +# Returns the weekday number (Monday=1, Sunday=7) +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc lookupDayOfWeek { wday } { + set indx [lsearch -regexp { + {} Monday Tuesday Wednesday Thursday Friday Saturday Sunday + } ${wday}.*] + if { $indx < 1 } { + error "unknown weekday name \"$wday\"" + } + return $indx +} + +#---------------------------------------------------------------------- +# +# parseZone -- +# +# Parses a Zone directive in an Olson file +# +# Parameters: +# fileName -- Name of the file being parsed. +# lno -- Line number within the file. +# zone -- Name of the time zone +# words -- Remaining words on the line. +# start -- 'Until' time from the previous line if this is a +# continuation line, or 'minimum' if this is the first line. +# +# Results: +# Returns the 'until' field of the current line +# +# Side effects: +# Stores a row in the 'zones' array describing the current zone. +# The row consists of a start time (year month day tod), a Standard +# Time offset from Greenwich, a Daylight Saving Time offset from +# Standard Time, and a format for printing the time zone. +# +# The start time is the result of an earlier call to 'parseUntil' +# or else the keyword 'minimum'. The GMT offset is the +# result of a call to 'parseOffsetTime'. The Daylight Saving +# Time offset is represented as a partial Tcl command. To the +# command will be appended a start time (seconds from epoch) +# the current offset of Standard Time from Greenwich, the current +# offset of Daylight Saving Time from Greenwich, the default +# offset from this line, the name pattern from this line, +# the 'until' field from this line, and a variable name where points +# are to be stored. This command is implemented by the 'applyNoRule', +# 'applyDSTOffset' and 'applyRules' procedures. +# +#---------------------------------------------------------------------- + +proc parseZone { fileName lno zone words start } { + variable zones + variable rules + variable errorCount + variable forwardRuleRefs + foreach { gmtoff save format } $words break + if { [catch {parseOffsetTime $gmtoff} gmtoff] } { + puts stderr "$fileName:$lno:$gmtoff" + incr errorCount + return + } + if { [info exists rules($save)] } { + set save [list applyRules $save] + } elseif { $save eq {-} } { + set save [list applyNoRule] + } else { + if { [catch { parseOffsetTime $save } save2] } { + lappend forwardRuleRefs($save) $fileName $lno + set save [list applyRules $save] + } else { + set save [list applyDSTOffset $save2] + } + } + lappend zones($zone) $start $gmtoff $save $format + if { [llength $words] >= 4 } { + return [parseUntil [lrange $words 3 end]] + } else { + return {} + } +} + +#---------------------------------------------------------------------- +# +# parseUntil -- +# +# Parses the 'UNTIL' part of a 'Zone' directive. +# +# Parameters: +# words - The 'UNTIL' part of the directie. +# +# Results: +# Returns a list comprising the year, the month, the day, and +# the time of day. Time of day is represented as the result of +# 'parseTOD'. +# +#---------------------------------------------------------------------- + +proc parseUntil { words } { + variable firstYear + if { [llength $words] >= 1 } { + set year [lindex $words 0] + if { ![string is integer $year] } { + error "can't parse UNTIL field \"$words\"" + } + if { ![info exists firstYear] || $year < $firstYear } { + set firstYear $year + } + } else { + set year maximum + } + if { [llength $words] >= 2 } { + set month [lookupMonth [lindex $words 1]] + } else { + set month 1 + } + if { [llength $words] >= 3 } { + set day [parseON [lindex $words 2]] + } else { + set day {onDayOfMonth 1} + } + if { [llength $words] >= 4 } { + set tod [parseTOD [lindex $words 3]] + } else { + set tod {0 w} + } + return [list $year $month $day $tod] +} + +#---------------------------------------------------------------------- +# +# applyNoRule -- +# +# Generates time zone data for a zone without Daylight Saving +# Time. +# +# Parameters: +# year - Year in which the rule applies +# startSecs - Time at which the rule starts. +# stdGMTOffset - Offset from Greenwich prior to the start of the +# rule +# DSTOffset - Offset of Daylight from Standard prior to the +# start of the rule. +# nextGMTOffset - Offset from Greenwich when the rule is in effect. +# namePattern - Name of the timezone. +# until - Time at which the rule expires. +# pointsVar - Name of a variable in callers scope that receives +# transition times +# +# Results: +# Returns a two element list comprising 'nextGMTOffset' and +# 0 - the zero indicates that Daylight Saving Time is not +# in effect. +# +# Side effects: +# Appends a row to the 'points' variable comprising the start time, +# the offset from GMT, a zero (indicating that DST is not in effect), +# and the name of the time zone. +# +#---------------------------------------------------------------------- + +proc applyNoRule { year startSecs stdGMTOffset DSTOffset nextGMTOffset + namePattern until pointsVar } { + upvar 1 $pointsVar points + lappend points $startSecs $nextGMTOffset 0 \ + [convertNamePattern $namePattern -] + return [list $nextGMTOffset 0] + +} + +#---------------------------------------------------------------------- +# +# applyNoRule -- +# +# Generates time zone data for a zone with permanent Daylight +# Saving Time. +# +# Parameters: +# nextDSTOffset - Offset of Daylight from Standard while the +# rule is in effect. +# year - Year in which the rule applies +# startSecs - Time at which the rule starts. +# stdGMTOffset - Offset from Greenwich prior to the start of the +# rule +# DSTOffset - Offset of Daylight from Standard prior to the +# start of the rule. +# nextGMTOffset - Offset from Greenwich when the rule is in effect. +# namePattern - Name of the timezone. +# until - Time at which the rule expires. +# pointsVar - Name of a variable in callers scope that receives +# transition times +# +# Results: +# Returns a two element list comprising 'nextGMTOffset' and +# 'nextDSTOffset'. +# +# Side effects: +# Appends a row to the 'points' variable comprising the start time, +# the offset from GMT, a one (indicating that DST is in effect), +# and the name of the time zone. +# +#---------------------------------------------------------------------- + +proc applyDSTOffset { nextDSTOffset year startSecs + stdGMTOffset DSTOffset nextGMTOffset + namePattern until pointsVar } { + upvar 1 $pointsVar points + lappend points \ + $startSecs \ + [expr { $nextGMTOffset + $nextDSTOffset }] \ + 1 \ + [convertNamePattern $namePattern S] + return [list $nextGMTOffset $nextDSTOffset] +} + +#---------------------------------------------------------------------- +# +# applyRules -- +# +# Applies a rule set to a time zone for a given range of time +# +# Parameters: +# ruleSet - Name of the rule set to apply +# year - Starting year for the rules +# startSecs - Time at which the rules begin to apply +# stdGMTOffset - Offset from Greenwich prior to the start of the +# rules. +# DSTOffset - Offset of Daylight from Standard prior to the +# start of the rules. +# nextGMTOffset - Offset from Greenwich when the rules are in effect. +# namePattern - Name pattern for the time zone. +# until - Time at which the rule set expires. +# pointsVar - Name of a variable in callers scope that receives +# transition times +# +# Results: +# Returns a two element list comprising the offset from GMT +# to Standard and the offset from Standard to Daylight (if DST +# is in effect) at the end of the period in which the rules apply +# +# Side effects: +# Appends one or more rows to the 'points' variable, each of which +# comprises a transition time, the offset from GMT that is +# in effect after the transition, a flag for whether DST is in +# effect, and the name of the time zone. +# +#---------------------------------------------------------------------- + +proc applyRules { ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset \ + namePattern until pointsVar } { + variable done + variable rules + variable maxyear + + upvar 1 $pointsVar points + + # Extract the rules that apply to the current year, and the number + # of rules (now or in future) that will end at a specific year. + # Ignore rules entirely in the past. + + foreach { + currentRules nSunsetRules + } [divideRules $ruleSet $year] break + + # If the first transition is later than $startSecs, and $stdGMTOffset is + # different from $nextGMTOffset, we will need an initial record like: + # lappend points $startSecs $stdGMTOffset 0 \ + # [convertNamePattern $namePattern -] + + set didTransitionIn false + + # Determine the letter to use in Standard Time + + set prevLetter {} + foreach { + fromYear toYear yearType monthIn daySpecOn timeAt save letter + } $rules($ruleSet) { + if { $save == 0 } { + set prevLetter $letter + break + } + } + + # Walk through each year in turn. This loop will break when + # (a) the 'until' time is passed + # or (b) the 'until' time is empty and all remaining rules extend to + # the end of time + + set stdGMTOffset $nextGMTOffset + + # convert "until" to seconds from epoch in current time zone + + if { $until ne {} } { + foreach { + untilYear untilMonth untilDaySpec untilTimeOfDay + } $until break + lappend untilDaySpec $untilYear $untilMonth + set untilJCD [eval $untilDaySpec] + set untilBaseSecs [expr { + wide(86400) * wide($untilJCD) + - $::tcl::clock::PosixEpochAsJulianSeconds }] + set untilSecs [eval [linsert $untilTimeOfDay 0 convertTimeOfDay \ + $untilBaseSecs $stdGMTOffset $DSTOffset]] + } + + set origStartSecs $startSecs + + while { ( $until ne {} && + $startSecs < $untilSecs ) + || ( $until eq {} && + ( $nSunsetRules > 0 || $year < $maxyear ) ) } { + + set remainingRules $currentRules + while { [llength $remainingRules] > 0 } { + + + # Find the rule with the earliest start time from among the + # active rules that haven't yet been processed. + + foreach { + earliestSecs earliestIndex + } [findEarliestRule $remainingRules $year \ + $stdGMTOffset $DSTOffset] break + + set endi [expr {$earliestIndex + 7}] + set rule [lrange $remainingRules $earliestIndex $endi] + foreach { + fromYear toYear yearType monthIn daySpecOn timeAt save letter + } $rule break + + # Test if the rule is in effect. + + if { $earliestSecs > $startSecs && + ( $until eq {} || $earliestSecs < $untilSecs ) } { + + # Test if the initial transition has been done. + # If not, do it now. + + if { !$didTransitionIn && $earliestSecs > $origStartSecs } { + set nm [convertNamePattern $namePattern $prevLetter] + lappend points \ + $origStartSecs \ + [expr { $stdGMTOffset + $DSTOffset }] \ + 0 \ + $nm + set didTransitionIn true + } + + # Add a row to 'points' for the rule + + set nm [convertNamePattern $namePattern $letter] + lappend points \ + $earliestSecs \ + [expr { $stdGMTOffset + $save }] \ + [expr { $save != 0 }] \ + $nm + } + + # Remove the rule just applied from the queue + + set remainingRules [lreplace \ + [K $remainingRules \ + [set remainingRules {}]] \ + $earliestIndex $endi] + + # Update current DST offset and time zone letter + + set DSTOffset $save + set prevLetter $letter + + # Reconvert the 'until' time in the current zone. + + if { $until ne {} } { + set untilSecs [eval [linsert $untilTimeOfDay 0 \ + convertTimeOfDay $untilBaseSecs \ + $stdGMTOffset $DSTOffset]] + } + } + + # Advance to the next year + + incr year + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ + [dict create era CE year $year month 1 dayOfMonth 1]] + set startSecs [expr { [dict get $date julianDay] * wide(86400) \ + - $::tcl::clock::PosixEpochAsJulianSeconds }] + set startSecs [expr { $startSecs - $stdGMTOffset - $DSTOffset }] + + + # Get rules in effect in the new year. + + foreach { + currentRules nSunsetRules + } [divideRules $ruleSet $year] break + + } + + return [list $stdGMTOffset $DSTOffset] +} + +#---------------------------------------------------------------------- +# +# divideRules -- +# Determine what Daylight Saving Time rules may be in effect in +# a given year. +# +# Parameters: +# ruleSet - Set of rules from 'parseRule' +# year - Year to test +# +# Results: +# Returns a two element list comprising the subset of 'ruleSet' +# that is in effect in the given year, and the count of rules +# that expire in the future (as opposed to those that expire in +# the past or not at all). If this count is zero, the rules do +# not change in future years. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc divideRules { ruleSet year } { + + variable rules + + set currentRules {} + set nSunsetRules 0 + + foreach { + fromYear toYear yearType monthIn daySpecOn timeAt save letter + } $rules($ruleSet) { + if { $toYear ne {maximum} && $year > $toYear } { + # ignore - rule is in the past + } else { + if { $fromYear eq {minimum} || $fromYear <= $year } { + lappend currentRules $fromYear $toYear $yearType $monthIn \ + $daySpecOn $timeAt $save $letter + } + if { $toYear ne {maximum} } { + incr nSunsetRules + } + } + } + + return [list $currentRules $nSunsetRules] + +} + +#---------------------------------------------------------------------- +# +# findEarliestRule -- +# +# Find the rule in a rule set that has the earliest start time. +# +# Parameters: +# remainingRules -- Rules to search +# year - Year being processed. +# stdGMTOffset - Current offset of standard time from GMT +# DSTOffset - Current offset of daylight time from standard, +# if daylight time is in effect. +# +# Results: +# Returns the index in remainingRules of the next rule to +# go into effect. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc findEarliestRule { remainingRules year stdGMTOffset DSTOffset } { + + set earliest $::MAXWIDE + set i 0 + foreach { + fromYear toYear yearType monthIn daySpecOn timeAt save letter + } $remainingRules { + lappend daySpecOn $year $monthIn + set dayIn [eval $daySpecOn] + set secs [expr { + wide(86400) * wide($dayIn) + - $::tcl::clock::PosixEpochAsJulianSeconds }] + set secs [eval [linsert $timeAt 0 convertTimeOfDay \ + $secs $stdGMTOffset $DSTOffset]] + if { $secs < $earliest } { + set earliest $secs + set earliestIdx $i + } + incr i 8 + } + + return [list $earliest $earliestIdx] + +} + +#---------------------------------------------------------------------- +# +# convertNamePattern -- +# +# Converts a name pattern to the name of the time zone. +# +# Parameters: +# pattern - Patthern to convert +# flag - Daylight Time flag. An empty string denotes Standard +# Time, anything else is Daylight Time. +# +# Results; +# Returns the name of the time zone. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc convertNamePattern { pattern flag } { + if { [regexp {(.*)/(.*)} $pattern -> standard daylight] } { + if { $flag ne {} } { + set pattern $daylight + } else { + set pattern $standard + } + } + return [string map [list %s $flag] $pattern] +} + +#---------------------------------------------------------------------- +# +# convertTimeOfDay -- +# +# Takes a time of day specifier from 'parseAt' and converts +# to seconds from the Epoch, +# +# Parameters: +# seconds -- Time at which the GMT day starts, in seconds +# from the Posix epoch +# stdGMTOffset - Offset of Standard Time from Greenwich +# DSTOffset - Offset of Daylight Time from standard. +# timeOfDay - Time of day to convert, in seconds from midnight +# flag - Flag indicating whether the time is Greenwich, Standard +# or wall-clock. (g, s, or w) +# +# Results: +# Returns the time of day in seconds from the Posix epoch. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc convertTimeOfDay { seconds stdGMTOffset DSTOffset timeOfDay flag } { + incr seconds $timeOfDay + switch -exact $flag { + g - u - z { + } + w { + incr seconds [expr { -$stdGMTOffset }] + incr seconds [expr { -$DSTOffset }] + } + z { + incr seconds [expr { -$stdGMTOffset }] + } + } + return $seconds +} + +#---------------------------------------------------------------------- +# +# processTimeZone -- +# +# Generate the information about all time transitions in a +# time zone. +# +# Parameters: +# zoneName - Name of the time zone +# zoneData - List containing the rows describing the time zone, +# obtained from 'parseZone. +# +# Results: +# Returns a list of rows. Each row consists of a time in +# seconds from the Posix epoch, an offset from GMT to local +# that begins at that time, a flag indicating whether DST +# is in effect after that time, and the printable name of the +# timezone that goes into effect at that time. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc processTimeZone { zoneName zoneData } { + + set points {} + set i 0 + foreach { startTime nextGMTOffset dstRule namePattern } $zoneData { + incr i 4 + set until [lindex $zoneData $i] + if {! [info exists stdGMTOffset] } { + set stdGMTOffset $nextGMTOffset + } + if {! [info exists DSTOffset] } { + set DSTOffset 0 + } + if { $startTime eq {minimum} } { + set secs $::MINWIDE + set year 0 + } else { + foreach { year month dayRule timeOfDay } $startTime break + lappend dayRule $year $month + set startDay [eval $dayRule] + set secs [expr { + wide(86400) * wide($startDay) + - $::tcl::clock::PosixEpochAsJulianSeconds}] + set secs [eval [linsert $timeOfDay 0 convertTimeOfDay \ + $secs $stdGMTOffset $DSTOffset]] + } + lappend dstRule \ + $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \ + $namePattern $until points + foreach {stdGMTOffset DSTOffset} [eval $dstRule] break + } + return $points +} + +#---------------------------------------------------------------------- +# +# writeZones -- +# +# Writes all the time zone information files. +# +# Parameters: +# outDir - Directory in which to store the files. +# +# Results: +# None. +# +# Side effects: +# Writes the time zone information files; traces what's happening +# on the standard output. +# +#---------------------------------------------------------------------- + +proc writeZones { outDir } { + + variable zones + + # Walk the zones + + foreach zoneName [lsort -dictionary [array names zones]] { + puts "calculating: $zoneName" + set fileName [eval [list file join $outDir] [file split $zoneName]] + + # Create directories as needed + + set dirName [file dirname $fileName] + if { ![file exists $dirName] } { + puts "creating directory: $dirName" + file mkdir $dirName + } + + # Generate data for a zone + + set data {} + foreach { + time offset dst name + } [processTimeZone $zoneName $zones($zoneName)] { + append data \n { } [list [list $time $offset $dst $name]] + } + append data \n + + # Write the data to the information file + + set f [open $fileName w] + puts $f "\# created by $::argv0 - do not edit" + puts $f {} + puts $f [list set TZData(:$zoneName) $data] + close $f + + } + + return +} + +#---------------------------------------------------------------------- +# +# writeLinks -- +# +# Write files describing time zone synonyms (the Link directives +# from the Olson files) +# +# Parameters: +# outDir - Name of the directory where the output files go. +# +# Results: +# None. +# +# Side effects: +# Creates a file for each link. + +proc writeLinks { outDir } { + + variable links + + # Walk the links + + foreach zoneName [lsort -dictionary [array names links]] { + puts "creating link: $zoneName" + set fileName [eval [list file join $outDir] [file split $zoneName]] + + # Create directories as needed + + set dirName [file dirname $fileName] + if { ![file exists $dirName] } { + puts "creating directory: $dirName" + file mkdir $dirName + } + + # Create code for the synonym + + set linkTo $links($zoneName) + set sourceCmd "\n [list loadTimeZoneFile $linkTo]\n" + set ifCmd [list if "!\[info exists TZData($linkTo)\]" $sourceCmd] + set setCmd "set tzdata(:$zoneName) \$TZData(:$linkTo)" + + # Write the file + + set f [open $fileName w] + puts $f "\# created by $::argv0 - do not edit" + puts $f $ifCmd + puts $f $setCmd + close $f + } + + return +} + +#---------------------------------------------------------------------- +# +# MAIN PROGRAM +# +#---------------------------------------------------------------------- + +# Determine directories + +foreach { inDir outDir } $argv break + +# Initialize count of errors + +set errorCount 0 + +# Parse the Olson files + +loadFiles $inDir +if { $errorCount > 0 } { + exit 1 +} + +# Check that all riles appearing in Zone and Link lines actually exist + +checkForwardRuleRefs +if { $errorCount > 0 } { + exit 1 +} + +# Write the time zone information files + +writeZones $outDir +writeLinks $outDir +if { $errorCount > 0 } { + exit 1 +} + +# All done! + +exit
\ No newline at end of file |