summaryrefslogtreecommitdiffstats
path: root/tools
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
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')
-rw-r--r--tools/installData.tcl53
-rwxr-xr-xtools/loadICU.tcl622
-rwxr-xr-xtools/makeTestCases.tcl1154
-rwxr-xr-xtools/tclZIC.tcl1440
4 files changed, 3269 insertions, 0 deletions
diff --git a/tools/installData.tcl b/tools/installData.tcl
new file mode 100644
index 0000000..cf067a3
--- /dev/null
+++ b/tools/installData.tcl
@@ -0,0 +1,53 @@
+#!/bin/sh
+#\
+ exec tclsh "$0" ${1+"$@"}
+
+#----------------------------------------------------------------------
+#
+# installData.tcl --
+#
+# This file installs a hierarchy of data found in the directory
+# specified by its first argument into the directory specified
+# by its second.
+#
+#----------------------------------------------------------------------
+#
+# 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: installData.tcl,v 1.1 2004/08/18 19:59:09 kennykb Exp $
+#
+#----------------------------------------------------------------------
+
+proc copyDir { d1 d2 } {
+
+ puts [format {%*sCreating %s} [expr { 4 * [info level] }] {} \
+ [file tail $d2]]
+
+ file delete -force -- $d2
+ file mkdir $d2
+
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if { [file isdirectory $f] && [string compare CVS $ftail] } {
+ copyDir $f [file join $d2 $ftail]
+ } elseif { [file isfile $f] } {
+ file copy -force $f [file join $d2 $ftail]
+ if { $::tcl_platform(platform) eq {unix} } {
+ file attributes [file join $d2 $ftail] -permissions 0644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if { $::tcl_platform(platform) eq {unix} } {
+ file attributes $d2 -permissions 0755
+ } else {
+ file attributes $d2 -readonly 1
+ }
+
+}
+
+copyDir [lindex $argv 0] [lindex $argv 1]
diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl
new file mode 100755
index 0000000..a41a8dc
--- /dev/null
+++ b/tools/loadICU.tcl
@@ -0,0 +1,622 @@
+#----------------------------------------------------------------------
+#
+# loadICU,tcl --
+#
+# Extracts locale strings from a distribution of ICU
+# (http://oss.software.ibm.com/developerworks/opensource/icu/project/)
+# and makes Tcl message catalogs for the 'clock' command.
+#
+# Usage:
+# loadICU.tcl sourceDir destDir
+#
+# Parameters:
+# sourceDir -- Path name of the 'data' directory of your ICU4C
+# distribution.
+# destDir -- Directory into which the Tcl message catalogs should go.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Creates the message catalogs.
+#
+#----------------------------------------------------------------------
+#
+# 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: loadICU.tcl,v 1.1 2004/08/18 19:59:09 kennykb Exp $
+#
+#----------------------------------------------------------------------
+
+# Calculate the Chinese numerals from zero to ninety-nine.
+
+set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
+ \u4e94 \u516d \u4e03 \u516b \u4e5d]
+set t 0
+foreach zt $zhDigits {
+ if { $t == 0 } {
+ set zt {}
+ } elseif { $t == 10 } {
+ set zt \u5341
+ } else {
+ append zt \u5341
+ }
+ set d 0
+ foreach zd $zhDigits {
+ if { $t == 0 && $d == 0 } {
+ set zd \u3007
+ } elseif { $t == 20 && $d != 0 } {
+ set zt \u5eff
+ } elseif { $t == 30 && $d != 0 } {
+ set zt \u5345
+ }
+ lappend zhNumbers $zt$zd
+ incr d
+ }
+ incr t 10
+}
+
+# Set format overrides for various locales.
+
+set format(zh,LOCALE_NUMERALS) $zhNumbers
+set format(ja,LOCALE_NUMERALS) $zhNumbers
+set format(ja,LOCALE_ERAS) [list \
+ [list -9223372036854775808 \u897f\u66a6 0 ] \
+ [list -3060979200 \u660e\u6cbb 1867] \
+ [list -1812153600 \u5927\u6b63 1911] \
+ [list -1357603200 \u662d\u548c 1925] \
+ [list 568512000 \u5e73\u6210 1987]]
+set format(zh,LOCALE_DATE_FORMAT) "\u516c\u5143%Y\u5e74%B%Od\u65E5"
+set format(ja,LOCALE_DATE_FORMAT) "%EY\u5e74%B%Od\u65E5"
+set format(ko,LOCALE_DATE_FORMAT) "%Y\ub144%B%Od\uc77c"
+set format(zh,LOCALE_TIME_FORMAT) "%OH\u65f6%OM\u5206%OS\u79d2"
+set format(ja,LOCALE_TIME_FORMAT) "%OH\u6642%OM\u5206%OS\u79d2"
+set format(ko,LOCALE_TIME_FORMAT) "%H\uc2dc%M\ubd84%S\ucd08"
+set format(zh,LOCALE_DATE_TIME_FORMAT) "%A %Y\u5e74%B%Od\u65E5%OH\u65f6%OM\u5206%OS\u79d2 %z"
+set format(ja,LOCALE_DATE_TIME_FORMAT) "%A %EY\u5e74%B%Od\u65E5%OH\u6642%OM\u5206%OS\u79d2 %z"
+set format(ko,LOCALE_DATE_TIME_FORMAT) "%A %Y\ub144%B%Od\uc77c%H\uc2dc%M\ubd84%S\ucd08 %z"
+
+# The next set of format overrides were obtained from the glibc
+# localization strings.
+
+set format(cs_CZ,DATE_FORMAT) %d.%m.%Y
+set format(cs_CZ,DATE_TIME_FORMAT) {%a %e. %B %Y, %H:%M:%S %z}
+set format(cs_CZ,TIME_FORMAT) %H:%M:%S
+set format(cs_CZ,TIME_FORMAT_12) %I:%M:%S
+set format(da_DK,DATE_FORMAT) %d-%m-%Y
+set format(da_DK,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(da_DK,TIME_FORMAT) %T
+set format(da_DK,TIME_FORMAT_12) %T
+set format(de_AT,DATE_FORMAT) %Y-%m-%d
+set format(de_AT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_AT,TIME_FORMAT) %T
+set format(de_AT,TIME_FORMAT_12) %T
+set format(de_BE,DATE_FORMAT) %Y-%m-%d
+set format(de_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_BE,TIME_FORMAT) %T
+set format(de_BE,TIME_FORMAT_12) %T
+set format(de_CH,DATE_FORMAT) %Y-%m-%d
+set format(de_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_CH,TIME_FORMAT) %T
+set format(de_CH,TIME_FORMAT_12) %T
+set format(de_DE,DATE_FORMAT) %Y-%m-%d
+set format(de_DE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_DE,TIME_FORMAT) %T
+set format(de_DE,TIME_FORMAT_12) %T
+set format(de_LU,DATE_FORMAT) %Y-%m-%d
+set format(de_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_LU,TIME_FORMAT) %T
+set format(de_LU,TIME_FORMAT_12) %T
+set format(en_CA,DATE_FORMAT) %d/%m/%y
+set format(en_CA,DATE_TIME_FORMAT) {%a %d %b %Y %r %z}
+set format(en_CA,TIME_FORMAT) %r
+set format(en_CA,TIME_FORMAT_12) {%I:%M:%S %p}
+set format(en_DK,DATE_FORMAT) %Y-%m-%d
+set format(en_DK,DATE_TIME_FORMAT) {%Y-%m-%dT%T %z}
+set format(en_DK,TIME_FORMAT) %T
+set format(en_DK,TIME_FORMAT_12) %T
+set format(en_GB,DATE_FORMAT) %d/%m/%y
+set format(en_GB,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(en_GB,TIME_FORMAT) %T
+set format(en_GB,TIME_FORMAT_12) %T
+set format(en_IE,DATE_FORMAT) %d/%m/%y
+set format(en_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(en_IE,TIME_FORMAT) %T
+set format(en_IE,TIME_FORMAT_12) %T
+set format(en_US,DATE_FORMAT) %m/%d/%y
+set format(en_US,DATE_TIME_FORMAT) {%a %d %b %Y %r %z}
+set format(en_US,TIME_FORMAT) %r
+set format(en_US,TIME_FORMAT_12) {%I:%M:%S %p}
+set format(es_ES,DATE_FORMAT) %d/%m/%y
+set format(es_ES,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(es_ES,TIME_FORMAT) %T
+set format(es_ES,TIME_FORMAT_12) %T
+set format(et_EE,DATE_FORMAT) %d.%m.%Y
+set format(et_EE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(et_EE,TIME_FORMAT) %T
+set format(et_EE,TIME_FORMAT_12) %T
+set format(eu_ES,DATE_FORMAT) {%a, %Yeko %bren %da}
+set format(eu_ES,DATE_TIME_FORMAT) {%y-%m-%d %T %z}
+set format(eu_ES,TIME_FORMAT) %T
+set format(eu_ES,TIME_FORMAT_12) %T
+set format(fi_FI,DATE_FORMAT) %d.%m.%Y
+set format(fi_FI,DATE_TIME_FORMAT) {%a %e %B %Y %T}
+set format(fi_FI,TIME_FORMAT) %T
+set format(fi_FI,TIME_FORMAT_12) %T
+set format(fo_FO,DATE_FORMAT) %d/%m-%Y
+set format(fo_FO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fo_FO,TIME_FORMAT) %T
+set format(fo_FO,TIME_FORMAT_12) %T
+set format(fr_BE,DATE_FORMAT) %d/%m/%y
+set format(fr_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_BE,TIME_FORMAT) %T
+set format(fr_BE,TIME_FORMAT_12) %T
+set format(fr_CA,DATE_FORMAT) %Y-%m-%d
+set format(fr_CA,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_CA,TIME_FORMAT) %T
+set format(fr_CA,TIME_FORMAT_12) %T
+set format(fr_CH,DATE_FORMAT) {%d. %m. %y}
+set format(fr_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_CH,TIME_FORMAT) %T
+set format(fr_CH,TIME_FORMAT_12) %T
+set format(fr_FR,DATE_FORMAT) %d.%m.%Y
+set format(fr_FR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_FR,TIME_FORMAT) %T
+set format(fr_FR,TIME_FORMAT_12) %T
+set format(fr_LU,DATE_FORMAT) %d.%m.%Y
+set format(fr_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_LU,TIME_FORMAT) %T
+set format(fr_LU,TIME_FORMAT_12) %T
+set format(ga_IE,DATE_FORMAT) %d.%m.%y
+set format(ga_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(ga_IE,TIME_FORMAT) %T
+set format(ga_IE,TIME_FORMAT_12) %T
+set format(gr_GR,DATE_FORMAT) %d/%m/%Y
+set format(gr_GR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(gr_GR,TIME_FORMAT) %T
+set format(gr_GR,TIME_FORMAT_12) %T
+set format(hr_HR,DATE_FORMAT) %d.%m.%y
+set format(hr_HR,DATE_TIME_FORMAT) {%a %d %b %Y %T}
+set format(hr_HR,TIME_FORMAT) %T
+set format(hr_HR,TIME_FORMAT_12) %T
+set format(hu_HU,DATE_FORMAT) %Y-%m-%d
+set format(hu_HU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(hu_HU,TIME_FORMAT) %T
+set format(hu_HU,TIME_FORMAT_12) %T
+set format(is_IS,DATE_FORMAT) {%a %e.%b %Y}
+set format(is_IS,DATE_TIME_FORMAT) {%a %e.%b %Y, %T %z}
+set format(is_IS,TIME_FORMAT) %T
+set format(is_IS,TIME_FORMAT_12) %T
+set format(it_IT,DATE_FORMAT) %d/%m/%Y
+set format(it_IT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(it_IT,TIME_FORMAT) %T
+set format(it_IT,TIME_FORMAT_12) %T
+set format(iw_IL,DATE_FORMAT) %d/%m/%y
+set format(iw_IL,DATE_TIME_FORMAT) {%z %H:%M:%S %Y %b %d %a}
+set format(iw_IL,TIME_FORMAT) %H:%M:%S
+set format(iw_IL,TIME_FORMAT_12) {%I:%M:%S %P}
+set format(kl_GL,DATE_FORMAT) {%d %b %Y}
+set format(kl_GL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(kl_GL,TIME_FORMAT) %T
+set format(kl_GL,TIME_FORMAT_12) %T
+set format(lt_LT,DATE_FORMAT) %Y.%m.%d
+set format(lt_LT,DATE_TIME_FORMAT) {%Y m. %B %d d. %T}
+set format(lt_LT,TIME_FORMAT) %T
+set format(lt_LT,TIME_FORMAT_12) %T
+set format(lv_LV,DATE_FORMAT) %Y.%m.%d.
+set format(lv_LV,DATE_TIME_FORMAT) {%A, %Y. gada %e. %B, plkst. %H un %M}
+set format(lv_LV,TIME_FORMAT) %T
+set format(lv_LV,TIME_FORMAT_12) %T
+set format(nl_BE,DATE_FORMAT) %d-%m-%y
+set format(nl_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(nl_BE,TIME_FORMAT) %T
+set format(nl_BE,TIME_FORMAT_12) %T
+set format(nl_NL,DATE_FORMAT) %d-%m-%y
+set format(nl_NL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(nl_NL,TIME_FORMAT) %T
+set format(nl_NL,TIME_FORMAT_12) %T
+set format(no_NO,DATE_FORMAT) %d-%m-%Y
+set format(no_NO,DATE_TIME_FORMAT) {%a %d-%m-%Y %T %z}
+set format(no_NO,TIME_FORMAT) %T
+set format(no_NO,TIME_FORMAT_12) %T
+set format(pl_PL,DATE_FORMAT) %Y-%m-%d
+set format(pl_PL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pl_PL,TIME_FORMAT) %T
+set format(pl_PL,TIME_FORMAT_12) %T
+set format(pt_BR,DATE_FORMAT) %d-%m-%Y
+set format(pt_BR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pt_BR,TIME_FORMAT) %T
+set format(pt_BR,TIME_FORMAT_12) %T
+set format(pt_PT,DATE_FORMAT) %d-%m-%Y
+set format(pt_PT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pt_PT,TIME_FORMAT) %T
+set format(pt_PT,TIME_FORMAT_12) %T
+set format(ro_RO,DATE_FORMAT) %Y-%m-%d
+set format(ro_RO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(ro_RO,TIME_FORMAT) %T
+set format(ro_RO,TIME_FORMAT_12) %T
+set format(ru_RU,DATE_FORMAT) %d.%m.%Y
+set format(ru_RU,DATE_TIME_FORMAT) {%a %d %b %Y %T}
+set format(ru_RU,TIME_FORMAT) %T
+set format(ru_RU,TIME_FORMAT_12) %T
+set format(sl_SI,DATE_FORMAT) %d.%m.%Y
+set format(sl_SI,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(sl_SI,TIME_FORMAT) %T
+set format(sl_SI,TIME_FORMAT_12) %T
+set format(sv_FI,DATE_FORMAT) %Y-%m-%d
+set format(sv_FI,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S}
+set format(sv_FI,TIME_FORMAT) %H.%M.%S
+set format(sv_FI,TIME_FORMAT_12) %H.%M.%S
+set format(sv_SE,DATE_FORMAT) %Y-%m-%d
+set format(sv_SE,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S}
+set format(sv_SE,TIME_FORMAT) %H.%M.%S
+set format(sv_SE,TIME_FORMAT_12) %H.%M.%S
+set format(tr_TR,DATE_FORMAT) %Y-%m-%d
+set format(tr_TR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(tr_TR,TIME_FORMAT) %T
+set format(tr_TR,TIME_FORMAT_12) %T
+
+#----------------------------------------------------------------------
+#
+# handleLocaleFile --
+#
+# Extracts strings from an ICU locale definition.
+#
+# Parameters:
+# localeName - Name of the locale (e.g., de_AT_euro)
+# fileName - Name of the file containing the data
+# msgFileName - Name of the file containing the Tcl message catalog
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes the Tcl message catalog.
+#
+#----------------------------------------------------------------------
+
+proc handleLocaleFile { localeName fileName msgFileName } {
+ variable format
+
+ # Get the content of the ICU file
+
+ set f [open $fileName r]
+ fconfigure $f -encoding utf-8
+ set data [read $f]
+ close $f
+
+ # Parse the ICU data
+
+ set state {}
+ foreach line [split $data \n] {
+ switch -exact -- $state {
+ {} {
+
+ # Look for the beginnings of data blocks
+
+ switch -regexp -- $line {
+ {^[[:space:]]*AmPmMarkers[[:space:]]+[\{]} {
+ set state data
+ set key AmPmMarkers
+ }
+ {^[[:space:]]*DateTimePatterns[[:space:]]+[\{]} {
+ set state data
+ set key DateTimePatterns
+ }
+ {^[[:space:]]*DayAbbreviations[[:space:]]+[\{]} {
+ set state data
+ set key DayAbbreviations
+ }
+ {^[[:space:]]*DayNames[[:space:]]+[\{]} {
+ set state data
+ set key DayNames
+ }
+ {^[[:space:]]*Eras[[:space:]]+[\{]} {
+ set state data
+ set key Eras
+ }
+ {^[[:space:]]*MonthAbbreviations[[:space:]]+[\{]} {
+ set state data
+ set key MonthAbbreviations
+ }
+ {^[[:space:]]*MonthNames[[:space:]]+[\{]} {
+ set state data
+ set key MonthNames
+ }
+ }
+ }
+ data {
+
+
+ # Inside a data block, collect the strings, doing backslash
+ # expansion to pick up the Unicodes
+
+ if { [regexp {"(.*)",} $line -> item] } {
+ lappend items($key) [subst -nocommands -novariables $item]
+ } elseif { [regexp {^[[:space:]]*[\}][[:space:]]*$} $line] } {
+ set state {}
+ }
+ }
+ }
+ }
+
+ # Skip locales that don't change time strings.
+
+ if {![array exists items]} return
+
+ # Write the Tcl message catalog
+
+ set f [open $msgFileName w]
+
+ # Write a header
+
+ puts $f "\# created by $::argv0 -- do not edit"
+ puts $f "namespace eval ::tcl::clock \{"
+
+ # Do ordinary sets of strings (weekday and month names)
+
+ foreach key {
+ DayAbbreviations DayNames MonthAbbreviations MonthNames
+ } tkey {
+ DAYS_OF_WEEK_ABBREV DAYS_OF_WEEK_FULL
+ MONTHS_ABBREV MONTHS_FULL
+ } {
+ if { [info exists items($key)] } {
+ set itemList $items($key)
+ set cmd1 " ::msgcat::mcset "
+ append cmd1 $localeName " " $tkey " \[list "
+ foreach item $itemList {
+ append cmd1 \\\n { } \" [backslashify $item] \"
+ }
+ append cmd1 \]
+ puts $f $cmd1
+ }
+ }
+
+ # Do the eras, B.C.E., and C.E.
+
+ if { [info exists items(Eras)] } {
+ foreach { bce ce } $items(Eras) break
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " BCE " \"" [backslashify $bce] \"
+ puts $f $cmd
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " CE " \"" [backslashify $ce] \"
+ puts $f $cmd
+ }
+
+ # Do the AM and PM markers
+
+ if { [info exists items(AmPmMarkers)] } {
+ foreach { am pm } $items(AmPmMarkers) break
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " AM " \"" [backslashify $am] \"
+ puts $f $cmd
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " PM " \"" [backslashify $pm] \"
+ puts $f $cmd
+ }
+
+ # Do the date/time patterns. First date...
+
+ if { [info exists format($localeName,DATE_FORMAT)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Find the shortest date format that includes a 4-digit year.
+
+ if { ![info exists format($localeName,DATE_FORMAT)] } {
+ for { set i 7 } { $i >= 4 } { incr i -1 } {
+ if { [regexp yyyy [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ set format($localeName,DATE_FORMAT) $fmt
+ }
+
+ # Put it to the message catalog
+
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " DATE_FORMAT \"" \
+ $format($localeName,DATE_FORMAT) "\""
+ puts $f $cmd
+ }
+
+ # Time
+
+ if { [info exists format($localeName,TIME_FORMAT)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Find the shortest time pattern that includes the seconds
+
+ if { ![info exists format($localeName,TIME_FORMAT)] } {
+ for { set i 3 } { $i >= 0 } { incr i -1 } {
+ if { [regexp H [lindex $items(DateTimePatterns) $i]]
+ && [regexp s [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ if { $i >= 0 } {
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ regsub { %Z} $fmt {} format($localeName,TIME_FORMAT)
+ }
+ }
+
+ # Put it to the message catalog
+
+ if { [info exists format($localeName,TIME_FORMAT)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " TIME_FORMAT \"" \
+ $format($localeName,TIME_FORMAT) "\""
+ puts $f $cmd
+ }
+ }
+
+ # 12-hour time...
+
+ if { [info exists format($localeName,TIME_FORMAT_12)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Shortest patterm with 12-hour time that includes seconds
+
+ if { ![info exists format($localeName,TIME_FORMAT_12)] } {
+ for { set i 3 } { $i >= 0 } { incr i -1 } {
+ if { [regexp h [lindex $items(DateTimePatterns) $i]]
+ && [regexp s [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ if { $i >= 0 } {
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ regsub { %Z} $fmt {} format($localeName,TIME_FORMAT_12)
+ }
+ }
+
+ # Put it to the catalog
+
+ if { [info exists format($localeName,TIME_FORMAT_12)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " TIME_FORMAT_12 \"" \
+ $format($localeName,TIME_FORMAT_12) "\""
+ puts $f $cmd
+ }
+ }
+
+ # Date and time... Prefer 24-hour format to 12-hour format.
+
+ if { ![info exists format($localeName,DATE_TIME_FORMAT)]
+ && [info exists format($localeName,DATE_FORMAT)]
+ && [info exists format($localeName,TIME_FORMAT)]} {
+ set format($localeName,DATE_TIME_FORMAT) \
+ $format($localeName,DATE_FORMAT)
+ append format($localeName,DATE_TIME_FORMAT) \
+ " " $format($localeName,TIME_FORMAT) " %z"
+ }
+ if { ![info exists format($localeName,DATE_TIME_FORMAT)]
+ && [info exists format($localeName,DATE_FORMAT)]
+ && [info exists format($localeName,TIME_FORMAT_12)]} {
+ set format($localeName,DATE_TIME_FORMAT) \
+ $format($localeName,DATE_FORMAT)
+ append format($localeName,DATE_TIME_FORMAT) \
+ " " $format($localeName,TIME_FORMAT_12) " %z"
+ }
+
+ # Write date/time format to the file
+
+ if { [info exists format($localeName,DATE_TIME_FORMAT)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " DATE_TIME_FORMAT \"" \
+ $format($localeName,DATE_TIME_FORMAT) "\""
+ puts $f $cmd
+ }
+
+ # Write the string sets to the file.
+
+ foreach key {
+ LOCALE_NUMERALS LOCALE_DATE_FORMAT LOCALE_TIME_FORMAT
+ LOCALE_DATE_TIME_FORMAT LOCALE_ERAS LOCALE_YEAR_FORMAT
+ } {
+ if { [info exists format($localeName,$key)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " $key " \"" \
+ [backslashify $format($localeName,$key)] "\""
+ puts $f $cmd
+ }
+ }
+
+ # Footer
+
+ puts $f "\}"
+ close $f
+}
+
+#----------------------------------------------------------------------
+#
+# percentify --
+#
+# Converts a Java/ICU-style time format to a C/Tcl style one.
+#
+# Parameters:
+# string -- Format to convert
+#
+# Results:
+# Returns the converted format.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc percentify { string } {
+ set retval {}
+ foreach { unquoted quoted } [split $string '] {
+ append retval [string map {
+ EEEE %A MMMM %B yyyy %Y
+ MMM %b EEE %a
+ dd %d hh %I HH %H mm %M MM %m ss %S yy %y
+ a %P d %e h %l H %k M %m z %z
+ } $unquoted]
+ append retval $quoted
+ }
+ return $retval
+}
+
+#----------------------------------------------------------------------
+#
+# backslashify --
+#
+# Converts a UTF-8 string to a plain ASCII one with escapes.
+#
+# Parameters:
+# string -- String to convert
+#
+# Results:
+# Returns the converted string
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc backslashify { string } {
+
+ set retval {}
+ foreach char [split $string {}] {
+ scan $char %c ccode
+ if { $ccode >= 0x0020 && $ccode < 0x007f
+ && $char ne "\{" && $char ne "\}" && $char ne "\["
+ && $char ne "\]" && $char ne "\\" && $char ne "\$" } {
+ append retval $char
+ } else {
+ append retval \\u [format %04x $ccode]
+ }
+ }
+ return $retval
+}
+
+#----------------------------------------------------------------------
+#
+# MAIN PROGRAM
+#
+#----------------------------------------------------------------------
+
+# Extract directories from command line
+
+foreach { icudir msgdir } $argv break
+
+# Walk the ICU files and create corresponding Tcl message catalogs
+
+foreach fileName [glob -directory $icudir *.txt] {
+ set n [file rootname [file tail $fileName]]
+ if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } {
+ handleLocaleFile $n $fileName [file join $msgdir ${n}.msg]
+ }
+}
diff --git a/tools/makeTestCases.tcl b/tools/makeTestCases.tcl
new file mode 100755
index 0000000..497205b
--- /dev/null
+++ b/tools/makeTestCases.tcl
@@ -0,0 +1,1154 @@
+# TODO - When integrating this with the Core, path names will need to be
+# swizzled here.
+
+package require newclock
+set d [file dirname [file dirname [info script]]]
+source [file join $d library/tzdata/America/Detroit]
+
+namespace eval ::tcl::clock {
+ ::msgcat::mcmset en_US_roman {
+ LOCALE_ERAS {
+ {-62164627200 {} 0}
+ {-59008867200 c 100}
+ {-55853107200 cc 200}
+ {-52697347200 ccc 300}
+ {-49541587200 cd 400}
+ {-46385827200 d 500}
+ {-43230067200 dc 600}
+ {-40074307200 dcc 700}
+ {-36918547200 dccc 800}
+ {-33762787200 cm 900}
+ {-30607027200 m 1000}
+ {-27451267200 mc 1100}
+ {-24295507200 mcc 1200}
+ {-21139747200 mccc 1300}
+ {-17983987200 mcd 1400}
+ {-14828227200 md 1500}
+ {-11672467200 mdc 1600}
+ {-8516707200 mdcc 1700}
+ {-5364662400 mdccc 1800}
+ {-2208988800 mcm 1900}
+ {946684800 mm 2000}
+ }
+ LOCALE_NUMERALS {
+ ? i ii iii iv v vi vii viii ix
+ x xi xii xiii xiv xv xvi xvii xviii xix
+ xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
+ xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
+ xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
+ l li lii liii liv lv lvi lvii lviii lix
+ lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
+ lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
+ lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii
+ lxxxix
+ xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
+ c
+ }
+ DATE_FORMAT {%m/%d/%Y}
+ TIME_FORMAT {%H:%M:%S}
+ DATE_TIME_FORMAT {%x %X}
+ LOCALE_DATE_FORMAT {die %Od mensis %Om annoque %EY}
+ LOCALE_TIME_FORMAT {%OH h %OM m %OS s}
+ LOCALE_DATE_TIME_FORMAT {%Ex %EX}
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# listYears --
+#
+# List the years to test in the common clock test cases.
+#
+# Parameters:
+# startOfYearArray - Name of an array in caller's scope that will
+# be initialized as
+# Results:
+# None
+#
+# Side effects:
+# Determines the year numbers of one common year, one leap year, one year
+# following a common year, and one year following a leap year -- starting
+# on each day of the week -- in the XIXth, XXth and XXIth centuries.
+# Initializes the given array to have keys equal to the year numbers and
+# values equal to [clock seconds] at the start of the corresponding
+# years.
+#
+#----------------------------------------------------------------------
+
+proc listYears { startOfYearArray } {
+
+ upvar 1 $startOfYearArray startOfYear
+
+ # List years after 1970
+
+ set y 1970
+ set s 0
+ set dw 4 ;# Thursday
+ while { $y < 2100 } {
+ if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } {
+ set l 1
+ incr dw 366
+ set s2 [expr { $s + wide( 366 * 86400 ) }]
+ } else {
+ set l 0
+ incr dw 365
+ set s2 [expr { $s + wide( 365 * 86400 ) }]
+ }
+ set x [expr { $y >= 2037 }]
+ set dw [expr {$dw % 7}]
+ set c [expr { $y / 100 }]
+ if { ![info exists do($x$c$dw$l)] } {
+ set do($x$c$dw$l) $y
+ set startOfYear($y) $s
+ set startOfYear([expr {$y + 1}]) $s2
+ }
+ set s $s2
+ incr y
+ }
+
+ # List years before 1970
+
+ set y 1970
+ set s 0
+ set dw 4; # Thursday
+ while { $y >= 1801 } {
+ set s0 $s
+ incr dw 371
+ incr y -1
+ if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } {
+ set l 1
+ incr dw -366
+ set s [expr { $s - wide(366 * 86400) }]
+ } else {
+ set l 0
+ incr dw -365
+ set s [expr { $s - wide(365 * 86400) }]
+ }
+ set dw [expr {$dw % 7}]
+ set c [expr { $y / 100 }]
+ if { ![info exists do($c$dw$l)] } {
+ set do($c$dw$l) $y
+ set startOfYear($y) $s
+ set startOfYear([expr {$y + 1}]) $s0
+ }
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# processFile -
+#
+# Processes the 'clock.test' file, updating the test cases in it.
+#
+# Parameters:
+# None.
+#
+# Side effects:
+# Replaces the file with a new copy, constructing needed test cases.
+#
+#----------------------------------------------------------------------
+
+proc processFile {d} {
+
+ # Open two files
+
+ set f1 [open [file join $d tests/clock.test] r]
+ set f2 [open [file join $d tests/clock.new] w]
+
+ # Copy leading portion of the test file
+
+ set state {}
+ while { [gets $f1 line] >= 0 } {
+ switch -exact -- $state {
+ {} {
+ puts $f2 $line
+ if { [regexp "^\# BEGIN (.*)" $line -> cases]
+ && [string compare {} [info commands $cases]] } {
+ set state inCaseSet
+ $cases $f2
+ }
+ }
+ inCaseSet {
+ if { [regexp "^\#\ END $cases\$" $line] } {
+ puts $f2 $line
+ set state {}
+ }
+ }
+ }
+ }
+
+ # Rotate the files
+
+ close $f1
+ close $f2
+ file delete -force [file join $d tests/clock.bak]
+ file rename -force [file join $d tests/clock.test] \
+ [file join $d tests/clock.bak]
+ file rename [file join $d tests/clock.new] [file join $d tests/clock.test]
+
+}
+
+#----------------------------------------------------------------------
+#
+# testcases2 --
+#
+# Outputs the 'clock-2.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for formatting in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases2 { f2 } {
+
+ listYears startOfYear
+
+ # Define the roman numerals
+
+ set roman {
+ ? i ii iii iv v vi vii viii ix
+ x xi xii xiii xiv xv xvi xvii xviii xix
+ xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
+ xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
+ xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
+ l li lii liii liv lv lvi lvii lviii lix
+ lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
+ lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
+ lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix
+ xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
+ c
+ }
+ set romanc {
+ ? c cc ccc cd d dc dcc dccc cm
+ m mc mcc mccc mcd md mdc mdcc mdccc mcm
+ mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm
+ mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm
+ }
+
+ # Names of the months
+
+ set short {{} Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
+ set long {
+ {} January February March April May June July August September
+ October November December
+ }
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test formatting of Gregorian year, month, day, all formats"
+ puts $f2 "\# Formats tested: %b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y %EY"
+ puts $f2 ""
+
+ # Generate the test cases for the first and last day of every month
+ # from 1896 to 2045
+
+ set n 0
+ foreach { y } [lsort -integer [array names startOfYear]] {
+ set s [expr { $startOfYear($y) + wide(12*3600 + 34*60 + 56) }]
+ set m 0
+ set yd 1
+ foreach hath { 31 28 31 30 31 30 31 31 30 31 30 31 } {
+ incr m
+ if { $m == 2 && ( $y%4 == 0 && $y%100 != 0 || $y%400 == 0 ) } {
+ incr hath
+ }
+
+ set b [lindex $short $m]
+ set B [lindex $long $m]
+ set C [format %02d [expr { $y / 100 }]]
+ set h $b
+ set j [format %03d $yd]
+ set mm [format %02d $m]
+ set N [format %2d $m]
+ set yy [format %02d [expr { $y % 100 }]]
+
+ set J [expr { ( $s / 86400 ) + 2440588 }]
+
+ set dt $y-$mm-01
+ set result ""
+ append result $b " " $B " " \
+ $mm /01/ $y " 12:34:56 " \
+ "die i mensis " [lindex $roman $m] " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] " " \
+ [lindex $roman 12] " h " [lindex $roman 34] " m " \
+ [lindex $roman 56] " s " \
+ $C " " [lindex $romanc [expr { $y / 100 }]] \
+ " 01 i 1 i " \
+ $h " " $j " " $J " " $mm " " [lindex $roman $m] " " $N \
+ " " $mm "/01/" $y \
+ " die i mensis " [lindex $roman $m] " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] \
+ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y
+ puts $f2 "test clock-2.[incr n] {conversion of $dt} {"
+ puts $f2 " clock format $s \\"
+ puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\"
+ puts $f2 "\t-gmt true -locale en_US_roman"
+ puts $f2 "} {$result}"
+
+ set hm1 [expr { $hath - 1 }]
+ incr s [expr { 86400 * ( $hath - 1 ) }]
+ incr yd $hm1
+
+ set dd [format %02d $hath]
+ set ee [format %2d $hath]
+ set j [format %03d $yd]
+
+ set J [expr { ( $s / 86400 ) + 2440588 }]
+
+ set dt $y-$mm-$dd
+ set result ""
+ append result $b " " $B " " \
+ $mm / $dd / $y " 12:34:56 " \
+ "die " [lindex $roman $hath] " mensis " [lindex $roman $m] \
+ " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] " " \
+ [lindex $roman 12] " h " [lindex $roman 34] " m " \
+ [lindex $roman 56] " s " \
+ $C " " [lindex $romanc [expr { $y / 100 }]] \
+ " " $dd " " [lindex $roman $hath] " " \
+ $ee " " [lindex $roman $hath] " "\
+ $h " " $j " " $J " " $mm " " [lindex $roman $m] " " $N \
+ " " $mm "/" $dd "/" $y \
+ " die " [lindex $roman $hath] " mensis " [lindex $roman $m] \
+ " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] \
+ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y
+ puts $f2 "test clock-2.[incr n] {conversion of $dt} {"
+ puts $f2 " clock format $s \\"
+ puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\"
+ puts $f2 "\t-gmt true -locale en_US_roman"
+ puts $f2 "} {$result}"
+
+ incr s 86400
+ incr yd
+ }
+ }
+ puts "testcases2: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases3 --
+#
+# Generate test cases for ISO8601 calendar.
+#
+# Parameters:
+# f2 - Channel handle to the output file
+#
+# Results:
+# None
+#
+# Side effects:
+# Makes a test case for the first and last day of weeks 51, 52, and 1
+# plus the first and last day of a year. Does so for each possible
+# weekday on which a Common Year or Leap Year can begin.
+#
+#----------------------------------------------------------------------
+
+proc testcases3 { f2 } {
+
+ listYears startOfYear
+
+ set case 0
+ foreach { y } [lsort -integer [array names startOfYear]] {
+ set secs $startOfYear($y)
+ set ym1 [expr { $y - 1 }]
+ set dow [expr { ( $secs / 86400 + 4 ) % 7}]
+ switch -exact $dow {
+ 0 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 6*86400 }]
+ testISO $f2 $ym1 52 6 [expr { $secs - 86400 }]
+ testISO $f2 $ym1 52 7 $secs
+ testISO $f2 $y 1 1 [expr { $secs + 86400 }]
+ testISO $f2 $y 1 7 [expr { $secs + 7*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 8*86400 }]
+ }
+ 1 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 7*86400 }]
+ testISO $f2 $ym1 52 7 [expr { $secs - 86400 }]
+ testISO $f2 $y 1 1 $secs
+ testISO $f2 $y 1 7 [expr { $secs + 6*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 7*86400 }]
+ }
+ 2 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 8*86400 }]
+ testISO $f2 $ym1 52 7 [expr { $secs - 2*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 86400 }]
+ testISO $f2 $y 1 2 $secs
+ testISO $f2 $y 1 7 [expr { $secs + 5*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 6*86400 }]
+ }
+ 3 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 9*86400 }]
+ testISO $f2 $ym1 52 7 [expr { $secs - 3*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 2*86400 }]
+ testISO $f2 $y 1 3 $secs
+ testISO $f2 $y 1 7 [expr { $secs + 4*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 5*86400 }]
+ }
+ 4 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 10*86400 }]
+ testISO $f2 $ym1 52 7 [expr { $secs - 4*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 3*86400 }]
+ testISO $f2 $y 1 4 $secs
+ testISO $f2 $y 1 7 [expr { $secs + 3*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 4*86400 }]
+ }
+ 5 {
+ testISO $f2 $ym1 53 1 [expr { $secs - 4*86400 }]
+ testISO $f2 $ym1 53 5 $secs
+ testISO $f2 $ym1 53 7 [expr { $secs + 2*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs + 3*86400 }]
+ testISO $f2 $y 1 7 [expr { $secs + 9*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 10*86400 }]
+ }
+ 6 {
+ # messy case because previous year may have had 52 or 53 weeks
+ if { $y%4 == 1 } {
+ testISO $f2 $ym1 53 1 [expr { $secs - 5*86400 }]
+ testISO $f2 $ym1 53 6 $secs
+ testISO $f2 $ym1 53 7 [expr { $secs + 86400 }]
+ } else {
+ testISO $f2 $ym1 52 1 [expr { $secs - 5*86400 }]
+ testISO $f2 $ym1 52 6 $secs
+ testISO $f2 $ym1 52 7 [expr { $secs + 86400 }]
+ }
+ testISO $f2 $y 1 1 [expr { $secs + 2*86400 }]
+ testISO $f2 $y 1 7 [expr { $secs + 8*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 9*86400 }]
+ }
+ }
+ }
+ puts "testcases3: $case test cases."
+
+}
+
+proc testISO { f2 G V u secs } {
+
+ upvar 1 case case
+
+ set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday}
+ set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun}
+
+ puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {"
+ puts $f2 " clock format $secs -format {%a %A %g %G %u %V %w} -gmt true; \# $G-W[format %02d $V]-$u"
+ puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\
+ [format %02d [expr { $G % 100 }]] $G\
+ $u\
+ [format %02d $V] [expr { $u % 7 }]}"
+
+}
+
+#----------------------------------------------------------------------
+#
+# testcases4 --
+#
+# Makes the test cases that test formatting of time of day.
+#
+# Parameters:
+# f2 - Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes test cases to the output.
+#
+#----------------------------------------------------------------------
+
+proc testcases4 { f2 } {
+
+ puts $f2 {}
+ puts $f2 "\# Test formatting of time of day"
+ puts $f2 "\# Format groups tested: %H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+"
+ puts $f2 {}
+
+ set i 0
+ set fmt "%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+"
+ foreach { h romanH I romanI am } {
+ 0 ? 12 xii AM
+ 1 i 1 i AM
+ 11 xi 11 xi AM
+ 12 xii 12 xii PM
+ 13 xiii 1 i PM
+ 23 xxiii 11 xi PM
+ } {
+ set hh [format %02d $h]
+ set II [format %02d $I]
+ set hs [format %2d $h]
+ set Is [format %2d $I]
+ foreach { m romanM } { 0 ? 1 i 58 lviii 59 lix } {
+ set mm [format %02d $m]
+ foreach { s romanS } { 0 ? 1 i 58 lviii 59 lix } {
+ set ss [format %02d $s]
+ set x [expr { ( $h * 60 + $m ) * 60 + $s }]
+ set result ""
+ append result $hh " " $romanH " " $II " " $romanI " " \
+ $hs " " $romanH " " $Is " " $romanI " " $mm " " $romanM " " \
+ $am " " [string tolower $am] " " \
+ $II ":" $mm ":" $ss " " [string tolower $am] " " \
+ $hh ":" $mm " " \
+ $ss " " $romanS " " \
+ $hh ":" $mm ":" $ss " " \
+ $hh ":" $mm ":" $ss " " \
+ $romanH " h " $romanM " m " $romanS " s " \
+ "Thu Jan 1 " $hh : $mm : $ss " GMT 1970"
+ puts $f2 "test clock-4.[incr i] { format time of day $hh:$mm:$ss } {"
+ puts $f2 " clock format $x \\"
+ puts $f2 " -format [list $fmt] \\"
+ puts $f2 " -locale en_US_roman \\"
+ puts $f2 " -gmt true"
+ puts $f2 "} {$result}"
+ }
+ }
+ }
+
+ puts "testcases4: $i test cases."
+}
+
+#----------------------------------------------------------------------
+#
+# testcases5 --
+#
+# Generates the test cases for Daylight Saving Time
+#
+# Parameters:
+# f2 - Channel handle for the input file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Makes test cases for each known or anticipated time change
+# in Detroit.
+#
+#----------------------------------------------------------------------
+
+proc testcases5 { f2 } {
+ variable TZData
+
+ puts $f2 {}
+ puts $f2 "\# Test formatting of Daylight Saving Time"
+ puts $f2 {}
+
+ set fmt {%H:%M:%S %z %Z}
+
+ set i 0
+ puts $f2 "::tcltest::testConstraint detroit 0"
+ puts $f2 "test clock-5.[incr i] {does Detroit exist} {"
+ puts $f2 " clock format 0 -format {} -timezone :America/Detroit"
+ puts $f2 " ::tcltest::testConstraint detroit 1"
+ puts $f2 " concat"
+ puts $f2 "} {}"
+ puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {"
+ puts $f2 " if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {"
+ puts $f2 " concat {y2038 problem}"
+ puts $f2 " } else {"
+ puts $f2 " ::tcltest::testConstraint y2038 1"
+ puts $f2 " concat {ok}"
+ puts $f2 " }"
+ puts $f2 "} ok"
+
+ foreach row $TZData(:America/Detroit) {
+ foreach { t offset isdst tzname } $row break
+ if { $t > -4000000000000 } {
+ set conds [list detroit]
+ if { $t > wide(0x7fffffff) } {
+ set conds [list detroit y2038]
+ }
+ incr t -1
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ incr t
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ incr t
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ }
+ }
+ puts "testcases5: $i test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases8 --
+#
+# Outputs the 'clock-8.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in ccyymmdd format are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases8 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of ccyymmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach ccyy {%C%y %Y} {
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$ccyy $mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format [list $ccyy $mm $dd] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ foreach fmt {%x %D} {
+ set string [clock format $scanned \
+ -format $fmt \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format $fmt -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases8: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases11 --
+#
+# Outputs the 'clock-11.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for precedence among YYYYMMDD and YYYYDDD are written
+# to f2.
+#
+#----------------------------------------------------------------------
+
+proc testcases11 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test precedence among yyyymmdd and yyyyddd"
+ puts $f2 ""
+
+ array set v {
+ Y 1970
+ m 01
+ d 01
+ j 002
+ }
+
+ set n 0
+
+ foreach {a b c d} {
+ Y m d j m Y d j d Y m j j Y m d
+ Y m j d m Y j d d Y j m j Y d m
+ Y d m j m d Y j d m Y j j m Y d
+ Y d j m m d j Y d m j Y j m d Y
+ Y j m d m j Y d d j Y m j d Y m
+ Y j d m m j d Y d j m Y j d m Y
+ } {
+ foreach x [list $a $b $c $d] {
+ switch -exact -- $x {
+ m - d {
+ set value 0
+ }
+ j {
+ set value 86400
+ }
+ }
+ }
+ set format "%$a%$b%$c%$d"
+ set string "$v($a)$v($b)$v($c)$v($d)"
+ puts $f2 "test clock-11.[incr n] {precedence of ccyyddd and ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format $format -gmt 1]"
+ puts $f2 "} $value"
+ }
+
+ puts "testcases11: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases12 --
+#
+# Outputs the 'clock-12.x' test cases, parsing CCyyWwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases12 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of ccyyWwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "%G W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-12.[incr n] {parse ccyyWwwd} {"
+ puts $f2 " [list clock scan $string -format [list %G W%V $d] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases12: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases14 --
+#
+# Outputs the 'clock-14.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing yymmdd dates are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases14 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of yymmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1938 1970 2000 2037} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach yy {%y %Oy} {
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$yy $mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-14.[incr n] {parse yymmdd} {"
+ puts $f2 " [list clock scan $string -format [list $yy $mm $dd] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+ }
+ }
+
+ puts "testcases14: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases17 --
+#
+# Outputs the 'clock-17.x' test cases, parsing yyWwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases17 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of yyWwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "%g W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-17.[incr n] {parse yyWwwd} {"
+ puts $f2 " [list clock scan $string -format [list %g W%V $d] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases17: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases19 --
+#
+# Outputs the 'clock-19.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing mmdd dates are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases19 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of mmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1938 1970 2000 2037} {
+ set base [clock scan ${year}0101 -gmt true]
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-19.[incr n] {parse mmdd} {"
+ puts $f2 " [list clock scan $string -format [list $mm $dd] -locale en_US_roman -base $base -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+ }
+
+ puts "testcases19: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases21 --
+#
+# Outputs the 'clock-21.x' test cases, parsing Wwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases22 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of Wwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ set base [clock scan ${year}0104 -gmt true]
+ foreach month {03 10} {
+ foreach day {01 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-22.[incr n] {parse Wwwd} {"
+ puts $f2 " [list clock scan $string -format [list W%V $d] -locale en_US_roman -gmt 1] -base $base"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases22: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases24 --
+#
+# Outputs the 'clock-24.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing naked day of the month are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases24 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of naked day-of-month"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 2000} {
+ foreach month {01 12} {
+ set base [clock scan ${year}${month}01 -gmt true]
+ foreach day {02 28} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-24.[incr n] {parse naked day of month} {"
+ puts $f2 " [list clock scan $string -format $dd -locale en_US_roman -base $base -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases24: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases26 --
+#
+# Outputs the 'clock-26.x' test cases, parsing naked day of week
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases26 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of naked day of week"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 2001} {
+ foreach week {01 52} {
+ set base [clock scan ${year}W${week}4 \
+ -format %GW%V%u -gmt true]
+ foreach day {1 7} {
+ set scanned [clock scan ${year}W${week}${day} \
+ -format %GW%V%u -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "$d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-26.[incr n] {parse naked day of week} {"
+ puts $f2 " [list clock scan $string -format $d -locale en_US_roman -gmt 1] -base $base"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases26: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases29 --
+#
+# Makes test cases for parsing of time of day.
+#
+# Parameters:
+# f2 -- Channel where tests are to be written
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes the tests.
+#
+#----------------------------------------------------------------------
+
+proc testcases29 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of time of day"
+ puts $f2 ""
+
+ set n 0
+ foreach hour {0 1 11 12 13 23} \
+ hampm {12 1 11 12 1 11} \
+ lhour {? i xi xii xiii xxiii} \
+ lhampm {xii i xi xii i xi} \
+ ampmind {am am am pm pm pm} {
+ set sphr [format %2d $hour]
+ set 2dhr [format %02d $hour]
+ set sphampm [format %2d $hampm]
+ set 2dhampm [format %02d $hampm]
+ set AMPMind [string toupper $ampmind]
+ foreach minute {00 01 59} lminute {? i lix} {
+ foreach second {00 01 59} lsecond {? i lix} {
+ set time [expr { ( 60 * $hour + $minute ) * 60 + $second }]
+ foreach {hfmt afmt} [list \
+ %H {} %k {} %OH {} %Ok {} \
+ %I %p %l %p \
+ %OI %p %Ol %p \
+ %I %P %l %P \
+ %OI %P %Ol %P] \
+ {hfld afld} [list \
+ $2dhr {} $sphr {} $lhour {} $lhour {} \
+ $2dhampm $AMPMind $sphampm $AMPMind \
+ $lhampm $AMPMind $lhampm $AMPMind \
+ $2dhampm $ampmind $sphampm $ampmind \
+ $lhampm $ampmind $lhampm $ampmind] \
+ {
+ if { $second eq "00" } {
+ if { $minute eq "00" } {
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt $afmt}"
+ puts $f2 "} $time"
+ }
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$minute $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%M $afmt}"
+ puts $f2 "} $time"
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$lminute $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%OM $afmt}"
+ puts $f2 "} $time"
+ }
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$minute:$second $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%M:%S $afmt}"
+ puts $f2 "} $time"
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$lminute:$lsecond $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%OM:%OS $afmt}"
+ puts $f2 "} $time"
+ }
+ }
+ }
+
+ }
+ puts "testcases29: $n test cases"
+}
+
+processFile $d
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
generated by cgit v0.12 at 2024-11-01 05:52:12 (GMT)