sql/ooddl.lisp

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