;;;; "timezone.scm" Compute timezones and DST from TZ environment variable. ;;; Copyright (C) 1994, 1996, 1997 Aubrey Jaffer. ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and ;understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warrantee or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;; The C-library support for time in general and time-zones in particular ;; stands as a fine example of how *not* to create interfaces. ;; ;; Functions are not consistently named. Support for GMT is offered in one ;; direction only; The localtime function returns some timezone data in the ;; structure which it returns, and some data in shared global variables. ;; The structure which localtime returns is overwritten with each ;; invocation. There is no way to find local time in zones other than GMT ;; and the local timezone. ;; ;; The tzfile(5) format encodes only a single timezone per file. There is ;; no dispatch on zone names, so multiple copies of a timezone file exist ;; under different names. The TZ `:' specification is unix filesystem ;; specific. The tzfile(5) format makes no provision for byte-order ;; differences; It mixes 32-bit integer data with characters; specifying ;; ASCII bytes, it is incompatible with different character sizes. The ;; binary format makes it impossible to easily inspect a file for ;; corruption. ;; ;; I have corrected most of the failings of the C-library time interface in ;; SLIB while maintaining compatablility. I wrote support for Linux ;; timezone files because on a system where TZ is not set, there is no ;; other way to reveal this information. HP-UX appears to have a more ;; sensible arrangement; I invite you to add support for it and other ;; platforms. ;; ;; Writing this was a long, tedious, and unenlightening process. I hope it ;; is useful. ;; ;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer (provide 'time-zone) (require 'scanf) (define daylight? #f) (define *timezone* 0) (define tzname '#("UTC" "???")) (define tz:default #f) ;;; Parse Posix TZ string. (define (string->transition-day-time str) (let ((month 0) (week 0) (day #f) (junk #f)) (or (case (sscanf str "J%u%s" day junk) ((1) (and (<= 1 day 365) (list #f #f day))) (else #f)) (case (sscanf str "%u%s" day junk) ((1) (and (<= 0 day 365) (list #f #t day))) (else #f)) (case (sscanf str "M%u.%u.%u%s" month week day junk) ((3) (and (<= 1 month 12) (<= 1 week 5) (<= 0 day 6) (list month week day))) (else #f))))) (define (string->transition-time str) (let ((date #f) (time "2") (junk #f)) (and (or (eqv? 2 (sscanf str "%[JM.0-9]/%[:0-9]%s" date time junk)) (eqv? 1 (sscanf str "%[JM.0-9]" date junk))) (let ((day (string->transition-day-time date)) (tim (string->time-offset time))) (and day tim (append day (list tim))))))) (define (string->time-offset str) (and str (string? str) (positive? (string-length str)) (let ((hh #f) (mm 0) (ss 0) (junk #f)) (and (<= 1 (sscanf (if (memv (string-ref str 0) '(#\+ #\-)) (substring str 1 (string-length str)) str) "%u:%u:%u%s" hh mm ss junk) 3) hh (<= 0 hh 23) (<= 0 mm 59) (<= 0 ss 59) (* (if (char=? #\- (string-ref str 0)) -1 1) (+ ss (* 60 (+ mm (* hh 60))))))))) (define (string->time-zone tz) (let ((tzname #f) (offset #f) (dtzname #f) (doffset #f) (start-str #f) (end-str #f) (junk #f)) (define found (sscanf tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-]%[-:+0-9],%[JM.0-9/:],%[JM.0-9/:]%s" tzname offset dtzname doffset start-str end-str junk)) (set! offset (string->time-offset offset)) (set! doffset (string->time-offset doffset)) (cond ((and offset (eqv? 3 found)) (set! doffset (+ -3600 offset)) (set! found (+ 1 (sscanf tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-],%[JM.0-9/:],%[JM.0-9/:]%s" tzname offset dtzname start-str end-str junk))) (set! offset (string->time-offset offset)))) (case found ((2) (vector 'tz:fixed tz tzname offset)) ((4) (vector 'tz:rule tz tzname dtzname offset doffset (list 4 1 0 7200) (list 10 5 0 7200))) ((6) (let ((start (string->transition-time start-str)) (end (string->transition-time end-str))) (and start end (vector 'tz:rule tz tzname dtzname offset doffset start end)))) (else #f)))) (define (read-tzfile path) (require 'tzfile) (let ((realpath (cond ((not path) (in-vicinity tzfile:vicinity "localtime")) ((or (char-alphabetic? (string-ref path 0)) (char-numeric? (string-ref path 0))) (in-vicinity tzfile:vicinity path)) (else path)))) (if (file-exists? realpath) (let ((zone (tzfile:read realpath))) (if zone (list->vector (cons 'tz:file zone)) (slib:error 'read-tzfile realpath))) (slib:error 'read-tzfile "file not found:" realpath) ))) (define (time-zone tz) (cond ((not tz) (read-tzfile #f)) ((vector? tz) tz) ((eqv? #\: (string-ref tz 0)) (read-tzfile (substring tz 1 (string-length tz)))) (else (string->time-zone tz)))) ;;; Use the timezone (define (tzrule->caltime year previous-gmt-offset tr-month tr-week tr-day tr-time) (define leap? (leap-year? year)) (define gmmt (time:invert time:gmtime (vector 0 0 0 1 (if tr-month (+ -1 tr-month) 0) year #f #f 0))) (offset-time gmmt (+ tr-time previous-gmt-offset (* 3600 24 (if tr-month (let* ((fdow (vector-ref (time:gmtime gmmt) 6))) (case tr-week ((1 2 3 4) (+ (modulo (- tr-day fdow) 7) (* 7 (+ -1 tr-week)))) ((5) (do ((mmax (vector-ref (vector-ref time:days/month (if leap? 1 0)) (+ -1 tr-month))) (d (modulo (- tr-day fdow) 7) (+ 7 d))) ((>= d mmax) (+ -7 d)))) (else (slib:error 'tzrule->caltime "week out of range" tr-week)))) (+ tr-day (if (and (not tr-week) (>= tr-day 60) (leap-year? year)) 1 0))))))) (define (tz:params caltime tz) (case (vector-ref tz 0) ((tz:fixed) (list 0 (vector-ref tz 3) (vector-ref tz 2))) ((tz:rule) (let* ((year (vector-ref (time:gmtime caltime) 5)) (ttime0 (apply tzrule->caltime year (vector-ref tz 4) (vector-ref tz 6))) (ttime1 (apply tzrule->caltime year (vector-ref tz 5) (vector-ref tz 7))) (dst (if (and (not (negative? (difftime caltime ttime0))) (negative? (difftime caltime ttime1))) 1 0))) (list dst (vector-ref tz (+ 4 dst)) (vector-ref tz (+ 2 dst))) ;;(for-each display (list (gtime ttime0) (gtime caltime) (gtime ttime1))) )) ((tz:file) (let ((zone-spec (tzfile:get-zone-spec caltime tz))) (list (if (vector-ref zone-spec 2) 1 0) (- (vector-ref zone-spec 1)) (vector-ref zone-spec 0)))) (else (slib:error 'tz:params "unknown timezone type" tz)))) (define (tz:std-offset zone) (case (vector-ref zone 0) ((tz:fixed) (vector-ref zone 3)) ((tz:rule) (vector-ref zone 4)) ((tz:file) (let ((mode-table (vector-ref zone 2))) (do ((type-idx 0 (+ 1 type-idx))) ((or (>= type-idx (vector-length mode-table)) (not (vector-ref (vector-ref mode-table type-idx) 2))) (if (>= type-idx (vector-length mode-table)) (vector-ref (vector-ref mode-table 0) 1) (- (vector-ref (vector-ref mode-table type-idx) 1))))))) (else (slib:error 'tz:std-offset "unknown timezone type" tz)))) ;;; Interpret the TZ envariable. (define (tzset . opt-tz) (define tz (if (null? opt-tz) (getenv "TZ") (car opt-tz))) (if (or (not tz:default) (and (string? tz) (not (string-ci=? tz (vector-ref tz:default 1))))) (set! tz:default (or (time-zone tz) '#(tz:fixed "UTC" "GMT" 0)))) (case (vector-ref tz:default 0) ((tz:fixed) (set! tzname (vector (vector-ref tz:default 2) "???")) (set! daylight? #f) (set! *timezone* (vector-ref tz:default 3))) ((tz:rule) (set! tzname (vector (vector-ref tz:default 2) (vector-ref tz:default 3))) (set! daylight? #t) (set! *timezone* (vector-ref tz:default 4))) ((tz:file) (let ((mode-table (vector-ref tz:default 2)) (transition-types (vector-ref tz:default 5))) (set! daylight? #f) (set! *timezone* (vector-ref (vector-ref mode-table 0) 1)) (set! tzname (make-vector 2 #f)) (do ((type-idx 0 (+ 1 type-idx))) ((>= type-idx (vector-length mode-table))) (let ((rec (vector-ref mode-table type-idx))) (if (vector-ref rec 2) (set! daylight? #t) (set! *timezone* (- (vector-ref rec 1)))))) (do ((transition-idx (+ -1 (vector-length transition-types)) (+ -1 transition-idx))) ((or (negative? transition-idx) (and (vector-ref tzname 0) (vector-ref tzname 1)))) (let ((rec (vector-ref mode-table (vector-ref transition-types transition-idx)))) (if (vector-ref rec 2) (if (not (vector-ref tzname 1)) (vector-set! tzname 1 (vector-ref rec 0))) (if (not (vector-ref tzname 0)) (vector-set! tzname 0 (vector-ref rec 0)))))))) (else (slib:error 'tzset "unknown timezone type" tz))) tz:default)