summaryrefslogtreecommitdiffstats
path: root/tools/tclZIC.tcl
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
committerKevin B Kenny <kennykb@acm.org>2004-08-18 19:58:56 (GMT)
commitfab56e2415bbbc5e2355f500b28d26c5e907ef29 (patch)
tree0bfbd9e68acb81b08b317b956ce8ac4cca0824cd /tools/tclZIC.tcl
parentdcdb6368302f0bb38e0d11e8c2d346b684507b07 (diff)
downloadtcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.zip
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.gz
tcl-fab56e2415bbbc5e2355f500b28d26c5e907ef29.tar.bz2
TIP #173 and #209 implementation - see ChangeLog for details
Diffstat (limited to 'tools/tclZIC.tcl')
-rwxr-xr-xtools/tclZIC.tcl1440
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