[PATCH] expressions, metaclasses, generic-postgresql

Good day,

Here are small patches for CLSQL.

Changes:

- sql/expressions.lisp - make column alias a symbol not a string,
  at least PostgreSQL and Oracle don't accept a string as valid alias;

- sql/generic-postgresql.lisp - corrected decoding of table attribute
  parameters;

- 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.


Best Regards,
Vladimir Sekissov

diff -Naur clsql-3.5.0.orig/sql/expressions.lisp clsql-3.5.0/sql/expressions.lisp
--- clsql-3.5.0.orig/sql/expressions.lisp	2005-11-16 13:49:00.000000000 +0500
+++ clsql-3.5.0/sql/expressions.lisp	2005-12-01 03:01:36.000000000 +0500
@@ -201,7 +201,10 @@
   (with-slots (name alias) expr
      (let ((namestr (if (symbolp name)
                         (symbol-name name)
-                      name)))
+                      name))
+           (aliastr (if (symbolp alias)
+                        (symbol-name alias)
+                      alias)))
        (if (null alias)
            (write-string
             (sql-escape (convert-to-db-default-case namestr database))
@@ -211,7 +214,9 @@
             (sql-escape (convert-to-db-default-case namestr database))
             *sql-stream*)
            (write-char #\Space *sql-stream*)
-           (format *sql-stream* "~s" alias)))))
+           (write-string
+            (sql-escape (convert-to-db-default-case aliastr database))
+            *sql-stream*)))))
   t)
 
 (defmethod output-sql-hash-key ((expr sql-ident-table) database)
diff -Naur clsql-3.5.0.orig/sql/generic-postgresql.lisp clsql-3.5.0/sql/generic-postgresql.lisp
--- clsql-3.5.0.orig/sql/generic-postgresql.lisp	2005-10-13 11:09:01.000000000 +0600
+++ clsql-3.5.0/sql/generic-postgresql.lisp	2005-12-01 03:01:36.000000000 +0500
@@ -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 -Naur clsql-3.5.0.orig/sql/metaclasses.lisp clsql-3.5.0/sql/metaclasses.lisp
--- clsql-3.5.0.orig/sql/metaclasses.lisp	2005-11-16 13:07:54.000000000 +0500
+++ clsql-3.5.0/sql/metaclasses.lisp	2005-12-01 03:01:36.000000000 +0500
@@ -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