1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
8 ;;;; This file is part of CLSQL.
10 ;;;; CLSQL users are granted the rights to distribute and use this software
11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
13 ;;;; *************************************************************************
16 (in-package #:clsql-sys)
18 (defclass standard-db-object ()
19 ((view-database :initform nil :initarg :view-database :reader view-database
21 (:metaclass standard-db-class)
22 (:documentation "Superclass for all CLSQL View Classes."))
24 (defvar *db-auto-sync* nil
25 "A non-nil value means that creating View Class instances or
26 setting their slots automatically creates/updates the
27 corresponding records in the underlying database.")
29 (defvar *db-deserializing* nil)
30 (defvar *db-initializing* nil)
32 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
33 (declare (optimize (speed 3)))
34 (unless *db-deserializing*
35 (let* ((slot-name (%svuc-slot-name slot-def))
36 (slot-object (%svuc-slot-object slot-def class))
37 (slot-kind (view-class-slot-db-kind slot-object)))
38 (when (and (eql slot-kind :join)
39 (not (slot-boundp instance slot-name)))
40 (let ((*db-deserializing* t))
41 (if (view-database instance)
42 (setf (slot-value instance slot-name)
43 (fault-join-slot class instance slot-object))
44 (setf (slot-value instance slot-name) nil))))))
47 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
49 (declare (ignore new-value))
50 (let* ((slot-name (%svuc-slot-name slot-def))
51 (slot-object (%svuc-slot-object slot-def class))
52 (slot-kind (view-class-slot-db-kind slot-object)))
55 (when (and *db-auto-sync*
56 (not *db-initializing*)
57 (not *db-deserializing*)
58 (not (eql slot-kind :virtual)))
59 (update-record-from-slot instance slot-name)))))
61 (defmethod initialize-instance ((object standard-db-object)
62 &rest all-keys &key &allow-other-keys)
63 (declare (ignore all-keys))
64 (let ((*db-initializing* t))
66 (when (and *db-auto-sync*
67 (not *db-deserializing*))
68 (update-records-from-instance object))))
71 ;; Build the database tables required to store the given view class
74 (defun create-view-from-class (view-class-name
75 &key (database *default-database*)
77 "Creates a table as defined by the View Class VIEW-CLASS-NAME
78 in DATABASE which defaults to *DEFAULT-DATABASE*."
79 (let ((tclass (find-class view-class-name)))
81 (let ((*default-database* database))
82 (%install-class tclass database :transactions transactions))
83 (error "Class ~s not found." view-class-name)))
86 (defmethod %install-class ((self standard-db-class) database
87 &key (transactions t))
88 (let ((schemadef '()))
89 (dolist (slotdef (ordered-class-slots self))
90 (let ((res (database-generate-column-definition (class-name self)
93 (push res schemadef))))
95 (error "Class ~s has no :base slots" self))
96 (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
98 :transactions transactions
99 :constraints (database-pkey-constraint self database))
100 (push self (database-view-classes database)))
103 (defmethod database-pkey-constraint ((class standard-db-class) database)
104 (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
106 (convert-to-db-default-case
107 (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
108 (database-output-sql (view-table class) database)
109 (database-output-sql keylist database))
112 (defmethod database-generate-column-definition (class slotdef database)
113 (declare (ignore database class))
114 (when (member (view-class-slot-db-kind slotdef) '(:base :key))
116 (list (sql-expression :attribute (view-class-slot-column slotdef))
117 (specified-type slotdef))))
118 (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
119 (let ((const (view-class-slot-db-constraints slotdef)))
121 (setq cdef (append cdef (list const)))))
126 ;; Drop the tables which store the given view class
129 (defun drop-view-from-class (view-class-name &key (database *default-database*))
130 "Removes a table defined by the View Class VIEW-CLASS-NAME from
131 DATABASE which defaults to *DEFAULT-DATABASE*."
132 (let ((tclass (find-class view-class-name)))
134 (let ((*default-database* database))
135 (%uninstall-class tclass))
136 (error "Class ~s not found." view-class-name)))
139 (defun %uninstall-class (self &key (database *default-database*))
140 (drop-table (sql-expression :table (view-table self))
141 :if-does-not-exist :ignore
143 (setf (database-view-classes database)
144 (remove self (database-view-classes database))))
148 ;; List all known view classes
151 (defun list-classes (&key (test #'identity)
152 (root-class (find-class 'standard-db-object))
153 (database *default-database*))
154 "Returns a list of all the View Classes which are connected to
155 DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
156 from the class ROOT-CLASS and which satisfy the function TEST. By
157 default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
158 (flet ((find-superclass (class)
159 (member root-class (class-precedence-list class))))
160 (let ((view-classes (and database (database-view-classes database))))
162 (remove-if #'(lambda (c) (or (not (funcall test c))
163 (not (find-superclass c))))
167 ;; Define a new view class
170 (defmacro def-view-class (class supers slots &rest cl-options)
171 "Creates a View Class called CLASS whose slots SLOTS can map
172 onto the attributes of a table in a database. If SUPERS is nil
173 then the superclass of CLASS will be STANDARD-DB-OBJECT,
174 otherwise SUPERS is a list of superclasses for CLASS which must
175 include STANDARD-DB-OBJECT or a descendent of this class. The
176 syntax of DEFCLASS is extended through the addition of a class
177 option :base-table which defines the database table onto which
178 the View Class maps and which defaults to CLASS. The DEFCLASS
179 syntax is also extended through additional slot
180 options. The :db-kind slot option specifies the kind of DB
181 mapping which is performed for this slot and defaults to :base
182 which indicates that the slot maps to an ordinary column of the
183 database table. A :db-kind value of :key indicates that this slot
184 is a special kind of :base slot which maps onto a column which is
185 one of the unique keys for the database table, the value :join
186 indicates this slot represents a join onto another View Class
187 which contains View Class objects, and the value :virtual
188 indicates a standard CLOS slot which does not map onto columns of
189 the database table. If a slot is specified with :db-kind :join,
190 the slot option :db-info contains a list which specifies the
191 nature of the join. For slots of :db-kind :base or :key,
192 the :type slot option has a special interpretation such that Lisp
193 types, such as string, integer and float are automatically
194 converted into appropriate SQL types for the column onto which
195 the slot maps. This behaviour may be over-ridden using
196 the :db-type slot option which is a string specifying the
197 vendor-specific database type for this slot's column definition
198 in the database. The :column slot option specifies the name of
199 the SQL column which the slot maps onto, if :db-kind is
200 not :virtual, and defaults to the slot name. The :void-value slot
201 option specifies the value to store if the SQL value is NULL and
202 defaults to NIL. The :db-constraints slot option is a string
203 representing an SQL table constraint expression or a list of such
206 (defclass ,class ,supers ,slots
207 ,@(if (find :metaclass `,cl-options :key #'car)
209 (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
210 (finalize-inheritance (find-class ',class))
211 (find-class ',class)))
213 (defun keyslots-for-class (class)
214 (slot-value class 'key-slots))