usql/metaclasses.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; ======================================================================
   3 ;;;; File:    metaclasses.lisp
   4 ;;;; Updated: <04/04/2004 12:08:11 marcusp>
   5 ;;;; ======================================================================
   6 ;;;;
   7 ;;;; Description ==========================================================
   8 ;;;; ======================================================================
   9 ;;;;
  10 ;;;; CLSQL-USQL metaclass for standard-db-objects created in the OODDL.
  11 ;;;;
  12 ;;;; ======================================================================
  13
  14
  15 (in-package #:clsql-usql-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    (version
  49     :accessor object-version
  50     :initarg :version
  51     :initform 0)
  52    (key-slots
  53     :accessor key-slots
  54     :initform nil)
  55    (class-qualifier
  56     :accessor view-class-qualifier
  57     :initarg :qualifier
  58     :initform nil))
  59   (:documentation "VIEW-CLASS metaclass."))
  60
  61 #+lispworks
  62 (defmacro push-on-end (value location)
  63   `(setf ,location (nconc ,location (list ,value))))
  64
  65 ;; As Heiko Kirscke (author of PLOB!) would say:  !@##^@%! Lispworks!
  66 #+lispworks
  67 (defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
  68                                     :db-writer :db-type :db-info))
  69
  70 #+lispworks
  71 (define-setf-expander assoc (key alist &environment env)
  72   (multiple-value-bind (temps vals stores store-form access-form)
  73       (get-setf-expansion alist env)
  74     (let ((new-value (gensym "NEW-VALUE-"))
  75           (keyed (gensym "KEYED-"))
  76           (accessed (gensym "ACCESSED-"))
  77           (store-new-value (car stores)))
  78       (values (cons keyed temps)
  79               (cons key vals)
  80               `(,new-value)
  81               `(let* ((,accessed ,access-form)
  82                       (,store-new-value (assoc ,keyed ,accessed)))
  83                 (if ,store-new-value
  84                     (rplacd ,store-new-value ,new-value)
  85                     (progn
  86                       (setq ,store-new-value
  87                             (acons ,keyed ,new-value ,accessed))
  88                       ,store-form))
  89                 ,new-value)
  90               `(assoc ,new-value ,access-form)))))
  91
  92 #+lispworks
  93 (defmethod clos::canonicalize-defclass-slot :around
  94   ((prototype standard-db-class) slot)
  95  "\\lw\\ signals an error on unknown slot options; so this method
  96 removes any extra allowed options before calling the default method
  97 and returns the canonicalized extra options concatenated to the result
  98 of the default method.  The extra allowed options are the value of the
  99 \\fcite{+extra-slot-options+}."
 100   (let ((extra-slot-options ())
 101         (rest-options ())
 102         (result ()))
 103     (do ((olist (cdr slot) (cddr olist)))
 104         ((null olist))
 105       (let ((option (car olist)))
 106         (cond
 107          ((find option +extra-slot-options+)
 108           ;;(push (cons option (cadr olist)) extra-slot-options))
 109           (setf (assoc option extra-slot-options) (cadr olist)))
 110          (t
 111           (push (cadr olist) rest-options)
 112           (push (car olist) rest-options)))))
 113     (setf result (call-next-method prototype (cons (car slot) rest-options)))
 114     (dolist (option extra-slot-options)
 115       (push-on-end (car option) result)
 116       (push-on-end `(quote ,(cdr option)) result))
 117     result))
 118
 119 #+lispworks
 120 (defconstant +extra-class-options+ '(:base-table :version :schemas))
 121
 122 #+lispworks
 123 (defmethod clos::canonicalize-class-options :around
 124     ((prototype standard-db-class) class-options)
 125   "\\lw\\ signals an error on unknown class options; so this method
 126 removes any extra allowed options before calling the default method
 127 and returns the canonicalized extra options concatenated to the result
 128 of the default method.  The extra allowed options are the value of the
 129 \\fcite{+extra-class-options+}."
 130   (let ((extra-class-options nil)
 131         (rest-options ())
 132         (result ()))
 133     (dolist (o class-options)
 134       (let ((option (car o)))
 135         (cond
 136          ((find option +extra-class-options+)
 137           ;;(push (cons option (cadr o)) extra-class-options))
 138           (setf (assoc option extra-class-options) (cadr o)))
 139          (t
 140           (push o rest-options)))))
 141     (setf result (call-next-method prototype rest-options))
 142     (dolist (option extra-class-options)
 143       (push-on-end (car option) result)
 144       (push-on-end `(quote ,(cdr option)) result))
 145     result))
 146
 147
 148 #+(or cmu scl sbcl openmcl)
 149 (defmethod validate-superclass ((class standard-db-class)
 150                                 (superclass standard-class))
 151   t)
 152
 153 (defun table-name-from-arg (arg)
 154   (cond ((symbolp arg)
 155          arg)
 156         ((typep arg 'sql-ident)
 157          (slot-value arg 'name))
 158         ((stringp arg)
 159          (intern (string-upcase arg)))))
 160
 161 (defun column-name-from-arg (arg)
 162   (cond ((symbolp arg)
 163          arg)
 164         ((typep arg 'sql-ident)
 165          (slot-value arg 'name))
 166         ((stringp arg)
 167          (intern (string-upcase arg)))))
 168
 169
 170 (defun remove-keyword-arg (arglist akey)
 171   (let ((mylist arglist)
 172         (newlist ()))
 173     (labels ((pop-arg (alist)
 174              (let ((arg (pop alist))
 175                    (val (pop alist)))
 176                (unless (equal arg akey)
 177                  (setf newlist (append (list arg val) newlist)))
 178                (when alist (pop-arg alist)))))
 179       (pop-arg mylist))
 180     newlist))
 181
 182 (defmethod initialize-instance :around ((class standard-db-class)
 183                                         &rest all-keys
 184                                         &key direct-superclasses base-table
 185                                         schemas version qualifier
 186                                         &allow-other-keys)
 187   (let ((root-class (find-class 'standard-db-object nil))
 188         (vmc (find-class 'standard-db-class)))
 189     (setf (view-class-qualifier class)
 190           (car qualifier))
 191     (if root-class
 192         (if (member-if #'(lambda (super)
 193                            (eq (class-of super) vmc)) direct-superclasses)
 194             (call-next-method)
 195             (apply #'call-next-method
 196                    class
 197                    :direct-superclasses (append (list root-class)
 198                                                 direct-superclasses)
 199                    (remove-keyword-arg all-keys :direct-superclasses)))
 200         (call-next-method))
 201     (setf (view-table class)
 202           (table-name-from-arg (sql-escape (or (and base-table
 203                                                     (if (listp base-table)
 204                                                         (car base-table)
 205                                                         base-table))
 206                                                (class-name class)))))
 207     (setf (object-version class) version)
 208     (mapc (lambda (schema)
 209             (pushnew (class-name class) (gethash schema *object-schemas*)))
 210           (if (listp schemas) schemas (list schemas)))
 211     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 212                                    all-keys))))
 213
 214 (defmethod reinitialize-instance :around ((class standard-db-class)
 215                                           &rest all-keys
 216                                           &key base-table schemas version
 217                                           direct-superclasses qualifier
 218                                           &allow-other-keys)
 219   (let ((root-class (find-class 'standard-db-object nil))
 220         (vmc (find-class 'standard-db-class)))
 221     (setf (view-table class)
 222           (table-name-from-arg (sql-escape (or (and base-table
 223                                                     (if (listp base-table)
 224                                                         (car base-table)
 225                                                         base-table))
 226                                                (class-name class)))))
 227     (setf (view-class-qualifier class)
 228           (car qualifier))
 229     (if (and root-class (not (equal class root-class)))
 230         (if (member-if #'(lambda (super)
 231                            (eq (class-of super) vmc)) direct-superclasses)
 232             (call-next-method)
 233             (apply #'call-next-method
 234                    class
 235                    :direct-superclasses (append (list root-class)
 236                                                 direct-superclasses)
 237                    (remove-keyword-arg all-keys :direct-superclasses)))
 238         (call-next-method)))
 239   (setf (object-version class) version)
 240   (mapc (lambda (schema)
 241           (pushnew (class-name class) (gethash schema *object-schemas*)))
 242         (if (listp schemas) schemas (list schemas)))
 243   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
 244                                  all-keys)))
 245
 246
 247 (defun get-keywords (keys list)
 248   (flet ((extract (key)
 249            (let ((pos (position key list)))
 250              (when pos
 251                (nth (1+ pos) list)))))
 252     (mapcar #'extract keys)))
 253
 254 (defun describe-db-layout (class)
 255   (flet ((not-db-col (col)
 256            (not (member (nth 2 col)  '(nil :base :key))))
 257          (frob-slot (slot)
 258            (let ((type (slot-value slot 'type)))
 259              (if (eq type t)
 260                  (setq type nil))
 261              (list (slot-value slot 'name)
 262                    type
 263                    (slot-value slot 'db-kind)
 264                    (and (slot-boundp slot 'column)
 265                         (slot-value slot 'column))))))
 266     (let ((all-slots (mapcar #'frob-slot (class-slots class))))
 267       (setq all-slots (remove-if #'not-db-col all-slots))
 268       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 269       ;;(mapcar #'dink-type all-slots)
 270       all-slots)))
 271
 272 (defun register-metaclass (class slots)
 273   (labels ((not-db-col (col)
 274              (not (member (nth 2 col)  '(nil :base :key))))
 275            (frob-slot (slot)
 276              (get-keywords '(:name :type :db-kind :column) slot)))
 277     (let ((all-slots (mapcar #'frob-slot slots)))
 278       (setq all-slots (remove-if #'not-db-col all-slots))
 279       (setq all-slots (stable-sort all-slots #'string< :key #'car))
 280       (setf (object-definition class) all-slots
 281             (key-slots class) (remove-if-not (lambda (slot)
 282                                                (eql (slot-value slot 'db-kind)
 283                                                     :key))
 284                                              (class-slots class))))))
 285
 286 #+allegro
 287 (defmethod finalize-inheritance :after ((class standard-db-class))
 288   (setf (key-slots class) (remove-if-not (lambda (slot)
 289                                            (eql (slot-value slot 'db-kind)
 290                                                 :key))
 291                                          (class-slots class))))
 292
 293 ;; return the deepest view-class ancestor for a given view class
 294
 295 (defun base-db-class (classname)
 296   (let* ((class (find-class classname))
 297          (db-class (find-class 'standard-db-object)))
 298     (loop
 299      (let ((cds (class-direct-superclasses class)))
 300        (cond ((null cds)
 301               (error "not a db class"))
 302              ((member db-class cds)
 303               (return (class-name class))))
 304        (setq class (car cds))))))
 305
 306 (defun db-ancestors (classname)
 307   (let ((class (find-class classname))
 308         (db-class (find-class 'standard-db-object)))
 309     (labels ((ancestors (class)
 310              (let ((scs (class-direct-superclasses class)))
 311                (if (member db-class scs)
 312                    (list class)
 313                    (append (list class) (mapcar #'ancestors scs))))))
 314       (ancestors class))))
 315
 316 (defclass view-class-slot-definition-mixin ()
 317   ((column
 318     :accessor view-class-slot-column
 319     :initarg :column
 320     :documentation
 321     "The name of the SQL column this slot is stored in.  Defaults to
 322 the slot name.")
 323    (db-kind
 324     :accessor view-class-slot-db-kind
 325     :initarg :db-kind
 326     :initform :base
 327     :type keyword
 328     :documentation
 329     "The kind of DB mapping which is performed for this slot.  :base
 330 indicates the slot maps to an ordinary column of the DB view.  :key
 331 indicates that this slot corresponds to part of the unique keys for
 332 this view, :join indicates ... and :virtual indicates that this slot
 333 is an ordinary CLOS slot.  Defaults to :base.")
 334    (db-reader
 335     :accessor view-class-slot-db-reader
 336     :initarg :db-reader
 337     :initform nil
 338     :documentation
 339     "If a string, then when reading values from the DB, the string
 340 will be used for a format string, with the only value being the value
 341 from the database.  The resulting string will be used as the slot
 342 value.  If a function then it will take one argument, the value from
 343 the database, and return the value that should be put into the slot.")
 344    (db-writer
 345     :accessor view-class-slot-db-writer
 346     :initarg :db-writer
 347     :initform nil
 348     :documentation
 349     "If a string, then when reading values from the slot for the DB,
 350 the string will be used for a format string, with the only value being
 351 the value of the slot.  The resulting string will be used as the
 352 column value in the DB.  If a function then it will take one argument,
 353 the value of the slot, and return the value that should be put into
 354 the database.")
 355    (db-type
 356     :accessor view-class-slot-db-type
 357     :initarg :db-type
 358     :initform nil
 359     :documentation
 360     "A string which will be used as the type specifier for this slots
 361 column definition in the database.")
 362    (db-constraints
 363     :accessor view-class-slot-db-constraints
 364     :initarg :db-constraints
 365     :initform nil
 366     :documentation
 367     "A single constraint or list of constraints for this column")
 368    (nulls-ok
 369     :accessor view-class-slot-nulls-ok
 370     :initarg :nulls-ok
 371     :initform nil
 372     :documentation
 373     "If t, all sql NULL values retrieved from the database become nil; if nil,
 374 all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 375    (db-info
 376     :accessor view-class-slot-db-info
 377     :initarg :db-info
 378     :documentation "Description of the join.")))
 379
 380 (defparameter *db-info-lambda-list*
 381   '(&key join-class
 382          home-key
 383          foreign-key
 384          (key-join nil)
 385          (target-slot nil)
 386          (retrieval :immmediate)
 387          (set nil)))
 388
 389 (defun parse-db-info (db-info-list)
 390   (destructuring-bind
 391         (&key join-class home-key key-join foreign-key (delete-rule nil)
 392               (target-slot nil) (retrieval :deferred) (set nil))
 393       db-info-list
 394     (let ((ih (make-hash-table :size 6)))
 395       (if join-class
 396           (setf (gethash :join-class ih) join-class)
 397           (error "Must specify :join-class in :db-info"))
 398       (if home-key
 399           (setf (gethash :home-key ih) home-key)
 400           (error "Must specify :home-key in :db-info"))
 401       (when delete-rule
 402         (setf (gethash :delete-rule ih) delete-rule))
 403       (if foreign-key
 404           (setf (gethash :foreign-key ih) foreign-key)
 405           (error "Must specify :foreign-key in :db-info"))
 406       (when key-join
 407         (setf (gethash :key-join ih) t))
 408       (when target-slot
 409         (setf (gethash :target-slot ih) target-slot))
 410       (when set
 411         (setf (gethash :set ih) set))
 412       (when retrieval
 413         (progn
 414           (setf (gethash :retrieval ih) retrieval)
 415           (if (eql retrieval :immediate)
 416               (setf (gethash :set ih) nil))))
 417       ih)))
 418
 419 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
 420                                              standard-direct-slot-definition)
 421   ())
 422
 423 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
 424                                                 standard-effective-slot-definition)
 425   ())
 426
 427 (defmethod direct-slot-definition-class ((class standard-db-class)
 428                                          #+kmr-normal-dsdc &rest
 429                                          initargs)
 430   (declare (ignore initargs))
 431   (find-class 'view-class-direct-slot-definition))
 432
 433 (defmethod effective-slot-definition-class ((class standard-db-class)
 434                                             #+kmr-normal-esdc &rest
 435                                             initargs)
 436   (declare (ignore initargs))
 437   (find-class 'view-class-effective-slot-definition))
 438
 439 ;; Compute the slot definition for slots in a view-class.  Figures out
 440 ;; what kind of database value (if any) is stored there, generates and
 441 ;; verifies the column name.
 442
 443 (defmethod compute-effective-slot-definition ((class standard-db-class)
 444                                               #+kmr-normal-cesd slot-name
 445                                               direct-slots)
 446   #+kmr-normal-cesd (declare (ignore slot-name))
 447   (let ((slotd (call-next-method))
 448         (sd (car direct-slots)))
 449
 450     (typecase sd
 451       (view-class-slot-definition-mixin
 452        ;; Use the specified :column argument if it is supplied, otherwise
 453        ;; the column slot is filled in with the slot-name,  but transformed
 454        ;; to be sql safe, - to _ and such.
 455        (setf (slot-value slotd 'column)
 456              (column-name-from-arg
 457               (if (slot-boundp sd 'column)
 458                   (view-class-slot-column sd)
 459                   (column-name-from-arg
 460                    (sql-escape (slot-definition-name sd))))))
 461
 462        (setf (slot-value slotd 'db-type)
 463              (when (slot-boundp sd 'db-type)
 464                (view-class-slot-db-type sd)))
 465
 466
 467        (setf (slot-value slotd 'nulls-ok)
 468              (view-class-slot-nulls-ok sd))
 469
 470        ;; :db-kind slot value defaults to :base (store slot value in
 471        ;; database)
 472
 473        (setf (slot-value slotd 'db-kind)
 474              (if (slot-boundp sd 'db-kind)
 475                  (view-class-slot-db-kind sd)
 476                  :base))
 477
 478        (setf (slot-value slotd 'db-writer)
 479              (when (slot-boundp sd 'db-writer)
 480                (view-class-slot-db-writer sd)))
 481        (setf (slot-value slotd 'db-constraints)
 482              (when (slot-boundp sd 'db-constraints)
 483                (view-class-slot-db-constraints sd)))
 484
 485
 486        ;; I wonder if this slot option and the previous could be merged,
 487        ;; so that :base and :key remain keyword options, but :db-kind
 488        ;; :join becomes :db-kind (:join <db info .... >)?
 489
 490        (setf (slot-value slotd 'db-info)
 491              (when (slot-boundp sd 'db-info)
 492                (if (listp (view-class-slot-db-info sd))
 493                    (parse-db-info (view-class-slot-db-info sd))
 494                    (view-class-slot-db-info sd)))))
 495       ;; all other slots
 496       (t
 497        (change-class slotd 'view-class-effective-slot-definition)
 498        (setf (slot-value slotd 'column)
 499              (column-name-from-arg
 500               (sql-escape (slot-definition-name sd))))
 501
 502        (setf (slot-value slotd 'db-info) nil)
 503        (setf (slot-value slotd 'db-kind)
 504              :virtual)))
 505     slotd))
 506
 507 (defun slotdefs-for-slots-with-class (slots class)
 508   (let ((result nil))
 509     (dolist (s slots)
 510       (let ((c (slotdef-for-slot-with-class s class)))
 511         (if c (setf result (cons c result)))))
 512     result))
 513
 514 (defun slotdef-for-slot-with-class (slot class)
 515   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 516            (class-slots class)))
 517
 518 #+ignore
 519 (eval-when (:compile-toplevel :load-toplevel :execute)
 520   #+kmr-normal-cesd
 521   (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
 522   #+kmr-normal-dsdc
 523   (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
 524   #+kmr-normal-esdc
 525   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
 526   )