;; ------------------------------------------------------------
;; 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))
;; ------------------------------------------------------------
;; 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< 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)
(< (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))))
;; ------------------------------------------------------------
;; Formatting and output
-
-(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-
-(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.")))
- (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)
+(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 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)))
"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)
+ (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))
+ (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))))))
+ (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
;; 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))))
+ (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*
: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 (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 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