sql/metaclasses.lisp

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