r10854: 02 Dec 2005 Kevin Rosenberg <kevin@rosenberg.net>

        * sql/generic-postgresql.lisp: improved decoding of table attribute
          parameters [from Vladimir Sekissov]
        * sql/metaclasses.lisp: check that metaclass is standard-db-class or
          it's subclass to prevent adding standard-db-object to supers if
          somebody in the path has it already when metaclass inherited from
          standard-db-class. [from Vladimir Sekissov]

diff --git a/ChangeLog b/ChangeLog
index 04aa5fba7253291be8748570a09fd9dc213ef296..2764914a7673d76550afdf0602b71794bac463bb 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+02 Dec 2005  Kevin Rosenberg <kevin@rosenberg.net>
+       * sql/generic-postgresql.lisp: improved decoding of table attribute
+         parameters [from Vladimir Sekissov]
+       * sql/metaclasses.lisp: check that metaclass is standard-db-class or
+         it's subclass to prevent adding standard-db-object to supers if
+         somebody in the path has it already when metaclass inherited from
+         standard-db-class. [from Vladimir Sekissov]
+       
 26 Nov 2005  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.5.0
        * tests/test-init.lisp, tests/test-fddl.lisp, tests/test-fdml.lisp, 
@@ -2000,5 +2008,3 @@
          for MYSQL structure. This will make the code more robust in
          the event that MySQL library changes the size of the mysql-mysql
          structure.
-
-

diff --git a/debian/changelog b/debian/changelog
index c67186824563a19a88c172de8335f72d4656692a..4f3986b4ba47175d5bd807defa4f14f6cc161a6f 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (3.5.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri,  2 Dec 2005 08:19:30 -0700
+
 cl-sql (3.5.0-1) unstable; urgency=low
 
   * New upstream (closes: 339842)

diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp
index c196a4568d46106e58d75dbf4a61429c1181759b..983af78b767025a496968f2e272e0e5c41b9563b 100644 (file)
--- a/sql/generic-postgresql.lisp
+++ b/sql/generic-postgresql.lisp
@@ -150,15 +150,29 @@
                           (owner-clause owner))
                   database nil nil))))
     (when row
-      (values
-       (ensure-keyword (first row))
-       (if (string= "-1" (second row))
-          (- (parse-integer (third row) :junk-allowed t) 4)
-        (parse-integer (second row)))
-       nil
-       (if (string-equal "f" (fourth row))
-          1
-        0)))))
+      (destructuring-bind (typname attlen atttypmod attnull) row
+
+        (setf attlen (parse-integer attlen :junk-allowed t)
+              atttypmod (parse-integer atttypmod :junk-allowed t))
+              
+        (let ((coltype (ensure-keyword typname))
+              (colnull (if (string-equal "f" attnull) 1 0))
+              collen
+              colprec)
+           (setf (values collen colprec)
+                 (case coltype
+                   ((:numeric :decimal)
+                    (if (= -1 atttypmod)
+                        (values nil nil)
+                        (values (ash (- atttypmod 4) -16)
+                                (boole boole-and (- atttypmod 4) #xffff))))
+                   (otherwise
+                    (values
+                     (cond ((and (= -1 attlen) (= -1 atttypmod)) nil)
+                           ((= -1 attlen) (- atttypmod 4))
+                           (t attlen))
+                     nil))))
+           (values coltype collen colprec colnull))))))
 
 (defmethod database-create-sequence (sequence-name
                                     (database generic-postgresql-database))

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 701181da53a8bb3a4da0217511485eb1587ccb19..5d254bfa5e33ad71f2f6cd80fe2ec434ee3f3b4d 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -107,12 +107,12 @@
                                         qualifier
                                        &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-       (vmc (find-class 'standard-db-class)))
+       (vmc 'standard-db-class))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if root-class
-       (if (member-if #'(lambda (super)
-                          (eq (class-of super) vmc)) direct-superclasses)
+       (if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
            (call-next-method)
             (apply #'call-next-method
                    class
@@ -135,7 +135,7 @@
                                           direct-superclasses qualifier
                                           &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-       (vmc (find-class 'standard-db-class)))
+       (vmc 'standard-db-class))
     (setf (view-table class)
           (table-name-from-arg (sql-escape (or (and base-table
                                                     (if (listp base-table)
@@ -145,8 +145,8 @@
     (setf (view-class-qualifier class)
           (car qualifier))
     (if (and root-class (not (equal class root-class)))
-       (if (member-if #'(lambda (super)
-                          (eq (class-of super) vmc)) direct-superclasses)
+       (if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
            (call-next-method)
             (apply #'call-next-method
                    class