X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fooddl.lisp;h=50c37a691a7639ad1c48fdfe71d6f4c1848e4a8b;hp=02c11f021df00c7d3bf1502c612ff4c4994696cc;hb=534849c88501e0ea2ee5dbf78d13d8cb73814d71;hpb=ef93cbe09e01bb540651e6719eb4e8fe7ebeefd0 diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 02c11f0..50c37a6 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -31,32 +31,33 @@ (defvar *db-initializing* nil) (defmethod slot-value-using-class ((class standard-db-class) instance slot-def) + "When a slot is unbound but should contain a join object or a value from a + normalized view-class, then retrieve and set those slots, so the value can + be returned" (declare (optimize (speed 3))) (unless *db-deserializing* (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))) - (if (and (eql slot-kind :join) - (not (slot-boundp instance slot-name))) - (let ((*db-deserializing* t)) - (if (view-database instance) - (setf (slot-value instance slot-name) - (fault-join-slot class instance slot-object)) - (setf (slot-value instance slot-name) nil))) - (when (and (normalizedp class) - (not (member slot-name - (mapcar #'(lambda (esd) (slot-definition-name esd)) - (ordered-class-direct-slots class)))) - (not (slot-boundp instance slot-name))) - (let ((*db-deserializing* t)) - (if (view-database instance) - (setf (slot-value instance slot-name) - (fault-join-normalized-slot class instance slot-object)) - (setf (slot-value instance slot-name) nil))))))) + (slot-object (%svuc-slot-object slot-def class))) + (unless (slot-boundp instance slot-name) + (let ((*db-deserializing* t)) + (cond + ((join-slot-p slot-def) + (setf (slot-value instance slot-name) + (if (view-database instance) + (fault-join-slot class instance slot-object) + ;; TODO: you could in theory get a join object even if + ;; its joined-to object was not in the database + nil + ))) + ((not-direct-normalized-slot-p class slot-def) + (if (view-database instance) + (update-fault-join-normalized-slot class instance slot-def) + (setf (slot-value instance slot-name) nil)))))))) (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) instance slot-def) + "Handle auto syncing values to the database if *db-auto-sync* is t" (declare (ignore new-value)) (let* ((slot-name (%svuc-slot-name slot-def)) (slot-object (%svuc-slot-object slot-def class)) @@ -91,30 +92,33 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (if tclass (let ((*default-database* database) (pclass (car (class-direct-superclasses tclass)))) - (when (and (normalizedp tclass) (not (table-exists-p (view-table pclass)))) + (when (and (normalizedp tclass) (not (table-exists-p pclass))) (create-view-from-class (class-name pclass) :database database :transactions transactions)) (%install-class tclass database :transactions transactions)) (error "Class ~s not found." view-class-name))) (values)) +(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*)) + (declare (ignore database)) + (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef))) + (slot-value slotdef 'autoincrement-sequence))) (defmethod %install-class ((self standard-db-class) database &key (transactions t)) (let ((schemadef '()) - (ordered-slots (if (normalizedp self) - (ordered-class-direct-slots self) - (ordered-class-slots self)))) + (ordered-slots (slots-for-possibly-normalized-class self))) (dolist (slotdef ordered-slots) - (let ((res (database-generate-column-definition self - slotdef database))) + (let ((res (database-generate-column-definition self slotdef database))) (when res (push res schemadef)))) (if (not schemadef) (unless (normalizedp self) (error "Class ~s has no :base slots" self)) (progn - (create-table (sql-expression :table (view-table self)) (nreverse schemadef) + (database-add-autoincrement-sequence self database) + (create-table (sql-expression :table (database-identifier self database)) + (nreverse schemadef) :database database :transactions transactions :constraints (database-pkey-constraint self database)) @@ -122,22 +126,21 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." t) (defmethod database-pkey-constraint ((class standard-db-class) database) - (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))) - (table (view-table class))) + ;; Keylist will always be a list of escaped-indentifier + (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database)) + (keyslots-for-class class))) + (table (escaped (combine-database-identifiers + (list class 'PK) + database)))) (when keylist - (etypecase table - (string - (format nil "CONSTRAINT \"~APK\" PRIMARY KEY~A" table - (sql-output keylist database))) - ((or symbol sql-ident) - (format nil "CONSTRAINT ~APK PRIMARY KEY~A" table - (sql-output keylist database))))))) + (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table + keylist)))) (defmethod database-generate-column-definition (class slotdef database) - (declare (ignore database class)) - (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (declare (ignore class)) + (when (key-or-base-slot-p slotdef) (let ((cdef - (list (sql-expression :attribute (view-class-slot-column slotdef)) + (list (sql-expression :attribute (database-identifier slotdef database)) (specified-type slotdef)))) (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) @@ -164,10 +167,11 @@ DATABASE which defaults to *DEFAULT-DATABASE*." (defun %uninstall-class (self &key (database *default-database*) (owner nil)) - (drop-table (sql-expression :table (view-table self)) + (drop-table (sql-expression :table (database-identifier self database)) :if-does-not-exist :ignore :database database :owner owner) + (database-remove-autoincrement-sequence self database) (setf (database-view-classes database) (remove self (database-view-classes database))))