X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=1fde1eef9f2319b7045396d3d113b0f51bf1a17a;hp=594211c08bda72b95db783aa55f8d8292d38ff45;hb=39e2802cd264ddacb3ca59b3b2c5c38f202149de;hpb=f6ab1b1e5f2cac1257f2a37de4260840c3204d51

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 594211c..1fde1ee 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -1,8 +1,6 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
-;;;; $Id$
-;;;;
 ;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
 ;;;;
 ;;;; This file is part of CLSQL.
@@ -16,21 +14,21 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'compute-effective-slot-definition)))
-	    3)
+                     (ensure-generic-function
+                      'compute-effective-slot-definition)))
+            3)
     (pushnew :kmr-normal-cesd cl:*features*))
 
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'direct-slot-definition-class)))
-	    3)
+                     (ensure-generic-function
+                      'direct-slot-definition-class)))
+            3)
     (pushnew :kmr-normal-dsdc cl:*features*))
 
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'effective-slot-definition-class)))
-	    3)
+                     (ensure-generic-function
+                      'effective-slot-definition-class)))
+            3)
     (pushnew :kmr-normal-esdc cl:*features*)))
 
 
@@ -48,6 +46,9 @@
    (key-slots
     :accessor key-slots
     :initform nil)
+   (normalizedp
+    :accessor normalizedp
+    :initform nil)
    (class-qualifier
     :accessor view-class-qualifier
     :initarg :qualifier
@@ -57,7 +58,7 @@
 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
 
 (defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints
-			       :db-writer :db-info))
+                               :db-writer :db-info))
 (defvar +extra-class-options+ '(:base-table))
 
 #+lispworks
@@ -69,90 +70,83 @@
   (eval `(process-class-option standard-db-class ,class-option)))
 
 (defmethod validate-superclass ((class standard-db-class)
-				(superclass standard-class))
+                                (superclass standard-class))
   t)
 
 (defun table-name-from-arg (arg)
   (cond ((symbolp arg)
-	 arg)
-	((typep arg 'sql-ident)
-	 (slot-value arg 'name))
-	((stringp arg)
-	 (intern arg))))
-
-(defun column-name-from-arg (arg)
-  (cond ((symbolp arg)
-	 arg)
-	((typep arg 'sql-ident)
-	 (slot-value arg 'name))
-	((stringp arg)
-	 (intern (symbol-name-default-case arg)))))
-
+         (intern (sql-escape arg)))
+        ((typep arg 'sql-ident)
+         (if (symbolp (slot-value arg 'name))
+             (intern (sql-escape (slot-value arg 'name)))
+             (sql-escape (slot-value arg 'name))))
+        ((stringp arg)
+         (sql-escape arg))))
 
 (defun remove-keyword-arg (arglist akey)
   (let ((mylist arglist)
-	(newlist ()))
+        (newlist ()))
     (labels ((pop-arg (alist)
-	     (let ((arg (pop alist))
-		   (val (pop alist)))
-	       (unless (equal arg akey)
-		 (setf newlist (append (list arg val) newlist)))
-	       (when alist (pop-arg alist)))))
+             (let ((arg (pop alist))
+                   (val (pop alist)))
+               (unless (equal arg akey)
+                 (setf newlist (append (list arg val) newlist)))
+               (when alist (pop-arg alist)))))
       (pop-arg mylist))
     newlist))
 
+(defun set-view-table-slot (class base-table)
+  (setf (view-table class)
+        (table-name-from-arg (or (and base-table
+                                      (if (listp base-table)
+                                          (car base-table)
+                                          base-table))
+                                 (class-name class)))))
+
 (defmethod initialize-instance :around ((class standard-db-class)
                                         &rest all-keys
-					&key direct-superclasses base-table
-                                        qualifier
-					&allow-other-keys)
+                                        &key direct-superclasses base-table
+                                        qualifier normalizedp
+                                        &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc 'standard-db-class))
+        (vmc 'standard-db-class))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if root-class
-	(if (some #'(lambda (super) (typep super vmc))
+        (if (some #'(lambda (super) (typep super vmc))
                   direct-superclasses)
-	    (call-next-method)
+            (call-next-method)
             (apply #'call-next-method
                    class
-		   :direct-superclasses (append (list root-class)
+                   :direct-superclasses (append (list root-class)
                                                 direct-superclasses)
-		   (remove-keyword-arg all-keys :direct-superclasses)))
-	(call-next-method))
-    (setf (view-table class)
-          (table-name-from-arg (sql-escape (or (and base-table
-                                                    (if (listp base-table)
-                                                        (car base-table)
-                                                        base-table))
-                                               (class-name class)))))
+                   (remove-keyword-arg all-keys :direct-superclasses)))
+        (call-next-method))
+    (set-view-table-slot class base-table)
+    (setf (normalizedp class) (car normalizedp))
     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
                                    all-keys))))
 
 (defmethod reinitialize-instance :around ((class standard-db-class)
                                           &rest all-keys
-                                          &key base-table
+                                          &key base-table normalizedp
                                           direct-superclasses qualifier
                                           &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc 'standard-db-class))
-    (setf (view-table class)
-          (table-name-from-arg (sql-escape (or (and base-table
-                                                    (if (listp base-table)
-                                                        (car base-table)
-                                                        base-table))
-                                               (class-name class)))))
+        (vmc 'standard-db-class))
+    (set-view-table-slot class base-table)
+    (setf (normalizedp class) (car normalizedp))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if (and root-class (not (equal class root-class)))
-	(if (some #'(lambda (super) (typep super vmc))
+        (if (some #'(lambda (super) (typep super vmc))
                   direct-superclasses)
-	    (call-next-method)
+            (call-next-method)
             (apply #'call-next-method
                    class
                    :direct-superclasses (append (list root-class)
                                                 direct-superclasses)
-		   (remove-keyword-arg all-keys :direct-superclasses)))
+                   (remove-keyword-arg all-keys :direct-superclasses)))
         (call-next-method)))
   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
                                  all-keys)))
@@ -192,18 +186,18 @@
       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       (setf (object-definition class) all-slots))
-    #-allegro
+    #-(or sbcl allegro)
     (setf (key-slots class) (remove-if-not (lambda (slot)
-					     (eql (slot-value slot 'db-kind)
-						  :key))
-					   (ordered-class-slots class)))))
+                                             (eql (slot-value slot 'db-kind)
+                                                  :key))
+                                           (slots-for-possibly-normalized-class class)))))
 
-#+allegro
+#+(or sbcl allegro)
 (defmethod finalize-inheritance :after ((class standard-db-class))
   (setf (key-slots class) (remove-if-not (lambda (slot)
-					   (eql (slot-value slot 'db-kind)
-						:key))
-					 (ordered-class-slots class))))
+                                           (eql (slot-value slot 'db-kind)
+                                                :key))
+                                         (slots-for-possibly-normalized-class class))))
 
 ;; return the deepest view-class ancestor for a given view class
 
@@ -294,54 +288,61 @@ column definition in the database.")
     :documentation "Description of the join.")
    (specified-type
     :accessor specified-type
+    :initarg specified-type
+    :initform nil
+    :documentation "Internal slot storing the :type specified by user.")
+   (autoincrement-sequence
+    :accessor view-class-slot-autoincrement-sequence
+    :initarg :autoincrement-sequence
     :initform nil
-    :documentation "KMR: Internal slot storing the :type specified by user.")))
+    :documentation "A string naming the (possibly automatically generated) sequence
+for a slot with an :auto-increment constraint.")))
 
 (defparameter *db-info-lambda-list*
   '(&key join-class
-	 home-key
-	 foreign-key
+         home-key
+         foreign-key
          (key-join nil)
          (target-slot nil)
-	 (retrieval :immmediate)
-	 (set nil)))
+         (retrieval :immmediate)
+         (set nil)))
 
 (defun parse-db-info (db-info-list)
   (destructuring-bind
-	(&key join-class home-key key-join foreign-key (delete-rule nil)
-	      (target-slot nil) (retrieval :deferred) (set t))
+        (&key join-class home-key key-join foreign-key (delete-rule nil)
+              (target-slot nil) (retrieval :deferred) (set t))
       db-info-list
     (let ((ih (make-hash-table :size 6)))
       (if join-class
-	  (setf (gethash :join-class ih) join-class)
-	  (error "Must specify :join-class in :db-info"))
+          (setf (gethash :join-class ih) join-class)
+          (error "Must specify :join-class in :db-info"))
       (if home-key
-	  (setf (gethash :home-key ih) home-key)
-	  (error "Must specify :home-key in :db-info"))
+          (setf (gethash :home-key ih) home-key)
+          (error "Must specify :home-key in :db-info"))
       (when delete-rule
-	(setf (gethash :delete-rule ih) delete-rule))
+        (setf (gethash :delete-rule ih) delete-rule))
       (if foreign-key
-	  (setf (gethash :foreign-key ih) foreign-key)
-	  (error "Must specify :foreign-key in :db-info"))
+          (setf (gethash :foreign-key ih) foreign-key)
+          (error "Must specify :foreign-key in :db-info"))
       (when key-join
         (setf (gethash :key-join ih) t))
       (when target-slot
-	(setf (gethash :target-slot ih) target-slot))
+        (setf (gethash :target-slot ih) target-slot))
       (when set
-	(setf (gethash :set ih) set))
+        (setf (gethash :set ih) set))
       (when retrieval
-	(progn
-	  (setf (gethash :retrieval ih) retrieval)
-	  (if (eql retrieval :immediate)
-	      (setf (gethash :set ih) nil))))
+        (progn
+          (setf (gethash :retrieval ih) retrieval)
+          (if (eql retrieval :immediate)
+              (setf (gethash :set ih) nil))))
       ih)))
 
 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
-					     standard-direct-slot-definition)
+                                             standard-direct-slot-definition)
   ())
 
 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
-						standard-effective-slot-definition)
+                                                standard-effective-slot-definition)
   ())
 
 (defmethod direct-slot-definition-class ((class standard-db-class)
@@ -351,8 +352,8 @@ column definition in the database.")
   (find-class 'view-class-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class standard-db-class)
-					    #+kmr-normal-esdc &rest
-					    initargs)
+                                            #+kmr-normal-esdc &rest
+                                            initargs)
   (declare (ignore initargs))
   (find-class 'view-class-effective-slot-definition))
 
@@ -367,40 +368,35 @@ column definition in the database.")
   "Need to sort order of class slots so they are the same across
 implementations."
   (let ((slots (call-next-method))
-	desired-sequence
-	output-slots)
+        desired-sequence
+        output-slots)
     (dolist (c (compute-class-precedence-list class))
       (dolist (s (class-direct-slots c))
-	(let ((name (slot-definition-name s)))
-	  (unless (find name desired-sequence)
-	    (push name desired-sequence)))))
+        (let ((name (slot-definition-name s)))
+          (unless (find name desired-sequence)
+            (push name desired-sequence)))))
     (dolist (desired desired-sequence)
       (let ((slot (find desired slots :key #'slot-definition-name)))
-	(assert slot)
-	(push slot output-slots)))
+        (assert slot)
+        (push slot output-slots)))
     output-slots))
 
-(defun compute-lisp-type-from-slot-specification (slotd specified-type)
-  "Computes the Lisp type for a user-specified type. Needed for OpenMCL
-which does type checking before storing a value in a slot."
-  ;; This function is called after the base compute-effective-slots is called.
-  ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
-  ;; so we have to override the type-predicates here
+(defun compute-lisp-type-from-specified-type (specified-type db-constraints)
+  "Computes the Lisp type for a user-specified type."
   (let ((type
          (cond
            ((consp specified-type)
-            (cond
-              ((and (symbolp (car specified-type))
-                    (string-equal (symbol-name (car specified-type)) "string"))
-               'string)
-              ((and (symbolp (car specified-type))
-                    (string-equal (symbol-name (car specified-type)) "varchar"))
-               'string)
-              ((and (symbolp (car specified-type))
-                    (string-equal (symbol-name (car specified-type)) "char"))
-               'string)
-              (t
-               specified-type)))
+            (let* ((first (first specified-type))
+                   (name (etypecase first
+                           (symbol (symbol-name first))
+                           (string first))))
+              (cond
+               ((or (string-equal name "string")
+                    (string-equal name "varchar")
+                    (string-equal name "char"))
+                'string)
+               (t
+                specified-type))))
            ((eq (ensure-keyword specified-type) :bigint)
             'integer)
            ((eq (ensure-keyword specified-type) :char)
@@ -408,11 +404,10 @@ which does type checking before storing a value in a slot."
            ((eq (ensure-keyword specified-type) :varchar)
             'string)
            (t
-            specified-type)))
-        (constraints (slot-value slotd 'db-constraints)))
-    (if (and type (not (member :not-null (listify constraints))))
+            specified-type))))
+    (if (and type (not (member :not-null (listify db-constraints))))
         `(or null ,type)
-        type)))
+        (or type t))))
 
 ;; Compute the slot definition for slots in a view-class.  Figures out
 ;; what kind of database value (if any) is stored there, generates and
