;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
;;;;
;;;; This file is part of CLSQL.
(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."))
(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)
- (setf (slot-value instance slot-name)
- (fault-join-slot class instance slot-object))
- (setf (slot-value instance slot-name) nil))))))
+ (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)))))))
(call-next-method))
(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
(slot-object (%svuc-slot-object slot-def class))
(slot-kind (view-class-slot-db-kind slot-object)))
(prog1
- (call-next-method)
+ (call-next-method)
(when (and *db-auto-sync*
(not *db-initializing*)
(not *db-deserializing*)
(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)
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 (view-table 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 %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)
+ (let ((schemadef '())
+ (ordered-slots (if (normalizedp self)
+ (ordered-class-direct-slots self)
+ (ordered-class-slots self))))
+ (dolist (slotdef ordered-slots)
+ (let ((res (database-generate-column-definition 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)))
+ (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 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))))
+ (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))
+ (table (view-table class)))
(when keylist
- (convert-to-db-default-case
- (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
- (sql-output (view-table class) database)
- (sql-output keylist database))
- database))))
+ (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)))))))
(defmethod database-generate-column-definition (class slotdef database)
(declare (ignore database class))
;;
(defun drop-view-from-class (view-class-name &key (database *default-database*)
- (owner nil))
+ (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)))
(values))
(defun %uninstall-class (self &key
- (database *default-database*)
- (owner nil))
+ (database *default-database*)
+ (owner nil))
(drop-table (sql-expression :table (view-table self))
:if-does-not-exist :ignore
:database database
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))