[25] | 1 | #---------------------------------------------------------------------- |
---|
| 2 | # |
---|
| 3 | # tclZIC.tcl -- |
---|
| 4 | # |
---|
| 5 | # Take the time zone data source files from Arthur Olson's |
---|
| 6 | # repository at elsie.nci.nih.gov, and prepare time zone |
---|
| 7 | # information files for Tcl. |
---|
| 8 | # |
---|
| 9 | # Usage: |
---|
| 10 | # tclsh tclZIC.tcl inputDir outputDir |
---|
| 11 | # |
---|
| 12 | # Parameters: |
---|
| 13 | # inputDir - Directory (e.g., tzdata2003e) where Olson's source |
---|
| 14 | # files are to be found. |
---|
| 15 | # outputDir - Directory (e.g., ../library/tzdata) where |
---|
| 16 | # the time zone information files are to be placed. |
---|
| 17 | # |
---|
| 18 | # Results: |
---|
| 19 | # May produce error messages on the standard error. An exit |
---|
| 20 | # code of zero denotes success; any other exit code is failure. |
---|
| 21 | # |
---|
| 22 | # This program parses the timezone data in a means analogous to the |
---|
| 23 | # 'zic' command, and produces Tcl time zone information files suitable |
---|
| 24 | # for loading into the 'clock' namespace. |
---|
| 25 | # |
---|
| 26 | #---------------------------------------------------------------------- |
---|
| 27 | # |
---|
| 28 | # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. |
---|
| 29 | # See the file "license.terms" for information on usage and redistribution |
---|
| 30 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 31 | # |
---|
| 32 | # RCS: @(#) $Id: tclZIC.tcl,v 1.9 2006/11/03 00:34:53 hobbs Exp $ |
---|
| 33 | # |
---|
| 34 | #---------------------------------------------------------------------- |
---|
| 35 | |
---|
| 36 | package require Tcl 8.5 |
---|
| 37 | |
---|
| 38 | # Define the names of the Olson files that we need to load. |
---|
| 39 | # We avoid the solar time files and the leap seconds. |
---|
| 40 | |
---|
| 41 | set olsonFiles { |
---|
| 42 | africa antarctica asia australasia |
---|
| 43 | backward etcetera europe northamerica |
---|
| 44 | pacificnew southamerica systemv |
---|
| 45 | } |
---|
| 46 | |
---|
| 47 | # Define the year at which the DST information will stop. |
---|
| 48 | |
---|
| 49 | set maxyear 2100 |
---|
| 50 | |
---|
| 51 | # Determine how big a wide integer is. |
---|
| 52 | |
---|
| 53 | set MAXWIDE [expr {wide(1)}] |
---|
| 54 | while 1 { |
---|
| 55 | set next [expr {wide($MAXWIDE + $MAXWIDE + 1)}] |
---|
| 56 | if {$next < 0} { |
---|
| 57 | break |
---|
| 58 | } |
---|
| 59 | set MAXWIDE $next |
---|
| 60 | } |
---|
| 61 | set MINWIDE [expr {-$MAXWIDE-1}] |
---|
| 62 | |
---|
| 63 | #---------------------------------------------------------------------- |
---|
| 64 | # |
---|
| 65 | # loadFiles -- |
---|
| 66 | # |
---|
| 67 | # Loads the time zone files for each continent into memory |
---|
| 68 | # |
---|
| 69 | # Parameters: |
---|
| 70 | # dir - Directory where the time zone source files are found |
---|
| 71 | # |
---|
| 72 | # Results: |
---|
| 73 | # None. |
---|
| 74 | # |
---|
| 75 | # Side effects: |
---|
| 76 | # Calls 'loadZIC' for each continent's data file in turn. |
---|
| 77 | # Reports progress on stdout. |
---|
| 78 | # |
---|
| 79 | #---------------------------------------------------------------------- |
---|
| 80 | |
---|
| 81 | proc loadFiles {dir} { |
---|
| 82 | variable olsonFiles |
---|
| 83 | foreach file $olsonFiles { |
---|
| 84 | puts "loading: [file join $dir $file]" |
---|
| 85 | loadZIC [file join $dir $file] |
---|
| 86 | } |
---|
| 87 | return |
---|
| 88 | } |
---|
| 89 | |
---|
| 90 | #---------------------------------------------------------------------- |
---|
| 91 | # |
---|
| 92 | # checkForwardRuleRefs -- |
---|
| 93 | # |
---|
| 94 | # Checks to make sure that all references to Daylight Saving |
---|
| 95 | # Time rules designate defined rules. |
---|
| 96 | # |
---|
| 97 | # Parameters: |
---|
| 98 | # None. |
---|
| 99 | # |
---|
| 100 | # Results: |
---|
| 101 | # None. |
---|
| 102 | # |
---|
| 103 | # Side effects: |
---|
| 104 | # Produces an error message and increases the error count if |
---|
| 105 | # any undefined rules are present. |
---|
| 106 | # |
---|
| 107 | #---------------------------------------------------------------------- |
---|
| 108 | |
---|
| 109 | proc checkForwardRuleRefs {} { |
---|
| 110 | variable forwardRuleRefs |
---|
| 111 | variable rules |
---|
| 112 | |
---|
| 113 | foreach {rule where} [array get forwardRuleRefs] { |
---|
| 114 | if {![info exists rules($rule)]} { |
---|
| 115 | foreach {fileName lno} $where { |
---|
| 116 | puts stderr "$fileName:$lno:can't locate rule \"$rule\"" |
---|
| 117 | incr errorCount |
---|
| 118 | } |
---|
| 119 | } |
---|
| 120 | } |
---|
| 121 | } |
---|
| 122 | |
---|
| 123 | #---------------------------------------------------------------------- |
---|
| 124 | # |
---|
| 125 | # loadZIC -- |
---|
| 126 | # |
---|
| 127 | # Load one continent's data into memory. |
---|
| 128 | # |
---|
| 129 | # Parameters: |
---|
| 130 | # fileName -- Name of the time zone source file. |
---|
| 131 | # |
---|
| 132 | # Results: |
---|
| 133 | # None. |
---|
| 134 | # |
---|
| 135 | # Side effects: |
---|
| 136 | # The global variable, 'errorCount' counts the number of errors. |
---|
| 137 | # The global array, 'links', contains a distillation of the |
---|
| 138 | # 'Link' directives in the file. The keys are 'links to' and |
---|
| 139 | # the values are 'links from'. The 'parseRule' and 'parseZone' |
---|
| 140 | # procedures are called to handle 'Rule' and 'Zone' directives. |
---|
| 141 | # |
---|
| 142 | #---------------------------------------------------------------------- |
---|
| 143 | |
---|
| 144 | proc loadZIC {fileName} { |
---|
| 145 | variable errorCount |
---|
| 146 | variable links |
---|
| 147 | |
---|
| 148 | # Suck the text into memory. |
---|
| 149 | |
---|
| 150 | set f [open $fileName r] |
---|
| 151 | set data [read $f] |
---|
| 152 | close $f |
---|
| 153 | |
---|
| 154 | # Break the input into lines, and count line numbers. |
---|
| 155 | |
---|
| 156 | set lno 0 |
---|
| 157 | foreach line [split $data \n] { |
---|
| 158 | incr lno |
---|
| 159 | |
---|
| 160 | # Break a line of input into words. |
---|
| 161 | |
---|
| 162 | regsub {\s*(\#.*)?$} $line {} line |
---|
| 163 | if {$line eq ""} { |
---|
| 164 | continue |
---|
| 165 | } |
---|
| 166 | set words {} |
---|
| 167 | if {[regexp {^\s} $line]} { |
---|
| 168 | # Detect continuations of a zone and flag the list appropriately |
---|
| 169 | lappend words "" |
---|
| 170 | } |
---|
| 171 | lappend words {*}[regexp -all -inline {\S+} $line] |
---|
| 172 | |
---|
| 173 | # Switch on the directive |
---|
| 174 | |
---|
| 175 | switch -exact -- [lindex $words 0] { |
---|
| 176 | Rule { |
---|
| 177 | parseRule $fileName $lno $words |
---|
| 178 | } |
---|
| 179 | Link { |
---|
| 180 | set links([lindex $words 2]) [lindex $words 1] |
---|
| 181 | } |
---|
| 182 | Zone { |
---|
| 183 | set lastZone [lindex $words 1] |
---|
| 184 | set until [parseZone $fileName $lno \ |
---|
| 185 | $lastZone [lrange $words 2 end] "minimum"] |
---|
| 186 | } |
---|
| 187 | {} { |
---|
| 188 | set i 0 |
---|
| 189 | foreach word $words { |
---|
| 190 | if {[lindex $words $i] ne ""} { |
---|
| 191 | break |
---|
| 192 | } |
---|
| 193 | incr i |
---|
| 194 | } |
---|
| 195 | set words [lrange $words $i end] |
---|
| 196 | set until [parseZone $fileName $lno $lastZone $words $until] |
---|
| 197 | } |
---|
| 198 | default { |
---|
| 199 | incr errorCount |
---|
| 200 | puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\"" |
---|
| 201 | } |
---|
| 202 | } |
---|
| 203 | } |
---|
| 204 | |
---|
| 205 | return |
---|
| 206 | } |
---|
| 207 | |
---|
| 208 | #---------------------------------------------------------------------- |
---|
| 209 | # |
---|
| 210 | # parseRule -- |
---|
| 211 | # |
---|
| 212 | # Parses a Rule directive in an Olson file. |
---|
| 213 | # |
---|
| 214 | # Parameters: |
---|
| 215 | # fileName -- Name of the file being parsed. |
---|
| 216 | # lno - Line number within the file |
---|
| 217 | # words - The line itself, broken into words. |
---|
| 218 | # |
---|
| 219 | # Results: |
---|
| 220 | # None. |
---|
| 221 | # |
---|
| 222 | # Side effects: |
---|
| 223 | # The rule is analyzed and added to the 'rules' array. |
---|
| 224 | # Errors are reported and counted. |
---|
| 225 | # |
---|
| 226 | #---------------------------------------------------------------------- |
---|
| 227 | |
---|
| 228 | proc parseRule {fileName lno words} { |
---|
| 229 | variable rules |
---|
| 230 | variable errorCount |
---|
| 231 | |
---|
| 232 | # Break out the columns |
---|
| 233 | |
---|
| 234 | lassign $words Rule name from to type in on at save letter |
---|
| 235 | |
---|
| 236 | # Handle the 'only' keyword |
---|
| 237 | |
---|
| 238 | if {$to eq "only"} { |
---|
| 239 | set to $from |
---|
| 240 | } |
---|
| 241 | |
---|
| 242 | # Process the start year |
---|
| 243 | |
---|
| 244 | if {![string is integer $from]} { |
---|
| 245 | if {![string equal -length [string length $from] $from "minimum"]} { |
---|
| 246 | puts stderr "$fileName:$lno:FROM field \"$from\" not an integer." |
---|
| 247 | incr errorCount |
---|
| 248 | return |
---|
| 249 | } else { |
---|
| 250 | set from "minimum" |
---|
| 251 | } |
---|
| 252 | } |
---|
| 253 | |
---|
| 254 | # Process the end year |
---|
| 255 | |
---|
| 256 | if {![string is integer $to]} { |
---|
| 257 | if {![string equal -length [string length $to] $to "maximum"]} { |
---|
| 258 | puts stderr "$fileName:$lno:TO field \"$to\" not an integer." |
---|
| 259 | incr errorCount |
---|
| 260 | return |
---|
| 261 | } else { |
---|
| 262 | set to "maximum" |
---|
| 263 | } |
---|
| 264 | } |
---|
| 265 | |
---|
| 266 | # Process the type of year in which the rule applies |
---|
| 267 | |
---|
| 268 | if {$type ne "-"} { |
---|
| 269 | puts stderr "$fileName:$lno:year types are not yet supported." |
---|
| 270 | incr errorCount |
---|
| 271 | return |
---|
| 272 | } |
---|
| 273 | |
---|
| 274 | # Process the month in which the rule starts |
---|
| 275 | |
---|
| 276 | if {[catch {lookupMonth $in} in]} { |
---|
| 277 | puts stderr "$fileName:$lno:$in" |
---|
| 278 | incr errorCount |
---|
| 279 | return |
---|
| 280 | } |
---|
| 281 | |
---|
| 282 | # Process the day of the month on which the rule starts |
---|
| 283 | |
---|
| 284 | if {[catch {parseON $on} on]} { |
---|
| 285 | puts stderr "$fileName:$lno:$on" |
---|
| 286 | incr errorCount |
---|
| 287 | return |
---|
| 288 | } |
---|
| 289 | |
---|
| 290 | # Process the time of day on which the rule starts |
---|
| 291 | |
---|
| 292 | if {[catch {parseTOD $at} at]} { |
---|
| 293 | puts stderr "$fileName:$lno:$at" |
---|
| 294 | incr errorCount |
---|
| 295 | return |
---|
| 296 | } |
---|
| 297 | |
---|
| 298 | # Process the DST adder |
---|
| 299 | |
---|
| 300 | if {[catch {parseOffsetTime $save} save]} { |
---|
| 301 | puts stderr "$fileName:$lno:$save" |
---|
| 302 | incr errorCount |
---|
| 303 | return |
---|
| 304 | } |
---|
| 305 | |
---|
| 306 | # Process the letter to use for summer time |
---|
| 307 | |
---|
| 308 | if {$letter eq "-"} { |
---|
| 309 | set letter "" |
---|
| 310 | } |
---|
| 311 | |
---|
| 312 | # Accumulate all the data. |
---|
| 313 | |
---|
| 314 | lappend rules($name) $from $to $type $in $on $at $save $letter |
---|
| 315 | return |
---|
| 316 | |
---|
| 317 | } |
---|
| 318 | |
---|
| 319 | #---------------------------------------------------------------------- |
---|
| 320 | # |
---|
| 321 | # parseON -- |
---|
| 322 | # |
---|
| 323 | # Parse a specification for a day of the month |
---|
| 324 | # |
---|
| 325 | # Parameters: |
---|
| 326 | # on - the ON field from a line in an Olson file. |
---|
| 327 | # |
---|
| 328 | # Results: |
---|
| 329 | # Returns a partial Tcl command. When the year and number of the |
---|
| 330 | # month are appended, the command will return the Julian Day Number |
---|
| 331 | # of the desired date. |
---|
| 332 | # |
---|
| 333 | # Side effects: |
---|
| 334 | # None. |
---|
| 335 | # |
---|
| 336 | # The specification can be: |
---|
| 337 | # - a simple number, which designates a constant date. |
---|
| 338 | # - The name of a weekday, followed by >= or <=, followed by a number. |
---|
| 339 | # This designates the nearest occurrence of the given weekday on |
---|
| 340 | # or before (on or after) the given day of the month. |
---|
| 341 | # - The word 'last' followed by a weekday name with no intervening |
---|
| 342 | # space. This designates the last occurrence of the given weekday |
---|
| 343 | # in the month. |
---|
| 344 | # |
---|
| 345 | #---------------------------------------------------------------------- |
---|
| 346 | |
---|
| 347 | proc parseON {on} { |
---|
| 348 | if {![regexp -expanded { |
---|
| 349 | ^(?: |
---|
| 350 | # first possibility - simple number - field 1 |
---|
| 351 | ([[:digit:]]+) |
---|
| 352 | | |
---|
| 353 | # second possibility - weekday >= (or <=) number |
---|
| 354 | # field 2 - weekday |
---|
| 355 | ([[:alpha:]]+) |
---|
| 356 | # field 3 - direction |
---|
| 357 | ([<>]=) |
---|
| 358 | # field 4 - number |
---|
| 359 | ([[:digit:]]+) |
---|
| 360 | | |
---|
| 361 | # third possibility - lastWeekday - field 5 |
---|
| 362 | last([[:alpha:]]+) |
---|
| 363 | )$ |
---|
| 364 | } $on -> dom1 wday2 dir2 num2 wday3]} then { |
---|
| 365 | error "can't parse ON field \"$on\"" |
---|
| 366 | } |
---|
| 367 | if {$dom1 ne ""} { |
---|
| 368 | return [list onDayOfMonth $dom1] |
---|
| 369 | } elseif {$wday2 ne ""} { |
---|
| 370 | set wday2 [lookupDayOfWeek $wday2] |
---|
| 371 | return [list onWeekdayInMonth $wday2 $dir2 $num2] |
---|
| 372 | } elseif {$wday3 ne ""} { |
---|
| 373 | set wday3 [lookupDayOfWeek $wday3] |
---|
| 374 | return [list onLastWeekdayInMonth $wday3] |
---|
| 375 | } else { |
---|
| 376 | error "in parseOn \"$on\": can't happen" |
---|
| 377 | } |
---|
| 378 | } |
---|
| 379 | |
---|
| 380 | #---------------------------------------------------------------------- |
---|
| 381 | # |
---|
| 382 | # onDayOfMonth -- |
---|
| 383 | # |
---|
| 384 | # Find a given day of a given month |
---|
| 385 | # |
---|
| 386 | # Parameters: |
---|
| 387 | # day - Day of the month |
---|
| 388 | # year - Gregorian year |
---|
| 389 | # month - Number of the month (1-12) |
---|
| 390 | # |
---|
| 391 | # Results: |
---|
| 392 | # Returns the Julian Day Number of the desired day. |
---|
| 393 | # |
---|
| 394 | # Side effects: |
---|
| 395 | # None. |
---|
| 396 | # |
---|
| 397 | #---------------------------------------------------------------------- |
---|
| 398 | |
---|
| 399 | proc onDayOfMonth {day year month} { |
---|
| 400 | set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ |
---|
| 401 | [dict create era CE year $year month $month dayOfMonth $day] \ |
---|
| 402 | 2361222] |
---|
| 403 | return [dict get $date julianDay] |
---|
| 404 | } |
---|
| 405 | |
---|
| 406 | #---------------------------------------------------------------------- |
---|
| 407 | # |
---|
| 408 | # onWeekdayInMonth -- |
---|
| 409 | # |
---|
| 410 | # Find the weekday falling on or after (on or before) a |
---|
| 411 | # given day of the month |
---|
| 412 | # |
---|
| 413 | # Parameters: |
---|
| 414 | # dayOfWeek - Day of the week (Monday=1, Sunday=7) |
---|
| 415 | # relation - <= for the weekday on or before a given date, >= for |
---|
| 416 | # the weekday on or after the given date. |
---|
| 417 | # dayOfMonth - Day of the month |
---|
| 418 | # year - Gregorian year |
---|
| 419 | # month - Number of the month (1-12) |
---|
| 420 | # |
---|
| 421 | # Results: |
---|
| 422 | # Returns the Juloan Day Number of the desired day. |
---|
| 423 | # |
---|
| 424 | # Side effects: |
---|
| 425 | # None. |
---|
| 426 | # |
---|
| 427 | # onWeekdayInMonth is used to compute Daylight Saving Time rules |
---|
| 428 | # like 'Sun>=1' (for the nearest Sunday on or after the first of the month) |
---|
| 429 | # or "Mon<=4' (for the Monday on or before the fourth of the month). |
---|
| 430 | # |
---|
| 431 | #---------------------------------------------------------------------- |
---|
| 432 | |
---|
| 433 | proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} { |
---|
| 434 | set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ |
---|
| 435 | era CE year $year month $month dayOfMonth $dayOfMonth] 2361222] |
---|
| 436 | switch -exact -- $relation { |
---|
| 437 | <= { |
---|
| 438 | return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ |
---|
| 439 | [dict get $date julianDay]] |
---|
| 440 | } |
---|
| 441 | >= { |
---|
| 442 | return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ |
---|
| 443 | [expr {[dict get $date julianDay] + 6}]] |
---|
| 444 | } |
---|
| 445 | } |
---|
| 446 | } |
---|
| 447 | |
---|
| 448 | #---------------------------------------------------------------------- |
---|
| 449 | # |
---|
| 450 | # onLastWeekdayInMonth -- |
---|
| 451 | # |
---|
| 452 | # Find the last instance of a given weekday in a month. |
---|
| 453 | # |
---|
| 454 | # Parameters: |
---|
| 455 | # dayOfWeek - Weekday to find (Monday=1, Sunday=7) |
---|
| 456 | # year - Gregorian year |
---|
| 457 | # month - Month (1-12) |
---|
| 458 | # |
---|
| 459 | # Results: |
---|
| 460 | # Returns the Julian Day number of the last instance of |
---|
| 461 | # the given weekday in the given month |
---|
| 462 | # |
---|
| 463 | # Side effects: |
---|
| 464 | # None. |
---|
| 465 | # |
---|
| 466 | #---------------------------------------------------------------------- |
---|
| 467 | |
---|
| 468 | proc onLastWeekdayInMonth {dayOfWeek year month} { |
---|
| 469 | incr month |
---|
| 470 | # Find day 0 of the following month, which is the last day of |
---|
| 471 | # the current month. Yes, it works to ask for day 0 of month 13! |
---|
| 472 | set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ |
---|
| 473 | era CE year $year month $month dayOfMonth 0] 2361222] |
---|
| 474 | return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ |
---|
| 475 | [dict get $date julianDay]] |
---|
| 476 | } |
---|
| 477 | |
---|
| 478 | #---------------------------------------------------------------------- |
---|
| 479 | # |
---|
| 480 | # parseTOD -- |
---|
| 481 | # |
---|
| 482 | # Parses the specification of a time of day in an Olson file. |
---|
| 483 | # |
---|
| 484 | # Parameters: |
---|
| 485 | # tod - Time of day, which may be followed by 'w', 's', 'u', 'g' |
---|
| 486 | # or 'z'. 'w' (or no letter) designates a wall clock time, |
---|
| 487 | # 's' designates Standard Time in the given zone, and |
---|
| 488 | # 'u', 'g', and 'z' all designate UTC. |
---|
| 489 | # |
---|
| 490 | # Results: |
---|
| 491 | # Returns a two element list containing a count of seconds from |
---|
| 492 | # midnight and the letter that followed the time. |
---|
| 493 | # |
---|
| 494 | # Side effects: |
---|
| 495 | # Reports and counts an error if the time cannot be parsed. |
---|
| 496 | # |
---|
| 497 | #---------------------------------------------------------------------- |
---|
| 498 | |
---|
| 499 | proc parseTOD {tod} { |
---|
| 500 | if {![regexp -expanded { |
---|
| 501 | ^ |
---|
| 502 | ([[:digit:]]{1,2}) # field 1 - hour |
---|
| 503 | (?: |
---|
| 504 | :([[:digit:]]{2}) # field 2 - minute |
---|
| 505 | (?: |
---|
| 506 | :([[:digit:]]{2}) # field 3 - second |
---|
| 507 | )? |
---|
| 508 | )? |
---|
| 509 | (?: |
---|
| 510 | ([wsugz]) # field 4 - type indicator |
---|
| 511 | )? |
---|
| 512 | } $tod -> hour minute second ind]} then { |
---|
| 513 | puts stderr "$fileName:$lno:can't parse time field \"$tod\"" |
---|
| 514 | incr errorCount |
---|
| 515 | } |
---|
| 516 | scan $hour %d hour |
---|
| 517 | if {$minute ne ""} { |
---|
| 518 | scan $minute %d minute |
---|
| 519 | } else { |
---|
| 520 | set minute 0 |
---|
| 521 | } |
---|
| 522 | if {$second ne ""} { |
---|
| 523 | scan $second %d second |
---|
| 524 | } else { |
---|
| 525 | set second 0 |
---|
| 526 | } |
---|
| 527 | if {$ind eq ""} { |
---|
| 528 | set ind w |
---|
| 529 | } |
---|
| 530 | return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind] |
---|
| 531 | } |
---|
| 532 | |
---|
| 533 | #---------------------------------------------------------------------- |
---|
| 534 | # |
---|
| 535 | # parseOffsetTime -- |
---|
| 536 | # |
---|
| 537 | # Parses the specification of an offset time in an Olson file. |
---|
| 538 | # |
---|
| 539 | # Parameters: |
---|
| 540 | # offset - Offset time as [+-]hh:mm:ss |
---|
| 541 | # |
---|
| 542 | # Results: |
---|
| 543 | # Returns the offset time as a count of seconds. |
---|
| 544 | # |
---|
| 545 | # Side effects: |
---|
| 546 | # Reports and counts an error if the time cannot be parsed. |
---|
| 547 | # |
---|
| 548 | #---------------------------------------------------------------------- |
---|
| 549 | |
---|
| 550 | proc parseOffsetTime {offset} { |
---|
| 551 | if {![regexp -expanded { |
---|
| 552 | ^ |
---|
| 553 | ([-+])? # field 1 - signum |
---|
| 554 | ([[:digit:]]{1,2}) # field 2 - hour |
---|
| 555 | (?: |
---|
| 556 | :([[:digit:]]{2}) # field 3 - minute |
---|
| 557 | (?: |
---|
| 558 | :([[:digit:]]{2}) # field 4 - second |
---|
| 559 | )? |
---|
| 560 | )? |
---|
| 561 | } $offset -> signum hour minute second]} then { |
---|
| 562 | puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" |
---|
| 563 | incr errorCount |
---|
| 564 | } |
---|
| 565 | append signum 1 |
---|
| 566 | scan $hour %d hour |
---|
| 567 | if {$minute ne ""} { |
---|
| 568 | scan $minute %d minute |
---|
| 569 | } else { |
---|
| 570 | set minute 0 |
---|
| 571 | } |
---|
| 572 | if {$second ne ""} { |
---|
| 573 | scan $second %d second |
---|
| 574 | } else { |
---|
| 575 | set second 0 |
---|
| 576 | } |
---|
| 577 | return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}] |
---|
| 578 | |
---|
| 579 | } |
---|
| 580 | |
---|
| 581 | #---------------------------------------------------------------------- |
---|
| 582 | # |
---|
| 583 | # lookupMonth - |
---|
| 584 | # Looks up a month by name |
---|
| 585 | # |
---|
| 586 | # Parameters: |
---|
| 587 | # month - Name of a month. |
---|
| 588 | # |
---|
| 589 | # Results: |
---|
| 590 | # Returns the number of the month. |
---|
| 591 | # |
---|
| 592 | # Side effects: |
---|
| 593 | # None. |
---|
| 594 | # |
---|
| 595 | #---------------------------------------------------------------------- |
---|
| 596 | |
---|
| 597 | proc lookupMonth {month} { |
---|
| 598 | set indx [lsearch -regexp { |
---|
| 599 | {} January February March April May June |
---|
| 600 | July August September October November December |
---|
| 601 | } ${month}.*] |
---|
| 602 | if {$indx < 1} { |
---|
| 603 | error "unknown month name \"$month\"" |
---|
| 604 | } |
---|
| 605 | return $indx |
---|
| 606 | } |
---|
| 607 | |
---|
| 608 | #---------------------------------------------------------------------- |
---|
| 609 | # |
---|
| 610 | # lookupDayOfWeek -- |
---|
| 611 | # |
---|
| 612 | # Looks up the name of a weekday. |
---|
| 613 | # |
---|
| 614 | # Parameters: |
---|
| 615 | # wday - Weekday name (or a unique prefix). |
---|
| 616 | # |
---|
| 617 | # Results: |
---|
| 618 | # Returns the weekday number (Monday=1, Sunday=7) |
---|
| 619 | # |
---|
| 620 | # Side effects: |
---|
| 621 | # None. |
---|
| 622 | # |
---|
| 623 | #---------------------------------------------------------------------- |
---|
| 624 | |
---|
| 625 | proc lookupDayOfWeek {wday} { |
---|
| 626 | set indx [lsearch -regexp { |
---|
| 627 | {} Monday Tuesday Wednesday Thursday Friday Saturday Sunday |
---|
| 628 | } ${wday}.*] |
---|
| 629 | if {$indx < 1} { |
---|
| 630 | error "unknown weekday name \"$wday\"" |
---|
| 631 | } |
---|
| 632 | return $indx |
---|
| 633 | } |
---|
| 634 | |
---|
| 635 | #---------------------------------------------------------------------- |
---|
| 636 | # |
---|
| 637 | # parseZone -- |
---|
| 638 | # |
---|
| 639 | # Parses a Zone directive in an Olson file |
---|
| 640 | # |
---|
| 641 | # Parameters: |
---|
| 642 | # fileName -- Name of the file being parsed. |
---|
| 643 | # lno -- Line number within the file. |
---|
| 644 | # zone -- Name of the time zone |
---|
| 645 | # words -- Remaining words on the line. |
---|
| 646 | # start -- 'Until' time from the previous line if this is a |
---|
| 647 | # continuation line, or 'minimum' if this is the first line. |
---|
| 648 | # |
---|
| 649 | # Results: |
---|
| 650 | # Returns the 'until' field of the current line |
---|
| 651 | # |
---|
| 652 | # Side effects: |
---|
| 653 | # Stores a row in the 'zones' array describing the current zone. |
---|
| 654 | # The row consists of a start time (year month day tod), a Standard |
---|
| 655 | # Time offset from Greenwich, a Daylight Saving Time offset from |
---|
| 656 | # Standard Time, and a format for printing the time zone. |
---|
| 657 | # |
---|
| 658 | # The start time is the result of an earlier call to 'parseUntil' |
---|
| 659 | # or else the keyword 'minimum'. The GMT offset is the |
---|
| 660 | # result of a call to 'parseOffsetTime'. The Daylight Saving |
---|
| 661 | # Time offset is represented as a partial Tcl command. To the |
---|
| 662 | # command will be appended a start time (seconds from epoch) |
---|
| 663 | # the current offset of Standard Time from Greenwich, the current |
---|
| 664 | # offset of Daylight Saving Time from Greenwich, the default |
---|
| 665 | # offset from this line, the name pattern from this line, |
---|
| 666 | # the 'until' field from this line, and a variable name where points |
---|
| 667 | # are to be stored. This command is implemented by the 'applyNoRule', |
---|
| 668 | # 'applyDSTOffset' and 'applyRules' procedures. |
---|
| 669 | # |
---|
| 670 | #---------------------------------------------------------------------- |
---|
| 671 | |
---|
| 672 | proc parseZone {fileName lno zone words start} { |
---|
| 673 | variable zones |
---|
| 674 | variable rules |
---|
| 675 | variable errorCount |
---|
| 676 | variable forwardRuleRefs |
---|
| 677 | |
---|
| 678 | lassign $words gmtoff save format |
---|
| 679 | if {[catch {parseOffsetTime $gmtoff} gmtoff]} { |
---|
| 680 | puts stderr "$fileName:$lno:$gmtoff" |
---|
| 681 | incr errorCount |
---|
| 682 | return |
---|
| 683 | } |
---|
| 684 | if {[info exists rules($save)]} { |
---|
| 685 | set save [list applyRules $save] |
---|
| 686 | } elseif {$save eq "-"} { |
---|
| 687 | set save [list applyNoRule] |
---|
| 688 | } elseif {[catch {parseOffsetTime $save} save2]} { |
---|
| 689 | lappend forwardRuleRefs($save) $fileName $lno |
---|
| 690 | set save [list applyRules $save] |
---|
| 691 | } else { |
---|
| 692 | set save [list applyDSTOffset $save2] |
---|
| 693 | } |
---|
| 694 | lappend zones($zone) $start $gmtoff $save $format |
---|
| 695 | if {[llength $words] >= 4} { |
---|
| 696 | return [parseUntil [lrange $words 3 end]] |
---|
| 697 | } else { |
---|
| 698 | return {} |
---|
| 699 | } |
---|
| 700 | } |
---|
| 701 | |
---|
| 702 | #---------------------------------------------------------------------- |
---|
| 703 | # |
---|
| 704 | # parseUntil -- |
---|
| 705 | # |
---|
| 706 | # Parses the 'UNTIL' part of a 'Zone' directive. |
---|
| 707 | # |
---|
| 708 | # Parameters: |
---|
| 709 | # words - The 'UNTIL' part of the directie. |
---|
| 710 | # |
---|
| 711 | # Results: |
---|
| 712 | # Returns a list comprising the year, the month, the day, and |
---|
| 713 | # the time of day. Time of day is represented as the result of |
---|
| 714 | # 'parseTOD'. |
---|
| 715 | # |
---|
| 716 | #---------------------------------------------------------------------- |
---|
| 717 | |
---|
| 718 | proc parseUntil {words} { |
---|
| 719 | variable firstYear |
---|
| 720 | |
---|
| 721 | if {[llength $words] >= 1} { |
---|
| 722 | set year [lindex $words 0] |
---|
| 723 | if {![string is integer $year]} { |
---|
| 724 | error "can't parse UNTIL field \"$words\"" |
---|
| 725 | } |
---|
| 726 | if {![info exists firstYear] || $year < $firstYear} { |
---|
| 727 | set firstYear $year |
---|
| 728 | } |
---|
| 729 | } else { |
---|
| 730 | set year "maximum" |
---|
| 731 | } |
---|
| 732 | if {[llength $words] >= 2} { |
---|
| 733 | set month [lookupMonth [lindex $words 1]] |
---|
| 734 | } else { |
---|
| 735 | set month 1 |
---|
| 736 | } |
---|
| 737 | if {[llength $words] >= 3} { |
---|
| 738 | set day [parseON [lindex $words 2]] |
---|
| 739 | } else { |
---|
| 740 | set day {onDayOfMonth 1} |
---|
| 741 | } |
---|
| 742 | if {[llength $words] >= 4} { |
---|
| 743 | set tod [parseTOD [lindex $words 3]] |
---|
| 744 | } else { |
---|
| 745 | set tod {0 w} |
---|
| 746 | } |
---|
| 747 | return [list $year $month $day $tod] |
---|
| 748 | } |
---|
| 749 | |
---|
| 750 | #---------------------------------------------------------------------- |
---|
| 751 | # |
---|
| 752 | # applyNoRule -- |
---|
| 753 | # |
---|
| 754 | # Generates time zone data for a zone without Daylight Saving |
---|
| 755 | # Time. |
---|
| 756 | # |
---|
| 757 | # Parameters: |
---|
| 758 | # year - Year in which the rule applies |
---|
| 759 | # startSecs - Time at which the rule starts. |
---|
| 760 | # stdGMTOffset - Offset from Greenwich prior to the start of the |
---|
| 761 | # rule |
---|
| 762 | # DSTOffset - Offset of Daylight from Standard prior to the |
---|
| 763 | # start of the rule. |
---|
| 764 | # nextGMTOffset - Offset from Greenwich when the rule is in effect. |
---|
| 765 | # namePattern - Name of the timezone. |
---|
| 766 | # until - Time at which the rule expires. |
---|
| 767 | # pointsVar - Name of a variable in callers scope that receives |
---|
| 768 | # transition times |
---|
| 769 | # |
---|
| 770 | # Results: |
---|
| 771 | # Returns a two element list comprising 'nextGMTOffset' and |
---|
| 772 | # 0 - the zero indicates that Daylight Saving Time is not |
---|
| 773 | # in effect. |
---|
| 774 | # |
---|
| 775 | # Side effects: |
---|
| 776 | # Appends a row to the 'points' variable comprising the start time, |
---|
| 777 | # the offset from GMT, a zero (indicating that DST is not in effect), |
---|
| 778 | # and the name of the time zone. |
---|
| 779 | # |
---|
| 780 | #---------------------------------------------------------------------- |
---|
| 781 | |
---|
| 782 | proc applyNoRule {year startSecs stdGMTOffset DSTOffset nextGMTOffset |
---|
| 783 | namePattern until pointsVar} { |
---|
| 784 | upvar 1 $pointsVar points |
---|
| 785 | lappend points $startSecs $nextGMTOffset 0 \ |
---|
| 786 | [convertNamePattern $namePattern -] |
---|
| 787 | return [list $nextGMTOffset 0] |
---|
| 788 | } |
---|
| 789 | |
---|
| 790 | #---------------------------------------------------------------------- |
---|
| 791 | # |
---|
| 792 | # applyDSTOffset -- |
---|
| 793 | # |
---|
| 794 | # Generates time zone data for a zone with permanent Daylight |
---|
| 795 | # Saving Time. |
---|
| 796 | # |
---|
| 797 | # Parameters: |
---|
| 798 | # nextDSTOffset - Offset of Daylight from Standard while the |
---|
| 799 | # rule is in effect. |
---|
| 800 | # year - Year in which the rule applies |
---|
| 801 | # startSecs - Time at which the rule starts. |
---|
| 802 | # stdGMTOffset - Offset from Greenwich prior to the start of the |
---|
| 803 | # rule |
---|
| 804 | # DSTOffset - Offset of Daylight from Standard prior to the |
---|
| 805 | # start of the rule. |
---|
| 806 | # nextGMTOffset - Offset from Greenwich when the rule is in effect. |
---|
| 807 | # namePattern - Name of the timezone. |
---|
| 808 | # until - Time at which the rule expires. |
---|
| 809 | # pointsVar - Name of a variable in callers scope that receives |
---|
| 810 | # transition times |
---|
| 811 | # |
---|
| 812 | # Results: |
---|
| 813 | # Returns a two element list comprising 'nextGMTOffset' and |
---|
| 814 | # 'nextDSTOffset'. |
---|
| 815 | # |
---|
| 816 | # Side effects: |
---|
| 817 | # Appends a row to the 'points' variable comprising the start time, |
---|
| 818 | # the offset from GMT, a one (indicating that DST is in effect), |
---|
| 819 | # and the name of the time zone. |
---|
| 820 | # |
---|
| 821 | #---------------------------------------------------------------------- |
---|
| 822 | |
---|
| 823 | proc applyDSTOffset {nextDSTOffset year startSecs |
---|
| 824 | stdGMTOffset DSTOffset nextGMTOffset |
---|
| 825 | namePattern until pointsVar} { |
---|
| 826 | upvar 1 $pointsVar points |
---|
| 827 | lappend points \ |
---|
| 828 | $startSecs \ |
---|
| 829 | [expr {$nextGMTOffset + $nextDSTOffset}] \ |
---|
| 830 | 1 \ |
---|
| 831 | [convertNamePattern $namePattern S] |
---|
| 832 | return [list $nextGMTOffset $nextDSTOffset] |
---|
| 833 | } |
---|
| 834 | |
---|
| 835 | #---------------------------------------------------------------------- |
---|
| 836 | # |
---|
| 837 | # applyRules -- |
---|
| 838 | # |
---|
| 839 | # Applies a rule set to a time zone for a given range of time |
---|
| 840 | # |
---|
| 841 | # Parameters: |
---|
| 842 | # ruleSet - Name of the rule set to apply |
---|
| 843 | # year - Starting year for the rules |
---|
| 844 | # startSecs - Time at which the rules begin to apply |
---|
| 845 | # stdGMTOffset - Offset from Greenwich prior to the start of the |
---|
| 846 | # rules. |
---|
| 847 | # DSTOffset - Offset of Daylight from Standard prior to the |
---|
| 848 | # start of the rules. |
---|
| 849 | # nextGMTOffset - Offset from Greenwich when the rules are in effect. |
---|
| 850 | # namePattern - Name pattern for the time zone. |
---|
| 851 | # until - Time at which the rule set expires. |
---|
| 852 | # pointsVar - Name of a variable in callers scope that receives |
---|
| 853 | # transition times |
---|
| 854 | # |
---|
| 855 | # Results: |
---|
| 856 | # Returns a two element list comprising the offset from GMT |
---|
| 857 | # to Standard and the offset from Standard to Daylight (if DST |
---|
| 858 | # is in effect) at the end of the period in which the rules apply |
---|
| 859 | # |
---|
| 860 | # Side effects: |
---|
| 861 | # Appends one or more rows to the 'points' variable, each of which |
---|
| 862 | # comprises a transition time, the offset from GMT that is |
---|
| 863 | # in effect after the transition, a flag for whether DST is in |
---|
| 864 | # effect, and the name of the time zone. |
---|
| 865 | # |
---|
| 866 | #---------------------------------------------------------------------- |
---|
| 867 | |
---|
| 868 | proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset |
---|
| 869 | namePattern until pointsVar} { |
---|
| 870 | variable done |
---|
| 871 | variable rules |
---|
| 872 | variable maxyear |
---|
| 873 | |
---|
| 874 | upvar 1 $pointsVar points |
---|
| 875 | |
---|
| 876 | # Extract the rules that apply to the current year, and the number |
---|
| 877 | # of rules (now or in future) that will end at a specific year. |
---|
| 878 | # Ignore rules entirely in the past. |
---|
| 879 | |
---|
| 880 | lassign [divideRules $ruleSet $year] currentRules nSunsetRules |
---|
| 881 | |
---|
| 882 | # If the first transition is later than $startSecs, and $stdGMTOffset is |
---|
| 883 | # different from $nextGMTOffset, we will need an initial record like: |
---|
| 884 | # lappend points $startSecs $stdGMTOffset 0 \ |
---|
| 885 | # [convertNamePattern $namePattern -] |
---|
| 886 | |
---|
| 887 | set didTransitionIn false |
---|
| 888 | |
---|
| 889 | # Determine the letter to use in Standard Time |
---|
| 890 | |
---|
| 891 | set prevLetter "" |
---|
| 892 | foreach { |
---|
| 893 | fromYear toYear yearType monthIn daySpecOn timeAt save letter |
---|
| 894 | } $rules($ruleSet) { |
---|
| 895 | if {$save == 0} { |
---|
| 896 | set prevLetter $letter |
---|
| 897 | break |
---|
| 898 | } |
---|
| 899 | } |
---|
| 900 | |
---|
| 901 | # Walk through each year in turn. This loop will break when |
---|
| 902 | # (a) the 'until' time is passed |
---|
| 903 | # or (b) the 'until' time is empty and all remaining rules extend to |
---|
| 904 | # the end of time |
---|
| 905 | |
---|
| 906 | set stdGMTOffset $nextGMTOffset |
---|
| 907 | |
---|
| 908 | # convert "until" to seconds from epoch in current time zone |
---|
| 909 | |
---|
| 910 | if {$until ne ""} { |
---|
| 911 | lassign $until untilYear untilMonth untilDaySpec untilTimeOfDay |
---|
| 912 | lappend untilDaySpec $untilYear $untilMonth |
---|
| 913 | set untilJCD [eval $untilDaySpec] |
---|
| 914 | set untilBaseSecs [expr { |
---|
| 915 | wide(86400) * wide($untilJCD) - 210866803200 }] |
---|
| 916 | set untilSecs [convertTimeOfDay $untilBaseSecs $stdGMTOffset \ |
---|
| 917 | $DSTOffset {*}$untilTimeOfDay] |
---|
| 918 | } |
---|
| 919 | |
---|
| 920 | set origStartSecs $startSecs |
---|
| 921 | |
---|
| 922 | while {($until ne "" && $startSecs < $untilSecs) |
---|
| 923 | || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} { |
---|
| 924 | set remainingRules $currentRules |
---|
| 925 | while {[llength $remainingRules] > 0} { |
---|
| 926 | |
---|
| 927 | # Find the rule with the earliest start time from among the |
---|
| 928 | # active rules that haven't yet been processed. |
---|
| 929 | |
---|
| 930 | lassign [findEarliestRule $remainingRules $year \ |
---|
| 931 | $stdGMTOffset $DSTOffset] earliestSecs earliestIndex |
---|
| 932 | |
---|
| 933 | set endi [expr {$earliestIndex + 7}] |
---|
| 934 | set rule [lrange $remainingRules $earliestIndex $endi] |
---|
| 935 | lassign $rule fromYear toYear \ |
---|
| 936 | yearType monthIn daySpecOn timeAt save letter |
---|
| 937 | |
---|
| 938 | # Test if the rule is in effect. |
---|
| 939 | |
---|
| 940 | if { |
---|
| 941 | $earliestSecs > $startSecs && |
---|
| 942 | ($until eq "" || $earliestSecs < $untilSecs) |
---|
| 943 | } then { |
---|
| 944 | # Test if the initial transition has been done. |
---|
| 945 | # If not, do it now. |
---|
| 946 | |
---|
| 947 | if {!$didTransitionIn && $earliestSecs > $origStartSecs} { |
---|
| 948 | set nm [convertNamePattern $namePattern $prevLetter] |
---|
| 949 | lappend points \ |
---|
| 950 | $origStartSecs \ |
---|
| 951 | [expr {$stdGMTOffset + $DSTOffset}] \ |
---|
| 952 | 0 \ |
---|
| 953 | $nm |
---|
| 954 | set didTransitionIn true |
---|
| 955 | } |
---|
| 956 | |
---|
| 957 | # Add a row to 'points' for the rule |
---|
| 958 | |
---|
| 959 | set nm [convertNamePattern $namePattern $letter] |
---|
| 960 | lappend points \ |
---|
| 961 | $earliestSecs \ |
---|
| 962 | [expr {$stdGMTOffset + $save}] \ |
---|
| 963 | [expr {$save != 0}] \ |
---|
| 964 | $nm |
---|
| 965 | } |
---|
| 966 | |
---|
| 967 | # Remove the rule just applied from the queue |
---|
| 968 | |
---|
| 969 | set remainingRules [lreplace \ |
---|
| 970 | $remainingRules[set remainingRules {}] \ |
---|
| 971 | $earliestIndex $endi] |
---|
| 972 | |
---|
| 973 | # Update current DST offset and time zone letter |
---|
| 974 | |
---|
| 975 | set DSTOffset $save |
---|
| 976 | set prevLetter $letter |
---|
| 977 | |
---|
| 978 | # Reconvert the 'until' time in the current zone. |
---|
| 979 | |
---|
| 980 | if {$until ne ""} { |
---|
| 981 | set untilSecs [convertTimeOfDay $untilBaseSecs \ |
---|
| 982 | $stdGMTOffset $DSTOffset {*}$untilTimeOfDay] |
---|
| 983 | } |
---|
| 984 | } |
---|
| 985 | |
---|
| 986 | # Advance to the next year |
---|
| 987 | |
---|
| 988 | incr year |
---|
| 989 | set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ |
---|
| 990 | [dict create era CE year $year month 1 dayOfMonth 1] 2361222] |
---|
| 991 | set startSecs [expr { |
---|
| 992 | [dict get $date julianDay] * wide(86400) - 210866803200 |
---|
| 993 | - $stdGMTOffset - $DSTOffset |
---|
| 994 | }] |
---|
| 995 | |
---|
| 996 | # Get rules in effect in the new year. |
---|
| 997 | |
---|
| 998 | lassign [divideRules $ruleSet $year] currentRules nSunsetRules |
---|
| 999 | } |
---|
| 1000 | |
---|
| 1001 | return [list $stdGMTOffset $DSTOffset] |
---|
| 1002 | } |
---|
| 1003 | |
---|
| 1004 | #---------------------------------------------------------------------- |
---|
| 1005 | # |
---|
| 1006 | # divideRules -- |
---|
| 1007 | # Determine what Daylight Saving Time rules may be in effect in |
---|
| 1008 | # a given year. |
---|
| 1009 | # |
---|
| 1010 | # Parameters: |
---|
| 1011 | # ruleSet - Set of rules from 'parseRule' |
---|
| 1012 | # year - Year to test |
---|
| 1013 | # |
---|
| 1014 | # Results: |
---|
| 1015 | # Returns a two element list comprising the subset of 'ruleSet' |
---|
| 1016 | # that is in effect in the given year, and the count of rules |
---|
| 1017 | # that expire in the future (as opposed to those that expire in |
---|
| 1018 | # the past or not at all). If this count is zero, the rules do |
---|
| 1019 | # not change in future years. |
---|
| 1020 | # |
---|
| 1021 | # Side effects: |
---|
| 1022 | # None. |
---|
| 1023 | # |
---|
| 1024 | #---------------------------------------------------------------------- |
---|
| 1025 | |
---|
| 1026 | proc divideRules {ruleSet year} { |
---|
| 1027 | variable rules |
---|
| 1028 | |
---|
| 1029 | set currentRules {} |
---|
| 1030 | set nSunsetRules 0 |
---|
| 1031 | |
---|
| 1032 | foreach { |
---|
| 1033 | fromYear toYear yearType monthIn daySpecOn timeAt save letter |
---|
| 1034 | } $rules($ruleSet) { |
---|
| 1035 | if {$toYear ne "maximum" && $year > $toYear} { |
---|
| 1036 | # ignore - rule is in the past |
---|
| 1037 | } else { |
---|
| 1038 | if {$fromYear eq "minimum" || $fromYear <= $year} { |
---|
| 1039 | lappend currentRules $fromYear $toYear $yearType $monthIn \ |
---|
| 1040 | $daySpecOn $timeAt $save $letter |
---|
| 1041 | } |
---|
| 1042 | if {$toYear ne "maximum"} { |
---|
| 1043 | incr nSunsetRules |
---|
| 1044 | } |
---|
| 1045 | } |
---|
| 1046 | } |
---|
| 1047 | |
---|
| 1048 | return [list $currentRules $nSunsetRules] |
---|
| 1049 | |
---|
| 1050 | } |
---|
| 1051 | |
---|
| 1052 | #---------------------------------------------------------------------- |
---|
| 1053 | # |
---|
| 1054 | # findEarliestRule -- |
---|
| 1055 | # |
---|
| 1056 | # Find the rule in a rule set that has the earliest start time. |
---|
| 1057 | # |
---|
| 1058 | # Parameters: |
---|
| 1059 | # remainingRules -- Rules to search |
---|
| 1060 | # year - Year being processed. |
---|
| 1061 | # stdGMTOffset - Current offset of standard time from GMT |
---|
| 1062 | # DSTOffset - Current offset of daylight time from standard, |
---|
| 1063 | # if daylight time is in effect. |
---|
| 1064 | # |
---|
| 1065 | # Results: |
---|
| 1066 | # Returns the index in remainingRules of the next rule to |
---|
| 1067 | # go into effect. |
---|
| 1068 | # |
---|
| 1069 | # Side effects: |
---|
| 1070 | # None. |
---|
| 1071 | # |
---|
| 1072 | #---------------------------------------------------------------------- |
---|
| 1073 | |
---|
| 1074 | proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} { |
---|
| 1075 | set earliest $::MAXWIDE |
---|
| 1076 | set i 0 |
---|
| 1077 | foreach { |
---|
| 1078 | fromYear toYear yearType monthIn daySpecOn timeAt save letter |
---|
| 1079 | } $remainingRules { |
---|
| 1080 | lappend daySpecOn $year $monthIn |
---|
| 1081 | set dayIn [eval $daySpecOn] |
---|
| 1082 | set secs [expr {wide(86400) * wide($dayIn) - 210866803200}] |
---|
| 1083 | set secs [convertTimeOfDay $secs \ |
---|
| 1084 | $stdGMTOffset $DSTOffset {*}$timeAt] |
---|
| 1085 | if {$secs < $earliest} { |
---|
| 1086 | set earliest $secs |
---|
| 1087 | set earliestIdx $i |
---|
| 1088 | } |
---|
| 1089 | incr i 8 |
---|
| 1090 | } |
---|
| 1091 | |
---|
| 1092 | return [list $earliest $earliestIdx] |
---|
| 1093 | } |
---|
| 1094 | |
---|
| 1095 | #---------------------------------------------------------------------- |
---|
| 1096 | # |
---|
| 1097 | # convertNamePattern -- |
---|
| 1098 | # |
---|
| 1099 | # Converts a name pattern to the name of the time zone. |
---|
| 1100 | # |
---|
| 1101 | # Parameters: |
---|
| 1102 | # pattern - Patthern to convert |
---|
| 1103 | # flag - Daylight Time flag. An empty string denotes Standard |
---|
| 1104 | # Time, anything else is Daylight Time. |
---|
| 1105 | # |
---|
| 1106 | # Results; |
---|
| 1107 | # Returns the name of the time zone. |
---|
| 1108 | # |
---|
| 1109 | # Side effects: |
---|
| 1110 | # None. |
---|
| 1111 | # |
---|
| 1112 | #---------------------------------------------------------------------- |
---|
| 1113 | |
---|
| 1114 | proc convertNamePattern {pattern flag} { |
---|
| 1115 | if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} { |
---|
| 1116 | if {$flag ne ""} { |
---|
| 1117 | set pattern $daylight |
---|
| 1118 | } else { |
---|
| 1119 | set pattern $standard |
---|
| 1120 | } |
---|
| 1121 | } |
---|
| 1122 | return [string map [list %s $flag] $pattern] |
---|
| 1123 | } |
---|
| 1124 | |
---|
| 1125 | #---------------------------------------------------------------------- |
---|
| 1126 | # |
---|
| 1127 | # convertTimeOfDay -- |
---|
| 1128 | # |
---|
| 1129 | # Takes a time of day specifier from 'parseAt' and converts |
---|
| 1130 | # to seconds from the Epoch, |
---|
| 1131 | # |
---|
| 1132 | # Parameters: |
---|
| 1133 | # seconds -- Time at which the GMT day starts, in seconds |
---|
| 1134 | # from the Posix epoch |
---|
| 1135 | # stdGMTOffset - Offset of Standard Time from Greenwich |
---|
| 1136 | # DSTOffset - Offset of Daylight Time from standard. |
---|
| 1137 | # timeOfDay - Time of day to convert, in seconds from midnight |
---|
| 1138 | # flag - Flag indicating whether the time is Greenwich, Standard |
---|
| 1139 | # or wall-clock. (g, s, or w) |
---|
| 1140 | # |
---|
| 1141 | # Results: |
---|
| 1142 | # Returns the time of day in seconds from the Posix epoch. |
---|
| 1143 | # |
---|
| 1144 | # Side effects: |
---|
| 1145 | # None. |
---|
| 1146 | # |
---|
| 1147 | #---------------------------------------------------------------------- |
---|
| 1148 | |
---|
| 1149 | proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} { |
---|
| 1150 | incr seconds $timeOfDay |
---|
| 1151 | switch -exact $flag { |
---|
| 1152 | g - u - z { |
---|
| 1153 | } |
---|
| 1154 | w { |
---|
| 1155 | incr seconds [expr {-$stdGMTOffset}] |
---|
| 1156 | incr seconds [expr {-$DSTOffset}] |
---|
| 1157 | } |
---|
| 1158 | s { |
---|
| 1159 | incr seconds [expr {-$stdGMTOffset}] |
---|
| 1160 | } |
---|
| 1161 | } |
---|
| 1162 | return $seconds |
---|
| 1163 | } |
---|
| 1164 | |
---|
| 1165 | #---------------------------------------------------------------------- |
---|
| 1166 | # |
---|
| 1167 | # processTimeZone -- |
---|
| 1168 | # |
---|
| 1169 | # Generate the information about all time transitions in a |
---|
| 1170 | # time zone. |
---|
| 1171 | # |
---|
| 1172 | # Parameters: |
---|
| 1173 | # zoneName - Name of the time zone |
---|
| 1174 | # zoneData - List containing the rows describing the time zone, |
---|
| 1175 | # obtained from 'parseZone. |
---|
| 1176 | # |
---|
| 1177 | # Results: |
---|
| 1178 | # Returns a list of rows. Each row consists of a time in |
---|
| 1179 | # seconds from the Posix epoch, an offset from GMT to local |
---|
| 1180 | # that begins at that time, a flag indicating whether DST |
---|
| 1181 | # is in effect after that time, and the printable name of the |
---|
| 1182 | # timezone that goes into effect at that time. |
---|
| 1183 | # |
---|
| 1184 | # Side effects: |
---|
| 1185 | # None. |
---|
| 1186 | # |
---|
| 1187 | #---------------------------------------------------------------------- |
---|
| 1188 | |
---|
| 1189 | proc processTimeZone {zoneName zoneData} { |
---|
| 1190 | set points {} |
---|
| 1191 | set i 0 |
---|
| 1192 | foreach {startTime nextGMTOffset dstRule namePattern} $zoneData { |
---|
| 1193 | incr i 4 |
---|
| 1194 | set until [lindex $zoneData $i] |
---|
| 1195 | if {![info exists stdGMTOffset]} { |
---|
| 1196 | set stdGMTOffset $nextGMTOffset |
---|
| 1197 | } |
---|
| 1198 | if {![info exists DSTOffset]} { |
---|
| 1199 | set DSTOffset 0 |
---|
| 1200 | } |
---|
| 1201 | if {$startTime eq "minimum"} { |
---|
| 1202 | set secs $::MINWIDE |
---|
| 1203 | set year 0 |
---|
| 1204 | } else { |
---|
| 1205 | lassign $startTime year month dayRule timeOfDay |
---|
| 1206 | lappend dayRule $year $month |
---|
| 1207 | set startDay [eval $dayRule] |
---|
| 1208 | set secs [expr {wide(86400) * wide($startDay) -210866803200}] |
---|
| 1209 | set secs [convertTimeOfDay $secs \ |
---|
| 1210 | $stdGMTOffset $DSTOffset {*}$timeOfDay] |
---|
| 1211 | } |
---|
| 1212 | lappend dstRule \ |
---|
| 1213 | $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \ |
---|
| 1214 | $namePattern $until points |
---|
| 1215 | lassign [eval $dstRule] stdGMTOffset DSTOffset |
---|
| 1216 | } |
---|
| 1217 | return $points |
---|
| 1218 | } |
---|
| 1219 | |
---|
| 1220 | #---------------------------------------------------------------------- |
---|
| 1221 | # |
---|
| 1222 | # writeZones -- |
---|
| 1223 | # |
---|
| 1224 | # Writes all the time zone information files. |
---|
| 1225 | # |
---|
| 1226 | # Parameters: |
---|
| 1227 | # outDir - Directory in which to store the files. |
---|
| 1228 | # |
---|
| 1229 | # Results: |
---|
| 1230 | # None. |
---|
| 1231 | # |
---|
| 1232 | # Side effects: |
---|
| 1233 | # Writes the time zone information files; traces what's happening |
---|
| 1234 | # on the standard output. |
---|
| 1235 | # |
---|
| 1236 | #---------------------------------------------------------------------- |
---|
| 1237 | |
---|
| 1238 | proc writeZones {outDir} { |
---|
| 1239 | variable zones |
---|
| 1240 | |
---|
| 1241 | # Walk the zones |
---|
| 1242 | |
---|
| 1243 | foreach zoneName [lsort -dictionary [array names zones]] { |
---|
| 1244 | puts "calculating: $zoneName" |
---|
| 1245 | set fileName [eval [list file join $outDir] [file split $zoneName]] |
---|
| 1246 | |
---|
| 1247 | # Create directories as needed |
---|
| 1248 | |
---|
| 1249 | set dirName [file dirname $fileName] |
---|
| 1250 | if {![file exists $dirName]} { |
---|
| 1251 | puts "creating directory: $dirName" |
---|
| 1252 | file mkdir $dirName |
---|
| 1253 | } |
---|
| 1254 | |
---|
| 1255 | # Generate data for a zone |
---|
| 1256 | |
---|
| 1257 | set data "" |
---|
| 1258 | foreach { |
---|
| 1259 | time offset dst name |
---|
| 1260 | } [processTimeZone $zoneName $zones($zoneName)] { |
---|
| 1261 | append data "\n " [list [list $time $offset $dst $name]] |
---|
| 1262 | } |
---|
| 1263 | append data \n |
---|
| 1264 | |
---|
| 1265 | # Write the data to the information file |
---|
| 1266 | |
---|
| 1267 | set f [open $fileName w] |
---|
| 1268 | puts $f "\# created by $::argv0 - do not edit" |
---|
| 1269 | puts $f "" |
---|
| 1270 | puts $f [list set TZData(:$zoneName) $data] |
---|
| 1271 | close $f |
---|
| 1272 | } |
---|
| 1273 | |
---|
| 1274 | return |
---|
| 1275 | } |
---|
| 1276 | |
---|
| 1277 | #---------------------------------------------------------------------- |
---|
| 1278 | # |
---|
| 1279 | # writeLinks -- |
---|
| 1280 | # |
---|
| 1281 | # Write files describing time zone synonyms (the Link directives |
---|
| 1282 | # from the Olson files) |
---|
| 1283 | # |
---|
| 1284 | # Parameters: |
---|
| 1285 | # outDir - Name of the directory where the output files go. |
---|
| 1286 | # |
---|
| 1287 | # Results: |
---|
| 1288 | # None. |
---|
| 1289 | # |
---|
| 1290 | # Side effects: |
---|
| 1291 | # Creates a file for each link. |
---|
| 1292 | |
---|
| 1293 | proc writeLinks {outDir} { |
---|
| 1294 | variable links |
---|
| 1295 | |
---|
| 1296 | # Walk the links |
---|
| 1297 | |
---|
| 1298 | foreach zoneName [lsort -dictionary [array names links]] { |
---|
| 1299 | puts "creating link: $zoneName" |
---|
| 1300 | set fileName [eval [list file join $outDir] [file split $zoneName]] |
---|
| 1301 | |
---|
| 1302 | # Create directories as needed |
---|
| 1303 | |
---|
| 1304 | set dirName [file dirname $fileName] |
---|
| 1305 | if {![file exists $dirName]} { |
---|
| 1306 | puts "creating directory: $dirName" |
---|
| 1307 | file mkdir $dirName |
---|
| 1308 | } |
---|
| 1309 | |
---|
| 1310 | # Create code for the synonym |
---|
| 1311 | |
---|
| 1312 | set linkTo $links($zoneName) |
---|
| 1313 | set sourceCmd "\n [list LoadTimeZoneFile $linkTo]\n" |
---|
| 1314 | set ifCmd [list if "!\[info exists TZData($linkTo)\]" $sourceCmd] |
---|
| 1315 | set setCmd "set TZData(:$zoneName) \$TZData(:$linkTo)" |
---|
| 1316 | |
---|
| 1317 | # Write the file |
---|
| 1318 | |
---|
| 1319 | set f [open $fileName w] |
---|
| 1320 | puts $f "\# created by $::argv0 - do not edit" |
---|
| 1321 | puts $f $ifCmd |
---|
| 1322 | puts $f $setCmd |
---|
| 1323 | close $f |
---|
| 1324 | } |
---|
| 1325 | |
---|
| 1326 | return |
---|
| 1327 | } |
---|
| 1328 | |
---|
| 1329 | #---------------------------------------------------------------------- |
---|
| 1330 | # |
---|
| 1331 | # MAIN PROGRAM |
---|
| 1332 | # |
---|
| 1333 | #---------------------------------------------------------------------- |
---|
| 1334 | |
---|
| 1335 | puts "Compiling time zones -- [clock format [clock seconds] \ |
---|
| 1336 | -format {%x %X} -locale system]" |
---|
| 1337 | |
---|
| 1338 | # Determine directories |
---|
| 1339 | |
---|
| 1340 | lassign $argv inDir outDir |
---|
| 1341 | |
---|
| 1342 | puts "Olson files in $inDir" |
---|
| 1343 | puts "Tcl files to be placed in $outDir" |
---|
| 1344 | |
---|
| 1345 | # Initialize count of errors |
---|
| 1346 | |
---|
| 1347 | set errorCount 0 |
---|
| 1348 | |
---|
| 1349 | # Parse the Olson files |
---|
| 1350 | |
---|
| 1351 | loadFiles $inDir |
---|
| 1352 | if {$errorCount > 0} { |
---|
| 1353 | exit 1 |
---|
| 1354 | } |
---|
| 1355 | |
---|
| 1356 | # Check that all riles appearing in Zone and Link lines actually exist |
---|
| 1357 | |
---|
| 1358 | checkForwardRuleRefs |
---|
| 1359 | if {$errorCount > 0} { |
---|
| 1360 | exit 1 |
---|
| 1361 | } |
---|
| 1362 | |
---|
| 1363 | # Write the time zone information files |
---|
| 1364 | |
---|
| 1365 | writeZones $outDir |
---|
| 1366 | writeLinks $outDir |
---|
| 1367 | if {$errorCount > 0} { |
---|
| 1368 | exit 1 |
---|
| 1369 | } |
---|
| 1370 | |
---|
| 1371 | # All done! |
---|
| 1372 | |
---|
| 1373 | exit |
---|