diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
commit | f24b9140d6f74804d5599ec225717d38ca443813 (patch) | |
tree | 0da952f1a5a7c0eacfc05c296766523e32c05fe2 /timezone.scm | |
parent | 8ffbc2df0fde83082610149d24e594c1cd879f4a (diff) | |
download | slib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz slib-f24b9140d6f74804d5599ec225717d38ca443813.zip |
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'timezone.scm')
-rw-r--r-- | timezone.scm | 257 |
1 files changed, 257 insertions, 0 deletions
diff --git a/timezone.scm b/timezone.scm new file mode 100644 index 0000000..8daa8fb --- /dev/null +++ b/timezone.scm @@ -0,0 +1,257 @@ +;;;; "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 <jaffer@martigny.ai.mit.edu> + +(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) |