module/slib/psxtime.scm

   1 ;;;; "psxtime.scm" Posix time conversion routines
   2 ;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 ;;; No, it doesn't do leap seconds.
  21
  22 (define time:days/month
  23   '#(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years.
  24      #(31 29 31 30 31 30 31 31 30 31 30 31)))
  25 (define (leap-year? year)
  26   (and (zero? (remainder year 4))
  27        (or (not (zero? (remainder year 100)))
  28            (zero? (remainder year 400))))) ; Leap years.
  29
  30 ;;; Returns the `struct tm' representation of T,
  31 ;;; offset TM_GMTOFF seconds east of UCT.
  32 (define (time:split t tm_isdst tm_gmtoff tm_zone)
  33   (set! t (difftime t tm_gmtoff))
  34   (let* ((secs (modulo t 86400))        ; SECS/DAY
  35          (days (+ (quotient t 86400)    ; SECS/DAY
  36                   (if (and (negative? t) (positive? secs)) -1 0))))
  37     (let ((tm_hour (quotient secs 3600))
  38           (secs (remainder secs 3600))
  39           (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday.
  40       (let loop ((tm_year 1970)
  41                  (tm_yday days))
  42         (let ((diy (if (leap-year? tm_year) 366 365)))
  43           (cond
  44            ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy)))
  45            ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy)))
  46            (else
  47             (let* ((mv (vector-ref time:days/month (- diy 365))))
  48               (do ((tm_mon 0 (+ 1 tm_mon))
  49                    (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon))))
  50                   ((< tm_mday (vector-ref mv tm_mon))
  51                    (vector
  52                     (remainder secs 60) ; Seconds.      [0-61] (2 leap seconds)
  53                     (quotient secs 60)  ; Minutes.      [0-59]
  54                     tm_hour             ; Hours.        [0-23]
  55                     (+ tm_mday 1)       ; Day.          [1-31]
  56                     tm_mon              ; Month.        [0-11]
  57                     (- tm_year 1900)    ; Year  - 1900.
  58                     tm_wday             ; Day of week.  [0-6]
  59                     tm_yday             ; Days in year. [0-365]
  60                     tm_isdst            ; DST.          [-1/0/1]
  61                     tm_gmtoff           ; Seconds west of UTC.
  62                     tm_zone             ; Timezone abbreviation.
  63                     )))))))))))
  64
  65 (define (time:gmtime t)
  66   (time:split t 0 0 "GMT"))
  67
  68 (define (time:localtime caltime . tz)
  69   (require 'time-zone)
  70   (set! tz (if (null? tz) (tzset) (car tz)))
  71   (apply time:split caltime (tz:params caltime tz)))
  72
  73 (define time:year-70
  74   (let* ((t (current-time)))
  75     (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800))))
  76
  77 (define (time:invert decoder target)
  78   (let* ((times '#(1 60 3600 86400 2678400 32140800))
  79          (trough                        ; rough time for target
  80           (do ((i 5 (+ i -1))
  81                (trough time:year-70
  82                        (offset-time trough (* (vector-ref target i)
  83                                               (vector-ref times i)))))
  84               ((negative? i) trough))))
  85 ;;;    (print 'trough trough 'target target)
  86     (let loop ((guess trough)
  87                (j 0)
  88                (guess-tm (decoder trough)))
  89 ;;;      (print 'guess guess 'guess-tm guess-tm)
  90       (do ((i 5 (+ i -1))
  91            (rough time:year-70
  92                   (offset-time rough (* (vector-ref guess-tm i)
  93                                         (vector-ref times i))))
  94            (sign (let ((d (- (vector-ref target 5)
  95                              (vector-ref guess-tm 5))))
  96                    (and (not (zero? d)) d))
  97                  (or sign
  98                      (let ((d (- (vector-ref target i)
  99                                  (vector-ref guess-tm i))))
 100                        (and (not (zero? d)) d)))))
 101           ((negative? i)
 102            (let* ((distance (abs (- trough rough))))
 103              (cond ((and (zero? distance) sign)
 104 ;;;                 (print "trying to jump")
 105                     (set! distance (if (negative? sign) -86400 86400)))
 106                    ((and sign (negative? sign)) (set! distance (- distance))))
 107              (set! guess (offset-time guess distance))
 108 ;;;          (print 'distance distance 'sign sign)
 109              (cond ((zero? distance) guess)
 110                    ((> j 5) #f)         ;to prevent inf loops.
 111                    (else
 112                     (loop guess
 113                           (+ 1 j)
 114                           (decoder guess))))))))))
 115
 116 (define (time:mktime univtime . tz)
 117   (require 'time-zone)
 118   (set! tz (if (null? tz) (tzset) (car tz)))
 119   (+ (gmktime univtime) (tz:std-offset tz)))
 120
 121 (define (time:gmktime univtime)
 122   (time:invert time:gmtime univtime))
 123
 124 (define (time:asctime decoded)
 125   (let ((days   '#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
 126         (months '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
 127                          "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 128         (number->2digits
 129          (lambda (n ch)
 130            (set! n (number->string n))
 131            (if (= 1 (string-length n))
 132                (string-append ch n)
 133                n))))
 134     (string-append
 135      (vector-ref days (vector-ref decoded 6)) " "
 136      (vector-ref months (vector-ref decoded 4)) " "
 137      (number->2digits (vector-ref decoded 3) " ") " "
 138      (number->2digits (vector-ref decoded 2) "0") ":"
 139      (number->2digits (vector-ref decoded 1) "0") ":"
 140      (number->2digits (vector-ref decoded 0) "0") " "
 141      (number->string (+ 1900 (vector-ref decoded 5)))
 142      (string #\newline))))
 143
 144 (define (time:ctime . args)
 145   (time:asctime (apply time:localtime args)))
 146
 147 (define (time:gtime time)
 148   (time:asctime (time:gmtime time)))
 149
 150 ;;;     GMT                             Local -- take optional 2nd TZ arg
 151 (define gmtime time:gmtime)     (define localtime time:localtime)
 152 (define gmktime time:gmktime)   (define mktime time:mktime)
 153 (define gtime time:gtime)       (define ctime time:ctime)
 154
 155 (define asctime time:asctime)