(:constructor %make-wall-time)
(:print-function %print-wall-time))
(mjd 0 :type fixnum)
- (second 0 :type fixnum))
+ (second 0 :type fixnum)
+ (usec 0 :type fixnum))
(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))
(day 0 :type fixnum)
(hour 0 :type fixnum)
(second 0 :type fixnum)
- (minute 0 :type fixnum))
+ (minute 0 :type fixnum)
+ (usec 0 :type fixnum))
(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))
+ (mjd 0 :type fixnum))
+
+(defun %print-date (date stream depth)
+ (declare (ignore depth))
+ (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
(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
- (second 0) (offset 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))))
+ (%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec))))
+
+(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
+ (second 0) (usec 0) (offset 0))
+ (time->date (make-time :year year :month month :day day :hour hour
+ :minute minute :second second :usec usec :offset offset)))
(defun copy-time (time)
(%make-wall-time :mjd (time-mjd time)
(make-time :year year :month mon :day day :hour hour :minute minute
:second second)))
+(defun date->time (date)
+ "Returns a walltime for the given date"
+ (%make-wall-time :mjd (date-mjd date)))
+
+(defun time->date (time)
+ "Returns a date for the given wall time (obvious loss in resolution)"
+ (%make-date :mjd (time-mjd time)))
+
(defun get-time ()
"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
(utime->time (get-universal-time)))
+(defun get-date ()
+ "Returns a date for today"
+ (time->date (get-time)))
+
(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
- (second 0))
- (multiple-value-bind (minute-add second-60)
- (floor second 60)
- (multiple-value-bind (hour-add minute-60)
- (floor (+ minute minute-add) 60)
- (multiple-value-bind (day-add hour-24)
- (floor (+ hour hour-add) 24)
- (%make-duration :year year :month month :day (+ day day-add)
- :hour hour-24
- :minute minute-60
- :second second-60)))))
+ (second 0) (usec 0))
+ (multiple-value-bind (second-add usec-1000000)
+ (floor usec 1000000)
+ (multiple-value-bind (minute-add second-60)
+ (floor (+ second second-add) 60)
+ (multiple-value-bind (hour-add minute-60)
+ (floor (+ minute minute-add) 60)
+ (multiple-value-bind (day-add hour-24)
+ (floor (+ hour hour-add) 24)
+ (%make-duration :year year :month month :day (+ day day-add)
+ :hour hour-24
+ :minute minute-60
+ :second second-60
+ :usec usec-1000000))))))
;; ------------------------------------------------------------
(mod (+ 3 (time-mjd time)) 7))
(defun decode-time (time)
- "returns the decoded time as multiple values: second, minute, hour, day,
-month, year, integer day-of-week"
+ "returns the decoded time as multiple values: usec, second, minute, hour,
+ day, month, year, integer day-of-week"
(multiple-value-bind (year month day)
(time-ymd time)
(multiple-value-bind (hour minute second)
(time-hms time)
- (values 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)))))
+
+(defun date-ymd (date)
+ (time-ymd (date->time date)))
+
+(defun date-dow (date)
+ (time-dow (date->time date)))
+
+(defun decode-date (date)
+ "returns the decoded date as multiple values: day month year integer day-of-week"
+ (multiple-value-bind (year month day)
+ (time-ymd (date->time date))
+ (values day month year (date-dow date))))
;; duration specific
(defun duration-reduce (duration precision &optional round)
(ecase precision
+ (:usec
+ (+ (duration-usec duration)
+ (* (duration-reduce duration :second) 1000000)))
(:second
- (+ (duration-second duration)
- (* (duration-reduce duration :minute) 60)))
+ (+ (if round
+ (floor (duration-usec duration) 500000)
+ 0)
+ (duration-second duration)
+ (* (duration-reduce duration :minute) 60)))
(:minute
(+ (if round
- (floor (duration-second duration) 30)
- 0)
- (duration-minute duration)
- (* (duration-reduce duration :hour) 60)))
+ (floor (duration-second duration) 30)
+ 0)
+ (duration-minute duration)
+ (* (duration-reduce duration :hour) 60)))
(:hour
(+ (if round
(floor (duration-minute duration) 30)
;; Arithemetic and comparators
(defun duration= (duration-a duration-b)
- (= (duration-reduce duration-a :second)
- (duration-reduce duration-b :second)))
+ (= (duration-reduce duration-a :usec)
+ (duration-reduce duration-b :usec)))
(defun duration< (duration-a duration-b)
- (< (duration-reduce duration-a :second)
- (duration-reduce duration-b :second)))
+ (< (duration-reduce duration-a :usec)
+ (duration-reduce duration-b :usec)))
(defun duration<= (duration-a duration-b)
- (<= (duration-reduce duration-a :second)
- (duration-reduce duration-b :second)))
-
+ (<= (duration-reduce duration-a :usec)
+ (duration-reduce duration-b :usec)))
+
(defun duration>= (x y)
(duration<= y x))
(mjd-y (time-mjd y)))
(if (/= mjd-x mjd-y)
(< mjd-x mjd-y)
- (< (time-second x) (time-second y)))))
-
+ (if (/= (time-second x) (time-second y))
+ (< (time-second x) (time-second y))
+ (< (time-usec x) (time-usec y))))))
+
(defun %time>= (x y)
(if (/= (time-mjd x) (time-mjd y))
(>= (time-mjd x) (time-mjd y))
- (>= (time-second x) (time-second y))))
+ (if (/= (time-second x) (time-second y))
+ (>= (time-second x) (time-second y))
+ (>= (time-usec x) (time-usec y)))))
(defun %time<= (x y)
(if (/= (time-mjd x) (time-mjd y))
(<= (time-mjd x) (time-mjd y))
- (<= (time-second x) (time-second y))))
+ (if (/= (time-second x) (time-second y))
+ (<= (time-second x) (time-second y))
+ (<= (time-usec x) (time-usec y)))))
(defun %time> (x y)
(if (/= (time-mjd x) (time-mjd y))
(> (time-mjd x) (time-mjd y))
- (> (time-second x) (time-second y))))
+ (if (/= (time-second x) (time-second y))
+ (> (time-second x) (time-second y))
+ (> (time-usec x) (time-usec y)))))
(defun %time= (x y)
(and (= (time-mjd x) (time-mjd y))
- (= (time-second x) (time-second y))))
+ (= (time-second x) (time-second y))
+ (= (time-usec x) (time-usec y))))
(defun time= (number &rest more-numbers)
"Returns T if all of its arguments are numerically equal, NIL otherwise."
(let ((mjd-a (time-mjd time-a))
(mjd-b (time-mjd time-b))
(sec-a (time-second time-a))
- (sec-b (time-second time-b)))
+ (sec-b (time-second time-b))
+ (usec-a (time-usec time-a))
+ (usec-b (time-usec time-b)))
(if (= mjd-a mjd-b)
(if (= sec-a sec-b)
- :equal
+ (if (= usec-a usec-b)
+ :equal
+ (if (< usec-a usec-b)
+ :less-than
+ :greater-than))
(if (< sec-a sec-b)
:less-than
:greater-than))
:less-than
:greater-than))))
+; now the same for dates
+(eval-when (:compile-toplevel :load-toplevel)
+(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)))
+ (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))))))
+ (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)
+ (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)))))
+
+(wrap-time-for-date time=)
+(wrap-time-for-date time/=)
+(wrap-time-for-date time<)
+(wrap-time-for-date time>)
+(wrap-time-for-date time<=)
+(wrap-time-for-date time>=)
+(wrap-time-for-date time-max :result-func time->date)
+(wrap-time-for-date time-min :result-func time->date)
+
+(defun date-compare (date-a date-b)
+ (time-compare (date->time date-a) (date->time date-b)))
;; ------------------------------------------------------------
;; Formatting and output
(defun db-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'")))
+ (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+))
(setf (aref output (+ (- size x 1) offset))
(aref +decimal-printer+ this))
(setf decimal next)))))
- (multiple-value-bind (second minute hour day month year)
+ (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 12 2 hour)
(inscribe-base-10 output 15 2 minute)
(inscribe-base-10 output 18 2 second)
- output))))
+ (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")))
+ (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+))
(setf (aref output (+ (- size x 1) offset))
(aref +decimal-printer+ this))
(setf decimal next)))))
- (multiple-value-bind (second minute hour day month year)
+ (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 11 2 hour)
(inscribe-base-10 output 14 2 minute)
(inscribe-base-10 output 17 2 second)
- output))))
+ (format nil "~a,~d" output usec)))))
+
+(defun db-datestring (date)
+ (db-timestring (date->time date)))
+(defun iso-datestring (date)
+ (iso-timestring (date->time date)))
;; ------------------------------------------------------------
(defstruct interval
(start nil)
(end nil)
- (name nil)
+ (name nil)
(contained nil)
(type nil)
(data nil))
(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))))))
-
+
(defun interval-clear (list time)
(dotimes (x (length list))
(let ((elt (nth x list)))
"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)))
(day (duration-day time))
(hour (duration-hour time))
(minute (duration-minute time))
- (second (duration-second time)))
+ (second (duration-second time))
+ (usec (duration-usec time)))
(dolist (duration durations)
(incf year (duration-year duration))
(incf month (duration-month duration))
(incf day (duration-day duration))
(incf hour (duration-hour duration))
(incf minute (duration-minute duration))
- (incf second (duration-second duration)))
+ (incf second (duration-second duration))
+ (incf usec (duration-usec duration)))
(make-duration :year year :month month :day day :hour hour :minute minute
- :second second)))
+ :second second :usec usec)))
(defun duration- (duration &rest durations)
"Subtract each DURATION from TIME, returning a new duration value."
(day (duration-day duration))
(hour (duration-hour duration))
(minute (duration-minute duration))
- (second (duration-second duration)))
+ (second (duration-second duration))
+ (usec (duration-usec duration)))
(dolist (duration durations)
(decf year (duration-year duration))
(decf month (duration-month duration))
(decf day (duration-day duration))
(decf hour (duration-hour duration))
(decf minute (duration-minute duration))
- (decf second (duration-second duration)))
+ (decf second (duration-second duration))
+ (decf usec (duration-usec duration)))
(make-duration :year year :month month :day day :hour hour :minute minute
- :second second)))
+ :second second :usec usec)))
;; Date + Duration
:hour (duration-hour duration)
:minute (duration-minute duration)
:second (duration-second duration)
+ :usec (duration-usec duration)
:destructive t))
new-time))
+(defun date+ (date &rest durations)
+ "Add each DURATION to DATE, returning a new date value.
+Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
+it as separate calculations will not, as the time is chopped to a date before being returned."
+ (time->date (apply #'time+ (cons (date->time date) durations))))
+
(defun time- (time &rest durations)
"Subtract each DURATION from TIME, returning a new wall-time value."
(let ((new-time (copy-time time)))
:hour (- (duration-hour duration))
:minute (- (duration-minute duration))
:second (- (duration-second duration))
+ :usec (- (duration-usec duration))
:destructive t))
new-time))
+(defun date- (date &rest durations)
+ "Subtract each DURATION to DATE, returning a new date value.
+Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
+it as separate calculations will not, as the time is chopped to a date before being returned."
+ (time->date (apply #'time- (cons (date->time date) durations))))
+
(defun time-difference (time1 time2)
"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)))
(do-diff time1 time2)
(do-diff time2 time1))))
+(defun date-difference (date1 date2)
+ "Returns a DURATION representing the difference between TIME1 and
+TIME2."
+ (time-difference (date->time date1) (date->time date2)))
+
+(defun format-date (stream date &key format
+ (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))
+
(defun format-time (stream time &key format
(date-separator "-")
(time-separator ":")
"produces on stream the timestring corresponding to the wall-time
with the given options"
(let ((*print-circle* nil))
- (multiple-value-bind (second minute hour day month year dow)
+ (multiple-value-bind (usec second minute hour day month year dow)
(decode-time time)
(case format
(:pretty
(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"
+ (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))))))
-
+ second usec))))))
+
(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)
(:year
year))))
+(defun date-element (date element)
+ (time-element (date->time date) element))
+
(defun format-duration (stream duration &key (precision :minute))
(let ((second (duration-second duration))
(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)
(%make-wall-time :mjd (time-mjd self)))
(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
- (minute 0) (destructive nil))
+ (minute 0) (usec 0) (destructive nil))
(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)))))
+ (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)))
- (multiple-value-bind (mjd-new sec-new)
- (floor (+ sec second
- (* 60 minute)
- (* 60 60 hour)) (* 60 60 24))
- (if destructive
- (progn
- (setf (time-mjd date) (+ mjd mjd-new day)
- (time-second date) sec-new)
- date)
- (%make-wall-time :mjd (+ mjd mjd-new day)
- :second sec-new)))))
+ (sec (time-second date))
+ (usec (time-usec date)))
+ (multiple-value-bind (sec-new usec-new)
+ (floor (+ usec
+ (* 1000000
+ (+ sec second
+ (* 60 minute)
+ (* 60 60 hour))))
+ 1000000)
+ (multiple-value-bind (mjd-new sec-new)
+ (floor sec-new (* 60 60 24))
+ (if destructive
+ (progn
+ (setf (time-mjd date) (+ mjd mjd-new day)
+ (time-second date) sec-new
+ (time-usec date) usec-new)
+ date)
+ (%make-wall-time :mjd (+ mjd mjd-new day)
+ :second sec-new
+ :usec usec-new))))))
(defun roll-to (date size position)
(ecase size
doy))
(defun parse-yearstring (string)
- (let ((year (or (parse-integer-insensitively 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 (error)
+(define-condition iso-8601-syntax-error (sql-user-error)
((bad-component;; year, month whatever
:initarg :bad-component
- :reader bad-component)))
+ :reader bad-component))
+ (:report (lambda (c stream)
+ (format stream "Bad component: ~A " (bad-component 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)) ;; FIXME
+ (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))))
+ (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))))))
+
(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)
+ (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)
(iso-8601-duration-subseq string index)
(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
(defun parse-iso-8601-time (string)
"return the wall-time corresponding to the given ISO 8601 datestring"
- (multiple-value-bind (year month day hour minute second offset)
+ (multiple-value-bind (year month day hour minute second usec offset)
(syntax-parse-iso-8601 string)
(make-time :year year
:month month
:hour hour
:minute minute
:second second
+ :usec usec
:offset offset)))
(defun syntax-parse-iso-8601 (string)
- (let (year month day hour minute second gmt-sec-offset)
+ ;; use strlen to determine if fractional seconds are present in timestamp
+ (let ((strlen (length string))
+ year month day hour minute second usec gmt-sec-offset)
(handler-case
(progn
- (setf year (parse-integer (subseq string 0 4))
- month (parse-integer (subseq string 5 7))
- day (parse-integer (subseq string 8 10))
- hour (if (<= 13 (length string))
- (parse-integer (subseq string 11 13))
- 0)
- minute (if (<= 16 (length string))
- (parse-integer (subseq string 14 16))
- 0)
- second (if (<= 19 (length string))
- (parse-integer (subseq string 17 19))
- 0)
- gmt-sec-offset (if (<= 22 (length string))
- (* 60 60
- (parse-integer (subseq string 19 22)))
+ (setf year (parse-integer string :start 0 :end 4)
+ month (parse-integer string :start 5 :end 7)
+ day (parse-integer string :start 8 :end 10)
+ hour (if (<= 13 strlen)
+ (parse-integer string :start 11 :end 13)
+ 0)
+ minute (if (<= 16 strlen)
+ (parse-integer string :start 14 :end 16)
+ 0)
+ 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 (or parsed-usec 0)
+ 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 day)
(error 'iso-8601-syntax-error
:bad-component '(month . 0)))
- (values year month day hour minute second gmt-sec-offset))
+ (values year month day hour minute second usec gmt-sec-offset))
(simple-error ()
(error 'iso-8601-syntax-error
:bad-component
(car (find-if (lambda (pair) (null (cdr pair)))
`((year . ,year) (month . ,month)
- (day . ,day) (hour ,hour)
- (minute ,minute) (second ,second)
- (timezone ,gmt-sec-offset)))))))))
+ (day . ,day) (hour . ,hour)
+ (minute . ,minute) (second . ,second)
+ (usec . ,usec)
+ (timezone . ,gmt-sec-offset)))))))))
projects / clsql.git / blobdiff