;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; A variety of structures and function for creating and
;;;; manipulating dates, times, durations and intervals for
;;;; CLSQL.
;; ------------------------------------------------------------
;; time classes: wall-time, duration
-(eval-when (:compile-toplevel :load-toplevel)
+(eval-when (:compile-toplevel :load-toplevel)
(defstruct (wall-time (:conc-name time-)
(:constructor %make-wall-time)
(:print-function %print-wall-time))
(mjd 0 :type fixnum)
(second 0 :type fixnum)
- (usec 0 :type fixnum))
+ (usec 0 :type fixnum)
+ (is-utc? nil :type boolean))
(defun %print-wall-time (time stream depth)
(declare (ignore depth))
- (format stream "#<WALL-TIME: ~a>" (format-time nil time)))
+ (if *print-escape*
+ (format stream "#<WALL-TIME: ~a>" (format-time nil time))
+ (format-time stream time :format :pretty)))
(defstruct (duration (:constructor %make-duration)
(:print-function %print-duration))
(defun %print-duration (duration stream depth)
(declare (ignore depth))
- (format stream "#<DURATION: ~a>"
- (format-duration nil duration :precision :second)))
+ (if *print-escape*
+ (format stream "#<DURATION: ~a>"
+ (format-duration nil duration :precision :second))
+ (format-duration stream duration :precision :second)))
(defstruct (date (:constructor %make-date)
- (:print-function %print-date))
+ (:print-function %print-date))
(mjd 0 :type fixnum))
(defun %print-date (date stream depth)
(declare (ignore depth))
- (format stream "#<DATE: ~a>" (format-date nil date)))
+ (if *print-escape*
+ (format stream "#<DATE: ~a>" (format-date nil date))
+ (format-date stream date :format :pretty)))
);eval-when
(let ((second (duration-second duration))
(minute (duration-minute duration))
(hour (duration-hour duration))
- (day (duration-day duration)))
- (format nil "P~dD~dH~dM~dS" day hour minute second)))
+ (day (duration-day duration))
+ (month (duration-month duration))
+ (year (duration-year duration)))
+ (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second)))
;; ------------------------------------------------------------
;; Constructors
+(defvar *default-timezone*)
+(defvar *default-timezone-is-dst?*)
+
+;; allows non implementation specific timezone defaulting.
+;; Its mostly for testing, or setting directly to UTC
+;; as its assumed to be relying on operating system / lisp system
+;; defaults for what your local time is otherwise
+(defun %decode-utime (ut)
+ (multiple-value-bind
+ (sec min hour day month year day-of-week dst? tz)
+ (decode-universal-time ut)
+ (values sec min hour day month year day-of-week
+ (or (when (boundp '*default-timezone-is-dst?*)
+ *default-timezone-is-dst?*)
+ dst?)
+ (or (when (boundp '*default-timezone*)
+ *default-timezone*)
+ tz))))
+
+(defun %universal-ts-offset (time)
+ ;; I verified this using the local-time lib as example
+ ;; --- see tests/utc-time-compare.lisp
+ (multiple-value-bind (tusec tsec tmin thour tday tmonth tyear)
+ (decode-time time)
+ (declare (ignore tusec))
+ ;; find tz info and apply to wall-time
+ (multiple-value-bind
+ (_sec _min _hour _day _month _year _day-of-week dst? tz)
+ (%decode-utime
+ (encode-universal-time
+ tsec tmin thour tday tmonth tyear))
+ (declare (ignore _sec _min _hour _day _month _year _day-of-week))
+ (when dst?
+ (incf tz -1))
+ (values (- (* tz 60 60)) tz))))
+
+(defun time-to-utc (in)
+ "Ensures that if we have a time thats not in UTC, treat it as a localtime,
+ and convert to UTC"
+ (if (time-is-utc? in)
+ in
+ (let ((newt
+ (time+ in (make-duration :second (%universal-ts-offset in)))))
+ (setf (time-is-utc? newt) T)
+ newt)))
+
(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
- (second 0) (usec 0) (offset 0))
- (let ((mjd (gregorian-to-mjd month day year))
- (sec (+ (* hour 60 60)
- (* minute 60)
- second (- offset))))
- (multiple-value-bind (day-add raw-sec)
- (floor sec (* 60 60 24))
- (%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec))))
+ (second 0) (usec 0) (offset nil))
+ (let* ((mjd (gregorian-to-mjd month day year))
+ (sec (+ (* hour 60 60)
+ (* minute 60)
+ second (or offset 0)))
+ (time (multiple-value-bind (day-add raw-sec)
+ (floor sec (* 60 60 24))
+ (%make-wall-time :mjd (+ mjd day-add)
+ :second raw-sec :usec (or usec 0)
+ :is-utc? (if offset t nil)))))
+ time))
(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
- (second 0) (usec 0) (offset 0))
+ (second 0) (usec 0) (offset nil))
(time->date (make-time :year year :month month :day day :hour hour
- :minute minute :second second :usec usec :offset offset)))
+ :minute minute :second second :usec usec
+ :offset offset)))
(defun copy-time (time)
(%make-wall-time :mjd (time-mjd time)
- :second (time-second time)))
+ :second (time-second time)
+ :usec (time-usec time)
+ :is-utc? (time-is-utc? time)))
(defun utime->time (utime)
"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
(time-ymd time)
(multiple-value-bind (hour minute second)
(time-hms time)
- (values (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
+ (values (time-usec time) second minute hour day month year
+ (mod (+ (time-mjd time) 3) 7)
+ (time-is-utc? time)))))
(defun date-ymd (date)
(time-ymd (date->time date)))
(* (duration-reduce duration :hour) 60)))
(:hour
(+ (if round
- (floor (duration-minute duration) 30)
- 0)
- (duration-hour duration)
- (* (duration-reduce duration :day) 24)))
+ (floor (duration-minute duration) 30)
+ 0)
+ (duration-hour duration)
+ (* (duration-reduce duration :day) 24)))
(:day
(+ (if round
- (floor (duration-hour duration) 12)
- 0)
- (duration-day duration)))))
+ (floor (duration-hour duration) 12)
+ 0)
+ (duration-day duration)))))
;; ------------------------------------------------------------
(defun duration<= (duration-a duration-b)
(<= (duration-reduce duration-a :usec)
(duration-reduce duration-b :usec)))
-
+
(defun duration>= (x y)
(duration<= y x))
(duration< y x))
(defun %time< (x y)
+ (setf x (time-to-utc x)
+ y (time-to-utc y))
(let ((mjd-x (time-mjd x))
(mjd-y (time-mjd y)))
(if (/= mjd-x mjd-y)
(if (/= (time-second x) (time-second y))
(< (time-second x) (time-second y))
(< (time-usec x) (time-usec y))))))
-
+
(defun %time>= (x y)
+ (setf x (time-to-utc x)
+ y (time-to-utc y))
(if (/= (time-mjd x) (time-mjd y))
(>= (time-mjd x) (time-mjd y))
(if (/= (time-second x) (time-second y))
(>= (time-usec x) (time-usec y)))))
(defun %time<= (x y)
+ (setf x (time-to-utc x)
+ y (time-to-utc y))
(if (/= (time-mjd x) (time-mjd y))
(<= (time-mjd x) (time-mjd y))
(if (/= (time-second x) (time-second y))
(<= (time-usec x) (time-usec y)))))
(defun %time> (x y)
+ (setf x (time-to-utc x)
+ y (time-to-utc y))
(if (/= (time-mjd x) (time-mjd y))
(> (time-mjd x) (time-mjd y))
(if (/= (time-second x) (time-second y))
(> (time-usec x) (time-usec y)))))
(defun %time= (x y)
+ (setf x (time-to-utc x)
+ y (time-to-utc y))
(and (= (time-mjd x) (time-mjd y))
(= (time-second x) (time-second y))
(= (time-usec x) (time-usec y))))
(defun time/= (number &rest more-numbers)
"Returns T if no two of its arguments are numerically equal, NIL otherwise."
(do* ((head number (car nlist))
- (nlist more-numbers (cdr nlist)))
+ (nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(unless (do* ((nl nlist (cdr nl)))
- ((atom nl) t)
- (declare (list nl))
- (if (%time= head (car nl)) (return nil)))
+ ((atom nl) t)
+ (declare (list nl))
+ (if (%time= head (car nl)) (return nil)))
(return nil))))
(defun time< (number &rest more-numbers)
"Returns T if its arguments are in strictly increasing order, NIL otherwise."
(do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
+ (nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (%time< n (car nlist))) (return nil))))
(defun time> (number &rest more-numbers)
"Returns T if its arguments are in strictly decreasing order, NIL otherwise."
(do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
+ (nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (%time> n (car nlist))) (return nil))))
(defun time<= (number &rest more-numbers)
"Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
(do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
+ (nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (%time<= n (car nlist))) (return nil))))
(defun time>= (number &rest more-numbers)
"Returns T if arguments are in strictly non-increasing order, NIL otherwise."
(do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
+ (nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (%time>= n (car nlist))) (return nil))))
(defun replace-string (string1 search-string replace-string &key (test #'string=))
"Search within string1 for search-string, replace with replace-string, non-destructively."
(let ((replace-string-length (length replace-string))
- (search-string-length (length search-string)))
+ (search-string-length (length search-string)))
(labels ((sub-replace-string (current-string position)
- (let ((found-position (search search-string current-string :test test :start2 position)))
- (if (null found-position)
- current-string
- (sub-replace-string (concatenate 'string
- (subseq current-string 0 found-position)
- replace-string
- (subseq current-string (+ found-position search-string-length)))
- (+ position replace-string-length))))))
+ (let ((found-position (search search-string current-string :test test :start2 position)))
+ (if (null found-position)
+ current-string
+ (sub-replace-string (concatenate 'string
+ (subseq current-string 0 found-position)
+ replace-string
+ (subseq current-string (+ found-position search-string-length)))
+ (+ position replace-string-length))))))
(sub-replace-string string1 0))))
);eval-when
(defmacro wrap-time-for-date (time-func &key (result-func))
- (let ((date-func (intern (replace-string (symbol-name time-func) "TIME" "DATE"))))
+ (let ((date-func (intern (replace-string (symbol-name time-func)
+ (symbol-name-default-case "TIME")
+ (symbol-name-default-case "DATE")))))
`(defun ,date-func (number &rest more-numbers)
(let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
- ,(if result-func
- `(funcall #',result-func result)
- 'result)))))
+ ,(if result-func
+ `(funcall #',result-func result)
+ 'result)))))
(wrap-time-for-date time=)
(wrap-time-for-date time/=)
;; ------------------------------------------------------------
;; Formatting and output
-
-(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-
-(defun db-timestring (time)
+(defun db-timestring (time &key stream )
"return the string to store the given time in the database"
- (declare (optimize (speed 3)))
- (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX.")))
- (flet ((inscribe-base-10 (output offset size decimal)
- (declare (type fixnum offset size decimal)
- (type (simple-vector 10) +decimal-printer+))
- (dotimes (x size)
- (declare (type fixnum x)
- (optimize (safety 0)))
- (multiple-value-bind (next this)
- (floor decimal 10)
- (setf (aref output (+ (- size x 1) offset))
- (aref +decimal-printer+ this))
- (setf decimal next)))))
- (multiple-value-bind (usec second minute hour day month year)
- (decode-time time)
- (inscribe-base-10 output 1 4 year)
- (inscribe-base-10 output 6 2 month)
- (inscribe-base-10 output 9 2 day)
- (inscribe-base-10 output 12 2 hour)
- (inscribe-base-10 output 15 2 minute)
- (inscribe-base-10 output 18 2 second)
- (format nil "~a~d'" output usec)))))
-
-(defun iso-timestring (time)
- "return the string to store the given time in the database"
- (declare (optimize (speed 3)))
- (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX,")))
- (flet ((inscribe-base-10 (output offset size decimal)
- (declare (type fixnum offset size decimal)
- (type (simple-vector 10) +decimal-printer+))
- (dotimes (x size)
- (declare (type fixnum x)
- (optimize (safety 0)))
- (multiple-value-bind (next this)
- (floor decimal 10)
- (setf (aref output (+ (- size x 1) offset))
- (aref +decimal-printer+ this))
- (setf decimal next)))))
- (multiple-value-bind (usec second minute hour day month year)
- (decode-time time)
- (inscribe-base-10 output 0 4 year)
- (inscribe-base-10 output 5 2 month)
- (inscribe-base-10 output 8 2 day)
- (inscribe-base-10 output 11 2 hour)
- (inscribe-base-10 output 14 2 minute)
- (inscribe-base-10 output 17 2 second)
- (format nil "~a,~d" output usec)))))
+ (if stream
+ (progn (write-char #\' stream) (iso-timestring time :stream stream) (write-char #\' stream))
+ (concatenate 'string "'" (iso-timestring time) "'")))
+
+(defun iso-timestring (time &key stream)
+ (multiple-value-bind (usec sec min hour day month year dow is-utc?)
+ (decode-time time)
+ (declare (ignore dow))
+ (flet ((fmt (stream)
+ (when (< year 1000) (princ #\0 stream))
+ (when (< year 100) (princ #\0 stream))
+ (when (< year 10) (princ #\0 stream))
+ (princ year stream)
+ (princ #\- stream)
+ (when (< month 10) (princ #\0 stream))
+ (princ month stream)
+ (princ #\- stream)
+ (when (< day 10) (princ #\0 stream))
+ (princ day stream)
+ (princ #\T stream) ;strict ISO says T here isn't optional.
+ (when (< hour 10) (princ #\0 stream))
+ (princ hour stream)
+ (princ #\: stream)
+ (when (< min 10) (princ #\0 stream))
+ (princ min stream)
+ (princ #\: stream)
+ (when (< sec 10) (princ #\0 stream))
+ (princ sec stream)
+ (when (and usec (plusp usec))
+ ;; we dont do this because different dbs support differnt precision levels
+ (princ #\. stream)
+ (loop for i from 5 downto 0
+ for x10 = (expt 10 i)
+ do (multiple-value-bind (quo rem)
+ (floor (/ usec x10))
+ (setf usec (- usec (* quo x10)))
+ (princ quo stream)
+ (when (= rem 0) (return)))))
+ (when is-utc? (princ #\Z stream))
+ nil))
+ (if stream
+ (fmt stream)
+ (with-output-to-string (stream)
+ (fmt stream))))))
(defun db-datestring (date)
(db-timestring (date->time date)))
(defstruct interval
(start nil)
(end nil)
- (name nil)
+ (name nil)
(contained nil)
(type nil)
(data nil))
(defun sort-interval-list (list)
(sort list (lambda (x y)
- (case (interval-relation x y)
- ((:precedes :contains) t)
- ((:follows :overlaps :contained) nil)))))
+ (case (interval-relation x y)
+ ((:precedes :contains) t)
+ ((:follows :overlaps :contained) nil)))))
;; interval push will return its list of intervals in strict order.
(defun interval-push (interval-list interval &optional container-rule)
(let ((sorted-list (sort-interval-list interval-list)))
(dotimes (x (length sorted-list))
(let ((elt (nth x sorted-list)))
- (case (interval-relation elt interval)
- (:follows
- (return-from interval-push (insert-at-index x sorted-list interval)))
- (:contains
- (return-from interval-push
- (replace-at-index x sorted-list
- (make-interval :start (interval-start elt)
- :end (interval-end elt)
- :type (interval-type elt)
- :contained (interval-push (interval-contained elt) interval)
- :data (interval-data elt)))))
- ((:overlaps :contained)
- (error "Overlap")))))
+ (case (interval-relation elt interval)
+ (:follows
+ (return-from interval-push (insert-at-index x sorted-list interval)))
+ (:contains
+ (return-from interval-push
+ (replace-at-index x sorted-list
+ (make-interval :start (interval-start elt)
+ :end (interval-end elt)
+ :type (interval-type elt)
+ :contained (interval-push (interval-contained elt) interval)
+ :data (interval-data elt)))))
+ ((:overlaps :contained)
+ (error "Overlap")))))
(append sorted-list (list interval))))
;; interval lists
-
+
(defun interval-match (list time)
"Return the index of the first interval in list containing time"
;; this depends on ordering of intervals!
- (let ((list (sort-interval-list list)))
+ (let ((list (sort-interval-list list)))
(dotimes (x (length list))
(let ((elt (nth x list)))
- (when (and (time<= (interval-start elt) time)
- (time< time (interval-end elt)))
- (return-from interval-match x))))))
-
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (return-from interval-match x))))))
+
(defun interval-clear (list time)
(dotimes (x (length list))
(let ((elt (nth x list)))
(if (interval-match (interval-contained elt) time)
(return-from interval-clear
(replace-at-index x list
- (make-interval :start (interval-start elt)
+ (make-interval :start (interval-start elt)
:end (interval-end elt)
:type (interval-type elt)
:contained (interval-clear (interval-contained elt) time)
"Attempts to modify the most deeply nested interval in list which
begins at time. If no changes are made, returns nil."
;; function required sorted interval list
- (let ((list (sort-interval-list list)))
+ (let ((list (sort-interval-list list)))
(if (null list) nil
(dotimes (x (length list))
- (let ((elt (nth x list)))
- (when (and (time<= (interval-start elt) time)
- (time< time (interval-end elt)))
- (or (interval-edit (interval-contained elt) time start end tag)
- (cond ((and (< 0 x)
- (time< start (interval-end (nth (1- x) list))))
- (error "Overlap of previous interval"))
- ((and (< x (1- (length list)))
- (time< (interval-start (nth (1+ x) list)) end))
- (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
- ((time= (interval-start elt) time)
- (return-from interval-edit
- (replace-at-index x list
- (make-interval :start start
- :end end
- :type (interval-type elt)
- :contained (restrict-intervals (interval-contained elt) start end)
- :data (or tag (interval-data elt))))))))))))))
+ (let ((elt (nth x list)))
+ (when (and (time<= (interval-start elt) time)
+ (time< time (interval-end elt)))
+ (or (interval-edit (interval-contained elt) time start end tag)
+ (cond ((and (< 0 x)
+ (time< start (interval-end (nth (1- x) list))))
+ (error "Overlap of previous interval"))
+ ((and (< x (1- (length list)))
+ (time< (interval-start (nth (1+ x) list)) end))
+ (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
+ ((time= (interval-start elt) time)
+ (return-from interval-edit
+ (replace-at-index x list
+ (make-interval :start start
+ :end end
+ :type (interval-type elt)
+ :contained (restrict-intervals (interval-contained elt) start end)
+ :data (or tag (interval-data elt))))))))))))))
(defun restrict-intervals (list start end &aux newlist)
(let ((test-interval (make-interval :start start :end end)))
"Returns a DURATION representing the difference between TIME1 and
TIME2."
(flet ((do-diff (time1 time2)
-
+
(let (day-diff sec-diff)
(setf day-diff (- (time-mjd time2)
- (time-mjd time1)))
+ (time-mjd time1)))
(if (> day-diff 0)
- (progn (decf day-diff)
- (setf sec-diff (+ (time-second time2)
- (- (* 60 60 24)
- (time-second time1)))))
+ (progn (decf day-diff)
+ (setf sec-diff (+ (time-second time2)
+ (- (* 60 60 24)
+ (time-second time1)))))
(setf sec-diff (- (time-second time2)
- (time-second time1))))
+ (time-second time1))))
(make-duration :day day-diff
:second sec-diff))))
(if (time< time1 time2)
- (do-diff time1 time2)
+ (do-diff time1 time2)
(do-diff time2 time1))))
(defun date-difference (date1 date2)
(time-difference (date->time date1) (date->time date2)))
(defun format-date (stream date &key format
- (date-separator "-")
- (internal-separator " "))
+ (date-separator "-")
+ (internal-separator " "))
"produces on stream the datestring corresponding to the date
with the given options"
(format-time stream (date->time date)
- :format format
- :date-separator date-separator
- :internal-separator internal-separator))
+ :format format
+ :date-separator date-separator
+ :internal-separator internal-separator))
(defun format-time (stream time &key format
(date-separator "-")
"produces on stream the timestring corresponding to the wall-time
with the given options"
(let ((*print-circle* nil))
- (multiple-value-bind (usec second minute hour day month year dow)
- (decode-time time)
+ (multiple-value-bind (usec second minute hour day month year dow is-utc?)
+ (decode-time time)
(case format
- (:pretty
- (format stream "~A ~A, ~A ~D, ~D"
- (pretty-time hour minute)
- (day-name dow)
- (month-name month)
- day
- year))
- (:short-pretty
- (format stream "~A, ~D/~D/~D"
- (pretty-time hour minute)
- month day year))
- (:iso
- (let ((string (iso-timestring time)))
- (if stream
- (write-string string stream)
- string)))
- (t
- (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D"
- year date-separator month date-separator day
- internal-separator hour time-separator minute time-separator
- second usec))))))
-
+ (:pretty
+ (format stream "~A ~A, ~A ~D, ~D"
+ (pretty-time hour minute)
+ (day-name dow)
+ (month-name month)
+ day
+ year))
+ (:short-pretty
+ (format stream "~A, ~D/~D/~D"
+ (pretty-time hour minute)
+ month day year))
+ ((:iso :iso8601) (iso-timestring time :stream stream))
+ (t (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D~A"
+ year date-separator month date-separator day
+ internal-separator hour time-separator minute time-separator
+ second usec
+ (if is-utc? "Z" ""))
+ )))))
+
(defun pretty-time (hour minute)
(cond
((eq hour 0)
(third (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-month ()
- (second (mjd-to-gregorian (time-mjd (get-time)))))
+ (first (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-day ()
- (first (mjd-to-gregorian (time-mjd (get-time)))))
+ (second (mjd-to-gregorian (time-mjd (get-time)))))
(defun parse-date-time (string)
"parses date like 08/08/01, 8.8.2001, eg"
(push (subseq input start x) output)
(setf start (1+ x))))
(nreverse (push (subseq input start) output))))
-
+
(defun merged-time (day time-of-day)
(%make-wall-time :mjd (time-mjd day)
:second (time-second time-of-day)))
(print-date time style)))
(defun print-date (time &optional (style :daytime))
- (multiple-value-bind (second minute hour day month year dow)
+ (multiple-value-bind (usec second minute hour day month year dow)
(decode-time time)
- (declare (ignore second))
+ (declare (ignore usec second))
(multiple-value-bind (hours meridian)
(time-meridian hour)
(ecase style
(format nil "~d/~d/~d" month day year))))))
(defun time-element (time element)
- (multiple-value-bind (second minute hour day month year dow)
+ (multiple-value-bind (usec second minute hour day month year dow)
(decode-time time)
+ (declare (ignore usec))
(ecase element
(:seconds
second)
(minute (duration-minute duration))
(hour (duration-hour duration))
(day (duration-day duration))
+ (month (duration-month duration))
+ (year (duration-year duration))
(return (null stream))
(stream (or stream (make-string-output-stream))))
(ecase precision
(setf second 0))
(:second
t))
- (if (= 0 day hour minute)
+ (if (= 0 year month day hour minute)
(format stream "0 minutes")
(let ((sent? nil))
+ (when (< 0 year)
+ (format stream "~d year~p" year year)
+ (setf sent? t))
+ (when (< 0 month)
+ (when sent?
+ (write-char #\Space stream))
+ (format stream "~d month~p" month month)
+ (setf sent? t))
(when (< 0 day)
+ (when sent?
+ (write-char #\Space stream))
(format stream "~d day~p" day day)
(setf sent? t))
(when (< 0 hour)
(unless (= 0 year month)
(multiple-value-bind (year-orig month-orig day-orig)
(time-ymd date)
- (setf date (make-time :year (+ year year-orig)
- :month (+ month month-orig)
- :day day-orig
- :second (time-second date)
- :usec usec))))
+ (multiple-value-bind (new-year new-month)
+ (floor (+ month month-orig (* 12 (+ year year-orig))) 12)
+ (let ((new-date (make-time :year new-year
+ :month new-month
+ :day day-orig
+ :second (time-second date)
+ :usec usec)))
+ (if destructive
+ (setf (time-mjd date) (time-mjd new-date))
+ (setq date new-date))))))
(let ((mjd (time-mjd date))
- (sec (time-second date))
- (usec (time-usec date)))
+ (sec (time-second date)))
(multiple-value-bind (sec-new usec-new)
- (floor (+ usec
+ (floor (+ usec (time-usec date)
(* 1000000
(+ sec second
(* 60 minute)
(* 60 60 hour))))
1000000)
- (declare (ignore sec-new))
(multiple-value-bind (mjd-new sec-new)
- (floor sec (* 60 60 24))
+ (floor sec-new (* 60 60 24))
(if destructive
(progn
(setf (time-mjd date) (+ mjd mjd-new day)
doy))
(defun parse-yearstring (string)
- (let ((year (or (parse-integer-insensitively string)
- (extract-roman string))))
+ (let ((year (or (parse-integer-insensitively string)
+ (extract-roman string))))
(when (and year (< 1500 year 2500))
(make-time :year year))))
;; ------------------------------------------------------------
-;; Parsing iso-8601 timestrings
+;; Parsing iso-8601 timestrings
(define-condition iso-8601-syntax-error (sql-user-error)
- ((bad-component;; year, month whatever
+ ((input :initarg :input :reader input)
+ (bad-component;; year, month whatever
:initarg :bad-component
:reader bad-component))
(:report (lambda (c stream)
- (format stream "Bad component: ~A " (bad-component c)))))
+ (format stream "Bad component: ~A of input: ~A "
+ (bad-component c) (input c)))))
(defun parse-timestring (timestring &key (start 0) end junk-allowed)
"parse a timestring and return the corresponding wall-time. If the
timestring starts with P, read a duration; otherwise read an ISO 8601
formatted date string."
- (declare (ignore junk-allowed))
- (let ((string (subseq timestring start end)))
- (if (char= (aref string 0) #\P)
- (parse-iso-8601-duration string)
- (parse-iso-8601-time string))))
+ (declare (ignore junk-allowed))
+ (etypecase timestring
+ (wall-time timestring)
+ (date (date->time timestring))
+ (string
+ (let ((string (subseq timestring start end)))
+ (if (char= (aref string 0) #\P)
+ (parse-iso-8601-duration string)
+ (parse-iso-8601-time string))))))
(defun parse-datestring (datestring &key (start 0) end junk-allowed)
"parse a ISO 8601 timestring and return the corresponding date.
Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)."
- (let ((parsed-value (parse-timestring datestring :start start :end end :junk-allowed junk-allowed)))
- (ecase (type-of parsed-value)
- (wall-time (%make-date :mjd (time-mjd parsed-value))))))
+ (etypecase datestring
+ (date datestring)
+ (wall-time (time->date datestring))
+ (string
+ (let ((parsed-value
+ (parse-timestring
+ datestring :start start :end end :junk-allowed junk-allowed)))
+ (etypecase parsed-value
+ (date parsed-value)
+ (wall-time (time->date parsed-value)))))))
(defvar *iso-8601-duration-delimiters*
- '((#\D . :days)
+ '((#\Y . :years)
+ (#\D . :days)
(#\H . :hours)
- (#\M . :minutes)
+ (#\M . :months/minutes)
(#\S . :seconds)))
(defun iso-8601-delimiter (elt)
(cdr (assoc elt *iso-8601-duration-delimiters*)))
-(defun iso-8601-duration-subseq (string start)
- (let* ((pos (position-if #'iso-8601-delimiter string :start start))
- (number (when pos (parse-integer (subseq string start pos)
- :junk-allowed t))))
+(defun iso-8601-duration-subseq (string end)
+ (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t))
+ (pos2 (when pos
+ (position-if-not #'digit-char-p string :end pos :from-end t)))
+ (number (when pos2
+ (parse-integer
+ (subseq string (1+ pos2) pos) :junk-allowed t))))
(when number
(values number
- (1+ pos)
- (iso-8601-delimiter (aref string pos))))))
+ (1+ pos)
+ (1+ pos2)
+ (iso-8601-delimiter (aref string pos))))))
(defun parse-iso-8601-duration (string)
"return a wall-time from a duration string"
(block parse
- (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
+ (let ((years 0)
+ (months 0)
+ (days 0)
+ (secs 0)
+ (hours 0)
+ (minutes 0)
+ (index (length string))
+ (months/minutes nil))
(loop
- (multiple-value-bind (duration next-index duration-type)
+ (multiple-value-bind (duration end next-index duration-type)
(iso-8601-duration-subseq string index)
+ (declare (ignore end))
(case duration-type
+ (:years
+ (incf years duration))
+ (:months/minutes
+ (if months/minutes
+ (incf months duration)
+ (progn
+ (setq months/minutes t)
+ (incf minutes duration))))
+ (:days
+ (setq months/minutes t)
+ (incf days duration))
(:hours
+ (setq months/minutes t)
(incf hours duration))
- (:minutes
- (incf minutes duration))
(:seconds
(incf secs duration))
- (:days
- (incf days duration))
(t
- (return-from parse (make-duration :day days :hour hours
- :minute minutes :second secs))))
+ (return-from parse
+ (make-duration
+ :year years :month months :day days :hour hours
+ :minute minutes :second secs))))
(setf index next-index))))))
;; e.g. 2000-11-11 00:00:00-06
:usec usec
:offset offset)))
+(defun %frac-string-to-usec (frac-str)
+ (when frac-str
+ (let* ((frac (parse-integer frac-str))
+ (frac-len (length frac-str))
+ (frac-exp (- 6 frac-len)))
+ (floor (* frac (expt 10 frac-exp))))))
+
+(defun %parse-offset-string (offset-str input &aux (len (length offset-str)))
+ (when (zerop len)
+ (return-from %parse-offset-string nil))
+ (when (and (= len 1) (char= #\Z (char offset-str 0)))
+ (return-from %parse-offset-string 0))
+ (let ((pos? (char= #\+ (char offset-str 0)))
+ (colon? (position #\: offset-str)))
+ (unless (or (member len '(3 5)) ;; +05 or -0530
+ (and colon? (= 6 len))) ;; +05:30
+ (error 'iso-8601-syntax-error
+ :input input
+ :bad-component `(timezone . ,offset-str)))
+ (handler-bind ((error (lambda (c) (declare (ignore c))
+ (error 'iso-8601-syntax-error
+ :input input
+ :bad-component `(timezone . ,offset-str))
+ )))
+ (let* ((hours (parse-integer offset-str :start 1 :end 3))
+ (hsec (* 60 60 hours))
+ (sec (* 60 (cond
+ (colon?
+ (parse-integer offset-str :start 4))
+ ((> len 3)
+ (parse-integer offset-str :start 3))
+ (t 0))))
+ (total (+ hsec sec)))
+ (if pos? (- total) total)))))
(defun syntax-parse-iso-8601 (string)
;; use strlen to determine if fractional seconds are present in timestamp
second (if (<= 19 strlen)
(parse-integer string :start 17 :end 19)
0))
- (cond
- ((and (> strlen 19)
- (or (char= #\, (char string 19))
- (char= #\. (char string 19))))
- (multiple-value-bind (parsed-usec usec-end)
- (parse-integer string :start 20 :junk-allowed t)
- (setf usec parsed-usec
- gmt-sec-offset (if (<= (+ 3 usec-end) strlen)
- (let ((skip-to (or (position #\+ string :start 19)
- (position #\- string :start 19))))
- (if skip-to
- (* 60 60
- (parse-integer string :start skip-to
- :end (+ skip-to 3)))
- 0))
- 0))))
- (t
- (setf usec 0
- gmt-sec-offset (if (<= 22 strlen)
- (let ((skip-to (or (position #\+ string :start 19)
- (position #\- string :start 19))))
- (if skip-to
- (* 60 60
- (parse-integer string :start skip-to
- :end (+ skip-to 3)))
- 0))
- 0))))
- (unless (< 0 year)
- (error 'iso-8601-syntax-error
- :bad-component '(year . 0)))
- (unless (< 0 month)
- (error 'iso-8601-syntax-error
- :bad-component '(month . 0)))
- (unless (< 0 day)
- (error 'iso-8601-syntax-error
- :bad-component '(month . 0)))
- (values year month day hour minute second usec gmt-sec-offset))
+ (when (> strlen 19)
+ ;; fractional second
+ (let* ((has-frac? (or (char= #\, (char string 19))
+ (char= #\. (char string 19))))
+ (z-idx (position #\Z string :start 19))
+ (offset-start (or (position #\+ string :start 19)
+ (position #\- string :start 19)))
+ (frac-end (or z-idx offset-start strlen ))
+ (frac-string (when has-frac? (subseq string 20 frac-end)))
+ (offset-string (when offset-start
+ (subseq string offset-start))))
+ (setf usec (or (%frac-string-to-usec frac-string)
+ 0)
+ gmt-sec-offset
+ (cond
+ (z-idx 0)
+ (offset-string
+ (%parse-offset-string offset-string string))))))
+
+ (unless (< 0 year)
+ (error 'iso-8601-syntax-error
+ :input string
+ :bad-component '(year . 0)))
+ (unless (< 0 month)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (unless (< 0 day)
+ (error 'iso-8601-syntax-error
+ :bad-component '(month . 0)))
+ (values year month day hour minute second usec gmt-sec-offset))
(simple-error ()
(error 'iso-8601-syntax-error
:bad-component
`((year . ,year) (month . ,month)
(day . ,day) (hour . ,hour)
(minute . ,minute) (second . ,second)
- (usec . ,usec)
- (timezone . ,gmt-sec-offset)))))))))
+ (usec . ,usec)))))))))
projects / clsql.git / blobdiff