X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fooddl.lisp;h=9db898b36a428afdb435684daa5b57af15516ed6;hp=d2158cc99091cbf36215b8d53b5c2df37268aaea;hb=refs%2Ftags%2Fv3.8.6;hpb=225c02af1ae1c9c6f0b6c29eaf8319d48caae89f diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index d2158cc..9db898b 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -21,7 +21,10 @@ (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) -(defvar *db-auto-sync* nil +(defparameter *default-string-length* 255 + "The length of a string which does not have a user-specified length.") + +(defvar *db-auto-sync* nil "A non-nil value means that creating View Class instances or setting their slots automatically creates/updates the corresponding records in the underlying database.") @@ -33,8 +36,8 @@ (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))) + (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)) @@ -45,25 +48,26 @@ (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) - instance slot-def) + instance slot-def) (declare (ignore new-value)) (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))) - (call-next-method) - (when (and *db-auto-sync* - (not *db-initializing*) - (not *db-deserializing*) - (not (eql slot-kind :virtual))) - (update-record-from-slot instance slot-name)))) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (prog1 + (call-next-method) + (when (and *db-auto-sync* + (not *db-initializing*) + (not *db-deserializing*) + (not (eql slot-kind :virtual))) + (update-record-from-slot instance slot-name))))) (defmethod initialize-instance ((object standard-db-object) - &rest all-keys &key &allow-other-keys) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-initializing* t)) (call-next-method) (when (and *db-auto-sync* - (not *db-deserializing*)) + (not *db-deserializing*)) (update-records-from-instance object)))) ;; @@ -71,37 +75,41 @@ ;; (defun create-view-from-class (view-class-name - &key (database *default-database*)) + &key (database *default-database*) + (transactions t)) "Creates a table as defined by the View Class VIEW-CLASS-NAME in DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%install-class tclass database)) + (%install-class tclass database :transactions transactions)) (error "Class ~s not found." view-class-name))) (values)) -(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))) - (when res - (push res schemadef)))) - (unless schemadef - (error "Class ~s has no :base slots" self)) - (create-table (sql-expression :table (view-table self)) (nreverse schemadef) - :database database - :constraints (database-pkey-constraint self database)) - (push self (database-view-classes database)) +(defmethod %install-class ((self standard-db-class) database + &key (transactions t)) + (let ((schemadef '())) + (dolist (slotdef (ordered-class-slots self)) + (let ((res (database-generate-column-definition (class-name self) + slotdef database))) + (when res + (push res schemadef)))) + (unless schemadef + (error "Class ~s has no :base slots" self)) + (create-table (sql-expression :table (view-table self)) (nreverse schemadef) + :database database + :transactions transactions + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database))) t) (defmethod database-pkey-constraint ((class standard-db-class) database) (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) - (when keylist + (when keylist (convert-to-db-default-case (format nil "CONSTRAINT ~APK PRIMARY KEY~A" - (database-output-sql (view-table class) database) - (database-output-sql keylist database)) + (sql-output (view-table class) database) + (sql-output keylist database)) database)))) (defmethod database-generate-column-definition (class slotdef database) @@ -112,8 +120,8 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (specified-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))))) + (when const + (setq cdef (append cdef (listify const))))) cdef))) @@ -121,20 +129,24 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." ;; Drop the tables which store the given view class ;; -(defun drop-view-from-class (view-class-name &key (database *default-database*)) +(defun drop-view-from-class (view-class-name &key (database *default-database*) + (owner nil)) "Removes a table defined by the View Class VIEW-CLASS-NAME from DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass)) + (%uninstall-class tclass :owner owner)) (error "Class ~s not found." view-class-name))) (values)) -(defun %uninstall-class (self &key (database *default-database*)) +(defun %uninstall-class (self &key + (database *default-database*) + (owner nil)) (drop-table (sql-expression :table (view-table self)) :if-does-not-exist :ignore - :database database) + :database database + :owner owner) (setf (database-view-classes database) (remove self (database-view-classes database)))) @@ -144,19 +156,19 @@ DATABASE which defaults to *DEFAULT-DATABASE*." ;; (defun list-classes (&key (test #'identity) - (root-class (find-class 'standard-db-object)) - (database *default-database*)) + (root-class (find-class 'standard-db-object)) + (database *default-database*)) "Returns a list of all the View Classes which are connected to DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend from the class ROOT-CLASS and which satisfy the function TEST. By default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." - (flet ((find-superclass (class) - (member root-class (class-precedence-list class)))) + (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))))) + (remove-if #'(lambda (c) (or (not (funcall test c)) + (not (find-superclass c)))) + view-classes))))) ;; ;; Define a new view class @@ -198,10 +210,10 @@ defaults to NIL. The :db-constraints slot option is a string representing an SQL table constraint expression or a list of such strings." `(progn - (defclass ,class ,supers ,slots + (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) - `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + `,cl-options + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) (finalize-inheritance (find-class ',class)) (find-class ',class)))