r1657: Auto :types implemented for mysql,postgresql

diff --git a/ChangeLog b/ChangeLog
index 2bab5bf84f8ceebbb5d0520692a13a574f4b7aef..ac948b26fef81802de4c5080202d2fc222d30564 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+25 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net)
+
+       * interfaces/mysql/mysql-api.cl
+       Added mysql-fetch-fields, mysql-fetch-field-direct
+       Got :auto types working
+
+       * interfaces/postgresql/postgresql-api.cl
+       Added pgsql-field-types enum
+       Got :auto types working
+
+;      * multiple-files
+;      Renamed :field-types to :types
+       
 24 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net)
 
        * Added field-types parameter to query, database-query,

diff --git a/interfaces/mysql/mysql-api.cl b/interfaces/mysql/mysql-api.cl
index 2a3b91109b3e71210409ab850fa0fb54e77f4463..1a91237adb5127f4362c894e85f590dac8e7c424 100644 (file)
--- a/interfaces/mysql/mysql-api.cl
+++ b/interfaces/mysql/mysql-api.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: mysql-api.cl,v 1.1 2002/03/23 17:10:47 kevin Exp $
+;;;; $Id: mysql-api.cl,v 1.2 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -121,6 +121,7 @@
 ;;; MYSQL-ROWS
 
 (uffi:def-array-pointer mysql-row (* :unsigned-char))
+(uffi:def-array-pointer mysql-field-vector (* mysql-field))
 
 (uffi:def-foreign-type mysql-field-offset :unsigned-int)
 
@@ -447,6 +448,19 @@
   :module "mysql"
   :returning (* mysql-field))
 
