diff options
Diffstat (limited to 'psxtime.scm')
| -rw-r--r-- | psxtime.scm | 163 |
1 files changed, 73 insertions, 90 deletions
diff --git a/psxtime.scm b/psxtime.scm index 753e81f..fed0707 100644 --- a/psxtime.scm +++ b/psxtime.scm @@ -19,106 +19,32 @@ ;;; No, it doesn't do leap seconds. +(require 'time-core) (require-if 'compiling 'time-zone) - -(define time:days/month - '#(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years. - #(31 29 31 30 31 30 31 31 30 31 30 31))) -(define (leap-year? year) - (and (zero? (remainder year 4)) - (or (not (zero? (remainder year 100))) - (zero? (remainder year 400))))) ; Leap years. - -;;; Returns the `struct tm' representation of T, -;;; offset TM_GMTOFF seconds east of UCT. -(define (time:split t tm_isdst tm_gmtoff tm_zone) - (set! t (difftime t tm_gmtoff)) - (let* ((secs (modulo t 86400)) ; SECS/DAY - (days (+ (quotient t 86400) ; SECS/DAY - (if (and (negative? t) (positive? secs)) -1 0)))) - (let ((tm_hour (quotient secs 3600)) - (secs (remainder secs 3600)) - (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday. - (let loop ((tm_year 1970) - (tm_yday days)) - (let ((diy (if (leap-year? tm_year) 366 365))) - (cond - ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy))) - ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy))) - (else - (let* ((mv (vector-ref time:days/month (- diy 365)))) - (do ((tm_mon 0 (+ 1 tm_mon)) - (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon)))) - ((< tm_mday (vector-ref mv tm_mon)) - (vector - (remainder secs 60) ; Seconds. [0-61] (2 leap seconds) - (quotient secs 60) ; Minutes. [0-59] - tm_hour ; Hours. [0-23] - (+ tm_mday 1) ; Day. [1-31] - tm_mon ; Month. [0-11] - (- tm_year 1900) ; Year - 1900. - tm_wday ; Day of week. [0-6] - tm_yday ; Days in year. [0-365] - tm_isdst ; DST. [-1/0/1] - tm_gmtoff ; Seconds west of UTC. - tm_zone ; Timezone abbreviation. - ))))))))))) ;@ -(define (gmtime t) - (time:split t 0 0 "GMT")) +(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" zone)))) ;@ (define (localtime caltime . tz) (require 'time-zone) (set! tz (if (null? tz) (tzset) (car tz))) (apply time:split caltime (tz:params caltime tz))) - -(define time:year-70 - (let* ((t (current-time))) - (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800)))) - -(define (time:invert decoder target) - (let* ((times '#(1 60 3600 86400 2678400 32140800)) - (trough ; rough time for target - (do ((i 5 (+ i -1)) - (trough time:year-70 - (offset-time trough (* (vector-ref target i) - (vector-ref times i))))) - ((negative? i) trough)))) -;;; (print 'trough trough 'target target) - (let loop ((guess trough) - (j 0) - (guess-tm (decoder trough))) -;;; (print 'guess guess 'guess-tm guess-tm) - (do ((i 5 (+ i -1)) - (rough time:year-70 - (offset-time rough (* (vector-ref guess-tm i) - (vector-ref times i)))) - (sign (let ((d (- (vector-ref target 5) - (vector-ref guess-tm 5)))) - (and (not (zero? d)) d)) - (or sign - (let ((d (- (vector-ref target i) - (vector-ref guess-tm i)))) - (and (not (zero? d)) d))))) - ((negative? i) - (let* ((distance (abs (- trough rough)))) - (cond ((and (zero? distance) sign) -;;; (print "trying to jump") - (set! distance (if (negative? sign) -86400 86400))) - ((and sign (negative? sign)) (set! distance (- distance)))) - (set! guess (offset-time guess distance)) -;;; (print 'distance distance 'sign sign) - (cond ((zero? distance) guess) - ((> j 5) #f) ;to prevent inf loops. - (else - (loop guess - (+ 1 j) - (decoder guess)))))))))) ;@ (define (mktime univtime . tz) (require 'time-zone) (set! tz (if (null? tz) (tzset) (car tz))) - (+ (gmktime univtime) (tz:std-offset tz))) + (offset-time (gmktime univtime) (tz:std-offset tz))) ;@ (define (gmktime univtime) (time:invert time:gmtime univtime)) @@ -150,8 +76,65 @@ (time:asctime (time:gmtime time))) ;;; GMT Local -- take optional 2nd TZ arg -(define time:gmtime gmtime) (define time:localtime localtime) +;;@ +(define gmtime time:gmtime) + +(define time:localtime localtime) ;;(define time:gmktime gmktime) (define time:mktime mktime) ;;(define time:gtime gtime) (define time:ctime ctime) (define time:asctime asctime) + +;@ +(define daylight? #f) +(define *timezone* 0) +(define tzname '#("UTC" "???")) + +(define tz:default #f) + +;;;@ 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))))) + (let () + (require 'time-zone) + (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) |