r10742: 17 Sep 2005 Kevin Rosenberg <kevin@rosenberg.net>
authorKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 18 Sep 2005 00:13:11 +0000 (00:13 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 18 Sep 2005 00:13:11 +0000 (00:13 +0000)
        * Version 3.3.0
        * sql/time.lisp: Apply patch from Alan Shields adding DATE type.
        * doc/ref-ooddl.xml: Documentation of new type
        * notes/add-type-hints.txt: New file from Alan Shields
        * sql/fddl.lisp: Add owner keyword to drop-table as suggested
        by Francis Leboutte
        * db-postgresql-socket/postgresql-socket-sql.lisp: Fix database-probe
        as noted by Francis Leboutte. Similar fix applied to db-mysql and
        db-postgresql.
        * sql/expressions.lisp: Allow string table names for output as
        contributed by Francis Leboutte.
        * examples/clsql-tutorial.lisp: Support :postgresql-socket as noted
        by Francis Leboutte

15 files changed:
ChangeLog
db-mysql/mysql-sql.lisp
db-postgresql-socket/postgresql-socket-sql.lisp
db-postgresql/postgresql-sql.lisp
debian/changelog
doc/html.tar.gz
doc/ref-ooddl.xml
examples/clsql-tutorial.lisp
notes/add-type-hints.txt [new file with mode: 0644]
sql/expressions.lisp
sql/fddl.lisp
sql/ooddl.lisp
sql/oodml.lisp
sql/package.lisp
sql/time.lisp

index 1948aea..3518c6e 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+17 Sep 2005  Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 3.3.0
+       * sql/time.lisp: Apply patch from Alan Shields adding DATE type.
+       * doc/ref-ooddl.xml: Documentation of new type
+       * notes/add-type-hints.txt: New file from Alan Shields
+       * sql/fddl.lisp: Add owner keyword to drop-table as suggested
+       by Francis Leboutte
+       * db-postgresql-socket/postgresql-socket-sql.lisp: Fix database-probe
+       as noted by Francis Leboutte. Similar fix applied to db-mysql and
+       db-postgresql.
+       * sql/expressions.lisp: Allow string table names for output as
+       contributed by Francis Leboutte.
+       * examples/clsql-tutorial.lisp: Support :postgresql-socket as noted 
+       by Francis Leboutte
+       
 08 Sep 2005  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.2.4
        * doc/into.xml: Change download from ftp to http protocol
index ce81abe..8ead9d7 100644 (file)
 
 (defmethod database-probe (connection-spec (type (eql :mysql)))
   (when (find (second connection-spec) (database-list connection-spec type)
-             :key #'car :test #'string-equal)
+              :test #'string-equal)
     t))
 
 (defmethod database-list (connection-spec (type (eql :mysql)))
index 46e82ce..7a56931 100644 (file)
@@ -342,7 +342,7 @@ doesn't depend on UFFI."
 
 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
   (when (find (second connection-spec) (database-list connection-spec type)
-             :key #'car :test #'string-equal)
+              :test #'string-equal)
     t))
 
 
index 6a8c7c8..9b4e250 100644 (file)
 
 (defmethod database-probe (connection-spec (type (eql :postgresql)))
   (when (find (second connection-spec) (database-list connection-spec type)
-             :key #'car :test #'string-equal)
+              :test #'string-equal)
     t))
 
 
index 073f7a8..7eec7c4 100644 (file)
@@ -1,3 +1,9 @@
+cl-sql (3.2.5-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Sat, 17 Sep 2005 16:57:27 -0600
+
 cl-sql (3.2.4-1) unstable; urgency=low
 
   * New upstream
index 7e4ee52..219d527 100644 (file)
Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ
index 5c51f4b..b6873c8 100644 (file)
                provides a number of time manipulation functions to
                support objects of type <type>wall-time</type>.
              </member>
+             <member>
+               <parameter>date</parameter> - a slot which stores the
+               date (without any time of day resolution) in a
+                column. &clsql; provides a number of time
+               manipulation functions that operate on date values.
+             </member>
              <member>
                <parameter>duration</parameter> - stores a
                <type>duration</type> structure.  &clsql; provides
index 118ea20..265ae6d 100644 (file)
@@ -4,7 +4,7 @@
 
 ;; You must set these variables to appropriate values. 
 (defvar *tutorial-database-type* nil 
-  "Possible values are :postgresql,:postgresql-socket :mysql,
+  "Possible values are :postgresql :postgresql-socket, :mysql,
 :oracle, :odbc, :aodbc or :sqlite")
 (defvar *tutorial-database-name* "clsqltut"
   "The name of the database we will work in.")
@@ -86,7 +86,7 @@
 ;; Connect to the database (see the CLSQL documentation for vendor
 ;; specific connection specs).
 (case *tutorial-database-type*
-  ((:mysql :postgresql)
+  ((:mysql :postgresql :postgresql-socket)
    (clsql:connect `(,*tutorial-database-server* 
                    ,*tutorial-database-name*
                    ,*tutorial-database-user* 
diff --git a/notes/add-type-hints.txt b/notes/add-type-hints.txt
new file mode 100644 (file)
index 0000000..1f129b5
--- /dev/null
@@ -0,0 +1,32 @@
+How to Add a Type to CL-SQL (Alan Shields - Alan-Shields@omrf.ouhsc.edu)
+
+I made this small guide to eliminate some of the work I went through.
+I hope it is useful and/or correct.
+
+To add a type to CL-SQL, the following methods need to be
+declared.
+
+
+"sql/expressions.lisp"
+(defmethod database-output-sql (self database))
+
+SELF is specialized for the lisp type, such as (self integer).
+
+"sql/oodml.lisp"
+(defmethod database-get-type-specifier (type args database db-type))
+
+TYPE is a symbol for the clsql type, such as (type (eql 'integer)).
+Note that DB-TYPE is the database type, not DATABASE.
+
+"sql/oodml.lisp"
+(defmethod read-sql-value (val type database db-type))
+
+TYPE is a symbol for the clsql type, as above.
+Same warnings as above.
+
+
+If your type is stored in different ways in different sql servers, you'll need
+to specialize these methods.
+
+These specializations usually go in either db-<database>/<database>-objects.lisp or
+sql/generic-<database>.lisp.
index 2098cf3..e62d593 100644 (file)
     `(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
 
 (defmethod output-sql ((expr sql-ident-table) database)
-  (with-slots (name alias)
-    expr
-    (if (null alias)
-        (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
-        (progn
-          (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
-          (write-char #\Space *sql-stream*)
-          (format *sql-stream* "~s" alias))))
+  (with-slots (name alias) expr
+     (let ((namestr (if (symbolp name)
+                        (symbol-name name)
+                      name)))
+       (if (null alias)
+           (write-string
+            (sql-escape (convert-to-db-default-case namestr database))
+            *sql-stream*)
+         (progn
+           (write-string
+            (sql-escape (convert-to-db-default-case namestr database))
+            *sql-stream*)
+           (write-char #\Space *sql-stream*)
+           (format *sql-stream* "~s" alias)))))
   t)
 
 (defmethod output-sql-hash-key ((expr sql-ident-table) database)
@@ -903,6 +909,10 @@ uninclusive, and the args from that keyword to the end."
   (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)))
index c8d4d1f..51f8f05 100644 (file)
@@ -79,7 +79,8 @@ supports transactions."
     (execute-command stmt :database database)))
 
 (defun drop-table (name &key (if-does-not-exist :error)
-                            (database *default-database*))
+                            (database *default-database*)
+                             (owner nil))
   "Drops the table called NAME from DATABASE which defaults to
 *DEFAULT-DATABASE*. If the table does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
@@ -87,7 +88,8 @@ an error is signalled if IF-DOES-NOT-EXIST is :error."
   (let ((table-name (database-identifier name database)))
     (ecase if-does-not-exist
       (:ignore
-       (unless (table-exists-p table-name :database database)
+       (unless (table-exists-p table-name :database database
+                               :owner owner)
          (return-from drop-table nil)))
       (:error
        t))
index 3ec173a..09d879a 100644 (file)
@@ -129,20 +129,24 @@ in DATABASE which defaults to *DEFAULT-DATABASE*."
 ;; Drop the tables which store the given view class
 ;;
 
-(defun drop-view-from-class (view-class-name &key (database *default-database*))
+(defun drop-view-from-class (view-class-name &key (database *default-database*)
+                                             (owner nil))
   "Removes a table defined by the View Class VIEW-CLASS-NAME from
 DATABASE which defaults to *DEFAULT-DATABASE*."
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%uninstall-class tclass))
+          (%uninstall-class tclass :owner owner))
         (error "Class ~s not found." view-class-name)))
   (values))
 
-(defun %uninstall-class (self &key (database *default-database*))
+(defun %uninstall-class (self &key
+                              (database *default-database*)
+                              (owner nil))
   (drop-table (sql-expression :table (view-table self))
               :if-does-not-exist :ignore
-              :database database)
+              :database database
+              :owner owner)
   (setf (database-view-classes database)
         (remove self (database-view-classes database))))
 
index 85730dc..187694d 100644 (file)
   (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")
   (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)
index 242a044..ad785ec 100644 (file)
          #:current-year
          #:day-duration
          #:db-timestring
+        #:db-datestring
          #:decode-duration
          #:decode-time
+        #:decode-date
          #:duration
          #:duration+
          #:duration<
          #:extract-roman 
          #:format-duration
          #:format-time
+        #:format-date
          #:get-time
+        #:get-date
          #:utime->time
          #:interval-clear
          #:interval-contained
          #: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
          #: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
index c767018..0f8d5e2 100644 (file)
   (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)
         (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)))
     (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)
         (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
             :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
         (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 @@ 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,6 +774,12 @@ 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."
@@ -710,6 +801,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 ":")
@@ -881,6 +987,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))
@@ -1072,6 +1181,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)