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