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 (ordered-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                                            (ordered-class-slots class)))))
 285
 286 #+(or allegro openmcl)
 287 (defmethod finalize-inheritance :after ((class standard-db-class))
 288   ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
 289   ;; for standard-db-class
 290   #+openmcl
 291   (mapcar
 292    #'(lambda (s)
 293        (if (eq 'ccl:false (slot-value s 'ccl::type-predicate))
 294            (setf (slot-value s 'ccl::type-predicate) 'ccl:true)))
 295    (class-slots class))
 296
 297   (setf (key-slots class) (remove-if-not (lambda (slot)
 298                                            (eql (slot-value slot 'db-kind)
 299                                                 :key))
 300                                          (ordered-class-slots class))))
 301
 302 ;; return the deepest view-class ancestor for a given view class
 303
 304 (defun base-db-class (classname)
 305   (let* ((class (find-class classname))
 306          (db-class (find-class 'standard-db-object)))
 307     (loop
 308      (let ((cds (class-direct-superclasses class)))
 309        (cond ((null cds)
 310               (error "not a db class"))
 311              ((member db-class cds)
 312               (return (class-name class))))
 313        (setq class (car cds))))))
 314
 315 (defun db-ancestors (classname)
 316   (let ((class (find-class classname))
 317         (db-class (find-class 'standard-db-object)))
 318     (labels ((ancestors (class)
 319              (let ((scs (class-direct-superclasses class)))
 320                (if (member db-class scs)
 321                    (list class)
 322                    (append (list class) (mapcar #'ancestors scs))))))
 323       (ancestors class))))
 324
 325 (defclass view-class-slot-definition-mixin ()
 326   ((column
 327     :accessor view-class-slot-column
 328     :initarg :column
 329     :documentation
 330     "The name of the SQL column this slot is stored in.  Defaults to
 331 the slot name.")
 332    (db-kind
 333     :accessor view-class-slot-db-kind
 334     :initarg :db-kind
 335     :initform :base
 336     :type keyword
 337     :documentation
 338     "The kind of DB mapping which is performed for this slot.  :base
 339 indicates the slot maps to an ordinary column of the DB view.  :key
 340 indicates that this slot corresponds to part of the unique keys for
 341 this view, :join indicates ... and :virtual indicates that this slot
 342 is an ordinary CLOS slot.  Defaults to :base.")
 343    (db-reader
 344     :accessor view-class-slot-db-reader
 345     :initarg :db-reader
 346     :initform nil
 347     :documentation
 348     "If a string, then when reading values from the DB, the string
 349 will be used for a format string, with the only value being the value
 350 from the database.  The resulting string will be used as the slot
 351 value.  If a function then it will take one argument, the value from
 352 the database, and return the value that should be put into the slot.")
 353    (db-writer
 354     :accessor view-class-slot-db-writer
 355     :initarg :db-writer
 356     :initform nil
 357     :documentation
 358     "If a string, then when reading values from the slot for the DB,
 359 the string will be used for a format string, with the only value being
 360 the value of the slot.  The resulting string will be used as the
 361 column value in the DB.  If a function then it will take one argument,
 362 the value of the slot, and return the value that should be put into
 363 the database.")
 364    (db-type
 365     :accessor view-class-slot-db-type
 366     :initarg :db-type
 367     :initform nil
 368     :documentation
 369     "A string which will be used as the type specifier for this slots
 370 column definition in the database.")
 371    (db-constraints
 372     :accessor view-class-slot-db-constraints
 373     :initarg :db-constraints
 374     :initform nil
 375     :documentation
 376     "A single constraint or list of constraints for this column")
 377    (nulls-ok
 378     :accessor view-class-slot-nulls-ok
 379     :initarg :nulls-ok
 380     :initform nil
 381     :documentation
 382     "If t, all sql NULL values retrieved from the database become nil; if nil,
 383 all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 384    (db-info
 385     :accessor view-class-slot-db-info
 386     :initarg :db-info
 387     :documentation "Description of the join.")
 388    (specified-type
 389     :accessor specified-type
 390     :initform nil
 391     :documentation "KMR: Internal slot storing the :type specified by user.")))
 392
 393 (defparameter *db-info-lambda-list*
 394   '(&key join-class
 395          home-key
 396          foreign-key
 397          (key-join nil)
 398          (target-slot nil)
 399          (retrieval :immmediate)
 400          (set nil)))
 401
 402 (defun parse-db-info (db-info-list)
 403   (destructuring-bind
 404         (&key join-class home-key key-join foreign-key (delete-rule nil)
 405               (target-slot nil) (retrieval :deferred) (set nil))
 406       db-info-list
 407     (let ((ih (make-hash-table :size 6)))
 408       (if join-class
 409           (setf (gethash :join-class ih) join-class)
 410           (error "Must specify :join-class in :db-info"))
 411       (if home-key
 412           (setf (gethash :home-key ih) home-key)
 413           (error "Must specify :home-key in :db-info"))
 414       (when delete-rule
 415         (setf (gethash :delete-rule ih) delete-rule))
 416       (if foreign-key
 417           (setf (gethash :foreign-key ih) foreign-key)
 418           (error "Must specify :foreign-key in :db-info"))
 419       (when key-join
 420         (setf (gethash :key-join ih) t))
 421       (when target-slot
 422         (setf (gethash :target-slot ih) target-slot))
 423       (when set
 424         (setf (gethash :set ih) set))
 425       (when retrieval
 426         (progn
 427           (setf (gethash :retrieval ih) retrieval)
 428           (if (eql retrieval :immediate)
 429               (setf (gethash :set ih) nil))))
 430       ih)))
 431
 432 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 433                                              standard-direct-slot-definition)
 434   ())
 435
 436 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 437                                                 standard-effective-slot-definition)
 438   ())
 439
 440 (defmethod direct-slot-definition-class ((class standard-db-class)
 441                                          #+kmr-normal-dsdc &rest
 442                                          initargs)
 443   (declare (ignore initargs))
 444   (find-class 'view-class-direct-slot-definition))
 445
 446 (defmethod effective-slot-definition-class ((class standard-db-class)
 447                                             #+kmr-normal-esdc &rest
 448                                             initargs)
 449   (declare (ignore initargs))
 450   (find-class 'view-class-effective-slot-definition))
 451
 452 #+openmcl
 453 (defun compute-class-precedence-list (class)
 454   ;; safe to call this in openmcl
 455   (class-precedence-list class))
 456
 457 #-(or sbcl cmu)
 458 (defmethod compute-slots ((class standard-db-class))
 459   "Need to sort order of class slots so they are the same across
 460 implementations."
 461   (let ((slots (call-next-method))
 462         desired-sequence
 463         output-slots)
 464     (dolist (c (compute-class-precedence-list class))
 465       (dolist (s (class-direct-slots c))
 466         (let ((name (slot-definition-name s)))
 467           (unless (find name desired-sequence)
 468             (push name desired-sequence)))))
 469     (dolist (desired desired-sequence)
 470       (let ((slot (find desired slots :key #'slot-definition-name)))
 471         (assert slot)
 472         (push slot output-slots)))
 473     output-slots))
 474
 475 (defun compute-lisp-type-from-slot-specification (slotd specified-type)
 476   "Computes the Lisp type for a user-specified type. Needed for OpenMCL
 477 which does type checking before storing a value in a slot."
 478   #-openmcl (declare (ignore slotd))
 479   ;; This function is called after the base compute-effective-slots is called.
 480   ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
 481   ;; so we have to override the type-predicates here
 482   (cond
 483     ((consp specified-type)
 484      (cond
 485        ((and (symbolp (car specified-type))
 486              (string-equal (symbol-name (car specified-type)) "string"))
 487         #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp)
 488         'string)
 489        (t
 490         #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 491         specified-type)))
 492     #+openmcl
 493     ((null specified-type)
 494      ;; setting this here is not enough since openmcl later sets the
 495      ;; type-predicate to ccl:false. So, have to check slots again
 496      ;; in finalize-inheritance
 497      #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 498      t)
 499     (t
 500      ;; This can be improved for OpenMCL to set a more specific type
 501      ;; predicate based on the value specified-type
 502      #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 503      specified-type)))
 504
 505 ;; Compute the slot definition for slots in a view-class.  Figures out
 506 ;; what kind of database value (if any) is stored there, generates and
 507 ;; verifies the column name.
 508
 509 (defmethod compute-effective-slot-definition ((class standard-db-class)
 510                                               #+kmr-normal-cesd slot-name
 511                                               direct-slots)
 512   #+kmr-normal-cesd (declare (ignore slot-name))
 513
 514   (let ((slotd (call-next-method))
 515         (sd (car direct-slots)))
 516
 517     (typecase sd
 518       (view-class-slot-definition-mixin
 519        ;; Use the specified :column argument if it is supplied, otherwise
 520        ;; the column slot is filled in with the slot-name,  but transformed
 521        ;; to be sql safe, - to _ and such.
 522        (setf (slot-value slotd 'column)
 523              (column-name-from-arg
 524               (if (slot-boundp sd 'column)
 525                   (view-class-slot-column sd)
 526                   (column-name-from-arg
 527                    (sql-escape (slot-definition-name sd))))))
 528
 529        (setf (slot-value slotd 'db-type)
 530              (when (slot-boundp sd 'db-type)
 531                (view-class-slot-db-type sd)))
 532
 533        (setf (slot-value slotd 'nulls-ok)
 534              (view-class-slot-nulls-ok sd))
 535
 536        ;; :db-kind slot value defaults to :base (store slot value in
 537        ;; database)
 538
 539        (setf (slot-value slotd 'db-kind)
 540              (if (slot-boundp sd 'db-kind)
 541                  (view-class-slot-db-kind sd)
 542                  :base))
 543
 544        (setf (slot-value slotd 'db-writer)
 545              (when (slot-boundp sd 'db-writer)
 546                (view-class-slot-db-writer sd)))
 547        (setf (slot-value slotd 'db-constraints)
 548              (when (slot-boundp sd 'db-constraints)
 549                (view-class-slot-db-constraints sd)))
 550
 551        ;; I wonder if this slot option and the previous could be merged,
 552        ;; so that :base and :key remain keyword options, but :db-kind
 553        ;; :join becomes :db-kind (:join <db info .... >)?
 554
 555        (setf (slot-value slotd 'db-info)
 556              (when (slot-boundp sd 'db-info)
 557                (if (listp (view-class-slot-db-info sd))
 558                    (parse-db-info (view-class-slot-db-info sd))
 559                    (view-class-slot-db-info sd))))
 560
 561        ;; KMR: store the user-specified type and then compute
 562        ;; real Lisp type and store it
 563        (setf (specified-type slotd)
 564              (slot-definition-type slotd))
 565        (setf (slot-value slotd 'type)
 566              (compute-lisp-type-from-slot-specification
 567               slotd (slot-definition-type slotd)))
 568        )
 569       ;; all other slots
 570       (t
 571        (change-class slotd 'view-class-effective-slot-definition
 572                      #+allegro :name
 573                      #+allegro (slot-definition-name sd))
 574        (setf (slot-value slotd 'column)
 575              (column-name-from-arg
 576               (sql-escape (slot-definition-name sd))))
 577
 578        (setf (slot-value slotd 'db-info) nil)
 579        (setf (slot-value slotd 'db-kind)
 580              :virtual)))
 581     slotd))
 582
 583 (defun slotdefs-for-slots-with-class (slots class)
 584   (let ((result nil))
 585     (dolist (s slots)
 586       (let ((c (slotdef-for-slot-with-class s class)))
 587         (if c (setf result (cons c result)))))
 588     result))
 589
 590 (defun slotdef-for-slot-with-class (slot class)
 591   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 592            (class-slots class)))
 593
 594 #+ignore
 595 (eval-when (:compile-toplevel :load-toplevel :execute)
 596   #+kmr-normal-cesd
 597   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 598   #+kmr-normal-dsdc
 599   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 600   #+kmr-normal-esdc
 601   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 602   )