X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=092bcd3e031a63fc11968ac686fde2275568af81;hp=ceb8f98851a1cfccc71bffda8db91ca71774c5cb;hb=775a7dfa8c524a06c8f9021a8390d58ecbcacf9c;hpb=c7cbd01b259a1846a5e172d69c956b836b14febb

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index ceb8f98..092bcd3 100644
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -391,7 +391,9 @@
   (let* ((classes-and-slots (view-classes-and-storable-slots instance))
          (vd (choose-database-for-instance instance database)))
     (labels ((do-update (class-and-slots)
-               (let* ((select-list (make-select-list class-and-slots :do-joins-p nil))
+               (let* ((select-list (make-select-list class-and-slots
+                                                     :do-joins-p nil
+                                                     :database database))
                       (view-table (sql-table select-list))
                       (view-qual (key-qualifier-for-instance
                                   instance :database vd
@@ -465,311 +467,181 @@
             (error "No view-table for class ~A"  classname))
           (sql-expression :table (view-table class))))
 
-
-(defmethod database-get-type-specifier (type args database db-type)
-  (declare (ignore type args database db-type))
-  (format nil "VARCHAR(~D)" *default-string-length*))
-
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "INT(~A)" (car args))
-      "INT"))
-
 (deftype tinyint ()
   "An 8-bit integer, this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype smallint ()
   "An integer smaller than a 32-bit integer. this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype mediumint ()
   "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype bigint ()
   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
-  (declare (ignore args database db-type))
-  "BIGINT")
-
 (deftype varchar (&optional size)
   "A variable length string for the SQL varchar type."
   (declare (ignore size))
   'string)
 
-(defmethod database-get-type-specifier ((type (eql 'varchar)) args
-                                        database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "VARCHAR(~A)" (car args))
-      (format nil "VARCHAR(~D)" *default-string-length*)))
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "CHAR(~A)" (car args))
-      (format nil "VARCHAR(~D)" *default-string-length*)))
-
 (deftype universal-time ()
   "A positive integer as returned by GET-UNIVERSAL-TIME."
   '(integer 1 *))
 
-(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
-  (declare (ignore args database db-type))
-  "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
-  (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")
-
-(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
-  (declare (ignore database args db-type))
-  "INT8")
+(deftype generalized-boolean ()
+  "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
+  t)
 
 #+ignore
 (deftype char (&optional len)
   "A lisp type for the SQL CHAR type."
   `(string ,len))
 
-(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "FLOAT(~A)" (car args))
-      "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "FLOAT(~A)" (car args))
-      "FLOAT"))
-
-(deftype generalized-boolean ()
-  "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
-  t)
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
-  (declare (ignore args database db-type))
-  "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type)
+(defmethod database-get-type-specifier ((type string) args database (db-type t))
+  "Pass through the literal type as defined in the type string"
   (declare (ignore args database db-type))
-  "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
-  (declare (ignore database db-type))
-  (cond
-    ((and (consp args) (= (length args) 2))
-     (format nil "NUMBER(~D,~D)" (first args) (second args)))
-    ((and (consp args) (= (length args) 1))
-     (format nil "NUMBER(~D)" (first args)))
-    (t
-     "NUMBER")))
-
-(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "CHAR(~D)" (first args))
-      "CHAR(1)"))
-
+  type)
+
+
+(defmethod database-get-type-specifier ((type symbol) args database db-type)
+  (case type
+    (char (if args
+              (format nil "CHAR(~D)" (first args))
+              "CHAR(1)"))
+    ((varchar string)
+     (if args
+         (format nil "VARCHAR(~A)" (car args))
+         (format nil "VARCHAR(~D)" *default-string-length*)))
+    ((longchar text) "text")
+    (integer (if args
+                 (format nil "INT(~A)" (car args))
+                 "INT"))
+    ((tinyint smallint mediumint) "INT")
+    ((long-float float)
+     (if args
+         (format nil "FLOAT(~A)" (car args))
+         "FLOAT"))
+    ((bigint universal-time) "BIGINT")
+    (number
+     (cond
+       ((and (consp args) (= (length args) 2))
+        (format nil "NUMBER(~D,~D)" (first args) (second args)))
+       ((and (consp args) (= (length args) 1))
+        (format nil "NUMBER(~D)" (first args)))
+       (t
+        "NUMBER")))
+    (wall-time "TIMESTAMP")
+    (date "DATE")
+    (duration "VARCHAR")
+    (money "INT8")
+    ((boolean generalized-boolean) "BOOL")
+    (t (warn "Could not determine a valid ~A type specifier for ~A ~A ~A, defaulting to VARCHAR "
+             db-type type args database)
+     (format nil "VARCHAR(~D)" *default-string-length*))))
 
 (defmethod database-output-sql-as-type (type val database db-type)
   (declare (ignore type database db-type))
   val)
 
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
-  (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (let ((escaped (prin1-to-string val)))
-      (substitute-char-string
-       escaped #\Null " "))))
-
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
-  (declare (ignore database db-type))
-  (if val
-      (concatenate 'string
-                   (package-name (symbol-package val))
-                   "::"
-                   (symbol-name val))
-      ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
-  (declare (ignore database db-type))
-  (if val
-      (symbol-name val)
-      ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
-  (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
+(defmethod database-output-sql-as-type ((type symbol) val database db-type)
+  (declare (ignore database))
+  (case type ;; booleans handle null differently
+    ((boolean generalized-boolean)
+     (case db-type
+       ;; done here so it can be done once
+       ((:mssql :mysql) (if val 1 0))
+       (otherwise (if val "t" "f"))))
+    (otherwise
+     ;; in all other cases if we have nil give everyone else a shot at it,
+     ;; which by default returns nil
+     (if (null val)
+         (call-next-method)
+         (case type
+           (symbol
+            (format nil "~A::~A"
+                    (package-name (symbol-package val))
+                    (symbol-name val)))
+           (keyword (symbol-name val))
+           (string val)
+           (char (etypecase val
+                   (character (write-to-string val))
+                   (string val)))
+           (float (format nil "~F" val))
+           ((list vector array)
+            (let* ((*print-circle* t)
+                   (*print-array* t)
+                   (value (prin1-to-string val)))
+              value))
+           (otherwise (call-next-method)))))))
+
+(defmethod read-sql-value (val type database db-type
+                           &aux *read-eval*)
   (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (prin1-to-string val)))
+  ;; TODO: All the read-from-strings in here do not check that
+  ;; what we read was of the correct type, should this change?
 
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
-  (declare (ignore database db-type))
-  (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
-  (declare (ignore database db-type))
-  (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (character (write-to-string val))
-    (string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
-  (declare (ignore database db-type))
-  (if (eq (type-of val) 'null)
-      nil
-      (let ((*read-default-float-format* (type-of val)))
-       (format nil "~F" val))))
-
-(defmethod read-sql-value (val type database db-type)
-  (declare (ignore database db-type))
+  ;; TODO: Should this case `(typep val type)=>t` be an around
+  ;; method that short ciruits?
   (cond
     ((null type) val) ;;we have no desired type, just give the value
     ((typep val type) val) ;;check that it hasn't already been converted.
     ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
     (T (error "Unable to read-sql-value ~a as type ~a" val type))))
 
-(defmethod read-sql-value (val (type (eql 'string)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'char)) database db-type)
-  (declare (ignore database db-type))
-  (schar val 0))
-
-(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (intern (symbol-name-default-case val)
-            (find-package '#:keyword))))
-
-(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (unless (string= val (symbol-name-default-case "NIL"))
-      (read-from-string val))))
-
-(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'smallint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float (read-from-string val)))
-    (float val)))
-
-(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float
-	     (let ((*read-default-float-format* 'double-float))
-	       (read-from-string val))
-	     1.0d0))
-    (double-float val)
-    (float (coerce val 'double-float))))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'number)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (read-from-string val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (etypecase val
-      (string
-       (parse-integer val))
-      (number val))))
-
-(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
-  (declare (ignore database db-type))
-  (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)
-              (equal "NIL" val))
-    (parse-timestring val)))
+(defmethod read-sql-value (val (type symbol) database db-type
+                           ;; never eval while reading values
+                           &aux *read-eval*)
+  ;; TODO: All the read-from-strings in here do not check that
+  ;; what we read was of the correct type, should this change?
+  (unless (or (equalp "nil" val) (eql 'null val))
+    (case type
+      ((string varchar) val)
+      (char (etypecase val
+              (string (schar val 0))
+              (character val)))
+      (keyword
+       (when (< 0 (length val))
+         (intern (symbol-name-default-case val) :keyword)))
+      (symbol
+       (when (< 0 (length val))
+         (intern (symbol-name-default-case val))))
+      ((smallint mediumint bigint integer universal-time)
+       (etypecase val
+         (string (parse-integer val))
+         (number val)))
+      ((double-float float)
+       ;; ensure that whatever we got is coerced to a float of the correct
+       ;; type (eg: 1=>1.0d0)
+       (float
+        (etypecase val
+          (string (let ((*read-default-float-format*
+                          (ecase type
+                            (float 'single-float)
+                            (double-float 'double-float))))
+                    (read-from-string val)))
+          (float val))
+        (if (eql type 'double-float) 1.0d0 1.0s0)))
+      (number
+       (etypecase val
+         (string (read-from-string val))
+         (number val)))
+      ((boolean generalized-boolean)
+       (if (member val '(nil t))
+           val
+           (etypecase val
+             (string
+              (when (member val '("1" "t" "true" "y") :test #'string-equal)
+                t))
+             (number (not (zerop val))))))
+      ((wall-time duration)
+       (parse-timestring val))
+      (date
+       (parse-datestring val))
+      (t (call-next-method)))))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots
@@ -1116,7 +988,13 @@
 (defmethod sql-table ((o select-list))
   (sql-expression :table (view-table o)))
 
-(defun make-select-list (class-and-slots &key (do-joins-p nil))
+(defmethod filter-select-list ((c clsql-sys::standard-db-object)
+                               (sl clsql-sys::select-list)
+                               database)
+  sl)
+
+(defun make-select-list (class-and-slots &key (do-joins-p nil)
+                                         (database *default-database*))
   "Make a select-list for the current class (or class-and-slots) object."
   (let* ((class-and-slots
            (etypecase class-and-slots
@@ -1136,18 +1014,21 @@
               finally (return (values slots sqls)))
       (unless slots
         (error "No slots of type :base in view-class ~A" (class-name class)))
-      (make-instance
-       'select-list
-       :view-class class
-       :select-list sqls
-       :slot-list slots
-       :join-slots join-slots
-       ;; only do a single layer of join objects
-       :joins (when do-joins-p
-                (loop for js in join-slots
-                      collect (make-select-list
-                               (join-slot-class js)
-                               :do-joins-p nil)))))))
+      (let ((sl (make-instance
+                 'select-list
+                 :view-class class
+                 :select-list sqls
+                 :slot-list slots
+                 :join-slots join-slots
+                 ;; only do a single layer of join objects
+                 :joins (when do-joins-p
+                          (loop for js in join-slots
+                                collect (make-select-list
+                                         (join-slot-class js)
+                                         :do-joins-p nil
+                                         :database database))))))
+        (filter-select-list (make-instance class) sl database)
+        sl))))
 
 (defun full-select-list ( select-lists )
   "Returns a list of sql-ref of things to select for the given classes
@@ -1229,7 +1110,7 @@
                  appending (loop for slot in (immediate-join-slots class)
                                  collect (join-slot-qualifier class slot))))
          (select-lists (loop for class in sclasses
-                             collect (make-select-list class :do-joins-p t)))
+                             collect (make-select-list class :do-joins-p t :database database)))
          (full-select-list (full-select-list select-lists))
          (where (clsql-ands (append (listify where) (listify join-where))))
          #|