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