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