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