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 (defmethod ordered-class-direct-slots ((self standard-db-class))
 116   (let ((direct-slot-names
 117          (mapcar #'slot-definition-name (class-direct-slots self)))
 118         (ordered-direct-class-slots '()))
 119     (dolist (slot (ordered-class-slots self))
 120       (let ((slot-name (slot-definition-name slot)))
 121         (when (find slot-name direct-slot-names)
 122           (push slot ordered-direct-class-slots))))
 123     (nreverse ordered-direct-class-slots)))
 124
 125 (defmethod initialize-instance :around ((class standard-db-class)
 126                                         &rest all-keys
 127                                         &key direct-superclasses base-table
 128                                         qualifier normalizedp
 129                                         &allow-other-keys)
 130   (let ((root-class (find-class 'standard-db-object nil))
 131         (vmc 'standard-db-class))
 132     (setf (view-class-qualifier class)
 133           (car qualifier))
 134     (if root-class
 135         (if (some #'(lambda (super) (typep super vmc))
 136                   direct-superclasses)
 137             (call-next-method)
 138             (apply #'call-next-method
 139                    class
 140                    :direct-superclasses (append (list root-class)
 141                                                 direct-superclasses)
 142                    (remove-keyword-arg all-keys :direct-superclasses)))
 143         (call-next-method))
 144     (set-view-table-slot class base-table)
 145     (setf (normalizedp class) (car normalizedp))
 146     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 147                                    all-keys))))
 148
 149 (defmethod reinitialize-instance :around ((class standard-db-class)
 150                                           &rest all-keys
 151                                           &key base-table normalizedp
 152                                           direct-superclasses qualifier
 153                                           &allow-other-keys)
 154   (let ((root-class (find-class 'standard-db-object nil))
 155         (vmc 'standard-db-class))
 156     (set-view-table-slot class base-table)
 157     (setf (normalizedp class) (car normalizedp))
 158     (setf (view-class-qualifier class)
 159           (car qualifier))
 160     (if (and root-class (not (equal class root-class)))
 161         (if (some #'(lambda (super) (typep super vmc))
 162                   direct-superclasses)
 163             (call-next-method)
 164             (apply #'call-next-method
 165                    class
 166                    :direct-superclasses (append (list root-class)
 167                                                 direct-superclasses)
 168                    (remove-keyword-arg all-keys :direct-superclasses)))
 169         (call-next-method)))
 170   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 171                                  all-keys)))
 172
 173
 174 (defun get-keywords (keys list)
 175   (flet ((extract (key)
 176            (let ((pos (position key list)))
 177              (when pos
 178                (nth (1+ pos) list)))))
 179     (mapcar #'extract keys)))
 180
 181 (defun describe-db-layout (class)
 182   (flet ((not-db-col (col)
 183            (not (member (nth 2 col) '(nil :base :key))))
 184          (frob-slot (slot)
 185            (let ((type (slot-definition-type slot)))
 186              (if (eq type t)
 187                  (setq type nil))
 188              (list (slot-value slot 'name)
 189                    type
 190                    (slot-value slot 'db-kind)
 191                    (and (slot-boundp slot 'column)
 192                         (slot-value slot 'column))))))
 193     (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))
 194       (setq all-slots (remove-if #'not-db-col all-slots))
 195       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 196       ;;(mapcar #'dink-type all-slots)
 197       all-slots)))
 198
 199 (defun register-metaclass (class slots)
 200   (labels ((not-db-col (col)
 201              (not (member (nth 2 col)  '(nil :base :key))))
 202            (frob-slot (slot)
 203              (get-keywords '(:name :type :db-kind :column) slot)))
 204     (let ((all-slots (mapcar #'frob-slot slots)))
 205       (setq all-slots (remove-if #'not-db-col all-slots))
 206       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 207       (setf (object-definition class) all-slots))
 208     #-(or sbcl allegro)
 209     (setf (key-slots class) (remove-if-not (lambda (slot)
 210                                              (eql (slot-value slot 'db-kind)
 211                                                   :key))
 212                                            (if (normalizedp class)
 213                                                (ordered-class-direct-slots class)
 214                                                (ordered-class-slots class))))))
 215
 216 #+(or sbcl allegro)
 217 (defmethod finalize-inheritance :after ((class standard-db-class))
 218   (setf (key-slots class) (remove-if-not (lambda (slot)
 219                                            (eql (slot-value slot 'db-kind)
 220                                                 :key))
 221                                          (if (normalizedp class)
 222                                              (ordered-class-direct-slots class)
 223                                              (ordered-class-slots class)))))
 224
 225 ;; return the deepest view-class ancestor for a given view class
 226
 227 (defun base-db-class (classname)
 228   (let* ((class (find-class classname))
 229          (db-class (find-class 'standard-db-object)))
 230     (loop
 231      (let ((cds (class-direct-superclasses class)))
 232        (cond ((null cds)
 233               (error "not a db class"))
 234              ((member db-class cds)
 235               (return (class-name class))))
 236        (setq class (car cds))))))
 237
 238 (defun db-ancestors (classname)
 239   (let ((class (find-class classname))
 240         (db-class (find-class 'standard-db-object)))
 241     (labels ((ancestors (class)
 242              (let ((scs (class-direct-superclasses class)))
 243                (if (member db-class scs)
 244                    (list class)
 245                    (append (list class) (mapcar #'ancestors scs))))))
 246       (ancestors class))))
 247
 248 (defclass view-class-slot-definition-mixin ()
 249   ((column
 250     :accessor view-class-slot-column
 251     :initarg :column
 252     :documentation
 253     "The name of the SQL column this slot is stored in.  Defaults to
 254 the slot name.")
 255    (db-kind
 256     :accessor view-class-slot-db-kind
 257     :initarg :db-kind
 258     :initform :base
 259     ;; openmcl 0.14.2 stores the value as list in the DSD
 260     ;; :type (or list keyword)
 261     #-openmcl :type #-openmcl keyword
 262     :documentation
 263     "The kind of DB mapping which is performed for this slot.  :base
 264 indicates the slot maps to an ordinary column of the DB view.  :key
 265 indicates that this slot corresponds to part of the unique keys for
 266 this view, :join indicates ... and :virtual indicates that this slot
 267 is an ordinary CLOS slot.  Defaults to :base.")
 268    (db-reader
 269     :accessor view-class-slot-db-reader
 270     :initarg :db-reader
 271     :initform nil
 272     :documentation
 273     "If a string, then when reading values from the DB, the string
 274 will be used for a format string, with the only value being the value
 275 from the database.  The resulting string will be used as the slot
 276 value.  If a function then it will take one argument, the value from
 277 the database, and return the value that should be put into the slot.")
 278    (db-writer
 279     :accessor view-class-slot-db-writer
 280     :initarg :db-writer
 281     :initform nil
 282     :documentation
 283     "If a string, then when reading values from the slot for the DB,
 284 the string will be used for a format string, with the only value being
 285 the value of the slot.  The resulting string will be used as the
 286 column value in the DB.  If a function then it will take one argument,
 287 the value of the slot, and return the value that should be put into
 288 the database.")
 289    (db-type
 290     :accessor view-class-slot-db-type
 291     :initarg :db-type
 292     :initform nil
 293     :documentation
 294     "A string which will be used as the type specifier for this slots
 295 column definition in the database.")
 296    (db-constraints
 297     :accessor view-class-slot-db-constraints
 298     :initarg :db-constraints
 299     :initform nil
 300     :documentation
 301     "A keyword symbol representing a single SQL column constraint or list of such symbols.")
 302    (void-value
 303     :accessor view-class-slot-void-value
 304     :initarg :void-value
 305     :initform nil
 306     :documentation
 307     "Value to store if the SQL value is NULL. Default is NIL.")
 308    (db-info
 309     :accessor view-class-slot-db-info
 310     :initarg :db-info
 311     :documentation "Description of the join.")
 312    (specified-type
 313     :accessor specified-type
 314     :initarg specified-type
 315     :initform nil
 316     :documentation "Internal slot storing the :type specified by user.")))
 317
 318 (defparameter *db-info-lambda-list*
 319   '(&key join-class
 320          home-key
 321          foreign-key
 322          (key-join nil)
 323          (target-slot nil)
 324          (retrieval :immmediate)
 325          (set nil)))
 326
 327 (defun parse-db-info (db-info-list)
 328   (destructuring-bind
 329         (&key join-class home-key key-join foreign-key (delete-rule nil)
 330               (target-slot nil) (retrieval :deferred) (set t))
 331       db-info-list
 332     (let ((ih (make-hash-table :size 6)))
 333       (if join-class
 334           (setf (gethash :join-class ih) join-class)
 335           (error "Must specify :join-class in :db-info"))
 336       (if home-key
 337           (setf (gethash :home-key ih) home-key)
 338           (error "Must specify :home-key in :db-info"))
 339       (when delete-rule
 340         (setf (gethash :delete-rule ih) delete-rule))
 341       (if foreign-key
 342           (setf (gethash :foreign-key ih) foreign-key)
 343           (error "Must specify :foreign-key in :db-info"))
 344       (when key-join
 345         (setf (gethash :key-join ih) t))
 346       (when target-slot
 347         (setf (gethash :target-slot ih) target-slot))
 348       (when set
 349         (setf (gethash :set ih) set))
 350       (when retrieval
 351         (progn
 352           (setf (gethash :retrieval ih) retrieval)
 353           (if (eql retrieval :immediate)
 354               (setf (gethash :set ih) nil))))
 355       ih)))
 356
 357 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 358                                              standard-direct-slot-definition)
 359   ())
 360
 361 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 362                                                 standard-effective-slot-definition)
 363   ())
 364
 365 (defmethod direct-slot-definition-class ((class standard-db-class)
 366                                          #+kmr-normal-dsdc &rest
 367                                          initargs)
 368   (declare (ignore initargs))
 369   (find-class 'view-class-direct-slot-definition))
 370
 371 (defmethod effective-slot-definition-class ((class standard-db-class)
 372                                             #+kmr-normal-esdc &rest
 373                                             initargs)
 374   (declare (ignore initargs))
 375   (find-class 'view-class-effective-slot-definition))
 376
 377 #+openmcl
 378 (when (not (symbol-function 'compute-class-precedence-list))
 379   (eval
 380    (defun compute-class-precedence-list (class)
 381      (class-precedence-list class))))
 382
 383 #-mop-slot-order-reversed
 384 (defmethod compute-slots ((class standard-db-class))
 385   "Need to sort order of class slots so they are the same across
 386 implementations."
 387   (let ((slots (call-next-method))
 388         desired-sequence
 389         output-slots)
 390     (dolist (c (compute-class-precedence-list class))
 391       (dolist (s (class-direct-slots c))
 392         (let ((name (slot-definition-name s)))
 393           (unless (find name desired-sequence)
 394             (push name desired-sequence)))))
 395     (dolist (desired desired-sequence)
 396       (let ((slot (find desired slots :key #'slot-definition-name)))
 397         (assert slot)
 398         (push slot output-slots)))
 399     output-slots))
 400
 401 (defun compute-lisp-type-from-specified-type (specified-type db-constraints)
 402   "Computes the Lisp type for a user-specified type."
 403   (let ((type
 404          (cond
 405            ((consp specified-type)
 406             (let* ((first (first specified-type))
 407                    (name (etypecase first
 408                            (symbol (symbol-name first))
 409                            (string first))))
 410               (cond
 411                ((or (string-equal name "string")
 412                     (string-equal name "varchar")
 413                     (string-equal name "char"))
 414                 'string)
 415                (t
 416                 specified-type))))
 417            ((eq (ensure-keyword specified-type) :bigint)
 418             'integer)
 419            ((eq (ensure-keyword specified-type) :char)
 420             'character)
 421            ((eq (ensure-keyword specified-type) :varchar)
 422             'string)
 423            (t
 424             specified-type))))
 425     (if (and type (not (member :not-null (listify db-constraints))))
 426         `(or null ,type)
 427       type)))
 428
 429 ;; Compute the slot definition for slots in a view-class.  Figures out
 430 ;; what kind of database value (if any) is stored there, generates and
 431 ;; verifies the column name.
 432
 433 (declaim (inline delistify))
 434 (defun delistify (list)
 435   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 436   (if (listp list)
 437       (car list)
 438       list))
 439
 440 (declaim (inline delistify-dsd))
 441 (defun delistify-dsd (list)
 442   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 443   (if (and (listp list) (null (cdr list)))
 444       (car list)
 445       list))
 446
 447 (defmethod initialize-instance :around
 448     ((obj view-class-direct-slot-definition)
 449      &rest initargs &key db-constraints db-kind type &allow-other-keys)
 450   (when (and (not db-kind) (member :primary-key (listify db-constraints)))
 451     (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
 452           (slot-definition-name obj)))
 453   (apply #'call-next-method obj
 454          'specified-type type
 455          :type (compute-lisp-type-from-specified-type
 456                 type db-constraints)
 457          initargs))
 458
 459 (defmethod compute-effective-slot-definition ((class standard-db-class)
 460                                               #+kmr-normal-cesd slot-name
 461                                               direct-slots)
 462   #+kmr-normal-cesd (declare (ignore slot-name))
 463
 464   ;; KMR: store the user-specified type and then compute
 465   ;; real Lisp type and store it
 466   (let ((dsd (car direct-slots)))
 467     (let ((esd (call-next-method)))
 468       (typecase dsd
 469         (view-class-slot-definition-mixin
 470          ;; Use the specified :column argument if it is supplied, otherwise
 471          ;; the column slot is filled in with the slot-name,  but transformed
 472          ;; to be sql safe, - to _ and such.
 473          (setf (slot-value esd 'column)
 474            (column-name-from-arg
 475             (if (slot-boundp dsd 'column)
 476                 (delistify-dsd (view-class-slot-column dsd))
 477               (column-name-from-arg
 478                (sql-escape (slot-definition-name dsd))))))
 479
 480          (setf (slot-value esd 'db-type)
 481            (when (slot-boundp dsd 'db-type)
 482              (delistify-dsd
 483               (view-class-slot-db-type dsd))))
 484
 485          (setf (slot-value esd 'void-value)
 486                (delistify-dsd
 487                 (view-class-slot-void-value dsd)))
 488
 489          ;; :db-kind slot value defaults to :base (store slot value in
 490          ;; database)
 491
 492          (setf (slot-value esd 'db-kind)
 493            (if (slot-boundp dsd 'db-kind)
 494                (delistify-dsd (view-class-slot-db-kind dsd))
 495              :base))
 496
 497          (setf (slot-value esd 'db-reader)
 498            (when (slot-boundp dsd 'db-reader)
 499              (delistify-dsd (view-class-slot-db-reader dsd))))
 500          (setf (slot-value esd 'db-writer)
 501            (when (slot-boundp dsd 'db-writer)
 502              (delistify-dsd (view-class-slot-db-writer dsd))))
 503          (setf (slot-value esd 'db-constraints)
 504            (when (slot-boundp dsd 'db-constraints)
 505              (delistify-dsd (view-class-slot-db-constraints dsd))))
 506
 507          ;; I wonder if this slot option and the previous could be merged,
 508          ;; so that :base and :key remain keyword options, but :db-kind
 509          ;; :join becomes :db-kind (:join <db info .... >)?
 510
 511          (setf (slot-value esd 'db-info)
 512                (when (slot-boundp dsd 'db-info)
 513                  (let ((dsd-info (view-class-slot-db-info dsd)))
 514                    (cond
 515                      ((atom dsd-info)
 516                       dsd-info)
 517                      ((and (listp dsd-info) (> (length dsd-info) 1)
 518                            (atom (car dsd-info)))
 519                       (parse-db-info dsd-info))
 520                      ((and (listp dsd-info) (= 1 (length dsd-info))
 521                            (listp (car dsd-info)))
 522                       (parse-db-info (car dsd-info)))))))
 523
 524          (setf (specified-type esd)
 525                (delistify-dsd (specified-type dsd)))
 526
 527          )
 528         ;; all other slots
 529         (t
 530          (unless (typep esd 'view-class-effective-slot-definition)
 531            (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
 532
 533            (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
 534              #-openmcl (declare (ignore type-predicate))
 535              #-(or clisp sbcl)  (change-class esd 'view-class-effective-slot-definition
 536                                               #+allegro :name
 537                                               #+allegro (slot-definition-name dsd))
 538              #+openmcl (setf (slot-value esd 'ccl::type-predicate)
 539                              type-predicate)))
 540
 541          (setf (slot-value esd 'column)
 542            (column-name-from-arg
 543             (sql-escape (slot-definition-name dsd))))
 544
 545          (setf (slot-value esd 'db-info) nil)
 546          (setf (slot-value esd 'db-kind) :virtual)
 547          (setf (specified-type esd) (slot-definition-type dsd)))
 548         )
 549       esd)))
 550
 551 (defun slotdefs-for-slots-with-class (slots class)
 552   (let ((result nil))
 553     (dolist (s slots)
 554       (let ((c (slotdef-for-slot-with-class s class)))
 555         (if c (setf result (cons c result)))))
 556     result))
 557
 558 (defun slotdef-for-slot-with-class (slot class)
 559   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 560            (class-slots class)))
 561
 562 #+ignore
 563 (eval-when (:compile-toplevel :load-toplevel :execute)
 564   #+kmr-normal-cesd
 565   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 566   #+kmr-normal-dsdc
 567   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 568   #+kmr-normal-esdc
 569   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 570   )