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
 319 (defparameter *db-info-lambda-list*
 320   '(&key join-class
 321          home-key
 322          foreign-key
 323          (key-join nil)
 324          (target-slot nil)
 325          (retrieval :immmediate)
 326          (set nil)))
 327
 328 (defun parse-db-info (db-info-list)
 329   (destructuring-bind
 330         (&key join-class home-key key-join foreign-key (delete-rule nil)
 331               (target-slot nil) (retrieval :deferred) (set t))
 332       db-info-list
 333     (let ((ih (make-hash-table :size 6)))
 334       (if join-class
 335           (setf (gethash :join-class ih) join-class)
 336           (error "Must specify :join-class in :db-info"))
 337       (if home-key
 338           (setf (gethash :home-key ih) home-key)
 339           (error "Must specify :home-key in :db-info"))
 340       (when delete-rule
 341         (setf (gethash :delete-rule ih) delete-rule))
 342       (if foreign-key
 343           (setf (gethash :foreign-key ih) foreign-key)
 344           (error "Must specify :foreign-key in :db-info"))
 345       (when key-join
 346         (setf (gethash :key-join ih) t))
 347       (when target-slot
 348         (setf (gethash :target-slot ih) target-slot))
 349       (when set
 350         (setf (gethash :set ih) set))
 351       (when retrieval
 352         (progn
 353           (setf (gethash :retrieval ih) retrieval)
 354           (if (eql retrieval :immediate)
 355               (setf (gethash :set ih) nil))))
 356       ih)))
 357
 358 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 359                                              standard-direct-slot-definition)
 360   ())
 361
 362 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 363                                                 standard-effective-slot-definition)
 364   ())
 365
 366 (defmethod direct-slot-definition-class ((class standard-db-class)
 367                                          #+kmr-normal-dsdc &rest
 368                                          initargs)
 369   (declare (ignore initargs))
 370   (find-class 'view-class-direct-slot-definition))
 371
 372 (defmethod effective-slot-definition-class ((class standard-db-class)
 373                                             #+kmr-normal-esdc &rest
 374                                             initargs)
 375   (declare (ignore initargs))
 376   (find-class 'view-class-effective-slot-definition))
 377
 378 #+openmcl
 379 (when (not (symbol-function 'compute-class-precedence-list))
 380   (eval
 381    (defun compute-class-precedence-list (class)
 382      (class-precedence-list class))))
 383
 384 #-mop-slot-order-reversed
 385 (defmethod compute-slots ((class standard-db-class))
 386   "Need to sort order of class slots so they are the same across
 387 implementations."
 388   (let ((slots (call-next-method))
 389         desired-sequence
 390         output-slots)
 391     (dolist (c (compute-class-precedence-list class))
 392       (dolist (s (class-direct-slots c))
 393         (let ((name (slot-definition-name s)))
 394           (unless (find name desired-sequence)
 395             (push name desired-sequence)))))
 396     (dolist (desired desired-sequence)
 397       (let ((slot (find desired slots :key #'slot-definition-name)))
 398         (assert slot)
 399         (push slot output-slots)))
 400     output-slots))
 401
 402 (defun compute-lisp-type-from-specified-type (specified-type db-constraints)
 403   "Computes the Lisp type for a user-specified type."
 404   (let ((type
 405          (cond
 406            ((consp specified-type)
 407             (let* ((first (first specified-type))
 408                    (name (etypecase first
 409                            (symbol (symbol-name first))
 410                            (string first))))
 411               (cond
 412                ((or (string-equal name "string")
 413                     (string-equal name "varchar")
 414                     (string-equal name "char"))
 415                 'string)
 416                (t
 417                 specified-type))))
 418            ((eq (ensure-keyword specified-type) :bigint)
 419             'integer)
 420            ((eq (ensure-keyword specified-type) :char)
 421             'character)
 422            ((eq (ensure-keyword specified-type) :varchar)
 423             'string)
 424            (t
 425             specified-type))))
 426     (if (and type (not (member :not-null (listify db-constraints))))
 427         `(or null ,type)
 428         (or type t))))
 429
 430 ;; Compute the slot definition for slots in a view-class.  Figures out
 431 ;; what kind of database value (if any) is stored there, generates and
 432 ;; verifies the column name.
 433
 434 (declaim (inline delistify))
 435 (defun delistify (list)
 436   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 437   (if (listp list)
 438       (car list)
 439       list))
 440
 441 (declaim (inline delistify-dsd))
 442 (defun delistify-dsd (list)
 443   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
 444   (if (and (listp list) (null (cdr list)))
 445       (car list)
 446       list))
 447
 448 (defmethod initialize-instance :around
 449     ((obj view-class-direct-slot-definition)
 450      &rest initargs &key db-constraints db-kind type &allow-other-keys)
 451   (when (and (not db-kind) (member :primary-key (listify db-constraints)))
 452     (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
 453           (slot-definition-name obj)))
 454   (apply #'call-next-method obj
 455          'specified-type type
 456          :type (if (and (eql db-kind :virtual) (null type))
 457                    t
 458                    (compute-lisp-type-from-specified-type
 459                     type db-constraints))
 460          initargs))
 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          ;; Use the specified :column argument if it is supplied, otherwise
 474          ;; the column slot is filled in with the slot-name,  but transformed
 475          ;; to be sql safe, - to _ and such.
 476          (setf (slot-value esd 'column)
 477            (column-name-from-arg
 478             (if (slot-boundp dsd 'column)
 479                 (delistify-dsd (view-class-slot-column dsd))
 480               (column-name-from-arg
 481                (sql-escape (slot-definition-name dsd))))))
 482
 483          (setf (slot-value esd 'db-type)
 484            (when (slot-boundp dsd 'db-type)
 485              (delistify-dsd
 486               (view-class-slot-db-type dsd))))
 487
 488          (setf (slot-value esd 'void-value)
 489                (delistify-dsd
 490                 (view-class-slot-void-value dsd)))
 491
 492          ;; :db-kind slot value defaults to :base (store slot value in
 493          ;; database)
 494
 495          (setf (slot-value esd 'db-kind)
 496            (if (slot-boundp dsd 'db-kind)
 497                (delistify-dsd (view-class-slot-db-kind dsd))
 498              :base))
 499
 500          (setf (slot-value esd 'db-reader)
 501            (when (slot-boundp dsd 'db-reader)
 502              (delistify-dsd (view-class-slot-db-reader dsd))))
 503          (setf (slot-value esd 'db-writer)
 504            (when (slot-boundp dsd 'db-writer)
 505              (delistify-dsd (view-class-slot-db-writer dsd))))
 506          (setf (slot-value esd 'db-constraints)
 507            (when (slot-boundp dsd 'db-constraints)
 508              (delistify-dsd (view-class-slot-db-constraints dsd))))
 509
 510          ;; I wonder if this slot option and the previous could be merged,
 511          ;; so that :base and :key remain keyword options, but :db-kind
 512          ;; :join becomes :db-kind (:join <db info .... >)?
 513
 514          (setf (slot-value esd 'db-info)
 515                (when (slot-boundp dsd 'db-info)
 516                  (let ((dsd-info (view-class-slot-db-info dsd)))
 517                    (cond
 518                      ((atom dsd-info)
 519                       dsd-info)
 520                      ((and (listp dsd-info) (> (length dsd-info) 1)
 521                            (atom (car dsd-info)))
 522                       (parse-db-info dsd-info))
 523                      ((and (listp dsd-info) (= 1 (length dsd-info))
 524                            (listp (car dsd-info)))
 525                       (parse-db-info (car dsd-info)))))))
 526
 527          (setf (specified-type esd)
 528                (delistify-dsd (specified-type dsd)))
 529
 530          )
 531         ;; all other slots
 532         (t
 533          (unless (typep esd 'view-class-effective-slot-definition)
 534            (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
 535
 536            (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
 537              #-openmcl (declare (ignore type-predicate))
 538              #-(or clisp sbcl)  (change-class esd 'view-class-effective-slot-definition
 539                                               #+allegro :name
 540                                               #+allegro (slot-definition-name dsd))
 541              #+openmcl (setf (slot-value esd 'ccl::type-predicate)
 542                              type-predicate)))
 543
 544          (setf (slot-value esd 'column)
 545            (column-name-from-arg
 546             (sql-escape (slot-definition-name dsd))))
 547
 548          (setf (slot-value esd 'db-info) nil)
 549          (setf (slot-value esd 'db-kind) :virtual)
 550          (setf (specified-type esd) (slot-definition-type dsd)))
 551         )
 552       esd)))
 553
 554 (defun slotdefs-for-slots-with-class (slots class)
 555   (let ((result nil))
 556     (dolist (s slots)
 557       (let ((c (slotdef-for-slot-with-class s class)))
 558         (if c (setf result (cons c result)))))
 559     result))
 560
 561 (defun slotdef-for-slot-with-class (slot class)
 562   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 563            (class-slots class)))
 564
 565 #+ignore
 566 (eval-when (:compile-toplevel :load-toplevel :execute)
 567   #+kmr-normal-cesd
 568   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 569   #+kmr-normal-dsdc
 570   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 571   #+kmr-normal-esdc
 572   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 573   )