X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=df3c36e0e12f51836fc21e9c3557e0e02ce7cee3;hp=f6bbd3f68369ca2e065741e5abbccb92989893c2;hb=dc107d34212597ed1272cfa21138d384e71b00d2;hpb=008ef476827e2b4ec81829f1e204e9f954017678

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index f6bbd3f..df3c36e 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -83,15 +83,6 @@
         ((stringp arg)
          (sql-escape 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)))))
-
-
 (defun remove-keyword-arg (arglist akey)
   (let ((mylist arglist)
         (newlist ()))
@@ -314,7 +305,13 @@ column definition in the database.")
     :accessor specified-type
     :initarg specified-type
     :initform nil
-    :documentation "Internal slot storing the :type specified by user.")))
+    :documentation "Internal slot storing the :type specified by user.")
+   (autoincrement-sequence
+    :accessor view-class-slot-autoincrement-sequence
+    :initarg :autoincrement-sequence
+    :initform nil
+    :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
@@ -439,12 +436,7 @@ implementations."
       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))
-
+;; 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)
@@ -459,6 +451,14 @@ implementations."
                     type db-constraints))
          initargs))
 
+(defun compute-column-name (arg)
+  (database-identifier arg nil))
+
+(defmethod initialize-instance :after
+    ((obj view-class-direct-slot-definition)
+     &key &allow-other-keys)
+  (setf (view-class-slot-column obj) (compute-column-name obj)))
+
 (defmethod compute-effective-slot-definition ((class standard-db-class)
                                               #+kmr-normal-cesd slot-name
                                               direct-slots)
@@ -470,15 +470,7 @@ implementations."
     (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 'column) (compute-column-name dsd))
 
          (setf (slot-value esd 'db-type)
            (when (slot-boundp dsd 'db-type)
@@ -530,7 +522,9 @@ implementations."
          ;; 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:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl) '(and) '(or)))
+         #+(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)
 
          )
@@ -547,10 +541,8 @@ implementations."
              #+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))))
-
+         ;; 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)))
@@ -565,8 +557,11 @@ implementations."
     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)
@@ -577,3 +572,22 @@ implementations."
   #+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"
+  (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+                                &optional database 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))