+(declaim (inline mysql-fetch-fields))
+(uffi:def-function "mysql_fetch_fields"
+  ((res (* mysql-mysql-res)))
+  :module "mysql"
+  :returning mysql-field-vector)
+
+(declaim (inline mysql-fetch-field-direct))
+(uffi:def-function "mysql_fetch_field_direct"
+  ((res (* mysql-mysql-res))
+   (field-num :unsigned-int))
+  :module "mysql"
+  :returning (* mysql-field))
+
 (declaim (inline mysql-escape-string))
 (uffi:def-function "mysql_escape_string"
     ((to :cstring)

diff --git a/interfaces/mysql/mysql-package.cl b/interfaces/mysql/mysql-package.cl
index bb737f903bbd6fdacc411a860637aec9549acced..666bf5de736a06db162650e749abffd12f4e64fd 100644 (file)
--- a/interfaces/mysql/mysql-package.cl
+++ b/interfaces/mysql/mysql-package.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: mysql-package.cl,v 1.3 2002/03/24 04:37:09 kevin Exp $
+;;;; $Id: mysql-package.cl,v 1.4 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -110,6 +110,8 @@
      #:mysql-fetch-row
      #:mysql-fetch-lengths
      #:mysql-fetch-field
+     #:mysql-fetch-fields
+     #:mysql-fetch-field-direct
      #:mysql-escape-string
      #:mysql-debug
      #:mysql-num-rows

diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl
index 1850092d9ef86c89287ca518a9dd9b28f7fcf00e..65f2f6ff994051d0ab3c8f793d767eb21b95f7cc 100644 (file)
--- a/interfaces/mysql/mysql-sql.cl
+++ b/interfaces/mysql/mysql-sql.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: mysql-sql.cl,v 1.7 2002/03/25 06:07:06 kevin Exp $
+;;;; $Id: mysql-sql.cl,v 1.8 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -41,14 +41,15 @@
 
 ;;; Field conversion functions
 
-(defun canonicalize-field-types  (types num-fields)
-  (if (listp types)
-      (let ((length-types (length types))
-           new-types)
-       (loop for i from 0 below num-fields
+(defun canonicalize-field-types (types num-fields res-ptr)
+  (cond
+   ((if (listp types)
+       (let ((length-types (length types))
+             (new-types '()))
+         (loop for i from 0 below num-fields
              do
-             (if (>= i length-types)
-                 (push t new-types) ;; types is shorted than num-fields
+               (if (>= i length-types)
+                   (push t new-types) ;; types is shorted than num-fields
                  (push
                   (case (nth i types)
                     ((:int :long :double t)
@@ -56,10 +57,33 @@
                     (t
                      t))
                   new-types)))
-       (nreverse new-types))
-      (if (eq types :auto)
-         :auto
-         nil)))
+         (nreverse new-types))))
+   ((eq types :auto)
+    (let ((new-types '())
+         #+ignore (field-vec (mysql-fetch-fields res-ptr)))
+      (dotimes (i num-fields)
+       (declare (fixnum i))
+       (let* ((field (mysql-fetch-field-direct res-ptr i))
+              #+ignore
+              (field-test (uffi:deref-array field-vec 'mysql-field-vector i))
+              (type (uffi:get-slot-value field 'mysql-field 'type)))
+         (push
+          (case type
+            ((#.mysql-field-types#tiny 
+              #.mysql-field-types#short
+              #.mysql-field-types#int24
+              #.mysql-field-types#long)
+             :int)
+            ((#.mysql-field-types#double
+              #.mysql-field-types#float
+              #.mysql-field-types#decimal)
+             :double)
+            (otherwise
+             t))
+          new-types)))
+      (nreverse new-types)))
+   (t
+    nil)))
 
 (uffi:def-function "atoi"
     ((str :cstring))
@@ -156,7 +180,8 @@
             (if res-ptr
                 (let ((num-fields (mysql-num-fields res-ptr)))
                   (setq field-types (canonicalize-field-types 
-                                     field-types num-fields))
+                                     field-types num-fields
+                                     res-ptr))
                   (unwind-protect
                        (loop for row = (mysql-fetch-row res-ptr)
                              until (uffi:null-pointer-p row)
@@ -216,7 +241,8 @@
                                    :full-set full-set
                                    :field-types
                                    (canonicalize-field-types 
-                                    field-types num-fields)))) 
+                                    field-types num-fields
+                                    res-ptr)))) 
                  (if full-set
                      (values result-set
                              num-fields

diff --git a/interfaces/postgresql/postgresql-api.cl b/interfaces/postgresql/postgresql-api.cl
index 36b093f5d0102aae8e29c22baa0f54d469210055..f2319bec39b8d9f9a84a840af1446be02b9ca256 100644 (file)
--- a/interfaces/postgresql/postgresql-api.cl
+++ b/interfaces/postgresql/postgresql-api.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-api.cl,v 1.2 2002/03/24 22:25:51 kevin Exp $
+;;;; $Id: postgresql-api.cl,v 1.3 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -53,6 +53,14 @@
 (uffi:def-foreign-type pgsql-conn :pointer-void)
 (uffi:def-foreign-type pgsql-result :pointer-void)
 
+(uffi:def-enum pgsql-ftype
+    ((:bytea 17)
+     (:int2 21)
+     (:int4 23)
+     (:float4 700)
+     (:float8 701)))
+  
+    
 ;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0
 (uffi:def-function ("PQsetdbLogin" PQsetdbLogin)
   ((pghost :cstring)

diff --git a/interfaces/postgresql/postgresql-package.cl b/interfaces/postgresql/postgresql-package.cl
index 7991f9a5b095fd08929276ae23b97caf93922e2d..27a588ea2f100dd5f066afddd26a8a7dc1d87fa4 100644 (file)
--- a/interfaces/postgresql/postgresql-package.cl
+++ b/interfaces/postgresql/postgresql-package.cl
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-package.cl,v 1.3 2002/03/24 04:37:09 kevin Exp $
+;;;; $Id: postgresql-package.cl,v 1.4 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -39,6 +39,11 @@
      #:pgsql-conn
      #:pgsql-result
 
+     #:pgsql-ftype#bytea
+     #:pgsql-ftype#int2
+     #:pgsql-ftype#int4
+     #:pgsql-ftype#float4
+     #:pgsql-ftype#float8
      ;; Functions
      #:PQsetdbLogin
      #:PQlogin

diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl
index f0a1ee1bd511a614a6b5002c6152278570738e2d..db4128bf96c4eab0469eda865be9e716a44d029d 100644 (file)
--- a/interfaces/postgresql/postgresql-sql.cl
+++ b/interfaces/postgresql/postgresql-sql.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-sql.cl,v 1.7 2002/03/25 06:07:06 kevin Exp $
+;;;; $Id: postgresql-sql.cl,v 1.8 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -30,14 +30,15 @@
 
 ;;; Field conversion functions
 
-(defun canonicalize-field-types  (types num-fields)
-  (if (listp types)
-      (let ((length-types (length types))
-           new-types)
-       (loop for i from 0 below num-fields
+(defun canonicalize-field-types (types num-fields res-ptr)
+  (cond
+   ((if (listp types)
+       (let ((length-types (length types))
+             (new-types '()))
+         (loop for i from 0 below num-fields
              do
-             (if (>= i length-types)
-                 (push t new-types) ;; types is shorted than num-fields
+               (if (>= i length-types)
+                   (push t new-types) ;; types is shorted than num-fields
                  (push
                   (case (nth i types)
                     ((:int :long :double t)
@@ -45,10 +46,28 @@
                     (t
                      t))
                   new-types)))
-       (nreverse new-types))
-      (if (eq types :auto)
-         :auto
-         nil)))
+         (nreverse new-types))))
+   ((eq types :auto)
+    (let ((new-types '()))
+      (dotimes (i num-fields)
+       (declare (fixnum i))
+       (let* ((type (PQftype res-ptr i)))
+         (push
+          (case type
+            ((#.pgsql-ftype#bytea
+              #.pgsql-ftype#int2
+              #.pgsql-ftype#int4)
+             :int)
+            ((#.pgsql-ftype#float4
+              #.pgsql-ftype#float8)
+             :double)
+            (otherwise
+             t))
+          new-types)))
+      (nreverse new-types)))
+   (t
+    nil)))
+
 
 (uffi:def-function "atoi"
     ((str :cstring))
@@ -165,7 +184,8 @@
               (#.pgsql-exec-status-type#tuples-ok
               (let ((num-fields (PQnfields result)))
                 (setq field-types
-                      (canonicalize-field-types field-types num-fields))
+                  (canonicalize-field-types field-types num-fields
+                                            result))
                 (loop for tuple-index from 0 below (PQntuples result)
                       collect
                       (loop for i from 0 below num-fields
@@ -242,7 +262,8 @@
                         :num-tuples (PQntuples result)
                        :field-types (canonicalize-field-types 
                                      field-types
-                                     (PQnfields result)))))
+                                     (PQnfields result)
+                                     result))))
             (if full-set
                 (values result-set
                         (PQnfields result)

diff --git a/test-clsql.cl b/test-clsql.cl
index cbc5e928ef49e5e6225e2723226e649f86de4e42..2aed1633e5f0729d74634f9803fa3491a3cd113b 100644 (file)
--- a/test-clsql.cl
+++ b/test-clsql.cl
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Mar 2002
 ;;;;
-;;;; $Id: test-clsql.cl,v 1.5 2002/03/25 06:07:06 kevin Exp $
+;;;; $Id: test-clsql.cl,v 1.6 2002/03/25 14:13:41 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -71,7 +71,7 @@
             :database db))
          (pprint (clsql:map-query 'vector #'list "select * from test_clsql" 
                                   :database db
-                                  :field-types '(:int :double t)))
+                                  :field-types :auto)) ;;'(:int :double t)))
          (clsql:execute-command "DROP TABLE test_clsql"))
       (clsql:disconnect :database db)))
   )