r9224: 3 May 2004 Kevin Rosenberg (kevin@rosenberg.net)

        * sql/metaclasses.lisp: Properly store specified-type from
        direct-slot-definition and then store translated type in
        effective-slot-definition
        * sql/objects.lisp: Use specified type when invocating
        database-get-type-specifier

diff --git a/ChangeLog b/ChangeLog
index 2059e9d17c1421b97bfab70636b289d07419ba40..d2511fccdd39e818f0ec24b5525563e4366cec59 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+3 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+       * sql/metaclasses.lisp: Properly store specified-type from
+       direct-slot-definition and then store translated type in
+       effective-slot-definition
+       * sql/objects.lisp: Use specified type when invocating 
+       database-get-type-specifier
+       
 4 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) 
        * Version 2.10.9
        * sql/objects.lisp: added derived type specifier for universal time. 

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index d6d92b85ce3595aef251d63779212c3fe69753b1..a9f188950c52f3762bcf51a986c6c7f83b0fef86 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -56,7 +56,7 @@
 
 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
 
-(defvar +extra-slot-options+ '(:column :db-kind :db-reader :void-value :db-constraints
+(defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints
                               :db-writer :db-info))
 (defvar +extra-class-options+ '(:base-table))
 
@@ -401,6 +401,8 @@ which does type checking before storing a value in a slot."
        (t
        #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
        specified-type)))
+    ((eq (ensure-keyword specified-type) :bigint)
+     'integer)
     #+openmcl
     ((null specified-type)
      ;; setting this here is not enough since openmcl later sets the
@@ -422,76 +424,81 @@ which does type checking before storing a value in a slot."
                                              #+kmr-normal-cesd slot-name
                                              direct-slots)
   #+kmr-normal-cesd (declare (ignore slot-name))
-
-  (let ((slotd (call-next-method))
-       (sd (car direct-slots)))
-    
-    (typecase sd
-      (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 slotd 'column)
-             (column-name-from-arg
-              (if (slot-boundp sd 'column)
-                  (view-class-slot-column sd)
-                  (column-name-from-arg
-                   (sql-escape (slot-definition-name sd))))))
-       
-       (setf (slot-value slotd 'db-type)
-             (when (slot-boundp sd 'db-type)
-               (view-class-slot-db-type sd)))
-       
-       (setf (slot-value slotd 'void-value)
-             (view-class-slot-void-value sd))
-       
-       ;; :db-kind slot value defaults to :base (store slot value in
-       ;; database)
-       
-       (setf (slot-value slotd 'db-kind)
-             (if (slot-boundp sd 'db-kind)
-                 (view-class-slot-db-kind sd)
-                 :base))
-       
-       (setf (slot-value slotd 'db-writer)
-             (when (slot-boundp sd 'db-writer)
-               (view-class-slot-db-writer sd)))
-       (setf (slot-value slotd 'db-constraints)
-             (when (slot-boundp sd 'db-constraints)
-               (view-class-slot-db-constraints sd)))
-               
-       ;; 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 slotd 'db-info)
-             (when (slot-boundp sd 'db-info)
-               (if (listp (view-class-slot-db-info sd))
-                   (parse-db-info (view-class-slot-db-info sd))
-                   (view-class-slot-db-info sd))))
-
-       ;; KMR: store the user-specified type and then compute
-       ;; real Lisp type and store it
-       (setf (specified-type slotd)
-            (slot-definition-type slotd))
-       (setf (slot-value slotd 'type)
-            (compute-lisp-type-from-slot-specification 
-             slotd (slot-definition-type slotd)))
-       )
-      ;; all other slots
-      (t
-       (change-class slotd 'view-class-effective-slot-definition
-                    #+allegro :name 
-                    #+allegro (slot-definition-name sd))
-       (setf (slot-value slotd 'column)
-             (column-name-from-arg
-              (sql-escape (slot-definition-name sd))))
-
-       (setf (slot-value slotd 'db-info) nil)
-       (setf (slot-value slotd 'db-kind)
-             :virtual)))
-    slotd))
-
+  
+  ;; 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 (slot-value dsd 'type)
+       (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)
+               (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)
+            (view-class-slot-db-type dsd)))
+        
+        (setf (slot-value esd 'void-value)
+          (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)
+              (view-class-slot-db-kind dsd)
+            :base))
+        
+        (setf (slot-value esd 'db-writer)
+          (when (slot-boundp dsd 'db-writer)
+            (view-class-slot-db-writer dsd)))
+        (setf (slot-value esd 'db-constraints)
+          (when (slot-boundp dsd 'db-constraints)
+            (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)
+            (if (listp (view-class-slot-db-info dsd))
+                (parse-db-info (view-class-slot-db-info dsd))
+              (view-class-slot-db-info dsd))))
+        
+        (setf (specified-type esd) (specified-type dsd))
+        
+        )
+       ;; all other slots
+       (t
+        (change-class esd 'view-class-effective-slot-definition
+                      #+allegro :name 
+                      #+allegro (slot-definition-name dsd))
+        
+        (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)))
+      esd)))
+  
 (defun slotdefs-for-slots-with-class (slots class)
   (let ((result nil))
     (dolist (s slots)

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 8e56989d01eaa6751ea673c1e8d3c9963502a109..78d70442e4955616bb060a973ce02c3694194085 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -97,7 +97,7 @@ the view. The argument DATABASE has a default value of
   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
     (let ((cdef
            (list (sql-expression :attribute (view-class-slot-column slotdef))
-                 (slot-type slotdef))))
+                 (specified-type slotdef))))
       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
       (let ((const (view-class-slot-db-constraints slotdef)))
         (when const 
@@ -232,16 +232,13 @@ superclass of the newly-defined View Class."
       (car list)
       list))
 
-(defun slot-type (slotdef)
-  (specified-type slotdef))
-
 (defvar *update-context* nil)
 
 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let* ((slot-reader (view-class-slot-db-reader slotdef))
         (slot-name   (slot-definition-name slotdef))
-        (slot-type   (slot-type slotdef))
+        (slot-type   (specified-type slotdef))
         (*update-context* (cons (type-of instance) slot-name)))
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
@@ -261,7 +258,7 @@ superclass of the newly-defined View Class."
 (defmethod key-value-from-db (slotdef value database) 
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let ((slot-reader (view-class-slot-db-reader slotdef))
-        (slot-type (slot-type slotdef)))
+        (slot-type (specified-type slotdef)))
     (cond ((and value (null slot-reader))
            (read-sql-value value (delistify slot-type) database))
           ((null value)
@@ -275,7 +272,7 @@ superclass of the newly-defined View Class."
 
 (defun db-value-from-slot (slotdef val database)
   (let ((dbwriter (view-class-slot-db-writer slotdef))
-       (dbtype (slot-type slotdef)))
+       (dbtype (specified-type slotdef)))
     (typecase dbwriter
       (string (format nil dbwriter val))
       (function (apply dbwriter (list val)))
@@ -287,7 +284,7 @@ superclass of the newly-defined View Class."
          (database-output-sql-as-type dbtype val database)))))))
 
 (defun check-slot-type (slotdef val)
-  (let* ((slot-type (slot-type slotdef))
+  (let* ((slot-type (specified-type slotdef))
          (basetype (if (listp slot-type) (car slot-type) slot-type)))
     (when (and slot-type val)
       (unless (typep val basetype)