Add date type to clsql [patch]

I needed to deal in dates instead of date+time, so I implemented the ISO
type. I also implemented a date type - which mostly just wraps
time functions. All (reasonable) time functions are implemented for
dates as well.

I wrote a small bit of doc on implementing types in clsql - it's obvious
if you know where to look, this is mostly just a "look here and here and
here" doc. That'll be in the following email.

Patch guide: the first few patches are adding the type, following that
is the modification to add date and date functions.

Only in clsql-3.2.1/db-mysql: mysql-objects.lisp~
Only in clsql-3.2.1/db-oracle: oracle-objects.lisp~
Only in clsql-3.2.1/sql: expressions.fasl
diff -ru clsql-3.2.1.bak/sql/expressions.lisp clsql-3.2.1/sql/expressions.lisp
--- clsql-3.2.1.bak/sql/expressions.lisp	2005-05-12 20:09:04.000000000 -0500
+++ clsql-3.2.1/sql/expressions.lisp	2005-09-12 17:17:26.000000000 -0500
@@ -903,6 +903,10 @@
   (declare (ignore database))
   (db-timestring self))
 
+(defmethod database-output-sql ((self date) database)
+  (declare (ignore database))
+  (db-datestring self))
+
 (defmethod database-output-sql ((self duration) database)
   (declare (ignore database))
   (format nil "'~a'" (duration-timestring self)))
Only in clsql-3.2.1/sql: expressions.lisp~
Only in clsql-3.2.1/sql: generic-postgresql.fasl
Only in clsql-3.2.1/sql: generic-postgresql.lisp~
Only in clsql-3.2.1/sql: oodml.fasl
diff -ru clsql-3.2.1.bak/sql/oodml.lisp clsql-3.2.1/sql/oodml.lisp
--- clsql-3.2.1.bak/sql/oodml.lisp	2005-05-17 14:08:14.000000000 -0500
+++ clsql-3.2.1/sql/oodml.lisp	2005-09-12 16:16:23.000000000 -0500
@@ -381,6 +381,10 @@
   (declare (ignore args database db-type))
   "TIMESTAMP")
 
+(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
+  (declare (ignore args database db-type))
+  "DATE")
+
 (defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
   (declare (ignore database args db-type))
   "VARCHAR")
@@ -584,6 +588,11 @@
   (unless (eq 'NULL val)
     (parse-timestring val)))
 
+(defmethod read-sql-value (val (type (eql 'date)) database db-type)
+  (declare (ignore database db-type))
+  (unless (eq 'NULL val)
+    (parse-datestring val)))
+
 (defmethod read-sql-value (val (type (eql 'duration)) database db-type)
   (declare (ignore database db-type))
   (unless (or (eq 'NULL val)
Only in clsql-3.2.1/sql: oodml.lisp~
Only in clsql-3.2.1/sql: package.fasl
diff -ru clsql-3.2.1.bak/sql/package.lisp clsql-3.2.1/sql/package.lisp
--- clsql-3.2.1.bak/sql/package.lisp	2005-07-05 19:51:52.000000000 -0500
+++ clsql-3.2.1/sql/package.lisp	2005-09-12 16:33:36.000000000 -0500
@@ -451,8 +451,10 @@
          #:current-year
          #:day-duration
          #:db-timestring
+	 #:db-datestring
          #:decode-duration
          #:decode-time
+	 #:decode-date
          #:duration
          #:duration+
          #:duration<
@@ -471,7 +473,9 @@
          #:extract-roman 
          #:format-duration
          #:format-time
+	 #:format-date
          #:get-time
+	 #:get-date
          #:utime->time
          #:interval-clear
          #:interval-contained
@@ -486,11 +490,13 @@
          #:make-duration
          #:make-interval
          #:make-time
+	 #:make-date
          #:merged-time
          #:midnight
          #:month-name
          #:parse-date-time
          #:parse-timestring
+	 #:parse-datestring
          #:parse-yearstring
          #:print-date
          #:roll
@@ -516,6 +522,23 @@
          #:time=
          #:time>
          #:time>=
+	 #:date
+	 #:date+
+	 #:date-
+	 #:date-difference
+	 #:date-compare
+	 #:date-dow
+	 #:date-element
+	 #:date-max
+	 #:date-min
+	 #:date-mjd
+	 #:date-p
+	 #:date-ymd
+	 #:date<
+	 #:date<=
+	 #:date=
+	 #:date>
+	 #:date>=
          #:timezone
          #:universal-time
          #:wall-time
Only in clsql-3.2.1/sql: package.lisp~
Only in clsql-3.2.1/sql: time.fasl
diff -ru clsql-3.2.1.bak/sql/time.lisp clsql-3.2.1/sql/time.lisp
--- clsql-3.2.1.bak/sql/time.lisp	2005-05-18 02:27:55.000000000 -0500
+++ clsql-3.2.1/sql/time.lisp	2005-09-12 17:26:27.000000000 -0500
@@ -84,6 +84,14 @@
   (format stream "#<DURATION: ~a>"
           (format-duration nil 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))
+  (format stream "#<DATE: ~a>" (format-date nil date)))
+
 );eval-when
 
 (defun duration-timestring (duration)
@@ -107,6 +115,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 +131,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 +192,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
@@ -342,6 +379,43 @@
             :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
@@ -398,6 +472,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
@@ -674,6 +753,12 @@
             :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,6 +774,12 @@
             :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."
@@ -710,6 +801,21 @@
 	(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 ":")
@@ -881,6 +987,9 @@
       (: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))
@@ -1072,6 +1181,14 @@
 	(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)
Only in clsql-3.2.1/sql: time.lisp~