Changeset 15304


Ignore:
Timestamp:
Apr 8, 2012, 9:36:09 PM (8 years ago)
Author:
gb
Message:

DECODE-UNIVERSAL-TIME: handle time-zone arg correctly.

ENCODE-UNIVERSAL-TIME: explicitly typecheck args, check for
valid combinations of year/month/day. If we somehow would get
a negative answer, error.

Fixes ticket:934.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/time.lisp

    r13067 r15304  
    9090   Monday), T (daylight savings time) or NIL (standard time), and timezone.
    9191   Completely ignores daylight-savings-time when time-zone is supplied."
    92   (multiple-value-bind (weeks secs)
    93                        (truncate (+ universal-time seconds-offset)
    94                                  seconds-in-week)
    95     (let* ((weeks (+ weeks weeks-offset))
    96            (second NIL)
    97            (minute NIL)
    98            (hour NIL)
    99            (date NIL)
    100            (month NIL)
    101            (year NIL)
    102            (day NIL)
    103            (daylight NIL)
    104            (timezone (if (null time-zone)
    105                          (multiple-value-bind
    106                              (minwest dst)
    107                              (get-timezone (- universal-time
    108                                               unix-to-universal-time))
    109                            (setf daylight dst)
    110                            minwest)
    111                          (* time-zone 60))))
    112       (declare (fixnum timezone))
    113       (multiple-value-bind (t1 seconds) (truncate secs 60)
    114         (setq second seconds)
    115         (setq t1 (- t1 timezone))
    116         (let* ((tday (if (< t1 0)
    117                          (1- (truncate (1+ t1) minutes-per-day))
    118                          (truncate t1 minutes-per-day))))
    119           (multiple-value-setq (hour minute)
    120             (truncate (- t1 (* tday minutes-per-day)) 60))
    121           (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
    122                  (tcent (truncate t2 quarter-days-per-century)))
    123             (setq t2 (mod t2 quarter-days-per-century))
    124             (setq t2 (+ (- t2 (mod t2 4)) 3))
    125             (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
    126             (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
    127                                                  4))))
    128               (setq day (mod (+ tday weekday-november-17-1858) 7))
    129               (let ((t3 (+ (* days-since-mar0 5) 456)))
    130                 (cond ((>= t3 1989)
    131                        (setq t3 (- t3 1836))
    132                        (setq year (1+ year))))
    133                 (multiple-value-setq (month t3) (truncate t3 153))
    134                 (setq date (1+ (truncate t3 5))))))))
    135       (values second minute hour date month year day
    136               daylight
    137               (if daylight
    138                   (1+ (/ timezone 60))
    139                   (/ timezone 60))))))
     92  (let* ((daylight nil)
     93         (timezone (if (null time-zone)
     94                     (multiple-value-bind
     95                         (minwest dst)
     96                         (get-timezone (- universal-time
     97                                          unix-to-universal-time))
     98                       (declare (fixnum minwest))
     99                       (setf daylight dst)
     100                       (the fixnum (* minwest 60)))
     101                     (* time-zone 60 60))))
     102    (declare (fixnum timezone))
     103    (multiple-value-bind (weeks secs)
     104        (truncate (+ (- universal-time timezone) seconds-offset)
     105                  seconds-in-week)
     106      (let* ((weeks (+ weeks weeks-offset))
     107             (second NIL)
     108             (minute NIL)
     109             (hour NIL)
     110             (date NIL)
     111             (month NIL)
     112             (year NIL)
     113             (day NIL))
     114        (multiple-value-bind (t1 seconds) (truncate secs 60)
     115          (setq second seconds)
     116          (let* ((tday (truncate t1 minutes-per-day)))
     117            (multiple-value-setq (hour minute)
     118              (truncate (- t1 (* tday minutes-per-day)) 60))
     119            (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
     120                   (tcent (truncate t2 quarter-days-per-century)))
     121              (setq t2 (mod t2 quarter-days-per-century))
     122              (setq t2 (+ (- t2 (mod t2 4)) 3))
     123              (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
     124              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
     125                                                   4))))
     126                (setq day (mod (+ tday weekday-november-17-1858) 7))
     127                (let ((t3 (+ (* days-since-mar0 5) 456)))
     128                  (cond ((>= t3 1989)
     129                         (setq t3 (- t3 1836))
     130                         (setq year (1+ year))))
     131                  (multiple-value-setq (month t3) (truncate t3 153))
     132                  (setq date (1+ (truncate t3 5))))))))
     133        (values second minute hour date month year day
     134                daylight
     135                (if daylight
     136                  (1+ (/ timezone 60 60))
     137                  (/ timezone 60 60)))))))
    140138
    141139(defun get-decoded-time ()
     
    162160    (coerce (nreverse results) 'vector)))
    163161
     162(defun check-valid-date (year month day)
     163  (declare (fixnum year month day))
     164  (let* ((limit (if (and (eql month 2)
     165                         (not (logtest year 3))
     166                         (or (eql 0 (mod year 400))
     167                             (not (eql 0 (mod year 100)))))
     168                  29
     169                  (svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)))))
     170    (declare (fixnum limit))
     171    (unless (<= day limit)
     172      (report-bad-arg day `(integer 1 ,limit)))))
     173
    164174(defun encode-universal-time (second minute hour date month year
    165                                      &optional time-zone)
     175                                     &optional (time-zone nil tz-p))
    166176  "The time values specified in decoded format are converted to
    167177   universal time, which is returned."
    168   (declare (type (mod 60) second)
    169            (type (mod 60) minute)
    170            (type (mod 24) hour)
    171            (type (integer 1 31) date)
    172            (type (integer 1 12) month)
    173            (type unsigned-byte year)
    174            (type (or null rational) time-zone))
    175   (when (< year 100)
    176     (let* ((this (current-year))
    177            (past (- this 50))
    178            (future (+ this 49))
    179            (maybe-past (+ (- past (mod past 100)) year))
    180            (maybe-future (+ (- future (mod future 100)) year)))
    181       (if (>= maybe-past past)
    182         (setq year maybe-past)
    183         (setq year maybe-future))))
    184            
    185   (let* ((days (+ (1- date)
    186                   (aref *days-before-month* month)
    187                   (if (> month 2)
    188                     (leap-years-before (1+ year))
    189                     (leap-years-before year))
    190                   (* (- year 1900) 365)))
    191          (hours (+ hour (* days 24))))
    192     (if time-zone
    193       (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
    194       (let* ((minwest-guess
    195               (get-timezone (- (* hours 60 60)
    196                                unix-to-universal-time)))
    197              (guess (+ minute (* hours 60) minwest-guess))
    198              (minwest
    199               (get-timezone (- (* guess 60)
    200                                unix-to-universal-time))))
    201         (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
     178  (check-type second (mod 60))
     179  (check-type minute (mod 60))
     180  (check-type hour (mod 24))
     181  (check-type date (integer 1 31))
     182  (check-type month (integer 1 12))
     183  (check-type year unsigned-byte)
     184  (when time-zone
     185    (check-type time-zone (rational -24 24)))
     186  (locally
     187      (declare (type (mod 60) second)
     188               (type (mod 60) minute)
     189               (type (mod 24) hour)
     190               (type (integer 1 31) date)
     191               (type (integer 1 12) month)
     192               (type unsigned-byte year)
     193               (type (or null rational) time-zone))
     194    (when (< year 100)
     195      (let* ((this (current-year))
     196             (past (- this 50))
     197             (future (+ this 49))
     198             (maybe-past (+ (- past (mod past 100)) year))
     199             (maybe-future (+ (- future (mod future 100)) year)))
     200        (if (>= maybe-past past)
     201          (setq year maybe-past)
     202          (setq year maybe-future))))
     203    ;; 12/31/1899 in some time zones might yield a date after
     204    ;; the start of the epoch in UTC.
     205    (check-type year (integer 1899))
     206    (check-valid-date year month date)
     207    (let* ((days (+ (1- date)
     208                    (aref *days-before-month* month)
     209                    (if (> month 2)
     210                      (leap-years-before (1+ year))
     211                      (leap-years-before year))
     212                    (* (- year 1900) 365)))
     213           (hours (+ hour (* days 24)))
     214           (result
     215            (if time-zone
     216              (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
     217              (let* ((minwest-guess
     218                      (get-timezone (- (* hours 60 60)
     219                                       unix-to-universal-time)))
     220                     (guess (+ minute (* hours 60) minwest-guess))
     221                     (minwest
     222                      (get-timezone (- (* guess 60)
     223                                       unix-to-universal-time))))
     224                (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
     225      (if (< result 0)
     226        (error "Universal time for MM/DD/YYYY ~2,'0d/~2,'0d/~4,'0d ~2,'0d:~2,'0d:~2,'0d ~%with ~a time zone would be negative." month date year hour minute second (if tz-p "specified" "current"))
     227        result))))
    202228
    203229
Note: See TracChangeset for help on using the changeset viewer.