summaryrefslogtreecommitdiffstats
path: root/timezone.scm
diff options
context:
space:
mode:
Diffstat (limited to 'timezone.scm')
-rw-r--r--timezone.scm257
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 17:00:04 +0000