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    (version
  49     :accessor object-version
  50     :initarg :version
  51     :initform 0)
  52    (key-slots
  53     :accessor key-slots
  54     :initform nil)
  55    (class-qualifier
  56     :accessor view-class-qualifier
  57     :initarg :qualifier
  58     :initform nil))
  59   (:documentation "VIEW-CLASS metaclass."))
  60
  61 #+lispworks
  62 (defmacro push-on-end (value location)
  63   `(setf ,location (nconc ,location (list ,value))))
  64
  65 ;; As Heiko Kirscke (author of PLOB!) would say:  !@##^@%! Lispworks!
  66 #+lispworks
  67 (defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
  68                                     :db-writer :db-type :db-info))
  69
  70 #+lispworks
  71 (define-setf-expander assoc (key alist &environment env)
  72   (multiple-value-bind (temps vals stores store-form access-form)
  73       (get-setf-expansion alist env)
  74     (let ((new-value (gensym "NEW-VALUE-"))
  75           (keyed (gensym "KEYED-"))
  76           (accessed (gensym "ACCESSED-"))
  77           (store-new-value (car stores)))
  78       (values (cons keyed temps)
  79               (cons key vals)
  80               `(,new-value)
  81               `(let* ((,accessed ,access-form)
  82                       (,store-new-value (assoc ,keyed ,accessed)))
  83                 (if ,store-new-value
  84                     (rplacd ,store-new-value ,new-value)
  85                     (progn
  86                       (setq ,store-new-value
  87                             (acons ,keyed ,new-value ,accessed))
  88                       ,store-form))
  89                 ,new-value)
  90               `(assoc ,new-value ,access-form)))))
  91
  92 #+lispworks
  93 (defmethod clos::canonicalize-defclass-slot :around
  94   ((prototype standard-db-class) slot)
  95  "\\lw\\ signals an error on unknown slot options; so this method
  96 removes any extra allowed options before calling the default method
  97 and returns the canonicalized extra options concatenated to the result
  98 of the default method.  The extra allowed options are the value of the
  99 \\fcite{+extra-slot-options+}."
 100   (let ((extra-slot-options ())
 101         (rest-options ())
 102         (result ()))
 103     (do ((olist (cdr slot) (cddr olist)))
 104         ((null olist))
 105       (let ((option (car olist)))
 106         (cond
 107          ((find option +extra-slot-options+)
 108           ;;(push (cons option (cadr olist)) extra-slot-options))
 109           (setf (assoc option extra-slot-options) (cadr olist)))
 110          (t
 111           (push (cadr olist) rest-options)
 112           (push (car olist) rest-options)))))
 113     (setf result (call-next-method prototype (cons (car slot) rest-options)))
 114     (dolist (option extra-slot-options)
 115       (push-on-end (car option) result)
 116       (push-on-end `(quote ,(cdr option)) result))
 117     result))
 118
 119 #+lispworks
 120 (defconstant +extra-class-options+ '(:base-table :version :schemas))
 121
 122 #+lispworks
 123 (defmethod clos::canonicalize-class-options :around
 124     ((prototype standard-db-class) class-options)
 125   "\\lw\\ signals an error on unknown class options; so this method
 126 removes any extra allowed options before calling the default method
 127 and returns the canonicalized extra options concatenated to the result
 128 of the default method.  The extra allowed options are the value of the
 129 \\fcite{+extra-class-options+}."
 130   (let ((extra-class-options nil)
 131         (rest-options ())
 132         (result ()))
 133     (dolist (o class-options)
 134       (let ((option (car o)))
 135         (cond
 136          ((find option +extra-class-options+)
 137           ;;(push (cons option (cadr o)) extra-class-options))
 138           (setf (assoc option extra-class-options) (cadr o)))
 139          (t
 140           (push o rest-options)))))
 141     (setf result (call-next-method prototype rest-options))
 142     (dolist (option extra-class-options)
 143       (push-on-end (car option) result)
 144       (push-on-end `(quote ,(cdr option)) result))
 145     result))
 146
 147
 148 (defmethod validate-superclass ((class standard-db-class)
 149                                 (superclass standard-class))
 150   t)
 151
 152 (defun table-name-from-arg (arg)
 153   (cond ((symbolp arg)
 154          arg)
 155         ((typep arg 'sql-ident)
 156          (slot-value arg 'name))
 157         ((stringp arg)
 158          (intern (string-upcase arg)))))
 159
 160 (defun column-name-from-arg (arg)
 161   (cond ((symbolp arg)
 162          arg)
 163         ((typep arg 'sql-ident)
 164          (slot-value arg 'name))
 165         ((stringp arg)
 166          (intern (string-upcase arg)))))
 167
 168
 169 (defun remove-keyword-arg (arglist akey)
 170   (let ((mylist arglist)
 171         (newlist ()))
 172     (labels ((pop-arg (alist)
 173              (let ((arg (pop alist))
 174                    (val (pop alist)))
 175                (unless (equal arg akey)
 176                  (setf newlist (append (list arg val) newlist)))
 177                (when alist (pop-arg alist)))))
 178       (pop-arg mylist))
 179     newlist))
 180
 181 (defmethod initialize-instance :around ((class standard-db-class)
 182                                         &rest all-keys
 183                                         &key direct-superclasses base-table
 184                                         schemas version qualifier
 185                                         &allow-other-keys)
 186   (let ((root-class (find-class 'standard-db-object nil))
 187         (vmc (find-class 'standard-db-class)))
 188     (setf (view-class-qualifier class)
 189           (car qualifier))
 190     (if root-class
 191         (if (member-if #'(lambda (super)
 192                            (eq (class-of super) vmc)) direct-superclasses)
 193             (call-next-method)
 194             (apply #'call-next-method
 195                    class
 196                    :direct-superclasses (append (list root-class)
 197                                                 direct-superclasses)
 198                    (remove-keyword-arg all-keys :direct-superclasses)))
 199         (call-next-method))
 200     (setf (view-table class)
 201           (table-name-from-arg (sql-escape (or (and base-table
 202                                                     (if (listp base-table)
 203                                                         (car base-table)
 204                                                         base-table))
 205                                                (class-name class)))))
 206     (setf (object-version class) version)
 207     (mapc (lambda (schema)
 208             (pushnew (class-name class) (gethash schema *object-schemas*)))
 209           (if (listp schemas) schemas (list schemas)))
 210     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 211                                    all-keys))))
 212
 213 (defmethod reinitialize-instance :around ((class standard-db-class)
 214                                           &rest all-keys
 215                                           &key base-table schemas version
 216                                           direct-superclasses qualifier
 217                                           &allow-other-keys)
 218   (let ((root-class (find-class 'standard-db-object nil))
 219         (vmc (find-class 'standard-db-class)))
 220     (setf (view-table class)
 221           (table-name-from-arg (sql-escape (or (and base-table
 222                                                     (if (listp base-table)
 223                                                         (car base-table)
 224                                                         base-table))
 225                                                (class-name class)))))
 226     (setf (view-class-qualifier class)
 227           (car qualifier))
 228     (if (and root-class (not (equal class root-class)))
 229         (if (member-if #'(lambda (super)
 230                            (eq (class-of super) vmc)) direct-superclasses)
 231             (call-next-method)
 232             (apply #'call-next-method
 233                    class
 234                    :direct-superclasses (append (list root-class)
 235                                                 direct-superclasses)
 236                    (remove-keyword-arg all-keys :direct-superclasses)))
 237         (call-next-method)))
 238   (setf (object-version class) version)
 239   (mapc (lambda (schema)
 240           (pushnew (class-name class) (gethash schema *object-schemas*)))
 241         (if (listp schemas) schemas (list schemas)))
 242   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 243                                  all-keys)))
 244
 245
 246 (defun get-keywords (keys list)
 247   (flet ((extract (key)
 248            (let ((pos (position key list)))
 249              (when pos
 250                (nth (1+ pos) list)))))
 251     (mapcar #'extract keys)))
 252
 253 (defun describe-db-layout (class)
 254   (flet ((not-db-col (col)
 255            (not (member (nth 2 col)  '(nil :base :key))))
 256          (frob-slot (slot)
 257            (let ((type (slot-value slot 'type)))
 258              (if (eq type t)
 259                  (setq type nil))
 260              (list (slot-value slot 'name)
 261                    type
 262                    (slot-value slot 'db-kind)
 263                    (and (slot-boundp slot 'column)
 264                         (slot-value slot 'column))))))
 265     (let ((all-slots (mapcar #'frob-slot (class-slots class))))
 266       (setq all-slots (remove-if #'not-db-col all-slots))
 267       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 268       ;;(mapcar #'dink-type all-slots)
 269       all-slots)))
 270
 271 (defun register-metaclass (class slots)
 272   (labels ((not-db-col (col)
 273              (not (member (nth 2 col)  '(nil :base :key))))
 274            (frob-slot (slot)
 275              (get-keywords '(:name :type :db-kind :column) slot)))
 276     (let ((all-slots (mapcar #'frob-slot slots)))
 277       (setq all-slots (remove-if #'not-db-col all-slots))
 278       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 279       (setf (object-definition class) all-slots))
 280     #-(or allegro openmcl)
 281     (setf (key-slots class) (remove-if-not (lambda (slot)
 282                                              (eql (slot-value slot 'db-kind)
 283                                                   :key))
 284                                            (class-slots class)))))
 285
 286 #+(or allegro openmcl)
 287 (defmethod finalize-inheritance :after ((class standard-db-class))
 288   (setf (key-slots class) (remove-if-not (lambda (slot)
 289                                            (eql (slot-value slot 'db-kind)
 290                                                 :key))
 291                                          (class-slots class))))
 292
 293 ;; return the deepest view-class ancestor for a given view class
 294
 295 (defun base-db-class (classname)
 296   (let* ((class (find-class classname))
 297          (db-class (find-class 'standard-db-object)))
 298     (loop
 299      (let ((cds (class-direct-superclasses class)))
 300        (cond ((null cds)
 301               (error "not a db class"))
 302              ((member db-class cds)
 303               (return (class-name class))))
 304        (setq class (car cds))))))
 305
 306 (defun db-ancestors (classname)
 307   (let ((class (find-class classname))
 308         (db-class (find-class 'standard-db-object)))
 309     (labels ((ancestors (class)
 310              (let ((scs (class-direct-superclasses class)))
 311                (if (member db-class scs)
 312                    (list class)
 313                    (append (list class) (mapcar #'ancestors scs))))))
 314       (ancestors class))))
 315
 316 (defclass view-class-slot-definition-mixin ()
 317   ((column
 318     :accessor view-class-slot-column
 319     :initarg :column
 320     :documentation
 321     "The name of the SQL column this slot is stored in.  Defaults to
 322 the slot name.")
 323    (db-kind
 324     :accessor view-class-slot-db-kind
 325     :initarg :db-kind
 326     :initform :base
 327     :type keyword
 328     :documentation
 329     "The kind of DB mapping which is performed for this slot.  :base
 330 indicates the slot maps to an ordinary column of the DB view.  :key
 331 indicates that this slot corresponds to part of the unique keys for
 332 this view, :join indicates ... and :virtual indicates that this slot
 333 is an ordinary CLOS slot.  Defaults to :base.")
 334    (db-reader
 335     :accessor view-class-slot-db-reader
 336     :initarg :db-reader
 337     :initform nil
 338     :documentation
 339     "If a string, then when reading values from the DB, the string
 340 will be used for a format string, with the only value being the value
 341 from the database.  The resulting string will be used as the slot
 342 value.  If a function then it will take one argument, the value from
 343 the database, and return the value that should be put into the slot.")
 344    (db-writer
 345     :accessor view-class-slot-db-writer
 346     :initarg :db-writer
 347     :initform nil
 348     :documentation
 349     "If a string, then when reading values from the slot for the DB,
 350 the string will be used for a format string, with the only value being
 351 the value of the slot.  The resulting string will be used as the
 352 column value in the DB.  If a function then it will take one argument,
 353 the value of the slot, and return the value that should be put into
 354 the database.")
 355    (db-type
 356     :accessor view-class-slot-db-type
 357     :initarg :db-type
 358     :initform nil
 359     :documentation
 360     "A string which will be used as the type specifier for this slots
 361 column definition in the database.")
 362    (db-constraints
 363     :accessor view-class-slot-db-constraints
 364     :initarg :db-constraints
 365     :initform nil
 366     :documentation
 367     "A single constraint or list of constraints for this column")
 368    (nulls-ok
 369     :accessor view-class-slot-nulls-ok
 370     :initarg :nulls-ok
 371     :initform nil
 372     :documentation
 373     "If t, all sql NULL values retrieved from the database become nil; if nil,
 374 all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 375    (db-info
 376     :accessor view-class-slot-db-info
 377     :initarg :db-info
 378     :documentation "Description of the join.")))
 379
 380 (defparameter *db-info-lambda-list*
 381   '(&key join-class
 382          home-key
 383          foreign-key
 384          (key-join nil)
 385          (target-slot nil)
 386          (retrieval :immmediate)
 387          (set nil)))
 388
 389 (defun parse-db-info (db-info-list)
 390   (destructuring-bind
 391         (&key join-class home-key key-join foreign-key (delete-rule nil)
 392               (target-slot nil) (retrieval :deferred) (set nil))
 393       db-info-list
 394     (let ((ih (make-hash-table :size 6)))
 395       (if join-class
 396           (setf (gethash :join-class ih) join-class)
 397           (error "Must specify :join-class in :db-info"))
 398       (if home-key
 399           (setf (gethash :home-key ih) home-key)
 400           (error "Must specify :home-key in :db-info"))
 401       (when delete-rule
 402         (setf (gethash :delete-rule ih) delete-rule))
 403       (if foreign-key
 404           (setf (gethash :foreign-key ih) foreign-key)
 405           (error "Must specify :foreign-key in :db-info"))
 406       (when key-join
 407         (setf (gethash :key-join ih) t))
 408       (when target-slot
 409         (setf (gethash :target-slot ih) target-slot))
 410       (when set
 411         (setf (gethash :set ih) set))
 412       (when retrieval
 413         (progn
 414           (setf (gethash :retrieval ih) retrieval)
 415           (if (eql retrieval :immediate)
 416               (setf (gethash :set ih) nil))))
 417       ih)))
 418
 419 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 420                                              standard-direct-slot-definition)
 421   ())
 422
 423 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 424                                                 standard-effective-slot-definition)
 425   ())
 426
 427 (defmethod direct-slot-definition-class ((class standard-db-class)
 428                                          #+kmr-normal-dsdc &rest
 429                                          initargs)
 430   (declare (ignore initargs))
 431   (find-class 'view-class-direct-slot-definition))
 432
 433 (defmethod effective-slot-definition-class ((class standard-db-class)
 434                                             #+kmr-normal-esdc &rest
 435                                             initargs)
 436   (declare (ignore initargs))
 437   (find-class 'view-class-effective-slot-definition))
 438
 439 ;; Compute the slot definition for slots in a view-class.  Figures out
 440 ;; what kind of database value (if any) is stored there, generates and
 441 ;; verifies the column name.
 442
 443 (defmethod compute-effective-slot-definition ((class standard-db-class)
 444                                               #+kmr-normal-cesd slot-name
 445                                               direct-slots)
 446   #+kmr-normal-cesd (declare (ignore slot-name))
 447   (let ((slotd (call-next-method))
 448         (sd (car direct-slots)))
 449
 450     (typecase sd
 451       (view-class-slot-definition-mixin
 452        ;; Use the specified :column argument if it is supplied, otherwise
 453        ;; the column slot is filled in with the slot-name,  but transformed
 454        ;; to be sql safe, - to _ and such.
 455        (setf (slot-value slotd 'column)
 456              (column-name-from-arg
 457               (if (slot-boundp sd 'column)
 458                   (view-class-slot-column sd)
 459                   (column-name-from-arg
 460                    (sql-escape (slot-definition-name sd))))))
 461
 462        (setf (slot-value slotd 'db-type)
 463              (when (slot-boundp sd 'db-type)
 464                (view-class-slot-db-type sd)))
 465
 466
 467        (setf (slot-value slotd 'nulls-ok)
 468              (view-class-slot-nulls-ok sd))
 469
 470        ;; :db-kind slot value defaults to :base (store slot value in
 471        ;; database)
 472
 473        (setf (slot-value slotd 'db-kind)
 474              (if (slot-boundp sd 'db-kind)
 475                  (view-class-slot-db-kind sd)
 476                  :base))
 477
 478        (setf (slot-value slotd 'db-writer)
 479              (when (slot-boundp sd 'db-writer)
 480                (view-class-slot-db-writer sd)))
 481        (setf (slot-value slotd 'db-constraints)
 482              (when (slot-boundp sd 'db-constraints)
 483                (view-class-slot-db-constraints sd)))
 484
 485
 486        ;; I wonder if this slot option and the previous could be merged,
 487        ;; so that :base and :key remain keyword options, but :db-kind
 488        ;; :join becomes :db-kind (:join <db info .... >)?
 489
 490        (setf (slot-value slotd 'db-info)
 491              (when (slot-boundp sd 'db-info)
 492                (if (listp (view-class-slot-db-info sd))
 493                    (parse-db-info (view-class-slot-db-info sd))
 494                    (view-class-slot-db-info sd)))))
 495       ;; all other slots
 496       (t
 497        (change-class slotd 'view-class-effective-slot-definition
 498                      #+allegro :name
 499                      #+allegro (slot-definition-name sd))
 500        (setf (slot-value slotd 'column)
 501              (column-name-from-arg
 502               (sql-escape (slot-definition-name sd))))
 503
 504        (setf (slot-value slotd 'db-info) nil)
 505        (setf (slot-value slotd 'db-kind)
 506              :virtual)))
 507     slotd))
 508
 509 (defun slotdefs-for-slots-with-class (slots class)
 510   (let ((result nil))
 511     (dolist (s slots)
 512       (let ((c (slotdef-for-slot-with-class s class)))
 513         (if c (setf result (cons c result)))))
 514     result))
 515
 516 (defun slotdef-for-slot-with-class (slot class)
 517   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 518            (class-slots class)))
 519
 520 #+ignore
 521 (eval-when (:compile-toplevel :load-toplevel :execute)
 522   #+kmr-normal-cesd
 523   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 524   #+kmr-normal-dsdc
 525   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 526   #+kmr-normal-esdc
 527   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 528   )