X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ftime.lisp;h=95a7a683de6d7caa9bb0a154493419ab8b64dcfd;hp=c5e78a6738bc7d64122b468b653afe690d24ad3f;hb=e11daa653dbf4bdb74068995b79c22ad42325aa5;hpb=8c6c643e3debe875bd14408cc3129d8148dfd125 diff --git a/sql/time.lisp b/sql/time.lisp index c5e78a6..95a7a68 100644 --- a/sql/time.lisp +++ b/sql/time.lisp @@ -62,11 +62,14 @@ (: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 "#" (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)) @@ -75,12 +78,25 @@ (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 "#" - (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 @@ -96,14 +112,19 @@ ;; 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) @@ -116,22 +137,37 @@ (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)))))) ;; ------------------------------------------------------------ @@ -154,26 +190,44 @@ (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) @@ -191,16 +245,16 @@ month, year, integer day-of-week" ;; 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)) @@ -213,26 +267,35 @@ month, year, integer day-of-week" (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." @@ -305,10 +368,16 @@ month, year, integer day-of-week" (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)) @@ -316,6 +385,43 @@ month, year, integer day-of-week" :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) "TIME" "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 @@ -325,7 +431,7 @@ month, year, integer day-of-week" (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+)) @@ -337,7 +443,7 @@ month, year, integer day-of-week" (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) @@ -345,12 +451,12 @@ month, year, integer day-of-week" (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+)) @@ -362,7 +468,7 @@ month, year, integer day-of-week" (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) @@ -370,7 +476,12 @@ month, year, integer day-of-week" (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))) ;; ------------------------------------------------------------ @@ -598,16 +709,18 @@ begins at time. If no changes are made, returns nil." (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." @@ -616,16 +729,18 @@ begins at time. If no changes are made, returns nil." (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 @@ -640,9 +755,16 @@ begins at time. If no changes are made, returns nil." :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))) @@ -654,9 +776,16 @@ begins at time. If no changes are made, returns nil." :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." @@ -678,6 +807,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 ":") @@ -685,7 +829,7 @@ TIME2." "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 @@ -705,10 +849,10 @@ with the given options" (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 @@ -849,6 +993,9 @@ 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)) @@ -894,27 +1041,37 @@ with the given options" (%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))))) + :second (time-second date) + :usec usec)))) (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) + (declare (ignore sec-new)) + (multiple-value-bind (mjd-new sec-new) + (floor sec (* 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 @@ -1030,6 +1187,14 @@ formatted date 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) (#\H . :hours) @@ -1073,7 +1238,7 @@ formatted date string." (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 @@ -1081,29 +1246,55 @@ formatted date string." :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 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))) @@ -1113,12 +1304,13 @@ formatted date string." (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)))))))))