X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ftime.lisp;h=751203334a3665e2079f73eece2460eb4d54cc78;hp=c767018285e4e38b34361de77a0464ba4a778c01;hb=837ef5c074e599060d89b5fd51abbe6fcd960094;hpb=706c29aa55b25e5b7c7f90460589a4702b1390e7 diff --git a/sql/time.lisp b/sql/time.lisp index c767018..7512033 100644 --- a/sql/time.lisp +++ b/sql/time.lisp @@ -67,7 +67,9 @@ (defun %print-wall-time (time stream depth) (declare (ignore depth)) - (format stream "#" (format-time nil time))) + (if *print-escape* + (format stream "#" (format-time nil time)) + (format-time stream time :format :pretty))) (defstruct (duration (:constructor %make-duration) (:print-function %print-duration)) @@ -81,8 +83,20 @@ (defun %print-duration (duration stream depth) (declare (ignore depth)) - (format stream "#" - (format-duration nil duration :precision :second))) + (if *print-escape* + (format stream "#" + (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 "#" (format-date nil date)) + (format-date stream date :format :pretty))) );eval-when @@ -90,8 +104,10 @@ (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))) ;; ------------------------------------------------------------ @@ -107,6 +123,11 @@ (floor sec (* 60 60 24)) (%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) :second (time-second time))) @@ -118,10 +139,22 @@ (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) (usec 0)) (multiple-value-bind (second-add usec-1000000) @@ -167,6 +200,18 @@ (time-hms time) (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 @@ -212,7 +257,7 @@ (defun duration<= (duration-a duration-b) (<= (duration-reduce duration-a :usec) (duration-reduce duration-b :usec))) - + (defun duration>= (x y) (duration<= y x)) @@ -227,7 +272,7 @@ (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)) @@ -342,6 +387,45 @@ :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 @@ -398,6 +482,11 @@ (inscribe-base-10 output 17 2 second) (format nil "~a,~d" output usec))))) +(defun db-datestring (date) + (db-timestring (date->time date))) +(defun iso-datestring (date) + (iso-timestring (date->time date))) + ;; ------------------------------------------------------------ ;; Intervals @@ -405,7 +494,7 @@ (defstruct interval (start nil) (end nil) - (name nil) + (name nil) (contained nil) (type nil) (data nil)) @@ -478,17 +567,17 @@ (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))) @@ -509,7 +598,7 @@ "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))) @@ -674,6 +763,12 @@ begins at time. If no changes are made, returns nil." :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))) @@ -689,11 +784,17 @@ begins at time. If no changes are made, returns nil." :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))) @@ -710,6 +811,21 @@ TIME2." (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 ":") @@ -741,7 +857,7 @@ with the given options" 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) @@ -766,10 +882,10 @@ with the given options" (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" @@ -802,7 +918,7 @@ with the given options" (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))) @@ -826,9 +942,9 @@ with the given options" (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 @@ -861,8 +977,9 @@ with the given options" (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) @@ -881,11 +998,16 @@ with the given options" (: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 @@ -897,10 +1019,20 @@ with the given options" (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) @@ -930,11 +1062,16 @@ with the given options" (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))) @@ -945,9 +1082,8 @@ with the given options" (* 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) @@ -1023,7 +1159,7 @@ rules" 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)))) @@ -1053,7 +1189,7 @@ rules" ;; ------------------------------------------------------------ -;; Parsing iso-8601 timestrings +;; Parsing iso-8601 timestrings (define-condition iso-8601-syntax-error (sql-user-error) ((bad-component;; year, month whatever @@ -1066,49 +1202,79 @@ rules" "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) (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 @@ -1151,7 +1317,7 @@ formatted date string." (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))))