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   (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)))))))
  56   (call-next-method))
  57
  58 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  59                                           instance slot-def)
  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)))
  64     (prog1
  65         (call-next-method)
  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)))))
  71
  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))
  76     (call-next-method)
  77     (when (and *db-auto-sync*
  78                (not *db-deserializing*))
  79       (update-records-from-instance object))))
  80
  81 ;;
  82 ;; Build the database tables required to store the given view class
  83 ;;
  84
  85 (defun create-view-from-class (view-class-name
  86                                &key (database *default-database*)
  87                                (transactions t))
  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)))
  91     (if tclass
  92         (let ((*default-database* database)
  93               (pclass (car (class-direct-superclasses tclass))))
  94           (when (and (normalizedp tclass) (not (table-exists-p (view-table 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)))
  99   (values))
 100
 101
 102 (defmethod %install-class ((self standard-db-class) database
 103                            &key (transactions t))
 104   (let ((schemadef '())
 105         (ordered-slots (if (normalizedp self)
 106                            (ordered-class-direct-slots self)
 107                            (ordered-class-slots self))))
 108     (dolist (slotdef ordered-slots)
 109       (let ((res (database-generate-column-definition (class-name self)
 110                                                       slotdef database)))
 111         (when res
 112           (push res schemadef))))
 113     (if (not schemadef)
 114         (unless (normalizedp self)
 115           (error "Class ~s has no :base slots" self))
 116         (progn
 117           (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
 118                         :database database
 119                         :transactions transactions
 120                         :constraints (database-pkey-constraint self database))
 121           (push self (database-view-classes database)))))
 122   t)
 123
 124 (defmethod database-pkey-constraint ((class standard-db-class) database)
 125   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))
 126         (table (view-table class)))
 127     (when keylist
 128       (etypecase table
 129         (string
 130          (format nil "CONSTRAINT \"~APK\" PRIMARY KEY~A" table
 131                  (sql-output keylist database)))
 132         ((or symbol sql-ident)
 133          (format nil "CONSTRAINT ~APK PRIMARY KEY~A" table
 134                  (sql-output keylist database)))))))
 135
 136 (defmethod database-generate-column-definition (class slotdef database)
 137   (declare (ignore database class))
 138   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 139     (let ((cdef
 140            (list (sql-expression :attribute (view-class-slot-column slotdef))
 141                  (specified-type slotdef))))
 142       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 143       (let ((const (view-class-slot-db-constraints slotdef)))
 144         (when const
 145           (setq cdef (append cdef (listify const)))))
 146       cdef)))
 147
 148
 149 ;;
 150 ;; Drop the tables which store the given view class
 151 ;;
 152
 153 (defun drop-view-from-class (view-class-name &key (database *default-database*)
 154                              (owner nil))
 155   "Removes a table defined by the View Class VIEW-CLASS-NAME from
 156 DATABASE which defaults to *DEFAULT-DATABASE*."
 157   (let ((tclass (find-class view-class-name)))
 158     (if tclass
 159         (let ((*default-database* database))
 160           (%uninstall-class tclass :owner owner))
 161         (error "Class ~s not found." view-class-name)))
 162   (values))
 163
 164 (defun %uninstall-class (self &key
 165                          (database *default-database*)
 166                          (owner nil))
 167   (drop-table (sql-expression :table (view-table self))
 168               :if-does-not-exist :ignore
 169               :database database
 170               :owner owner)
 171   (setf (database-view-classes database)
 172         (remove self (database-view-classes database))))
 173
 174
 175 ;;
 176 ;; List all known view classes
 177 ;;
 178
 179 (defun list-classes (&key (test #'identity)
 180                      (root-class (find-class 'standard-db-object))
 181                      (database *default-database*))
 182   "Returns a list of all the View Classes which are connected to
 183 DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
 184 from the class ROOT-CLASS and which satisfy the function TEST. By
 185 default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
 186   (flet ((find-superclass (class)
 187            (member root-class (class-precedence-list class))))
 188     (let ((view-classes (and database (database-view-classes database))))
 189       (when view-classes
 190         (remove-if #'(lambda (c) (or (not (funcall test c))
 191                                      (not (find-superclass c))))
 192                    view-classes)))))
 193
 194 ;;
 195 ;; Define a new view class
 196 ;;
 197
 198 (defmacro def-view-class (class supers slots &rest cl-options)
 199   "Creates a View Class called CLASS whose slots SLOTS can map
 200 onto the attributes of a table in a database. If SUPERS is nil
 201 then the superclass of CLASS will be STANDARD-DB-OBJECT,
 202 otherwise SUPERS is a list of superclasses for CLASS which must
 203 include STANDARD-DB-OBJECT or a descendent of this class. The
 204 syntax of DEFCLASS is extended through the addition of a class
 205 option :base-table which defines the database table onto which
 206 the View Class maps and which defaults to CLASS. The DEFCLASS
 207 syntax is also extended through additional slot
 208 options. The :db-kind slot option specifies the kind of DB
 209 mapping which is performed for this slot and defaults to :base
 210 which indicates that the slot maps to an ordinary column of the
 211 database table. A :db-kind value of :key indicates that this slot
 212 is a special kind of :base slot which maps onto a column which is
 213 one of the unique keys for the database table, the value :join
 214 indicates this slot represents a join onto another View Class
 215 which contains View Class objects, and the value :virtual
 216 indicates a standard CLOS slot which does not map onto columns of
 217 the database table. If a slot is specified with :db-kind :join,
 218 the slot option :db-info contains a list which specifies the
 219 nature of the join. For slots of :db-kind :base or :key,
 220 the :type slot option has a special interpretation such that Lisp
 221 types, such as string, integer and float are automatically
 222 converted into appropriate SQL types for the column onto which
 223 the slot maps. This behaviour may be over-ridden using
 224 the :db-type slot option which is a string specifying the
 225 vendor-specific database type for this slot's column definition
 226 in the database. The :column slot option specifies the name of
 227 the SQL column which the slot maps onto, if :db-kind is
 228 not :virtual, and defaults to the slot name. The :void-value slot
 229 option specifies the value to store if the SQL value is NULL and
 230 defaults to NIL. The :db-constraints slot option is a string
 231 representing an SQL table constraint expression or a list of such
 232 strings."
 233   `(progn
 234      (defclass ,class ,supers ,slots
 235        ,@(if (find :metaclass `,cl-options :key #'car)
 236              `,cl-options
 237              (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
 238      (finalize-inheritance (find-class ',class))
 239      (find-class ',class)))
 240
 241 (defun keyslots-for-class (class)
 242   (slot-value class 'key-slots))