@@ -426,122 +421,130 @@ which does type checking before storing a value in a slot."
       list))
 
 (declaim (inline delistify-dsd))
-(defun delistify-dsd (list)
-  "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
-  (if (and (listp list) (null (cdr list)))
-      (car list)
-      list))
-
-(defvar *impl-type-attrib-name* #-clisp 'type #+clisp 'clos::$type)
+;; there is an :after method below too
+(defmethod initialize-instance :around
+    ((obj view-class-direct-slot-definition)
+     &rest initargs &key db-constraints db-kind type &allow-other-keys)
+  (when (and (not db-kind) (member :primary-key (listify db-constraints)))
+    (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
+          (slot-definition-name obj)))
+  (apply #'call-next-method obj
+         'specified-type type
+         :type (if (and (eql db-kind :virtual) (null type))
+                   t
+                   (compute-lisp-type-from-specified-type
+                    type db-constraints))
+         initargs))
+
+(defun compute-column-name (arg)
+  (database-identifier arg nil))
+
+(defun %convert-db-info-to-hash (slot-def)
+  ;; I wonder if this slot option and the previous could be merged,
+  ;; so that :base and :key remain keyword options, but :db-kind
+  ;; :join becomes :db-kind (:join <db info .... >)?
+  (setf (slot-value slot-def 'db-info)
+        (when (slot-boundp slot-def 'db-info)
+          (let ((info (view-class-slot-db-info slot-def)))
+            (etypecase info
+              (hash-table info)
+              (atom info)
+              (list
+               (cond ((and (> (length info) 1)
+                           (atom (car info)))
+                      (parse-db-info info))
+                     ((and (= 1 (length info))
+                           (listp (car info)))
+                      (parse-db-info (car info)))
+                     (t info))))))))
+
+(defmethod initialize-instance :after
+    ((obj view-class-direct-slot-definition)
+     &key &allow-other-keys)
+  (setf (view-class-slot-column obj) (compute-column-name obj)
+        (view-class-slot-autoincrement-sequence obj)
+        (dequote
+         (view-class-slot-autoincrement-sequence obj)))
+  (%convert-db-info-to-hash obj))
 
 (defmethod compute-effective-slot-definition ((class standard-db-class)
-					      #+kmr-normal-cesd slot-name
-					      direct-slots)
+                                              #+kmr-normal-cesd slot-name
+                                              direct-slots)
   #+kmr-normal-cesd (declare (ignore slot-name))
 
   ;; KMR: store the user-specified type and then compute
   ;; real Lisp type and store it
   (let ((dsd (car direct-slots)))
-    (when (and (typep dsd 'view-class-slot-definition-mixin)
-	       (null (specified-type dsd)))
-      (setf (specified-type dsd)
-	(slot-definition-type dsd))
-      (setf #-(or clisp sbcl) (slot-value dsd 'type)
-	    #+(or clisp sbcl) (slot-definition-type dsd)
-	    (compute-lisp-type-from-slot-specification
-	     dsd (slot-definition-type dsd))))
-
     (let ((esd (call-next-method)))
       (typecase dsd
-	(view-class-slot-definition-mixin
-	 ;; Use the specified :column argument if it is supplied, otherwise
-	 ;; the column slot is filled in with the slot-name,  but transformed
-	 ;; to be sql safe, - to _ and such.
-	 (setf (slot-value esd 'column)
-	   (column-name-from-arg
-	    (if (slot-boundp dsd 'column)
-		(delistify-dsd (view-class-slot-column dsd))
-	      (column-name-from-arg
-	       (sql-escape (slot-definition-name dsd))))))
-
-	 (setf (slot-value esd 'db-type)
-	   (when (slot-boundp dsd 'db-type)
-	     (delistify-dsd
-	      (view-class-slot-db-type dsd))))
-
-	 (setf (slot-value esd 'void-value)
-	       (delistify-dsd
-		(view-class-slot-void-value dsd)))
-
-	 ;; :db-kind slot value defaults to :base (store slot value in
-	 ;; database)
-
-	 (setf (slot-value esd 'db-kind)
-	   (if (slot-boundp dsd 'db-kind)
-	       (delistify-dsd (view-class-slot-db-kind dsd))
-	     :base))
-
-	 (setf (slot-value esd 'db-reader)
-	   (when (slot-boundp dsd 'db-reader)
-	     (delistify-dsd (view-class-slot-db-reader dsd))))
-	 (setf (slot-value esd 'db-writer)
-	   (when (slot-boundp dsd 'db-writer)
-	     (delistify-dsd (view-class-slot-db-writer dsd))))
-	 (setf (slot-value esd 'db-constraints)
-	   (when (slot-boundp dsd 'db-constraints)
-	     (delistify-dsd (view-class-slot-db-constraints dsd))))
-
-	 ;; I wonder if this slot option and the previous could be merged,
-	 ;; so that :base and :key remain keyword options, but :db-kind
-	 ;; :join becomes :db-kind (:join <db info .... >)?
-
-	 (setf (slot-value esd 'db-info)
-	       (when (slot-boundp dsd 'db-info)
-		 (let ((dsd-info (view-class-slot-db-info dsd)))
-		   (cond
-		     ((atom dsd-info)
-		      dsd-info)
-		     ((and (listp dsd-info) (> (length dsd-info) 1)
-			   (atom (car dsd-info)))
-		      (parse-db-info dsd-info))
-		     ((and (listp dsd-info) (= 1 (length dsd-info))
-			   (listp (car dsd-info)))
-		      (parse-db-info (car dsd-info)))))))
-
-	 (setf (specified-type esd)
-	       (delistify-dsd (specified-type dsd)))
-
-	 )
-	;; all other slots
-	(t
-	 (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
-	   #-openmcl (declare (ignore type-predicate))
-	   #-(or clisp sbcl)  (change-class esd 'view-class-effective-slot-definition
-				 #+allegro :name
-				 #+allegro (slot-definition-name dsd))
-	   #+openmcl (setf (slot-value esd 'ccl::type-predicate)
-			   type-predicate))
-
-	 (setf (slot-value esd 'column)
-	   (column-name-from-arg
-	    (sql-escape (slot-definition-name dsd))))
-
-	 (setf (slot-value esd 'db-info) nil)
-	 (setf (slot-value esd 'db-kind) :virtual)
-	 (setf (specified-type esd) (slot-definition-type dsd)))
-	)
+        (view-class-slot-definition-mixin
+         (setf (slot-value esd 'column) (compute-column-name dsd))
+
+         (macrolet
+             ((safe-copy-value (name &optional default)
+                (let ((fn (intern (format nil "~A~A" 'view-class-slot- name ))))
+                  `(setf (slot-value esd ',name)
+                    (or (when (slot-boundp dsd ',name)
+                          (delistify-dsd (,fn dsd)))
+                     ,default)))))
+           (safe-copy-value autoincrement-sequence)
+           (safe-copy-value db-type)
+           (safe-copy-value void-value)
+           (safe-copy-value db-reader)
+           (safe-copy-value db-writer)
+           ;; :db-kind slot value defaults to :base (store slot value in
+           ;; database)
+           (safe-copy-value db-kind :base)
+           (safe-copy-value db-constraints)
+           (safe-copy-value db-info)
+           (%convert-db-info-to-hash esd))
+
+         (setf (specified-type esd)
+               (delistify-dsd (specified-type dsd)))
+         ;; In older SBCL's the type-check-function is computed at
+         ;; defclass expansion, which is too early for the CLSQL type
+         ;; conversion to take place. This gets rid of it. It's ugly
+         ;; but it's better than nothing -wcp10/4/10.
+         #+(and sbcl #.(cl:if (cl:and (cl:find-package :sb-pcl)
+                                      (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl))
+                              '(cl:and) '(cl:or)))
+         (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
+
+         )
+        ;; all other slots
+        (t
+         (unless (typep esd 'view-class-effective-slot-definition)
+           (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
+
+           (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
+             #-openmcl (declare (ignore type-predicate))
+             #-(or clisp sbcl)  (change-class esd 'view-class-effective-slot-definition
+                                              #+allegro :name
+                                              #+allegro (slot-definition-name dsd))
+             #+openmcl (setf (slot-value esd 'ccl::type-predicate)
+                             type-predicate)))
+
+         ;; has no column name if it is not a database column
+         (setf (slot-value esd 'column) nil)
+         (setf (slot-value esd 'db-info) nil)
+         (setf (slot-value esd 'db-kind) :virtual)
+         (setf (specified-type esd) (slot-definition-type dsd)))
+        )
       esd)))
 
 (defun slotdefs-for-slots-with-class (slots class)
   (let ((result nil))
     (dolist (s slots)
       (let ((c (slotdef-for-slot-with-class s class)))
-	(if c (setf result (cons c result)))))
+        (if c (setf result (cons c result)))))
     result))
 
 (defun slotdef-for-slot-with-class (slot class)
-  (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
-	   (class-slots class)))
+  (typecase slot
+    (standard-slot-definition slot)
+    (symbol
+     (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
+              (class-slots class)))))
 
 #+ignore
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -552,3 +555,66 @@ which does type checking before storing a value in a slot."
   #+kmr-normal-esdc
   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
   )
+
+(defmethod database-identifier ( (name standard-db-class)
+                                &optional database find-class-p)
+  "the majority of this function is in expressions.lisp
+   this is here to make loading be less painful (try-recompiles) in SBCL"
+  (declare (ignore find-class-p))
+  (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+                                &optional database find-class-p)
+  (declare (ignore find-class-p))
+  (database-identifier
+   (if (slot-boundp name 'column)
+       (delistify-dsd (view-class-slot-column name))
+       (slot-definition-name name))
+   database))
+
+(defun find-standard-db-class (name &aux cls)
+  (and (setf cls (ignore-errors (find-class name)))
+       (typep cls 'standard-db-class)
+       cls))
+
+(defun slots-for-possibly-normalized-class (class)
+  (if (normalizedp class)
+      (ordered-class-direct-slots class)
+      (ordered-class-slots class)))
+
+(defun key-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (eql :key (view-class-slot-db-kind slot-def)))
+
+(defun join-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (eql :join (view-class-slot-db-kind slot-def)))
+
+(defun key-or-base-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (member (view-class-slot-db-kind slot-def) '(:key :base)))
+
+(defun direct-normalized-slot-p (class slot-name)
+  "Is this a normalized class and if so is the slot one of our direct slots?"
+  (setf slot-name (to-slot-name slot-name))
+  (and (typep class 'standard-db-class)
+       (normalizedp class)
+       (member slot-name (ordered-class-direct-slots class)
+               :key #'slot-definition-name)))
+
+(defun not-direct-normalized-slot-p (class slot-name)
+  "Is this a normalized class and if so is the slot not one of our direct slots?"
+  (setf slot-name (to-slot-name slot-name))
+  (and (typep class 'standard-db-class)
+       (normalizedp class)
+       (not (member slot-name (ordered-class-direct-slots class)
+                    :key #'slot-definition-name))))
+
+(defun slot-has-default-p (slot)
+  "returns nil if the slot does not have a default constraint"
+  (let* ((constraints
+           (when (typep slot '(or view-class-direct-slot-definition
+                               view-class-effective-slot-definition))
+             (listify (view-class-slot-db-constraints slot)))))
+    (member :default constraints)))
+