diff options
Diffstat (limited to 'timezone.scm')
| -rw-r--r-- | timezone.scm | 145 |
1 files changed, 18 insertions, 127 deletions
diff --git a/timezone.scm b/timezone.scm index 89f85c8..2d35dd7 100644 --- a/timezone.scm +++ b/timezone.scm @@ -49,35 +49,33 @@ ;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer (require 'scanf) +(require 'time-core) (require-if 'compiling 'tzfile) -;@ -(define daylight? #f) -(define *timezone* 0) -(define tzname '#("UTC" "???")) - -(define tz:default #f) ;;; 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/.") + (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) (in-vicinity tzfile:vicinity "localtime")) + (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)))) - (and (file-exists? realpath) - (let ((zone #f)) - (require 'tzfile) - (set! zone (tzfile:read realpath)) - (if zone (list->vector (cons 'tz:file zone)) - (slib:error 'read-tzfile realpath)))))) + (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. @@ -148,117 +146,10 @@ (else #f)))) ;@ (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)))) + (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)))) - -;;; 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) |