X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fooddl.lisp;h=50c37a691a7639ad1c48fdfe71d6f4c1848e4a8b;hp=64d974a99f758a91b487ff48a676b770475b979e;hb=534849c88501e0ea2ee5dbf78d13d8cb73814d71;hpb=39ee7191fd3087c2d7e149b33dd3e985db021721 diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 64d974a..50c37a6 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -1,8 +1,6 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ -;;;; ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) ;;;; ;;;; This file is part of CLSQL. @@ -17,11 +15,14 @@ (defclass standard-db-object () ((view-database :initform nil :initarg :view-database :reader view-database - :db-kind :virtual)) + :db-kind :virtual)) (: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.") @@ -30,41 +31,52 @@ (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))) - (when (and (eql slot-kind :join) - (not (slot-boundp instance slot-name))) + (slot-object (%svuc-slot-object slot-def class))) + (unless (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)))))) + (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) + 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)) - (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))) (prog1 - (call-next-method) - (when (and *db-auto-sync* + (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)))) ;; @@ -73,52 +85,67 @@ (defun create-view-from-class (view-class-name &key (database *default-database*) - (transactions t)) + (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)) + (let ((*default-database* database) + (pclass (car (class-direct-superclasses tclass)))) + (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 '())) - (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))) + &key (transactions t)) + (let ((schemadef '()) + (ordered-slots (slots-for-possibly-normalized-class self))) + (dolist (slotdef ordered-slots) + (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 + (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)) + (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 - (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)))) + ;; 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 + (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))) - (when const - (setq cdef (append cdef (list const))))) + (when const + (setq cdef (append cdef (listify const))))) cdef))) @@ -126,20 +153,25 @@ 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*)) - (drop-table (sql-expression :table (view-table self)) +(defun %uninstall-class (self &key + (database *default-database*) + (owner nil)) + (drop-table (sql-expression :table (database-identifier self database)) :if-does-not-exist :ignore - :database database) + :database database + :owner owner) + (database-remove-autoincrement-sequence self database) (setf (database-view-classes database) (remove self (database-view-classes database)))) @@ -149,19 +181,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 @@ -203,12 +235,12 @@ 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 - ,@(if (find :metaclass `,cl-options :key #'car) - `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) - (finalize-inheritance (find-class ',class)) - (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)) + (find-class ',class))) (defun keyslots-for-class (class) (slot-value class 'key-slots))