sql/metaclasses.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; CLSQL metaclass for standard-db-objects created in the 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 (in-package #:clsql-sys)
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (when (>= (length (generic-function-lambda-list
  19                      (ensure-generic-function
  20                       'compute-effective-slot-definition)))
  21             3)
  22     (pushnew :kmr-normal-cesd cl:*features*))
  23
  24   (when (>= (length (generic-function-lambda-list
  25                      (ensure-generic-function
  26                       'direct-slot-definition-class)))
  27             3)
  28     (pushnew :kmr-normal-dsdc cl:*features*))
  29
  30   (when (>= (length (generic-function-lambda-list
  31                      (ensure-generic-function
  32                       'effective-slot-definition-class)))
  33             3)
  34     (pushnew :kmr-normal-esdc cl:*features*)))
  35
  36
  37 ;; ------------------------------------------------------------
  38 ;; metaclass: view-class
  39
  40 (defclass standard-db-class (standard-class)
  41   ((view-table
  42     :accessor view-table
  43     :initarg :view-table)
  44    (definition
  45     :accessor object-definition
  46     :initarg :definition
  47     :initform nil)
  48    (key-slots
  49     :accessor key-slots
  50     :initform nil)
  51    (class-qualifier
  52     :accessor view-class-qualifier
  53     :initarg :qualifier
  54     :initform nil))
  55   (:documentation "VIEW-CLASS metaclass."))
  56
  57 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
  58
  59 (defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
  60                                     :db-writer :db-type :db-info))
  61 (defconstant +extra-class-options+ '(:base-table))
  62
  63 (dolist (slot-option +extra-slot-options+)
  64   (process-slot-option standard-db-class slot-option))
  65
  66 (dolist (class-option +extra-class-options+)
  67   (process-class-option standard-db-class class-option))
  68
  69 (defmethod validate-superclass ((class standard-db-class)
  70                                 (superclass standard-class))
  71   t)
  72
  73 (defun table-name-from-arg (arg)
  74   (cond ((symbolp arg)
  75          arg)
  76         ((typep arg 'sql-ident)
  77          (slot-value arg 'name))
  78         ((stringp arg)
  79          (intern (symbol-name-default-case arg)))))
  80
  81 (defun column-name-from-arg (arg)
  82   (cond ((symbolp arg)
  83          arg)
  84         ((typep arg 'sql-ident)
  85          (slot-value arg 'name))
  86         ((stringp arg)
  87          (intern (symbol-name-default-case arg)))))
  88
  89
  90 (defun remove-keyword-arg (arglist akey)
  91   (let ((mylist arglist)
  92         (newlist ()))
  93     (labels ((pop-arg (alist)
  94              (let ((arg (pop alist))
  95                    (val (pop alist)))
  96                (unless (equal arg akey)
  97                  (setf newlist (append (list arg val) newlist)))
  98                (when alist (pop-arg alist)))))
  99       (pop-arg mylist))
 100     newlist))
 101
 102 (defmethod initialize-instance :around ((class standard-db-class)
 103                                         &rest all-keys
 104                                         &key direct-superclasses base-table
 105                                         qualifier
 106                                         &allow-other-keys)
 107   (let ((root-class (find-class 'standard-db-object nil))
 108         (vmc (find-class 'standard-db-class)))
 109     (setf (view-class-qualifier class)
 110           (car qualifier))
 111     (if root-class
 112         (if (member-if #'(lambda (super)
 113                            (eq (class-of super) vmc)) direct-superclasses)
 114             (call-next-method)
 115             (apply #'call-next-method
 116                    class
 117                    :direct-superclasses (append (list root-class)
 118                                                 direct-superclasses)
 119                    (remove-keyword-arg all-keys :direct-superclasses)))
 120         (call-next-method))
 121     (setf (view-table class)
 122           (table-name-from-arg (sql-escape (or (and base-table
 123                                                     (if (listp base-table)
 124                                                         (car base-table)
 125                                                         base-table))
 126                                                (class-name class)))))
 127     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 128                                    all-keys))))
 129
 130 (defmethod reinitialize-instance :around ((class standard-db-class)
 131                                           &rest all-keys
 132                                           &key base-table
 133                                           direct-superclasses qualifier
 134                                           &allow-other-keys)
 135   (let ((root-class (find-class 'standard-db-object nil))
 136         (vmc (find-class 'standard-db-class)))
 137     (setf (view-table class)
 138           (table-name-from-arg (sql-escape (or (and base-table
 139                                                     (if (listp base-table)
 140                                                         (car base-table)
 141                                                         base-table))
 142                                                (class-name class)))))
 143     (setf (view-class-qualifier class)
 144           (car qualifier))
 145     (if (and root-class (not (equal class root-class)))
 146         (if (member-if #'(lambda (super)
 147                            (eq (class-of super) vmc)) direct-superclasses)
 148             (call-next-method)
 149             (apply #'call-next-method
 150                    class
 151                    :direct-superclasses (append (list root-class)
 152                                                 direct-superclasses)
 153                    (remove-keyword-arg all-keys :direct-superclasses)))
 154         (call-next-method)))
 155   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 156                                  all-keys)))
 157
 158
 159 (defun get-keywords (keys list)
 160   (flet ((extract (key)
 161            (let ((pos (position key list)))
 162              (when pos
 163                (nth (1+ pos) list)))))
 164     (mapcar #'extract keys)))
 165
 166 (defun describe-db-layout (class)
 167   (flet ((not-db-col (col)
 168            (not (member (nth 2 col)  '(nil :base :key))))
 169          (frob-slot (slot)
 170            (let ((type (slot-value slot 'type)))
 171              (if (eq type t)
 172                  (setq type nil))
 173              (list (slot-value slot 'name)
 174                    type
 175                    (slot-value slot 'db-kind)
 176                    (and (slot-boundp slot 'column)
 177                         (slot-value slot 'column))))))
 178     (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))
 179       (setq all-slots (remove-if #'not-db-col all-slots))
 180       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 181       ;;(mapcar #'dink-type all-slots)
 182       all-slots)))
 183
 184 (defun register-metaclass (class slots)
 185   (labels ((not-db-col (col)
 186              (not (member (nth 2 col)  '(nil :base :key))))
 187            (frob-slot (slot)
 188              (get-keywords '(:name :type :db-kind :column) slot)))
 189     (let ((all-slots (mapcar #'frob-slot slots)))
 190       (setq all-slots (remove-if #'not-db-col all-slots))
 191       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 192       (setf (object-definition class) all-slots))
 193     #-(or allegro openmcl)
 194     (setf (key-slots class) (remove-if-not (lambda (slot)
 195                                              (eql (slot-value slot 'db-kind)
 196                                                   :key))
 197                                            (ordered-class-slots class)))))
 198
 199 #+(or allegro openmcl)
 200 (defmethod finalize-inheritance :after ((class standard-db-class))
 201   ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
 202   ;; for standard-db-class
 203   #+openmcl
 204   (mapcar
 205    #'(lambda (s)
 206        (if (eq 'ccl:false (slot-value s 'ccl::type-predicate))
 207            (setf (slot-value s 'ccl::type-predicate) 'ccl:true)))
 208    (class-slots class))
 209
 210   (setf (key-slots class) (remove-if-not (lambda (slot)
 211                                            (eql (slot-value slot 'db-kind)
 212                                                 :key))
 213                                          (ordered-class-slots class))))
 214
 215 ;; return the deepest view-class ancestor for a given view class
 216
 217 (defun base-db-class (classname)
 218   (let* ((class (find-class classname))
 219          (db-class (find-class 'standard-db-object)))
 220     (loop
 221      (let ((cds (class-direct-superclasses class)))
 222        (cond ((null cds)
 223               (error "not a db class"))
 224              ((member db-class cds)
 225               (return (class-name class))))
 226        (setq class (car cds))))))
 227
 228 (defun db-ancestors (classname)
 229   (let ((class (find-class classname))
 230         (db-class (find-class 'standard-db-object)))
 231     (labels ((ancestors (class)
 232              (let ((scs (class-direct-superclasses class)))
 233                (if (member db-class scs)
 234                    (list class)
 235                    (append (list class) (mapcar #'ancestors scs))))))
 236       (ancestors class))))
 237
 238 (defclass view-class-slot-definition-mixin ()
 239   ((column
 240     :accessor view-class-slot-column
 241     :initarg :column
 242     :documentation
 243     "The name of the SQL column this slot is stored in.  Defaults to
 244 the slot name.")
 245    (db-kind
 246     :accessor view-class-slot-db-kind
 247     :initarg :db-kind
 248     :initform :base
 249     :type keyword
 250     :documentation
 251     "The kind of DB mapping which is performed for this slot.  :base
 252 indicates the slot maps to an ordinary column of the DB view.  :key
 253 indicates that this slot corresponds to part of the unique keys for
 254 this view, :join indicates ... and :virtual indicates that this slot
 255 is an ordinary CLOS slot.  Defaults to :base.")
 256    (db-reader
 257     :accessor view-class-slot-db-reader
 258     :initarg :db-reader
 259     :initform nil
 260     :documentation
 261     "If a string, then when reading values from the DB, the string
 262 will be used for a format string, with the only value being the value
 263 from the database.  The resulting string will be used as the slot
 264 value.  If a function then it will take one argument, the value from
 265 the database, and return the value that should be put into the slot.")
 266    (db-writer
 267     :accessor view-class-slot-db-writer
 268     :initarg :db-writer
 269     :initform nil
 270     :documentation
 271     "If a string, then when reading values from the slot for the DB,
 272 the string will be used for a format string, with the only value being
 273 the value of the slot.  The resulting string will be used as the
 274 column value in the DB.  If a function then it will take one argument,
 275 the value of the slot, and return the value that should be put into
 276 the database.")
 277    (db-type
 278     :accessor view-class-slot-db-type
 279     :initarg :db-type
 280     :initform nil
 281     :documentation
 282     "A string which will be used as the type specifier for this slots
 283 column definition in the database.")
 284    (db-constraints
 285     :accessor view-class-slot-db-constraints
 286     :initarg :db-constraints
 287     :initform nil
 288     :documentation
 289     "A single constraint or list of constraints for this column")
 290    (nulls-ok
 291     :accessor view-class-slot-nulls-ok
 292     :initarg :nulls-ok
 293     :initform nil
 294     :documentation
 295     "If t, all sql NULL values retrieved from the database become nil; if nil,
 296 all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 297    (db-info
 298     :accessor view-class-slot-db-info
 299     :initarg :db-info
 300     :documentation "Description of the join.")
 301    (specified-type
 302     :accessor specified-type
 303     :initform nil
 304     :documentation "KMR: Internal slot storing the :type specified by user.")))
 305
 306 (defparameter *db-info-lambda-list*
 307   '(&key join-class
 308          home-key
 309          foreign-key
 310          (key-join nil)
 311          (target-slot nil)
 312          (retrieval :immmediate)
 313          (set nil)))
 314
 315 (defun parse-db-info (db-info-list)
 316   (destructuring-bind
 317         (&key join-class home-key key-join foreign-key (delete-rule nil)
 318               (target-slot nil) (retrieval :deferred) (set nil))
 319       db-info-list
 320     (let ((ih (make-hash-table :size 6)))
 321       (if join-class
 322           (setf (gethash :join-class ih) join-class)
 323           (error "Must specify :join-class in :db-info"))
 324       (if home-key
 325           (setf (gethash :home-key ih) home-key)
 326           (error "Must specify :home-key in :db-info"))
 327       (when delete-rule
 328         (setf (gethash :delete-rule ih) delete-rule))
 329       (if foreign-key
 330           (setf (gethash :foreign-key ih) foreign-key)
 331           (error "Must specify :foreign-key in :db-info"))
 332       (when key-join
 333         (setf (gethash :key-join ih) t))
 334       (when target-slot
 335         (setf (gethash :target-slot ih) target-slot))
 336       (when set
 337         (setf (gethash :set ih) set))
 338       (when retrieval
 339         (progn
 340           (setf (gethash :retrieval ih) retrieval)
 341           (if (eql retrieval :immediate)
 342               (setf (gethash :set ih) nil))))
 343       ih)))
 344
 345 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 346                                              standard-direct-slot-definition)
 347   ())
 348
 349 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 350                                                 standard-effective-slot-definition)
 351   ())
 352
 353 (defmethod direct-slot-definition-class ((class standard-db-class)
 354                                          #+kmr-normal-dsdc &rest
 355                                          initargs)
 356   (declare (ignore initargs))
 357   (find-class 'view-class-direct-slot-definition))
 358
 359 (defmethod effective-slot-definition-class ((class standard-db-class)
 360                                             #+kmr-normal-esdc &rest
 361                                             initargs)
 362   (declare (ignore initargs))
 363   (find-class 'view-class-effective-slot-definition))
 364
 365 #+openmcl
 366 (defun compute-class-precedence-list (class)
 367   ;; safe to call this in openmcl
 368   (class-precedence-list class))
 369
 370 #-(or sbcl cmu)
 371 (defmethod compute-slots ((class standard-db-class))
 372   "Need to sort order of class slots so they are the same across
 373 implementations."
 374   (let ((slots (call-next-method))
 375         desired-sequence
 376         output-slots)
 377     (dolist (c (compute-class-precedence-list class))
 378       (dolist (s (class-direct-slots c))
 379         (let ((name (slot-definition-name s)))
 380           (unless (find name desired-sequence)
 381             (push name desired-sequence)))))
 382     (dolist (desired desired-sequence)
 383       (let ((slot (find desired slots :key #'slot-definition-name)))
 384         (assert slot)
 385         (push slot output-slots)))
 386     output-slots))
 387
 388 (defun compute-lisp-type-from-slot-specification (slotd specified-type)
 389   "Computes the Lisp type for a user-specified type. Needed for OpenMCL
 390 which does type checking before storing a value in a slot."
 391   #-openmcl (declare (ignore slotd))
 392   ;; This function is called after the base compute-effective-slots is called.
 393   ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
 394   ;; so we have to override the type-predicates here
 395   (cond
 396     ((consp specified-type)
 397      (cond
 398        ((and (symbolp (car specified-type))
 399              (string-equal (symbol-name (car specified-type)) "string"))
 400         #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp)
 401         'string)
 402        (t
 403         #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 404         specified-type)))
 405     #+openmcl
 406     ((null specified-type)
 407      ;; setting this here is not enough since openmcl later sets the
 408      ;; type-predicate to ccl:false. So, have to check slots again
 409      ;; in finalize-inheritance
 410      #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 411      t)
 412     (t
 413      ;; This can be improved for OpenMCL to set a more specific type
 414      ;; predicate based on the value specified-type
 415      #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 416      specified-type)))
 417
 418 ;; Compute the slot definition for slots in a view-class.  Figures out
 419 ;; what kind of database value (if any) is stored there, generates and
 420 ;; verifies the column name.
 421
 422 (defmethod compute-effective-slot-definition ((class standard-db-class)
 423                                               #+kmr-normal-cesd slot-name
 424                                               direct-slots)
 425   #+kmr-normal-cesd (declare (ignore slot-name))
 426
 427   (let ((slotd (call-next-method))
 428         (sd (car direct-slots)))
 429
 430     (typecase sd
 431       (view-class-slot-definition-mixin
 432        ;; Use the specified :column argument if it is supplied, otherwise
 433        ;; the column slot is filled in with the slot-name,  but transformed
 434        ;; to be sql safe, - to _ and such.
 435        (setf (slot-value slotd 'column)
 436              (column-name-from-arg
 437               (if (slot-boundp sd 'column)
 438                   (view-class-slot-column sd)
 439                   (column-name-from-arg
 440                    (sql-escape (slot-definition-name sd))))))
 441
 442        (setf (slot-value slotd 'db-type)
 443              (when (slot-boundp sd 'db-type)
 444                (view-class-slot-db-type sd)))
 445
 446        (setf (slot-value slotd 'nulls-ok)
 447              (view-class-slot-nulls-ok sd))
 448
 449        ;; :db-kind slot value defaults to :base (store slot value in
 450        ;; database)
 451
 452        (setf (slot-value slotd 'db-kind)
 453              (if (slot-boundp sd 'db-kind)
 454                  (view-class-slot-db-kind sd)
 455                  :base))
 456
 457        (setf (slot-value slotd 'db-writer)
 458              (when (slot-boundp sd 'db-writer)
 459                (view-class-slot-db-writer sd)))
 460        (setf (slot-value slotd 'db-constraints)
 461              (when (slot-boundp sd 'db-constraints)
 462                (view-class-slot-db-constraints sd)))
 463
 464        ;; I wonder if this slot option and the previous could be merged,
 465        ;; so that :base and :key remain keyword options, but :db-kind
 466        ;; :join becomes :db-kind (:join <db info .... >)?
 467
 468        (setf (slot-value slotd 'db-info)
 469              (when (slot-boundp sd 'db-info)
 470                (if (listp (view-class-slot-db-info sd))
 471                    (parse-db-info (view-class-slot-db-info sd))
 472                    (view-class-slot-db-info sd))))
 473
 474        ;; KMR: store the user-specified type and then compute
 475        ;; real Lisp type and store it
 476        (setf (specified-type slotd)
 477              (slot-definition-type slotd))
 478        (setf (slot-value slotd 'type)
 479              (compute-lisp-type-from-slot-specification
 480               slotd (slot-definition-type slotd)))
 481        )
 482       ;; all other slots
 483       (t
 484        (change-class slotd 'view-class-effective-slot-definition
 485                      #+allegro :name
 486                      #+allegro (slot-definition-name sd))
 487        (setf (slot-value slotd 'column)
 488              (column-name-from-arg
 489               (sql-escape (slot-definition-name sd))))
 490
 491        (setf (slot-value slotd 'db-info) nil)
 492        (setf (slot-value slotd 'db-kind)
 493              :virtual)))
 494     slotd))
 495
 496 (defun slotdefs-for-slots-with-class (slots class)
 497   (let ((result nil))
 498     (dolist (s slots)
 499       (let ((c (slotdef-for-slot-with-class s class)))
 500         (if c (setf result (cons c result)))))
 501     result))
 502
 503 (defun slotdef-for-slot-with-class (slot class)
 504   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 505            (class-slots class)))
 506
 507 #+ignore
 508 (eval-when (:compile-toplevel :load-toplevel :execute)
 509   #+kmr-normal-cesd
 510   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 511   #+kmr-normal-dsdc
 512   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 513   #+kmr-normal-esdc
 514   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 515   )