From: Kevin M. Rosenberg Date: Fri, 2 Dec 2005 15:30:16 +0000 (+0000) Subject: r10854: 02 Dec 2005 Kevin Rosenberg X-Git-Tag: v3.8.6~93 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=656074cf47344a3cedaf1986fc7677f573fd5c6f r10854: 02 Dec 2005 Kevin Rosenberg * 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 04aa5fb..2764914 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +02 Dec 2005 Kevin Rosenberg + * 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 * 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 c671868..4f3986b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (3.5.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg 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 c196a45..983af78 100644 --- 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 701181d..5d254bf 100644 --- 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