;;;; "timezone.scm" Compute timezones and DST from TZ environment variable.
;;; Copyright (C) 1994, 1996, 1997 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, 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 warranty 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
(require 'scanf)
(require 'time-core)
(require-if 'compiling 'tzfile)
;;; This definition is here so that READ-TZFILE can verify the
;;; existence of these files before loading tzfile.scm to actually
;;; read them.
(define tzfile:vicinity (make-vicinity
(if (file-exists? "/usr/share/zoneinfo/GMT")
"/usr/share/zoneinfo/"
"/usr/lib/zoneinfo/")))
(define (read-tzfile path)
(define (existing path) (and (file-exists? path) path))
(let ((realpath
(cond ((not path)
(or (existing (in-vicinity tzfile:vicinity "localtime"))
(existing "/etc/localtime")))
((or (char-alphabetic? (string-ref path 0))
(char-numeric? (string-ref path 0)))
(in-vicinity tzfile:vicinity path))
(else path))))
(or (and (file-exists? realpath)
(let ((zone #f))
(require 'tzfile)
(set! zone (tzfile:read realpath))
(and zone (list->vector (cons 'tz:file zone)))))
(slib:error 'read-tzfile realpath))))
;;; 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 (time-zone tz)
(cond ((vector? tz) tz)
((or (not tz)
(eqv? #\: (string-ref tz 0)))
(let ()
(require 'tzfile)
(read-tzfile (and tz (substring tz 1 (string-length tz))))))
(else (string->time-zone tz))))