X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=d8181d1fb763b6ae6034cd4a3d7c4a6dc631a4bb;hb=cb659acb4345ca90e8202c88a66f617de65df2f9;hp=a84bf3be9c44c19d843feb4f7632aafaabdd51d7;hpb=994eee8f4300e738456863610940d4ecaa678300;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index a84bf3b..d8181d1 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -78,9 +78,11 @@
 (defmethod database-pkey-constraint ((class standard-db-class) database)
   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
     (when keylist 
-      (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
-              (database-output-sql (view-table class) database)
-              (database-output-sql keylist database)))))
+      (convert-to-db-default-case
+       (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
+	       (database-output-sql (view-table class) database)
+	       (database-output-sql keylist database))
+       database))))
 
 
 (defun create-view-from-class (view-class-name
@@ -113,8 +115,6 @@ the view. The argument DATABASE has a default value of
 ;; Drop the tables which store the given view class
 ;;
 
-#.(locally-enable-sql-reader-syntax)
-
 (defun drop-view-from-class (view-class-name &key (database *default-database*))
   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 which defines that view. The argument DATABASE has a default value of
@@ -126,8 +126,6 @@ which defines that view. The argument DATABASE has a default value of
         (error "Class ~s not found." view-class-name)))
   (values))
 
-#.(restore-sql-reader-syntax-state)
-
 (defun %uninstall-class (self &key (database *default-database*))
   (drop-table (sql-expression :table (view-table self))
               :if-does-not-exist :ignore
@@ -141,19 +139,27 @@ which defines that view. The argument DATABASE has a default value of
 ;;
 
 (defun list-classes (&key (test #'identity)
-                          (root-class 'standard-db-object)
-                          (database *default-database*))
-  "Returns a list of View Classes connected to a given DATABASE which
-defaults to *DEFAULT-DATABASE*."
-  (declare (ignore root-class))
-  (remove-if #'(lambda (c) (not (funcall test c)))
-             (database-view-classes database)))
+		     (root-class (find-class 'standard-db-object))
+		     (database *default-database*))
+  "The LIST-CLASSES function collects all the classes below
+ROOT-CLASS, which defaults to standard-db-object, that are connected
+to the supplied DATABASE and which satisfy the TEST function. The
+default for the TEST argument is identity. By default, LIST-CLASSES
+returns a list of all the classes connected to the default database,
+*DEFAULT-DATABASE*."
+  (flet ((find-superclass (class) 
+	   (member root-class (class-precedence-list class))))
+    (let ((view-classes (and database (database-view-classes database))))
+      (when view-classes
+	(remove-if #'(lambda (c) (or (not (funcall test c))
+				     (not (find-superclass c))))
+		   view-classes)))))
 
 ;;
 ;; Define a new view class
 ;;
 
-(defmacro def-view-class (class supers slots &rest options)
+(defmacro def-view-class (class supers slots &rest cl-options)
   "Extends the syntax of defclass to allow special slots to be mapped
 onto the attributes of database views. The macro DEF-VIEW-CLASS
 creates a class called CLASS which maps onto a database view. Such a
@@ -166,9 +172,11 @@ instances are filled with attribute values from the database. If
 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 superclass of the newly-defined View Class."
   `(progn
-     (defclass ,class ,supers ,slots ,@options
-	       (:metaclass standard-db-class))
-     (finalize-inheritance (find-class ',class))))
+    (defclass ,class ,supers ,slots 
+      ,@(if (find :metaclass `,cl-options :key #'car)
+	    `,cl-options
+	    (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
+    (finalize-inheritance (find-class ',class))))
 
 (defun keyslots-for-class (class)
   (slot-value class 'key-slots))
@@ -230,6 +238,7 @@ superclass of the newly-defined View Class."
     (let ((cdef
            (list (sql-expression :attribute (view-class-slot-column slotdef))
                  (slot-type slotdef))))
+      (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
       (let ((const (view-class-slot-db-constraints slotdef)))
         (when const 
           (setq cdef (append cdef (list const)))))
@@ -539,7 +548,8 @@ DATABASE-NULL-VALUE on the type of the slot."))
 
 (defmethod database-get-type-specifier (type args database)
   (declare (ignore type args))
-  (if (member (database-type database) '(:postgresql :postgresql-socket))
+  (if (clsql-base-sys::in (database-underlying-type database)
+			  :postgresql :postgresql-socket)
           "VARCHAR"
           "VARCHAR(255)"))
 
@@ -554,31 +564,32 @@ DATABASE-NULL-VALUE on the type of the slot."))
                                         database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-      (if (member (database-type database) '(:postgresql :postgresql-socket))
-          "VARCHAR"
-          "VARCHAR(255)")))
+    (if (clsql-base-sys::in (database-underlying-type database) 
+			    :postgresql :postgresql-socket)
+	"VARCHAR"
+      "VARCHAR(255)")))
 
 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
                                         database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-      (if (member (database-type database) '(:postgresql :postgresql-socket))
-          "VARCHAR"
-          "VARCHAR(255)")))
+    (if (clsql-base-sys::in (database-underlying-type database) 
+			    :postgresql :postgresql-socket)
+	"VARCHAR"
+      "VARCHAR(255)")))
 
 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-      (if (member (database-type database) '(:postgresql :postgresql-socket))
-          "VARCHAR"
-          "VARCHAR(255)")))
+    (if (clsql-base-sys::in (database-underlying-type database) 
+			    :postgresql :postgresql-socket)
+	"VARCHAR"
+      "VARCHAR(255)")))
 
 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
   (declare (ignore args))
-  (case (database-type database)
-    (:postgresql
-     "TIMESTAMP WITHOUT TIME ZONE")
-    (:postgresql-socket
+  (case (database-underlying-type database)
+    ((:postgresql :postgresql-socket)
      "TIMESTAMP WITHOUT TIME ZONE")
     (:mysql
      "DATETIME")
@@ -697,13 +708,14 @@ DATABASE-NULL-VALUE on the type of the slot."))
 (defmethod read-sql-value (val (type (eql 'keyword)) database)
   (declare (ignore database))
   (when (< 0 (length val))
-    (intern (string-upcase val) "KEYWORD")))
+    (intern (symbol-name-default-case val) 
+	    (find-package '#:keyword))))
 
 (defmethod read-sql-value (val (type (eql 'symbol)) database)
   (declare (ignore database))
   (when (< 0 (length val))
-    (unless (string= val "NIL")
-      (intern (string-upcase val)
+    (unless (string= val (clsql-base-sys:symbol-name-default-case "NIL"))
+      (intern (clsql-base-sys:symbol-name-default-case val)
               (symbol-package *update-context*)))))
 
 (defmethod read-sql-value (val (type (eql 'integer)) database)
@@ -727,6 +739,11 @@ DATABASE-NULL-VALUE on the type of the slot."))
   (unless (eq 'NULL val)
     (parse-timestring val)))
 
+(defmethod read-sql-value (val (type (eql 'duration)) database)
+  (declare (ignore database))
+  (unless (or (eq 'NULL val)
+              (equal "NIL" val))
+    (parse-timestring val)))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots