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