X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=3c6588f5540af9aa2e3d2723cac8b87f82ff1fd5;hb=5068697a98c10224f3a3e0a7125ba64cf3d3b4fb;hp=f4caac808716395e01318547f3358a097ba6cc86;hpb=73cf858d596ad1d51c745b478292433617cf9d72;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index f4caac8..3c6588f 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -32,9 +32,10 @@
 (defmethod slot-value-using-class ((class standard-db-class) instance slot)
   (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))
+	   (slot-object (%svuc-slot-object slot 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)
@@ -48,21 +49,6 @@
   (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)
@@ -100,36 +86,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 32))
-                                    ([vers] integer)
-                                    ([def] (string 32)))
-                  :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,14 +94,12 @@ 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 standard-db-class) database &aux schemadef)
-  (dolist (slotdef (class-slots self))
+  (dolist (slotdef (ordered-class-slots self))
     (let ((res (database-generate-column-definition (class-name self)
                                                     slotdef database)))
       (when res 
@@ -262,7 +216,7 @@ superclass of the newly-defined View Class."
 
 (defun generate-selection-list (vclass)
   (let ((sels nil))
-    (dolist (slotdef (class-slots vclass))
+    (dolist (slotdef (ordered-class-slots vclass))
       (let ((res (generate-attribute-reference vclass slotdef)))
 	(when res
           (push (cons slotdef res) sels))))
@@ -297,7 +251,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
-  (let ((slot-type (slot-definition-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))
@@ -529,7 +483,7 @@ associated with that database."))
 		     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
 	   (view-class-table (view-table view-class))
-	   (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+	   (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 	   (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))
@@ -558,7 +512,7 @@ associated with that database."))
 		     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
 	   (view-class-table (view-table view-class))
-	   (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+	   (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 	   (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))
@@ -619,7 +573,7 @@ associated with that database."))
   (let* ((view-class (class-of instance))
 	 (joins (remove-if #'(lambda (sd)
 			       (not (equal (view-class-slot-db-kind sd) :join)))
-			   (class-slots view-class))))
+			   (ordered-class-slots view-class))))
     (dolist (slot joins)
       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
 	(cond