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