(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)))
;; ------------------------------------------------------------
(defun duration<= (duration-a duration-b)
(<= (duration-reduce duration-a :usec)
(duration-reduce duration-b :usec)))
-
+
(defun duration>= (x y)
(duration<= y x))
(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))
(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)))
"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)))
year date-separator month date-separator day
internal-separator hour time-separator minute time-separator
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)
(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)))
(* 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)
+ (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
"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))
+ (declare (ignore junk-allowed))
(let ((string (subseq timestring start end)))
(if (char= (aref string 0) #\P)
(parse-iso-8601-duration string)
(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
(char= #\. (char string 19))))
(multiple-value-bind (parsed-usec usec-end)
(parse-integer string :start 20 :junk-allowed t)
- (setf usec parsed-usec
+ (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))))
projects / clsql.git / blobdiff