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