sql/ooddl.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
   5 ;;;;
   6 ;;;; This file is part of CLSQL.
   7 ;;;;
   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 ;;;; *************************************************************************
  12
  13
  14 (in-package #:clsql-sys)
  15
  16 (defclass standard-db-object ()
  17   ((view-database :initform nil :initarg :view-database :reader view-database
  18                   :db-kind :virtual))
  19   (:metaclass standard-db-class)
  20   (:documentation "Superclass for all CLSQL View Classes."))
  21
  22 (defparameter *default-string-length* 255
  23   "The length of a string which does not have a user-specified length.")
  24
  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.")
  29
  30 (defvar *db-deserializing* nil)
  31 (defvar *db-initializing* nil)
  32
  33 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  34   "When a slot is unbound but should contain a join object or a value from a
  35    normalized view-class, then retrieve and set those slots, so the value can
  36    be returned"
  37   (declare (optimize (speed 3)))
  38   (unless *db-deserializing*
  39     (let* ((slot-name (%svuc-slot-name slot-def))
  40            (slot-object (%svuc-slot-object slot-def class)))
  41       (unless (slot-boundp instance slot-name)
  42         (let ((*db-deserializing* t))
  43           (cond
  44             ((join-slot-p slot-def)
  45              (setf (slot-value instance slot-name)
  46                    (if (view-database instance)
  47                        (fault-join-slot class instance slot-object)
  48                        ;; TODO: you could in theory get a join object even if
  49                        ;; its joined-to object was not in the database
  50                        nil
  51                        )))
  52             ((not-direct-normalized-slot-p class slot-def)
  53              (if (view-database instance)
  54                  (update-fault-join-normalized-slot class instance slot-def)
  55                  (setf (slot-value instance slot-name) nil))))))))
  56   (call-next-method))
  57
  58 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  59                                           instance slot-def)
  60   "Handle auto syncing values to the database if *db-auto-sync* is t"
  61   (declare (ignore new-value))
  62   (let* ((slot-name (%svuc-slot-name slot-def))
  63          (slot-object (%svuc-slot-object slot-def class))
  64          (slot-kind (view-class-slot-db-kind slot-object)))
  65     (prog1
  66         (call-next-method)
  67       (when (and *db-auto-sync*
  68                  (not *db-initializing*)
  69                  (not *db-deserializing*)
  70                  (not (eql slot-kind :virtual)))
  71         (update-record-from-slot instance slot-name)))))
  72
  73 (defmethod initialize-instance ((object standard-db-object)
  74                                 &rest all-keys &key &allow-other-keys)
  75   (declare (ignore all-keys))
  76   (let ((*db-initializing* t))
  77     (call-next-method)
  78     (when (and *db-auto-sync*
  79                (not *db-deserializing*))
  80       (update-records-from-instance object))))
  81
  82 ;;
  83 ;; Build the database tables required to store the given view class
  84 ;;
  85
  86 (defun create-view-from-class (view-class-name
  87                                &key (database *default-database*)
  88                                (transactions t))
  89   "Creates a table as defined by the View Class VIEW-CLASS-NAME
  90 in DATABASE which defaults to *DEFAULT-DATABASE*."
  91   (let ((tclass (find-class view-class-name)))
  92     (if tclass
  93         (let ((*default-database* database)
  94               (pclass (car (class-direct-superclasses tclass))))
  95           (when (and (normalizedp tclass) (not (table-exists-p pclass)))
  96             (create-view-from-class (class-name pclass)
  97                                     :database database :transactions transactions))
  98           (%install-class tclass database :transactions transactions))
  99         (error "Class ~s not found." view-class-name)))
 100   (values))
 101
 102 (defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
 103   (declare (ignore database))
 104   (or (intersection
 105        +auto-increment-names+
 106        (listify (view-class-slot-db-constraints slotdef)))
 107       (slot-value slotdef 'autoincrement-sequence)))
 108
 109 (defmethod %install-class ((self standard-db-class) database
 110                            &key (transactions t))
 111   (let ((schemadef '())
 112         (ordered-slots (slots-for-possibly-normalized-class self)))
 113     (dolist (slotdef ordered-slots)
 114       (let ((res (database-generate-column-definition self slotdef database)))
 115         (when res
 116           (push res schemadef))))
 117     (if (not schemadef)
 118         (unless (normalizedp self)
 119           (error "Class ~s has no :base slots" self))
 120         (progn
 121           (database-add-autoincrement-sequence self database)
 122           (create-table (sql-expression :table (database-identifier self database))
 123                         (nreverse schemadef)
 124                         :database database
 125                         :transactions transactions
 126                         :constraints (database-pkey-constraint self database))
 127           (push self (database-view-classes database)))))
 128   t)
 129
 130 (defmethod database-pkey-constraint ((class standard-db-class) database)
 131   ;; Keylist will always be a list of escaped-indentifier
 132   (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database))
 133                          (keyslots-for-class class)))
 134         (table (escaped (combine-database-identifiers
 135                          (list class 'PK)
 136                          database))))
 137     (when keylist
 138       (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table
 139               keylist))))
 140
 141 (defmethod database-generate-column-definition (class slotdef database)
 142   (declare (ignore class))
 143   (when (key-or-base-slot-p slotdef)
 144     (let ((cdef
 145            (list (sql-expression :attribute (database-identifier slotdef database))
 146                  (specified-type slotdef))))
 147       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 148       (let ((const (view-class-slot-db-constraints slotdef)))
 149         (when const
 150           (setq cdef (append cdef (listify const)))))
 151       cdef)))
 152
 153
 154 ;;
 155 ;; Drop the tables which store the given view class
 156 ;;
 157
 158 (defun drop-view-from-class (view-class-name &key (database *default-database*)
 159                              (owner nil))
 160   "Removes a table defined by the View Class VIEW-CLASS-NAME from
 161 DATABASE which defaults to *DEFAULT-DATABASE*."
 162   (let ((tclass (find-class view-class-name)))
 163     (if tclass
 164         (let ((*default-database* database))
 165           (%uninstall-class tclass :owner owner))
 166         (error "Class ~s not found." view-class-name)))
 167   (values))
 168
 169 (defun %uninstall-class (self &key
 170                          (database *default-database*)
 171                          (owner nil))
 172   (drop-table (sql-expression :table (database-identifier self database))
 173               :if-does-not-exist :ignore
 174               :database database
 175               :owner owner)
 176   (database-remove-autoincrement-sequence self database)
 177   (setf (database-view-classes database)
 178         (remove self (database-view-classes database))))
 179
 180
 181 ;;
 182 ;; List all known view classes
 183 ;;
 184
 185 (defun list-classes (&key (test #'identity)
 186                      (root-class (find-class 'standard-db-object))
 187                      (database *default-database*))
 188   "Returns a list of all the View Classes which are connected to
 189 DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
 190 from the class ROOT-CLASS and which satisfy the function TEST. By
 191 default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
 192   (flet ((find-superclass (class)
 193            (member root-class (class-precedence-list class))))
 194     (let ((view-classes (and database (database-view-classes database))))
 195       (when view-classes
 196         (remove-if #'(lambda (c) (or (not (funcall test c))
 197                                      (not (find-superclass c))))
 198                    view-classes)))))
 199
 200 ;;
 201 ;; Define a new view class
 202 ;;
 203
 204 (defmacro def-view-class (class supers slots &rest cl-options)
 205   "Creates a View Class called CLASS whose slots SLOTS can map
 206 onto the attributes of a table in a database. If SUPERS is nil
 207 then the superclass of CLASS will be STANDARD-DB-OBJECT,
 208 otherwise SUPERS is a list of superclasses for CLASS which must
 209 include STANDARD-DB-OBJECT or a descendent of this class. The
 210 syntax of DEFCLASS is extended through the addition of a class
 211 option :base-table which defines the database table onto which
 212 the View Class maps and which defaults to CLASS. The DEFCLASS
 213 syntax is also extended through additional slot
 214 options. The :db-kind slot option specifies the kind of DB
 215 mapping which is performed for this slot and defaults to :base
 216 which indicates that the slot maps to an ordinary column of the
 217 database table. A :db-kind value of :key indicates that this slot
 218 is a special kind of :base slot which maps onto a column which is
 219 one of the unique keys for the database table, the value :join
 220 indicates this slot represents a join onto another View Class
 221 which contains View Class objects, and the value :virtual
 222 indicates a standard CLOS slot which does not map onto columns of
 223 the database table. If a slot is specified with :db-kind :join,
 224 the slot option :db-info contains a list which specifies the
 225 nature of the join. For slots of :db-kind :base or :key,
 226 the :type slot option has a special interpretation such that Lisp
 227 types, such as string, integer and float are automatically
 228 converted into appropriate SQL types for the column onto which
 229 the slot maps. This behaviour may be over-ridden using
 230 the :db-type slot option which is a string specifying the
 231 vendor-specific database type for this slot's column definition
 232 in the database. The :column slot option specifies the name of
 233 the SQL column which the slot maps onto, if :db-kind is
 234 not :virtual, and defaults to the slot name. The :void-value slot
 235 option specifies the value to store if the SQL value is NULL and
 236 defaults to NIL. The :db-constraints slot option is a string
 237 representing an SQL table constraint expression or a list of such
 238 strings."
 239   `(progn
 240      (defclass ,class ,supers ,slots
 241        ,@(if (find :metaclass `,cl-options :key #'car)
 242              `,cl-options
 243              (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
 244      (finalize-inheritance (find-class ',class))
 245      (find-class ',class)))
 246
 247 (defun keyslots-for-class (class)
 248   (slot-value class 'key-slots))