X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=3073bfd17eb916214be19d3421e22dec168a61a8;hb=6c70be35cc348b559d8aa869ecd0e14e27d5edbc;hp=823df46069cd0ff6f5248db9859ee458798593f2;hpb=e3f355aa2b125569097bd7108fbbd14daa23e7aa;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 823df46..3073bfd 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -16,25 +16,21 @@
 (in-package #:clsql-sys)
 
 (defclass standard-db-object ()
-  ((view-database
-    :initform nil
-    :initarg :view-database
+  ((view-database :initform nil :initarg :view-database :reader view-database
     :db-kind :virtual))
-  (:metaclass view-metaclass)
+  (:metaclass standard-db-class)
   (:documentation "Superclass for all CLSQL View Classes."))
 
-(defmethod view-database ((self standard-db-object))
-  (slot-value self 'view-database))
-
 (defvar *db-deserializing* nil)
 (defvar *db-initializing* nil)
 
-(defmethod slot-value-using-class ((class view-metaclass) instance slot)
+(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
   (declare (optimize (speed 3)))
   (unless *db-deserializing*
-    (let ((slot-name (%slot-name slot))
-          (slot-object (%slot-object slot class)))
-      (when (and (eql (view-class-slot-db-kind slot-object) :join)
+    (let* ((slot-name (%svuc-slot-name slot-def))
+	   (slot-object (%svuc-slot-object slot-def class))
+	   (slot-kind (view-class-slot-db-kind slot-object)))
+      (when (and (eql slot-kind :join)
                  (not (slot-boundp instance slot-name)))
         (let ((*db-deserializing* t))
           (if (view-database instance)
@@ -43,29 +39,13 @@
               (setf (slot-value instance slot-name) nil))))))
   (call-next-method))
 
-(defmethod (setf slot-value-using-class) (new-value (class view-metaclass)
+(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
 					  instance slot)
   (declare (ignore new-value instance slot))
   (call-next-method))
 
-;; JMM - Can't go around trying to slot-access a symbol!  Guess in
-;; CMUCL slot-name is the actual slot _object_, while in lispworks it
-;; is a lowly symbol (the variable is called slot-name after all) so
-;; the object (or in MOP terminology- the "slot definition") has to be
-;; retrieved using find-slot-definition
-
-(defun %slot-name (slot)
-  #+lispworks slot
-  #-lispworks (slot-definition-name slot))
-
-(defun %slot-object (slot class)
-  (declare (ignorable class))
-  #+lispworks (clos:find-slot-definition slot class)
-  #-lispworks slot)
-
 (defmethod initialize-instance :around ((class standard-db-object)
-                                        &rest all-keys
-                                        &key &allow-other-keys)
+                                        &rest all-keys &key &allow-other-keys)
   (declare (ignore all-keys))
   (let ((*db-deserializing* t))
     (call-next-method)))
@@ -92,7 +72,7 @@
 ;; Build the database tables required to store the given view class
 ;;
 
-(defmethod database-pkey-constraint ((class view-metaclass) database)
+(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"
@@ -100,36 +80,6 @@
               (database-output-sql keylist database)))))
 
 
-#.(locally-enable-sql-reader-syntax)
-
-(defun ensure-schema-version-table (database)
-  (unless (table-exists-p "clsql_object_v" :database database)
-    (create-table [clsql_object_v] '(([name] string)
-                                    ([vers] integer)
-                                    ([def] string))
-                  :database database)))
-
-(defun update-schema-version-records (view-class-name
-                                      &key (database *default-database*))
-  (let ((schemadef nil)
-        (tclass (find-class view-class-name)))
-    (dolist (slotdef (class-slots tclass))
-      (let ((res (database-generate-column-definition view-class-name
-                                                      slotdef database)))
-        (when res (setf schemadef (cons res schemadef)))))
-    (when schemadef
-      (delete-records :from [clsql_object_v]
-                      :where [= [name] (sql-escape (class-name tclass))]
-                      :database database)
-      (insert-records :into [clsql_object_v]
-                      :av-pairs `(([name] ,(sql-escape (class-name tclass)))
-                                  ([vers] ,(car (object-version tclass)))
-                                  ([def] ,(prin1-to-string
-                                           (object-definition tclass))))
-                      :database database))))
-
-#.(restore-sql-reader-syntax-state)
-
 (defun create-view-from-class (view-class-name
                                &key (database *default-database*))
   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
@@ -138,13 +88,11 @@ the view. The argument DATABASE has a default value of
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%install-class tclass database)
-          (ensure-schema-version-table database)
-          (update-schema-version-records view-class-name :database database))
+          (%install-class tclass database))
         (error "Class ~s not found." view-class-name)))
   (values))
 
-(defmethod %install-class ((self view-metaclass) database &aux schemadef)
+(defmethod %install-class ((self standard-db-class) database &aux schemadef)
   (dolist (slotdef (ordered-class-slots self))
     (let ((res (database-generate-column-definition (class-name self)
                                                     slotdef database)))
@@ -171,9 +119,7 @@ which defines that view. The argument DATABASE has a default value of
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%uninstall-class tclass)
-          (delete-records :from [clsql_object_v]
-                          :where [= [name] (sql-escape view-class-name)]))
+          (%uninstall-class tclass))
         (error "Class ~s not found." view-class-name)))
   (values))
 
@@ -218,7 +164,7 @@ SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 superclass of the newly-defined View Class."
   `(progn
      (defclass ,class ,supers ,slots ,@options
-	       (:metaclass view-metaclass))
+	       (:metaclass standard-db-class))
      (finalize-inheritance (find-class ',class))))
 
 (defun keyslots-for-class (class)
@@ -297,11 +243,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
-  (let ((slot-type (specified-type slotdef)))
-    (if (listp slot-type)
-        (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
-              (cdr slot-type))
-        (find-symbol (symbol-name slot-type) :clsql-sys))))
+  (specified-type slotdef))
 
 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
@@ -572,9 +514,6 @@ associated with that database."))
         (setf (slot-value obj 'view-database) database))
     (values)))
 
-;; Perhaps the slot class is not correct in all CLOS implementations,
-;; tho I have not run across a problem yet.
-
 (defmethod handle-cascade-delete-rule ((instance standard-db-object)
 				       (slot
                                         view-class-effective-slot-definition))
@@ -712,14 +651,14 @@ value.  If nulls are allowed for the column, the slot's value will be
 nil, otherwise its value will be set to the result of calling
 DATABASE-NULL-VALUE on the type of the slot."))
 
-(defmethod update-slot-with-null ((instance standard-db-object)
+(defmethod update-slot-with-null ((object standard-db-object)
 				  slotname
 				  slotdef)
   (let ((st (slot-type slotdef))
         (allowed (slot-value slotdef 'nulls-ok)))
     (if allowed
-        (setf (slot-value instance slotname) nil)
-        (setf (slot-value instance slotname)
+        (setf (slot-value object slotname) nil)
+        (setf (slot-value object slotname)
               (database-null-value st)))))
 
 (defvar +no-slot-value+ '+no-slot-value+)
@@ -932,7 +871,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots
 
-(defun fault-join-slot-raw (class instance slot-def)
+(defun fault-join-slot-raw (class instancex slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
 	 (jc (gethash :join-class dbi)))
     (let ((jq (join-qualifier class instance slot-def)))
@@ -955,7 +894,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
 	((and (not ts) (gethash :set dbi))
 	 res)))))
 
-(defun join-qualifier (class instance slot-def)
+(defun join-qualifier (class object slot-def)
     (declare (ignore class))
     (let* ((dbi (view-class-slot-db-info slot-def))
 	   (jc (find-class (gethash :join-class dbi)))
@@ -964,8 +903,8 @@ DATABASE-NULL-VALUE on the type of the slot."))
 	   (foreign-keys (gethash :foreign-key dbi))
 	   (home-keys (gethash :home-key dbi)))
       (when (every #'(lambda (slt)
-		       (and (slot-boundp instance slt)
-                            (not (null (slot-value instance slt)))))
+		       (and (slot-boundp object slt)
+                            (not (null (slot-value object slt)))))
 		   (if (listp home-keys) home-keys (list home-keys)))
 	(let ((jc
                (mapcar #'(lambda (hk fk)
@@ -980,7 +919,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
                                               (t fk))
                                             (typecase hk
                                               (symbol
-                                               (slot-value instance hk))
+                                               (slot-value object hk))
                                               (t
                                                hk)))))
                        (if (listp home-keys)
@@ -1097,6 +1036,7 @@ tuples."
                        target-args))))
     (multiple-value-bind (target-args qualifier-args)
         (query-get-selections select-all-args)
+      ;; (cmsg "Qual args = ~s" qualifier-args)
       (if (select-objects target-args)
           (apply #'find-all target-args qualifier-args)
           (let ((expr (apply #'make-query select-all-args)))