sql/metaclasses.lisp

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