Changeset 15304

Timestamp:

Apr 8, 2012, 2:36:09 PM (13 years ago)

Author:

Gary Byers

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:

• trunk/source/lib/time.lisp (modified) (2 diffs)

trunk/source/lib/time.lisp

@@ -90 +90 @@
    Monday), T (daylight savings time) or NIL (standard time), and timezone.
    Completely ignores daylight-savings-time when time-zone is supplied."
-  (multiple-value-bind (weeks secs)
-                       (truncate (+ universal-time seconds-offset)
-                                 seconds-in-week)
-    (let* ((weeks (+ weeks weeks-offset))
-           (second NIL)
-           (minute NIL)
-           (hour NIL)
-           (date NIL)
-           (month NIL)
-           (year NIL)
-           (day NIL)
-           (daylight NIL)
-           (timezone (if (null time-zone)
-                         (multiple-value-bind
-                             (minwest dst)
-                             (get-timezone (- universal-time
-                                              unix-to-universal-time))
-                           (setf daylight dst)
-                           minwest)
-                         (* time-zone 60))))
-      (declare (fixnum timezone))
-      (multiple-value-bind (t1 seconds) (truncate secs 60)
-        (setq second seconds)
-        (setq t1 (- t1 timezone))
-        (let* ((tday (if (< t1 0)
-                         (1- (truncate (1+ t1) minutes-per-day))
-                         (truncate t1 minutes-per-day))))
-          (multiple-value-setq (hour minute)
-            (truncate (- t1 (* tday minutes-per-day)) 60))
-          (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
-                 (tcent (truncate t2 quarter-days-per-century)))
-            (setq t2 (mod t2 quarter-days-per-century))
-            (setq t2 (+ (- t2 (mod t2 4)) 3))
-            (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
-            (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
-                                                 4))))
-              (setq day (mod (+ tday weekday-november-17-1858) 7))
-              (let ((t3 (+ (* days-since-mar0 5) 456)))
-                (cond ((>= t3 1989)
-                       (setq t3 (- t3 1836))
-                       (setq year (1+ year))))
-                (multiple-value-setq (month t3) (truncate t3 153))
-                (setq date (1+ (truncate t3 5))))))))
-      (values second minute hour date month year day
-              daylight
-              (if daylight
-                  (1+ (/ timezone 60))
-                  (/ timezone 60))))))
+  (let* ((daylight nil)
+         (timezone (if (null time-zone)
+                     (multiple-value-bind
+                         (minwest dst)
+                         (get-timezone (- universal-time
+                                          unix-to-universal-time))
+                       (declare (fixnum minwest))
+                       (setf daylight dst)
+                       (the fixnum (* minwest 60)))
+                     (* time-zone 60 60))))
+    (declare (fixnum timezone))
+    (multiple-value-bind (weeks secs)
+        (truncate (+ (- universal-time timezone) seconds-offset)
+                  seconds-in-week)
+      (let* ((weeks (+ weeks weeks-offset))
+             (second NIL)
+             (minute NIL)
+             (hour NIL)
+             (date NIL)
+             (month NIL)
+             (year NIL)
+             (day NIL))
+        (multiple-value-bind (t1 seconds) (truncate secs 60)
+          (setq second seconds)
+          (let* ((tday (truncate t1 minutes-per-day)))
+            (multiple-value-setq (hour minute)
+              (truncate (- t1 (* tday minutes-per-day)) 60))
+            (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
+                   (tcent (truncate t2 quarter-days-per-century)))
+              (setq t2 (mod t2 quarter-days-per-century))
+              (setq t2 (+ (- t2 (mod t2 4)) 3))
+              (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
+              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
+                                                   4))))
+                (setq day (mod (+ tday weekday-november-17-1858) 7))
+                (let ((t3 (+ (* days-since-mar0 5) 456)))
+                  (cond ((>= t3 1989)
+                         (setq t3 (- t3 1836))
+                         (setq year (1+ year))))
+                  (multiple-value-setq (month t3) (truncate t3 153))
+                  (setq date (1+ (truncate t3 5))))))))
+        (values second minute hour date month year day
+                daylight
+                (if daylight
+                  (1+ (/ timezone 60 60))
+                  (/ timezone 60 60)))))))
 
 (defun get-decoded-time ()
@@ -162 +160 @@
     (coerce (nreverse results) 'vector)))
 
+(defun check-valid-date (year month day)
+  (declare (fixnum year month day))
+  (let* ((limit (if (and (eql month 2)
+                         (not (logtest year 3))
+                         (or (eql 0 (mod year 400))
+                             (not (eql 0 (mod year 100)))))
+                  29
+                  (svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)))))
+    (declare (fixnum limit))
+    (unless (<= day limit)
+      (report-bad-arg day `(integer 1 ,limit)))))
+
 (defun encode-universal-time (second minute hour date month year
-                                     &optional time-zone)
+                                     &optional (time-zone nil tz-p))
   "The time values specified in decoded format are converted to
    universal time, which is returned."
-  (declare (type (mod 60) second)
-           (type (mod 60) minute)
-           (type (mod 24) hour)
-           (type (integer 1 31) date)
-           (type (integer 1 12) month)
-           (type unsigned-byte year)
-           (type (or null rational) time-zone))
-  (when (< year 100)
-    (let* ((this (current-year))
-           (past (- this 50))
-           (future (+ this 49))
-           (maybe-past (+ (- past (mod past 100)) year))
-           (maybe-future (+ (- future (mod future 100)) year)))
-      (if (>= maybe-past past)
-        (setq year maybe-past)
-        (setq year maybe-future))))
-           
-  (let* ((days (+ (1- date)
-                  (aref *days-before-month* month)
-                  (if (> month 2)
-                    (leap-years-before (1+ year))
-                    (leap-years-before year))
-                  (* (- year 1900) 365)))
-         (hours (+ hour (* days 24))))
-    (if time-zone
-      (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
-      (let* ((minwest-guess
-              (get-timezone (- (* hours 60 60)
-                               unix-to-universal-time)))
-             (guess (+ minute (* hours 60) minwest-guess))
-             (minwest
-              (get-timezone (- (* guess 60)
-                               unix-to-universal-time))))
-        (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
+  (check-type second (mod 60))
+  (check-type minute (mod 60))
+  (check-type hour (mod 24))
+  (check-type date (integer 1 31))
+  (check-type month (integer 1 12))
+  (check-type year unsigned-byte)
+  (when time-zone
+    (check-type time-zone (rational -24 24)))
+  (locally
+      (declare (type (mod 60) second)
+               (type (mod 60) minute)
+               (type (mod 24) hour)
+               (type (integer 1 31) date)
+               (type (integer 1 12) month)
+               (type unsigned-byte year)
+               (type (or null rational) time-zone))
+    (when (< year 100)
+      (let* ((this (current-year))
+             (past (- this 50))
+             (future (+ this 49))
+             (maybe-past (+ (- past (mod past 100)) year))
+             (maybe-future (+ (- future (mod future 100)) year)))
+        (if (>= maybe-past past)
+          (setq year maybe-past)
+          (setq year maybe-future))))
+    ;; 12/31/1899 in some time zones might yield a date after
+    ;; the start of the epoch in UTC.
+    (check-type year (integer 1899))
+    (check-valid-date year month date)
+    (let* ((days (+ (1- date)
+                    (aref *days-before-month* month)
+                    (if (> month 2)
+                      (leap-years-before (1+ year))
+                      (leap-years-before year))
+                    (* (- year 1900) 365)))
+           (hours (+ hour (* days 24)))
+           (result
+            (if time-zone
+              (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
+              (let* ((minwest-guess
+                      (get-timezone (- (* hours 60 60)
+                                       unix-to-universal-time)))
+                     (guess (+ minute (* hours 60) minwest-guess))
+                     (minwest
+                      (get-timezone (- (* guess 60)
+                                       unix-to-universal-time))))
+                (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
+      (if (< result 0)
+        (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"))
+        result))))