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