;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id: $
+;;;; $Id$
;;;;
;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
;;;;
(: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.")
(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))
(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))))
;;
;;
(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)
(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)))
;; 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))))
;;
(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
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)))
projects / clsql.git / blobdiff