sql/metaclasses.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
   5 ;;;;
   6 ;;;; This file is part of CLSQL.
   7 ;;;;
   8 ;;;; CLSQL users are granted the rights to distribute and use this software
   9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  11 ;;;; *************************************************************************
  12
  13 (in-package #:clsql-sys)
  14
  15 (eval-when (:compile-toplevel :load-toplevel :execute)
  16   (when (>= (length (generic-function-lambda-list
  17                      (ensure-generic-function
  18                       'compute-effective-slot-definition)))
  19             3)
  20     (pushnew :kmr-normal-cesd cl:*features*))
  21
  22   (when (>= (length (generic-function-lambda-list
  23                      (ensure-generic-function
  24                       'direct-slot-definition-class)))
  25             3)
  26     (pushnew :kmr-normal-dsdc cl:*features*))
  27
  28   (when (>= (length (generic-function-lambda-list
  29                      (ensure-generic-function
  30                       'effective-slot-definition-class)))
  31             3)
  32     (pushnew :kmr-normal-esdc cl:*features*)))
  33
  34
  35 ;; ------------------------------------------------------------
  36 ;; metaclass: view-class
  37
  38 (defclass standard-db-class (standard-class)
  39   ((view-table
  40     :accessor view-table
  41     :initarg :view-table)
  42    (definition
  43     :accessor object-definition
  44     :initarg :definition
  45     :initform nil)
  46    (key-slots
  47     :accessor key-slots
  48     :initform nil)
  49    (normalizedp
  50     :accessor normalizedp
  51     :initform nil)
  52    (class-qualifier
  53     :accessor view-class-qualifier
  54     :initarg :qualifier
  55     :initform nil))
  56   (:documentation "Metaclass for all CLSQL View Classes."))
  57
  58 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
  59
  60 (defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints
  61                                :db-writer :db-info))
  62 (defvar +extra-class-options+ '(:base-table))
  63
  64 #+lispworks
  65 (dolist (slot-option +extra-slot-options+)
  66   (eval `(process-slot-option standard-db-class ,slot-option)))
  67
  68 #+lispworks
  69 (dolist (class-option +extra-class-options+)
  70   (eval `(process-class-option standard-db-class ,class-option)))
  71
  72 (defmethod validate-superclass ((class standard-db-class)
  73                                 (superclass standard-class))
  74   t)
  75
  76 (defun table-name-from-arg (arg)
  77   (cond ((symbolp arg)
  78          (intern (sql-escape arg)))
  79         ((typep arg 'sql-ident)
  80          (if (symbolp (slot-value arg 'name))
  81              (intern (sql-escape (slot-value arg 'name)))
  82              (sql-escape (slot-value arg 'name))))
  83         ((stringp arg)
  84          (sql-escape arg))))
  85
  86 (defun column-name-from-arg (arg)
  87   (cond ((symbolp arg)
  88          arg)
  89         ((typep arg 'sql-ident)
  90          (slot-value arg 'name))
  91         ((stringp arg)
  92          (intern (symbol-name-default-case arg)))))
  93
  94
  95 (defun remove-keyword-arg (arglist akey)
  96   (let ((mylist arglist)
  97         (newlist ()))
  98     (labels ((pop-arg (alist)
  99              (let ((arg (pop alist))
 100                    (val (pop alist)))
 101                (unless (equal arg akey)
 102                  (setf newlist (append (list arg val) newlist)))
 103                (when alist (pop-arg alist)))))
 104       (pop-arg mylist))
 105     newlist))
 106
 107 (defun set-view-table-slot (class base-table)
 108   (setf (view-table class)
 109         (table-name-from-arg (or (and base-table
 110                                       (if (listp base-table)
 111                                           (car base-table)
 112                                           base-table))
 113                                  (class-name class)))))
 114
 115 (defgeneric ordered-class-direct-slots (class))
 116 (defmethod ordered-class-direct-slots ((self standard-db-class))
 117   (let ((direct-slot-names
 118          (mapcar #'slot-definition-name (class-direct-slots self)))
 119         (ordered-direct-class-slots '()))
 120     (dolist (slot (ordered-class-slots self))
 121       (let ((slot-name (slot-definition-name slot)))
 122         (when (find slot-name direct-slot-names)
 123           (push slot ordered-direct-class-slots))))
 124     (nreverse ordered-direct-class-slots)))
 125
 126 (defmethod initialize-instance :around ((class standard-db-class)
 127                                         &rest all-keys
 128                                         &key direct-superclasses base-table
 129                                         qualifier normalizedp
 130                                         &allow-other-keys)
 131   (let ((root-class (find-class 'standard-db-object nil))
 132         (vmc 'standard-db-class))
 133     (setf (view-class-qualifier class)
 134           (car qualifier))
 135     (if root-class
 136         (if (some #'(lambda (super) (typep super vmc))
 137                   direct-superclasses)
 138             (call-next-method)
 139             (apply #'call-next-method
 140                    class
 141                    :direct-superclasses (append (list root-class)
 142                                                 direct-superclasses)
 143                    (remove-keyword-arg all-keys :direct-superclasses)))
 144         (call-next-method))
 145     (set-view-table-slot class base-table)
 146     (setf (normalizedp class) (car normalizedp))
 147     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 148                                    all-keys))))
 149
 150 (defmethod reinitialize-instance :around ((class standard-db-class)
 151                                           &rest all-keys
 152                                           &key base-table normalizedp
 153                                           direct-superclasses qualifier
 154                                           &allow-other-keys)
 155   (let ((root-class (find-class 'standard-db-object nil))
 156         (vmc 'standard-db-class))
 157     (set-view-table-slot class base-table)
 158     (setf (normalizedp class) (car normalizedp))
 159     (setf (view-class-qualifier class)
 160           (car qualifier))
 161     (if (and root-class (not (equal class root-class)))
 162         (if (some #'(lambda (super) (typep super vmc))
 163                   direct-superclasses)
 164             (call-next-method)
 165             (apply #'call-next-method
 166                    class
 167                    :direct-superclasses (append (list root-class)
 168                                                 direct-superclasses)
 169                    (remove-keyword-arg all-keys :direct-superclasses)))
 170         (call-next-method)))
 171   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 172                                  all-keys)))
 173
 174
 175 (defun get-keywords (keys list)
 176   (flet ((extract (key)
 177            (let ((pos (position key list)))
 178              (when pos
 179                (nth (1+ pos) list)))))
 180     (mapcar #'extract keys)))
 181
 182 (defun describe-db-layout (class)
 183   (flet ((not-db-col (col)
 184            (not (member (nth 2 col) '(nil :base :key))))
 185          (frob-slot (slot)
 186            (let ((type (slot-definition-type slot)))
 187              (if (eq type t)
 188                  (setq type nil))
 189              (list (slot-value slot 'name)
 190                    type
 191                    (slot-value slot 'db-kind)
 192                    (and (slot-boundp slot 'column)
 193                         (slot-value slot 'column))))))
 194     (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))
 195       (setq all-slots (remove-if #'not-db-col all-slots))
 196       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 197       ;;(mapcar #'dink-type all-slots)
 198       all-slots)))
 199
 200 (defun register-metaclass (class slots)
 201   (labels ((not-db-col (col)
 202              (not (member (nth 2 col)  '(nil :base :key))))
 203            (frob-slot (slot)
 204              (get-keywords '(:name :type :db-kind :column) slot)))
 205     (let ((all-slots (mapcar #'frob-slot slots)))
 206       (setq all-slots (remove-if #'not-db-col all-slots))
 207       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 208       (setf (object-definition class) all-slots))
 209     #-(or sbcl allegro)
 210     (setf (key-slots class) (remove-if-not (lambda (slot)
 211                                              (eql (slot-value slot 'db-kind)
 212                                                   :key))
 213                                            (if (normalizedp class)
 214                                                (ordered-class-direct-slots class)
 215                                                (ordered-class-slots class))))))
 216
 217 #+(or sbcl allegro)
 218 (defmethod finalize-inheritance :after ((class standard-db-class))
 219   (setf (key-slots class) (remove-if-not (lambda (slot)
 220                                            (eql (slot-value slot 'db-kind)
 221                                                 :key))
 222                                          (if (normalizedp class)
 223                                              (ordered-class-direct-slots class)
 224                                              (ordered-class-slots class)))))
 225
 226 ;; return the deepest view-class ancestor for a given view class
 227
 228 (defun base-db-class (classname)
 229   (let* ((class (find-class classname))
 230          (db-class (find-class 'standard-db-object)))
 231     (loop
 232      (let ((cds (class-direct-superclasses class)))
 233        (cond ((null cds)
 234               (error "not a db class"))
 235              ((member db-class cds)
 236               (return (class-name class))))
 237        (setq class (car cds))))))
 238
 239 (defun db-ancestors (classname)
 240   (let ((class (find-class classname))
 241         (db-class (find-class 'standard-db-object)))
 242     (labels ((ancestors (class)
 243              (let ((scs (class-direct-superclasses class)))
 244                (if (member db-class scs)
 245                    (list class)
 246                    (append (list class) (mapcar #'ancestors scs))))))
 247       (ancestors class))))
 248
 249 (defclass view-class-slot-definition-mixin ()
 250   ((column
 251     :accessor view-class-slot-column
 252     :initarg :column
 253     :documentation
 254     "The name of the SQL column this slot is stored in.  Defaults to
 255 the slot name.")
 256    (db-kind
 257     :accessor view-class-slot-db-kind
 258     :initarg :db-kind
 259     :initform :base
 260     ;; openmcl 0.14.2 stores the value as list in the DSD
 261     ;; :type (or list keyword)
 262     #-openmcl :type #-openmcl keyword
 263     :documentation
 264     "The kind of DB mapping which is performed for this slot.  :base
 265 indicates the slot maps to an ordinary column of the DB view.  :key
 266 indicates that this slot corresponds to part of the unique keys for
 267 this view, :join indicates ... and :virtual indicates that this slot
 268 is an ordinary CLOS slot.  Defaults to :base.")
 269    (db-reader
 270     :accessor view-class-slot-db-reader
 271     :initarg :db-reader
 272     :initform nil
 273     :documentation
 274     "If a string, then when reading values from the DB, the string
 275 will be used for a format string, with the only value being the value
 276 from the database.  The resulting string will be used as the slot
 277 value.  If a function then it will take one argument, the value from
 278 the database, and return the value that should be put into the slot.")
 279    (db-writer
 280     :accessor view-class-slot-db-writer
 281     :initarg :db-writer
 282     :initform nil
 283     :documentation
 284     "If a string, then when reading values from the slot for the DB,
 285 the string will be used for a format string, with the only value being
 286 the value of the slot.  The resulting string will be used as the
 287 column value in the DB.  If a function then it will take one argument,
 288 the value of the slot, and return the value that should be put into
 289 the database.")
 290    (db-type
 291     :accessor view-class-slot-db-type
 292     :initarg :db-type
 293     :initform nil
 294     :documentation
 295     "A string which will be used as the type specifier for this slots
 296 column definition in the database.")
 297    (db-constraints
 298     :accessor view-class-slot-db-constraints
 299     :initarg :db-constraints
 300     :initform nil
 301     :documentation
 302     "A keyword symbol representing a single SQL column constraint or list of such symbols.")
 303    (void-value
 304     :accessor view-class-slot-void-value
 305     :initarg :void-value
 306     :initform nil
 307     :documentation
 308     "Value to store if the SQL value is NULL. Default is NIL.")
 309    (db-info
 310     :accessor view-class-slot-db-info
 311     :initarg :db-info
 312     :documentation "Description of the join.")
 313    (specified-type
 314     :accessor specified-type
 315     :initarg specified-type
 316     :initform nil
 317     :documentation "Internal slot storing the :type specified by user.")
 318    (autoincrement-sequence
 319     :accessor view-class-slot-autoincrement-sequence
 320     :initarg :autoincrement-sequence
 321     :initform nil
 322     :documentation "A string naming the (possibly automatically generated) sequence
 323 for a slot with an :auto-increment constraint.")))
 324
 325 (defparameter *db-info-lambda-list*
 326   '(&key join-class
 327          home-key
 328          foreign-key
 329          (key-join nil)
 330          (target-slot nil)
 331          (retrieval :immmediate)
 332          (set nil)))
 333
 334 (defun parse-db-info (db-info-list)
 335   (destructuring-bind
 336         (&key join-class home-key key-join foreign-key (delete-rule nil)
 337               (target-slot nil) (retrieval :deferred) (set t))
 338       db-info-list
 339     (let ((ih (make-hash-table :size 6)))
 340       (if join-class
 341           (setf (gethash :join-class ih) join-class)
 342           (error "Must specify :join-class in :db-info"))
 343       (if home-key
 344           (setf (gethash :home-key ih) home-key)
 345           (error "Must specify :home-key in :db-info"))
 346       (when delete-rule
 347         (setf (gethash :delete-rule ih) delete-rule))
 348       (if foreign-key
 349           (setf (gethash :foreign-key ih) foreign-key)
 350           (error "Must specify :foreign-key in :db-info"))
 351       (when key-join
 352         (setf (gethash :key-join ih) t))
 353       (when target-slot
 354         (setf (gethash :target-slot ih) target-slot))
 355       (when set
 356         (setf (gethash :set ih) set))
 357       (when retrieval
 358         (progn
 359           (setf (gethash :retrieval ih) retrieval)
 360           (if (eql retrieval :immediate)
 361               (setf (gethash :set ih) nil))))
 362       ih)))
 363
 364 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 365                                              standard-direct-slot-definition)
 366   ())
 367
 368 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 369                                                 standard-effective-slot-definition)
 370   ())
 371
 372 (defmethod direct-slot-definition-class ((class standard-db-class)
 373                                          #+kmr-normal-dsdc &rest
 374                                          initargs)
 375   (declare (ignore initargs))
 376   (find-class 'view-class-direct-slot-definition))
 377
 378 (defmethod effective-slot-definition-class ((class standard-db-class)
 379                                             #+kmr-normal-esdc &rest
 380                                             initargs)
 381   (declare (ignore initargs))
 382   (find-class 'view-class-effective-slot-definition))
 383
 384 #+openmcl
 385 (when (not (symbol-function 'compute-class-precedence-list))
 386   (eval
 387    (defun compute-class-precedence-list (class)
 388      (class-precedence-list class))))
 389
 390 #-mop-slot-order-reversed
 391 (defmethod compute-slots ((class standard-db-class))
 392   "Need to sort order of class slots so they are the same across
 393 implementations."
 394   (let ((slots (call-next-method))
 395         desired-sequence
 396         output-slots)
 397     (dolist (c (compute-class-precedence-list class))
 398       (dolist (s (class-direct-slots c))
 399         (let ((name (slot-definition-name s)))
 400           (unless (find name desired-sequence)
 401             (push name desired-sequence)))))
 402     (dolist (desired desired-sequence)
 403       (let ((slot (find desired slots :key #'slot-definition-name)))
 404         (assert slot)
 405         (push slot output-slots)))
 406     output-slots))
 407
 408 (defun compute-lisp-type-from-specified-type (specified-type db-constraints)
 409   "Computes the Lisp type for a user-specified type."
 410   (let ((type
 411          (cond
 412            ((consp specified-type)
 413             (let* ((first (first specified-type))
 414                    (name (etypecase first
 415                            (symbol (symbol-name first))
 416                            (string first))))
 417               (cond
 418                ((or (string-equal name "string")
 419                     (string-equal name "varchar")
 420                     (string-equal name "char"))
 421                 'string)
 422                (t
 423                 specified-type))))
 424            ((eq (ensure-keyword specified-type) :bigint)
 425             'integer)
 426            ((eq (ensure-keyword specified-type) :char)
 427             'character)
 428            ((eq (ensure-keyword specified-type) :varchar)
 429             'string)
 430            (t
 431             specified-type))))
 432     (if (and type (not (member :not-null (listify db-constraints))))
 433         `(or null ,type)
 434         (or type t))))
 435
 436 ;; Compute the slot definition for slots in a view-class.  Figures out
 437 ;; what kind of database value (if any) is stored there, generates and
 438 ;; verifies the column name.
 439
 440 (declaim (inline delistify))
 441 (defun delistify (list)
 442   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 443   (if (listp list)
 444       (car list)
 445       list))
 446
 447 (declaim (inline delistify-dsd))
 448 (defun delistify-dsd (list)
 449   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 450   (if (and (listp list) (null (cdr list)))
 451       (car list)
 452       list))
 453
 454 (defmethod initialize-instance :around
 455     ((obj view-class-direct-slot-definition)
 456      &rest initargs &key db-constraints db-kind type &allow-other-keys)
 457   (when (and (not db-kind) (member :primary-key (listify db-constraints)))
 458     (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
 459           (slot-definition-name obj)))
 460   (apply #'call-next-method obj
 461          'specified-type type
 462          :type (if (and (eql db-kind :virtual) (null type))
 463                    t
 464                    (compute-lisp-type-from-specified-type
 465                     type db-constraints))
 466          initargs))
 467
 468 (defmethod compute-effective-slot-definition ((class standard-db-class)
 469                                               #+kmr-normal-cesd slot-name
 470                                               direct-slots)
 471   #+kmr-normal-cesd (declare (ignore slot-name))
 472
 473   ;; KMR: store the user-specified type and then compute
 474   ;; real Lisp type and store it
 475   (let ((dsd (car direct-slots)))
 476     (let ((esd (call-next-method)))
 477       (typecase dsd
 478         (view-class-slot-definition-mixin
 479          ;; Use the specified :column argument if it is supplied, otherwise
 480          ;; the column slot is filled in with the slot-name,  but transformed
 481          ;; to be sql safe, - to _ and such.
 482          (setf (slot-value esd 'column)
 483            (column-name-from-arg
 484             (if (slot-boundp dsd 'column)
 485                 (delistify-dsd (view-class-slot-column dsd))
 486               (column-name-from-arg
 487                (sql-escape (slot-definition-name dsd))))))
 488
 489          (setf (slot-value esd 'db-type)
 490            (when (slot-boundp dsd 'db-type)
 491              (delistify-dsd
 492               (view-class-slot-db-type dsd))))
 493
 494          (setf (slot-value esd 'void-value)
 495                (delistify-dsd
 496                 (view-class-slot-void-value dsd)))
 497
 498          ;; :db-kind slot value defaults to :base (store slot value in
 499          ;; database)
 500
 501          (setf (slot-value esd 'db-kind)
 502            (if (slot-boundp dsd 'db-kind)
 503                (delistify-dsd (view-class-slot-db-kind dsd))
 504              :base))
 505
 506          (setf (slot-value esd 'db-reader)
 507            (when (slot-boundp dsd 'db-reader)
 508              (delistify-dsd (view-class-slot-db-reader dsd))))
 509          (setf (slot-value esd 'db-writer)
 510            (when (slot-boundp dsd 'db-writer)
 511              (delistify-dsd (view-class-slot-db-writer dsd))))
 512          (setf (slot-value esd 'db-constraints)
 513            (when (slot-boundp dsd 'db-constraints)
 514              (delistify-dsd (view-class-slot-db-constraints dsd))))
 515
 516          ;; I wonder if this slot option and the previous could be merged,
 517          ;; so that :base and :key remain keyword options, but :db-kind
 518          ;; :join becomes :db-kind (:join <db info .... >)?
 519
 520          (setf (slot-value esd 'db-info)
 521                (when (slot-boundp dsd 'db-info)
 522                  (let ((dsd-info (view-class-slot-db-info dsd)))
 523                    (cond
 524                      ((atom dsd-info)
 525                       dsd-info)
 526                      ((and (listp dsd-info) (> (length dsd-info) 1)
 527                            (atom (car dsd-info)))
 528                       (parse-db-info dsd-info))
 529                      ((and (listp dsd-info) (= 1 (length dsd-info))
 530                            (listp (car dsd-info)))
 531                       (parse-db-info (car dsd-info)))))))
 532
 533          (setf (specified-type esd)
 534                (delistify-dsd (specified-type dsd)))
 535          ;; In older SBCL's the type-check-function is computed at
 536          ;; defclass expansion, which is too early for the CLSQL type
 537          ;; conversion to take place. This gets rid of it. It's ugly
 538          ;; but it's better than nothing -wcp10/4/10.
 539          #+(and sbcl #.(cl:if (cl:and (cl:find-package :sb-pcl)
 540                                       (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl))
 541                               '(list 'cl:and) '(list 'cl:or)))
 542          (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
 543
 544          )
 545         ;; all other slots
 546         (t
 547          (unless (typep esd 'view-class-effective-slot-definition)
 548            (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
 549
 550            (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
 551              #-openmcl (declare (ignore type-predicate))
 552              #-(or clisp sbcl)  (change-class esd 'view-class-effective-slot-definition
 553                                               #+allegro :name
 554                                               #+allegro (slot-definition-name dsd))
 555              #+openmcl (setf (slot-value esd 'ccl::type-predicate)
 556                              type-predicate)))
 557
 558          (setf (slot-value esd 'column)
 559            (column-name-from-arg
 560             (sql-escape (slot-definition-name dsd))))
 561
 562          (setf (slot-value esd 'db-info) nil)
 563          (setf (slot-value esd 'db-kind) :virtual)
 564          (setf (specified-type esd) (slot-definition-type dsd)))
 565         )
 566       esd)))
 567
 568 (defun slotdefs-for-slots-with-class (slots class)
 569   (let ((result nil))
 570     (dolist (s slots)
 571       (let ((c (slotdef-for-slot-with-class s class)))
 572         (if c (setf result (cons c result)))))
 573     result))
 574
 575 (defun slotdef-for-slot-with-class (slot class)
 576   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 577            (class-slots class)))
 578
 579 #+ignore
 580 (eval-when (:compile-toplevel :load-toplevel :execute)
 581   #+kmr-normal-cesd
 582   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 583   #+kmr-normal-dsdc
 584   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 585   #+kmr-normal-esdc
 586   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 587   )