1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
6 ;;;; This file is part of CLSQL.
8 ;;;; CLSQL users are granted the rights to distribute and use this software
9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
11 ;;;; *************************************************************************
14 (in-package #:clsql-sys)
16 (defclass standard-db-object ()
17 ((view-database :initform nil :initarg :view-database :reader view-database
19 (:metaclass standard-db-class)
20 (:documentation "Superclass for all CLSQL View Classes."))
22 (defparameter *default-string-length* 255
23 "The length of a string which does not have a user-specified length.")
25 (defvar *db-auto-sync* nil
26 "A non-nil value means that creating View Class instances or
27 setting their slots automatically creates/updates the
28 corresponding records in the underlying database.")
30 (defvar *db-deserializing* nil)
31 (defvar *db-initializing* nil)
33 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
34 (declare (optimize (speed 3)))
35 (unless *db-deserializing*
36 (let* ((slot-name (%svuc-slot-name slot-def))
37 (slot-object (%svuc-slot-object slot-def class))
38 (slot-kind (view-class-slot-db-kind slot-object)))
39 (if (and (eql slot-kind :join)
40 (not (slot-boundp instance slot-name)))
41 (let ((*db-deserializing* t))
42 (if (view-database instance)
43 (setf (slot-value instance slot-name)
44 (fault-join-slot class instance slot-object))
45 (setf (slot-value instance slot-name) nil)))
46 (when (and (normalizedp class)
47 (not (member slot-name
48 (mapcar #'(lambda (esd) (slot-definition-name esd))
49 (ordered-class-direct-slots class))))
50 (not (slot-boundp instance slot-name)))
51 (let ((*db-deserializing* t))
52 (if (view-database instance)
53 (setf (slot-value instance slot-name)
54 (fault-join-normalized-slot class instance slot-object))
55 (setf (slot-value instance slot-name) nil)))))))
58 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
60 (declare (ignore new-value))
61 (let* ((slot-name (%svuc-slot-name slot-def))
62 (slot-object (%svuc-slot-object slot-def class))
63 (slot-kind (view-class-slot-db-kind slot-object)))
66 (when (and *db-auto-sync*
67 (not *db-initializing*)
68 (not *db-deserializing*)
69 (not (eql slot-kind :virtual)))
70 (update-record-from-slot instance slot-name)))))
72 (defmethod initialize-instance ((object standard-db-object)
73 &rest all-keys &key &allow-other-keys)
74 (declare (ignore all-keys))
75 (let ((*db-initializing* t))
77 (when (and *db-auto-sync*
78 (not *db-deserializing*))
79 (update-records-from-instance object))))
82 ;; Build the database tables required to store the given view class
85 (defun create-view-from-class (view-class-name
86 &key (database *default-database*)
88 "Creates a table as defined by the View Class VIEW-CLASS-NAME
89 in DATABASE which defaults to *DEFAULT-DATABASE*."
90 (let ((tclass (find-class view-class-name)))
92 (let ((*default-database* database)
93 (pclass (car (class-direct-superclasses tclass))))
94 (when (and (normalizedp tclass) (not (table-exists-p pclass)))
95 (create-view-from-class (class-name pclass)
96 :database database :transactions transactions))
97 (%install-class tclass database :transactions transactions))
98 (error "Class ~s not found." view-class-name)))
101 (defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
102 (declare (ignore database))
103 (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef)))
104 (slot-value slotdef 'autoincrement-sequence)))
106 (defmethod %install-class ((self standard-db-class) database
107 &key (transactions t))
108 (let ((schemadef '())
109 (ordered-slots (if (normalizedp self)
110 (ordered-class-direct-slots self)
111 (ordered-class-slots self))))
112 (dolist (slotdef ordered-slots)
113 (let ((res (database-generate-column-definition self slotdef database)))
115 (push res schemadef))))
117 (unless (normalizedp self)
118 (error "Class ~s has no :base slots" self))
120 (database-add-autoincrement-sequence self database)
121 (create-table (sql-expression :table (database-identifier self database))
124 :transactions transactions
125 :constraints (database-pkey-constraint self database))
126 (push self (database-view-classes database)))))
129 (defmethod database-pkey-constraint ((class standard-db-class) database)
130 ;; Keylist will always be a list of escaped-indentifier
131 (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database))
132 (keyslots-for-class class)))
133 (table (escaped (combine-database-identifiers
137 (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table
140 (defmethod database-generate-column-definition (class slotdef database)
141 (declare (ignore class))
142 (when (member (view-class-slot-db-kind slotdef) '(:base :key))
144 (list (sql-expression :attribute (database-identifier slotdef database))
145 (specified-type slotdef))))
146 (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
147 (let ((const (view-class-slot-db-constraints slotdef)))
149 (setq cdef (append cdef (listify const)))))
154 ;; Drop the tables which store the given view class
157 (defun drop-view-from-class (view-class-name &key (database *default-database*)
159 "Removes a table defined by the View Class VIEW-CLASS-NAME from
160 DATABASE which defaults to *DEFAULT-DATABASE*."
161 (let ((tclass (find-class view-class-name)))
163 (let ((*default-database* database))
164 (%uninstall-class tclass :owner owner))
165 (error "Class ~s not found." view-class-name)))
168 (defun %uninstall-class (self &key
169 (database *default-database*)
171 (drop-table (sql-expression :table (database-identifier self database))
172 :if-does-not-exist :ignore
175 (database-remove-autoincrement-sequence self database)
176 (setf (database-view-classes database)
177 (remove self (database-view-classes database))))
181 ;; List all known view classes
184 (defun list-classes (&key (test #'identity)
185 (root-class (find-class 'standard-db-object))
186 (database *default-database*))
187 "Returns a list of all the View Classes which are connected to
188 DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
189 from the class ROOT-CLASS and which satisfy the function TEST. By
190 default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
191 (flet ((find-superclass (class)
192 (member root-class (class-precedence-list class))))
193 (let ((view-classes (and database (database-view-classes database))))
195 (remove-if #'(lambda (c) (or (not (funcall test c))
196 (not (find-superclass c))))
200 ;; Define a new view class
203 (defmacro def-view-class (class supers slots &rest cl-options)
204 "Creates a View Class called CLASS whose slots SLOTS can map
205 onto the attributes of a table in a database. If SUPERS is nil
206 then the superclass of CLASS will be STANDARD-DB-OBJECT,
207 otherwise SUPERS is a list of superclasses for CLASS which must
208 include STANDARD-DB-OBJECT or a descendent of this class. The
209 syntax of DEFCLASS is extended through the addition of a class
210 option :base-table which defines the database table onto which
211 the View Class maps and which defaults to CLASS. The DEFCLASS
212 syntax is also extended through additional slot
213 options. The :db-kind slot option specifies the kind of DB
214 mapping which is performed for this slot and defaults to :base
215 which indicates that the slot maps to an ordinary column of the
216 database table. A :db-kind value of :key indicates that this slot
217 is a special kind of :base slot which maps onto a column which is
218 one of the unique keys for the database table, the value :join
219 indicates this slot represents a join onto another View Class
220 which contains View Class objects, and the value :virtual
221 indicates a standard CLOS slot which does not map onto columns of
222 the database table. If a slot is specified with :db-kind :join,
223 the slot option :db-info contains a list which specifies the
224 nature of the join. For slots of :db-kind :base or :key,
225 the :type slot option has a special interpretation such that Lisp
226 types, such as string, integer and float are automatically
227 converted into appropriate SQL types for the column onto which
228 the slot maps. This behaviour may be over-ridden using
229 the :db-type slot option which is a string specifying the
230 vendor-specific database type for this slot's column definition
231 in the database. The :column slot option specifies the name of
232 the SQL column which the slot maps onto, if :db-kind is
233 not :virtual, and defaults to the slot name. The :void-value slot
234 option specifies the value to store if the SQL value is NULL and
235 defaults to NIL. The :db-constraints slot option is a string
236 representing an SQL table constraint expression or a list of such
239 (defclass ,class ,supers ,slots
240 ,@(if (find :metaclass `,cl-options :key #'car)
242 (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
243 (finalize-inheritance (find-class ',class))
244 (find-class ',class)))
246 (defun keyslots-for-class (class)
247 (slot-value class 'key-slots))