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