local-time-tweaks

lt-tweaks.lisp

(in-package #:local-time)

(deftype nanosecond-range ()
 '(mod 1000000000))

(deftype second-minute-range ()
 '(mod 60))

(deftype hour-range ()
 '(mod 24))

(deftype day-range ()
 '(mod 32))

(deftype month-range ()
  '(integer 1 12))

(deftype year-range ()
  '(integer -1000000 1000000))

(define-condition invalid-timestamp-component (error)
  ((component :accessor component-of :initarg :component))
  (:report (lambda (condition stream)
             (format stream "Got bad timestamp component: ~S" 
                     (component-of condition)))))

(define-condition invalid-timestamp-component-day (invalid-timestamp-component)
  ((component :accessor component-of :initarg :component))
  (:report (lambda (condition stream)
             (format stream "Got invalid day/month/year timestamp component: ~S" 
                     (component-of condition)))))

;; Following function will error instead of returning nil. It is meant to
;; account for certain anomalous behavior exhibited by the current
;; implementation of local-time::valid-timestamp-p when YEAR is outside the
;; integer range [-1000000,1000000] e.g.:
;;
;; (local-time::valid-timestamp-p 000001 0 0 0 28 2 most-positive-fixnum)
;;  => T
;; (local-time::valid-timestamp-p 000001 0 0 0 29 2 most-positive-fixnum)
;;  => NIL
;; (local-time:encode-timestamp 000001 0 0 0 29 2 most-positive-fixnum)
;;  => error
;; (local-time:encode-timestamp 000001 0 0 0 28 2 most-positive-fixnum)
;;  => error
;; 
;; (valid-timestamp-or-error 000001 0 0 0 29 2 2012)
;; => T
;; (valid-timestamp-or-error 000001 0 0 0 29 2 -1000000)
;; => T
;; (valid-timestamp-or-error 000001 0 0 0 29 2 1000000)
;;  => T
;;
;; Following error successfully:
;;
;; (valid-timestamp-or-error 000001 0 0 0 28 2 -1000001)
;; (valid-timestamp-or-error 000001 0 0 0 28 2 1000001)
;; (valid-timestamp-or-error 000001 0 0 0 28 2 most-positive-fixnum)
;; (valid-timestamp-or-error 000001 0 0 0 29 2 2011)
;;
(defun valid-timestamp-or-error (nsec sec minute hour day month year)
  "Returns T if the time values refer to a valid time, otherwise signals an
`invalid-timestamp-component' condition."
  (declare (optimize (speed 3)))
  (and (or (typep nsec 'nanosecond-range)
           (error 'invalid-timestamp-component
                  :component (list :nsec nsec)))
       (or (typep sec 'second-minute-range)
           (error 'invalid-timestamp-component
                  :component (list :sec sec)))
       (or (typep minute 'second-minute-range)
           (error 'invalid-timestamp-component
                  :component (list :min minute)))
       (or (typep hour 'hour-range)
           (error 'invalid-timestamp-component
                  :component (list :hour hour)))
       (or (typep month 'month-range)
           (error 'invalid-timestamp-component
                  :component (list :month month)))
       (and (or (typep day 'day-range)
                (error 'invalid-timestamp-component
                       :component (list :day day)))
            (or (<= 1 day (local-time:days-in-month month year))
                (error 'invalid-timestamp-component-day
                       :component (list :day day :month month :year year))))
       (or (and (typep year 'year-range)
               (not (zerop year)))
          (error 'invalid-timestamp-component
                 :component (list :year year)))))
;; Like `local-time::%construct-timestring' but allows FORMAT to contain the
;; element :GMT-OFFSET-NO-COLON.
;;
;; If present it indicates to print the offset from UTC in an alternative format
;; separate from that perscribed by ISO-8601/RFC 3339.
;;
;; This means that the time-numoffset form described in RFC 3339 section entitled
;; "5.6 - Internet Date/Time Format" can be returned without containing a colon
;; separating the time-hour and time-minute portions.
;;
;; So, instead of either +NN:NN or -NN:NN we can now get +NNNN or -NNNN.
;;
;;  time-numoffset = ("+" / "-") time-hour ":" time-minute
;;
;;  time-numoffset = ("+" / "-") time-hour time-minute
;;
;; :EXAMPLE
;;
;;  (%lt-construct-timestring (local-time:now)
;;                            '((:year 4) #\- (:month 2) #\- (:day 2) 
;;                              #\T (:hour 2) (:min 2) (:sec 2) 
;;                              :gmt-offset-no-colon)
;;                            local-time:*default-timezone*)
;;
;;  (%lt-construct-timestring (local-time:now)
;;                            '((:year 4) #\- (:month 2) #\- (:day 2) #\_ "FOO")
;;                            local-time:*default-timezone*)
;;
;;  (%lt-construct-timestring (local-time:now)
;;                            '((:year 4) #\- (:month 2) #\- (:day 2) 
;;                              #\T (:hour 2) #\_ (:min 2) #\_ (:sec 2) 
;;                              :gmt-offset #\_ #\( :timezone #\))
;;                            local-time:*default-timezone*)
;;
;;  (%lt-construct-timestring (local-time:now)
;;                            '((:year 4) #\- (:month 2) #\- (:day 2) 
;;                              #\T (:hour 2) #\_ (:min 2) #\_ (:sec 2) 
;;                              :gmt-offset-or-z) 
;;                            local-time:+utc-zone+)
(defun %lt-construct-timestring (timestamp format timezone)
  (declare (type local-time:timestamp timestamp)
           (optimize (speed 3)))
  (multiple-value-bind (nsec sec minute hour day month year weekday daylight-p offset abbrev)
      (local-time:decode-timestamp timestamp :timezone timezone)
    (declare (ignore daylight-p))
    (let ((*print-pretty* nil)
          (*print-circle* nil))
      (with-output-to-string (result nil :element-type 'base-char)
        (dolist (fmt format)
          (case (or (and (stringp fmt) :string) 
                    (and (characterp fmt) :character)
                    fmt)
            ((or :gmt-offset :gmt-offset-or-z :gmt-offset-no-colon)
             (multiple-value-bind (offset-hours offset-secs)
                 (floor offset local-time:+seconds-per-hour+)
               (declare (fixnum offset-hours offset-secs))
               (if (and (eql fmt :gmt-offset-or-z) 
                        (zerop offset))
                   (princ #\Z result)
                   (format result (if (eql fmt :gmt-offset-no-colon)
                                      "~C~2,'0D~2,'0D"
                                      "~C~2,'0D:~2,'0D")
                           (if (minusp offset-hours) #\- #\+)
                           (abs offset-hours)
                           (truncate (abs offset-secs)
                                     local-time:+seconds-per-minute+)))))
            (:short-year
             (princ (mod year 100) result))
            (:long-month
             (princ (aref local-time:+month-names+ month) result))
            (:short-month
             (princ (aref local-time:+short-month-names+ month) result))
            (:long-weekday
             (princ (aref local-time:+day-names+ weekday) result))
            (:short-weekday
             (princ (aref local-time:+short-day-names+ weekday) result))
            (:timezone
             (princ abbrev result))
            (:hour12
             (princ (1+ (mod (1- hour) 12)) result))
            (:ampm
             (princ (if (< hour 12) "am" "pm") result))
            (:ordinal-day
             (princ (local-time::ordinalize day) result))
            ((:character :string)
             (princ fmt result))
            (t
             (let ((val (ecase (if (consp fmt) (car fmt) fmt)
                          (:nsec nsec)
                          (:usec (floor nsec 1000))
                          (:msec (floor nsec 1000000))
                          (:sec sec)
                          (:min minute)
                          (:hour hour)
                          (:day day)
                          (:weekday weekday)
                          (:month month)
                          (:year year))))
               (cond
                 ((atom fmt)
                  (princ val result))
                 ((minusp val)
                  (format result "-~V,VD"
                          (second fmt)
                          (or (third fmt) #\0)
                          (abs val)))
                 (t
                  (format result "~V,VD"
                          (second fmt)
                          (or (third fmt) #\0)
                          val)))))))))))

(defun %lt-format-timestring (stream timestamp-object &key (format *iso-8601-format*)
                                                       (timezone local-time:*default-timezone*))
  (declare (type local-time:timestamp timestamp-object)
           (type (or boolean stream) stream))
  (let ((result (%lt-construct-timestring timestamp-object format timezone)))
    (when stream
      (write-string result stream))
    result))