From: Kevin M. Rosenberg Date: Mon, 25 Mar 2002 06:07:06 +0000 (+0000) Subject: r1656: More field type coding X-Git-Tag: v3.8.6~1220 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=421ef23a5a01534ac4c4d7594d182023ed31b376 r1656: More field type coding --- diff --git a/ChangeLog b/ChangeLog index 0cee6a8..2bab5bf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -9,9 +9,11 @@ * Updated test-clsql.cl to use automated testing with a config file - * Changed return types of field accessors from cstring to (* :unsigned-char). - This prepares for being able to use specified type conversions when taking - field data into lisp. + * Changed return types of field accessors from cstring to + (* :unsigned-char). This prepares for being able to use specified + type conversions when taking field data into lisp. + + * Added field-type processing for most interfaces. Not done yet. 23 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) diff --git a/interfaces/aodbc/aodbc-sql.cl b/interfaces/aodbc/aodbc-sql.cl index 780c196..e6244d1 100644 --- a/interfaces/aodbc/aodbc-sql.cl +++ b/interfaces/aodbc/aodbc-sql.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: aodbc-sql.cl,v 1.4 2002/03/24 18:39:32 kevin Exp $ +;;;; $Id: aodbc-sql.cl,v 1.5 2002/03/25 06:07:06 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -62,7 +62,8 @@ (defmethod database-query (query-expression (database aodbc-database) field-types) (handler-case - (dbi:sql query-expression :db (database-aodbc-conn database)) + (dbi:sql query-expression :db (database-aodbc-conn database) + :types field-types) (error () (error 'clsql-sql-error :database database @@ -95,6 +96,7 @@ :row-count nil :column-names t :query t + :types field-types ) (values (make-aodbc-result-set :query query :full-set full-set diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl index 8d8f243..1850092 100644 --- 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.6 2002/03/24 22:25:51 kevin Exp $ +;;;; $Id: mysql-sql.cl,v 1.7 2002/03/25 06:07:06 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -39,6 +39,54 @@ (in-package :clsql-mysql) +;;; 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 + do + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + ((:int :long :double t) + (nth i types)) + (t + t)) + new-types))) + (nreverse new-types)) + (if (eq types :auto) + :auto + nil))) + +(uffi:def-function "atoi" + ((str :cstring)) + :returning :int) + +(uffi:def-function "atol" + ((str :cstring)) + :returning :long) + +(uffi:def-function "atof" + ((str :cstring)) + :returning :double) + +(defun convert-raw-field (char-ptr types index) + (let ((type (if (listp types) + (nth index types) + types))) + (case type + (:int + (atoi char-ptr)) + (:long + (atol char-ptr)) + (:double + (atof char-ptr)) + (otherwise + (uffi:convert-from-foreign-string char-ptr))))) + (defmethod database-initialize-database-type ((database-type (eql :mysql))) t) @@ -56,6 +104,7 @@ (declare (ignore password)) (concatenate 'string host "/" db "/" user))) + (defmethod database-connect (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type (host db user password)) (destructuring-bind (host db user password) connection-spec @@ -98,45 +147,6 @@ t) -(defstruct mysql-result-set - (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) - :type mysql-mysql-res-ptr-def) - (field-types nil) - (full-set nil :type boolean)) - -(defmethod database-dump-result-set (result-set (database mysql-database)) - (mysql-free-result (mysql-result-set-res-ptr result-set)) - t) - - -(defmethod database-store-next-row (result-set (database mysql-database) list) - (let* ((res-ptr (mysql-result-set-res-ptr result-set)) - (row (mysql-fetch-row res-ptr))) - (declare (type mysql-mysql-res-ptr-def res-ptr) - (type mysql-row-def row)) - (unless (uffi:null-pointer-p row) - (loop for i from 0 below (mysql-num-fields res-ptr) - for rest on list - do - (setf (car rest) - (uffi:convert-from-foreign-string (uffi:deref-array row 'mysql-row i)))) - list))) - - -(defmethod database-execute-command (sql-expression (database mysql-database)) - (uffi:with-cstring (sql-native sql-expression) - (let ((mysql-ptr (database-mysql-ptr database))) - (declare (type mysql-mysql-ptr-def mysql-ptr)) - (if (zerop (mysql-query mysql-ptr sql-native)) - t - (error 'clsql-sql-error - :database database - :expression sql-expression - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr)))))) - - - (defmethod database-query (query-expression (database mysql-database) field-types) (with-slots (mysql-ptr) database @@ -144,15 +154,18 @@ (if (zerop (mysql-query mysql-ptr query-native)) (let ((res-ptr (mysql-use-result mysql-ptr))) (if res-ptr - (unwind-protect - (loop for row = (mysql-fetch-row res-ptr) - until (uffi:null-pointer-p row) - collect - (loop for i from 0 below (mysql-num-fields res-ptr) - collect - (uffi:convert-from-foreign-string - (uffi:deref-array row 'mysql-row i)))) - (mysql-free-result res-ptr)) + (let ((num-fields (mysql-num-fields res-ptr))) + (setq field-types (canonicalize-field-types + field-types num-fields)) + (unwind-protect + (loop for row = (mysql-fetch-row res-ptr) + until (uffi:null-pointer-p row) + collect + (loop for i from 0 below num-fields + collect + (uffi:convert-from-foreign-string + (uffi:deref-array row 'mysql-row i)))) + (mysql-free-result res-ptr))) (error 'clsql-sql-error :database database :expression query-expression @@ -164,8 +177,28 @@ :errno (mysql-errno mysql-ptr) :error (mysql-error-string mysql-ptr)))))) +(defmethod database-execute-command (sql-expression (database mysql-database)) + (uffi:with-cstring (sql-native sql-expression) + (let ((mysql-ptr (database-mysql-ptr database))) + (declare (type mysql-mysql-ptr-def mysql-ptr)) + (if (zerop (mysql-query mysql-ptr sql-native)) + t + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr)))))) + +(defstruct mysql-result-set + (res-ptr (uffi:make-null-pointer 'mysql-mysql-res) + :type mysql-mysql-res-ptr-def) + (field-types nil) + (num-fields nil :type fixnum) + (full-set nil :type boolean)) + -(defmethod database-query-result-set (query-expression (database mysql-database) +(defmethod database-query-result-set (query-expression + (database mysql-database) &key full-set field-types) (uffi:with-cstring (query-native query-expression) (let ((mysql-ptr (database-mysql-ptr database))) @@ -176,14 +209,21 @@ (mysql-use-result mysql-ptr)))) (declare (type mysql-mysql-res-ptr-def res-ptr)) (if (not (uffi:null-pointer-p res-ptr)) - (if full-set - (values (make-mysql-result-set :res-ptr res-ptr :full-set t - :field-types field-types) - (mysql-num-fields res-ptr) - (mysql-num-rows res-ptr)) - (values (make-mysql-result-set :res-ptr res-ptr) - (mysql-num-fields res-ptr))) - (error 'clsql-sql-error + (let* ((num-fields (mysql-num-fields res-ptr)) + (result-set (make-mysql-result-set + :res-ptr res-ptr + :num-fields num-fields + :full-set full-set + :field-types + (canonicalize-field-types + field-types num-fields)))) + (if full-set + (values result-set + num-fields + (mysql-num-rows res-ptr)) + (values result-set + num-fields))) + (error 'clsql-sql-error :database database :expression query-expression :errno (mysql-errno mysql-ptr) @@ -194,4 +234,27 @@ :errno (mysql-errno mysql-ptr) :error (mysql-error-string mysql-ptr)))))) +(defmethod database-dump-result-set (result-set (database mysql-database)) + (mysql-free-result (mysql-result-set-res-ptr result-set)) + t) + + + +(defmethod database-store-next-row (result-set (database mysql-database) list) + (let* ((res-ptr (mysql-result-set-res-ptr result-set)) + (row (mysql-fetch-row res-ptr)) + (field-types (mysql-result-set-field-types result-set))) + (declare (type mysql-mysql-res-ptr-def res-ptr) + (type mysql-row-def row)) + (unless (uffi:null-pointer-p row) + (loop for i from 0 below (mysql-result-set-num-fields result-set) + for rest on list + do + (setf (car rest) + (convert-raw-field + (uffi:deref-array row 'mysql-row i) + field-types + i))) + list))) + diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index a1dfdd7..f0a1ee1 100644 --- 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.6 2002/03/24 22:25:51 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.7 2002/03/25 06:07:06 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -28,6 +28,54 @@ (in-package :clsql-postgresql) +;;; 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 + do + (if (>= i length-types) + (push t new-types) ;; types is shorted than num-fields + (push + (case (nth i types) + ((:int :long :double t) + (nth i types)) + (t + t)) + new-types))) + (nreverse new-types)) + (if (eq types :auto) + :auto + nil))) + +(uffi:def-function "atoi" + ((str :cstring)) + :returning :int) + +(uffi:def-function "atol" + ((str :cstring)) + :returning :long) + +(uffi:def-function "atof" + ((str :cstring)) + :returning :double) + +(defun convert-raw-field (char-ptr types index) + (let ((type (if (listp types) + (nth index types) + types))) + (case type + (:int + (atoi char-ptr)) + (:long + (atol char-ptr)) + (:double + (atof char-ptr)) + (otherwise + (uffi:convert-from-foreign-string char-ptr))))) + (defun tidy-error-message (message) (unless (stringp message) @@ -115,14 +163,18 @@ (#.pgsql-exec-status-type#empty-query nil) (#.pgsql-exec-status-type#tuples-ok - (loop for tuple-index from 0 below (PQntuples result) - collect - (loop for i from 0 below (PQnfields result) - collect - (if (zerop (PQgetisnull result tuple-index i)) - (uffi:convert-from-foreign-string - (PQgetvalue result tuple-index i)) - nil)))) + (let ((num-fields (PQnfields result))) + (setq field-types + (canonicalize-field-types field-types num-fields)) + (loop for tuple-index from 0 below (PQntuples result) + collect + (loop for i from 0 below num-fields + collect + (if (zerop (PQgetisnull result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + field-types i) + nil))))) (t (error 'clsql-sql-error :database database @@ -184,22 +236,21 @@ (case (PQresultStatus result) ((#.pgsql-exec-status-type#empty-query #.pgsql-exec-status-type#tuples-ok) - (if full-set - (values (make-postgresql-result-set + (let ((result-set (make-postgresql-result-set :res-ptr result :num-fields (PQnfields result) :num-tuples (PQntuples result) - :field-types field-types) - (PQnfields result) - (PQntuples result)) - (values (make-postgresql-result-set - :res-ptr result - :num-fields (PQnfields result) - :num-tuples (PQntuples result) - :field-types field-types) - (PQnfields result)))) - (t - (unwind-protect + :field-types (canonicalize-field-types + field-types + (PQnfields result))))) + (if full-set + (values result-set + (PQnfields result) + (PQntuples result)) + (values result-set + (PQnfields result))))) + (t + (unwind-protect (error 'clsql-sql-error :database database :expression query-expression @@ -216,7 +267,8 @@ (defmethod database-store-next-row (result-set (database postgresql-database) list) - (let ((result (postgresql-result-set-res-ptr result-set))) + (let ((result (postgresql-result-set-res-ptr result-set)) + (field-types (postgresql-result-set-field-types result-set))) (declare (type pgsql-result-def result)) (if (>= (postgresql-result-set-tuple-index result-set) (postgresql-result-set-num-tuples result-set)) @@ -227,8 +279,9 @@ do (setf (car rest) (if (zerop (PQgetisnull result tuple-index i)) - (uffi:convert-from-foreign-string - (PQgetvalue result tuple-index i)) + (convert-raw-field + (PQgetvalue result tuple-index i) + field-types i) nil)) finally (incf (postgresql-result-set-tuple-index result-set)) diff --git a/test-clsql.cl b/test-clsql.cl index e0478d0..cbc5e92 100644 --- 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.4 2002/03/24 22:25:51 kevin Exp $ +;;;; $Id: test-clsql.cl,v 1.5 2002/03/25 06:07:06 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -69,7 +69,9 @@ (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" i (sqrt i) (format nil "~d" (sqrt i))) :database db)) - (pprint (clsql:map-query 'vector #'list "select * from test_clsql" :database db)) + (pprint (clsql:map-query 'vector #'list "select * from test_clsql" + :database db + :field-types '(:int :double t))) (clsql:execute-command "DROP TABLE test_clsql")) (clsql:disconnect :database db))) )