From: Kevin M. Rosenberg Date: Wed, 27 Mar 2002 12:09:39 +0000 (+0000) Subject: r1683: *** empty log message *** X-Git-Tag: v3.8.6~1193 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=17c4d99ca97dbdec882028929d645e16164b4b0b r1683: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 2bbd921..2ce065e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +27 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/postgresql-socket/postgresql-socket-api.cl: + Fixes to read-double-from-socket. Added 64-bit integer support. + + * test-suite/xptest-clsql.cl + Added testint for 64-bit integers + 26 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) * interfaces/postgresql-socket/postgresql-socket-api.cl: Implemented direct socket reading for field type :double @@ -16,7 +23,7 @@ read-double-from-socket function. * test-suite/xptest-clsql.cl - Start testing using XPTest package + Started work on test suite 25 Mar 2002 Kevin Rosenberg (kevin@rosenberg.net) diff --git a/Makefile b/Makefile index 1448463..8ed3bda 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.4 2002/03/27 09:03:47 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.5 2002/03/27 12:09:39 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -38,7 +38,7 @@ DIST_TARBALL=$(DISTDIR).tar.gz DIST_ZIP=$(DISTDIR).zip SOURCE_FILES=interfaces sql cmucl-compat doc test-suite Makefile VERSION \ COPYING.CLSQL COPYING.MaiSQL README INSTALL ChangeLog NEWS TODO \ - set-logical.cl test-clsql.cl \ + set-logical.cl clsql-uffi.system \ clsql.system clsql-aodbc.system clsql-mysql.system \ clsql-postgresql.system clsql-postgresql-socket.system diff --git a/VERSION b/VERSION index 44d8132..4f7397e 100644 --- a/VERSION +++ b/VERSION @@ -1,3 +1,3 @@ -0.6.0-pre +0.6.0 diff --git a/doc/intro.sgml b/doc/intro.sgml index 25c672e..7c8c227 100644 --- a/doc/intro.sgml +++ b/doc/intro.sgml @@ -60,7 +60,7 @@ of &clsql;. &uffi; - &clsql; uses &clsql; uses &uffi; as a Foreign Function Interface (FFI) to support multiple &cl; @@ -72,6 +72,16 @@ are zip files for Microsoft Windows systems and gzipped tar files for other systems. + + XPTest (optional) + The test suite for &clsql; uses the onShore Development's +XPTest package. onShore has graciously put the package in the public +domain. You can download the package from onShore's web site. +This package is not required except if you wish to run the &clsql; +test suite. + + Supported Common Lisp Implementation @@ -114,29 +124,29 @@ the following implementations are supported: - Build <filename>clsql-mysql</filename> helper library - &mysql; uses functions that require 64-bit integer + Build &c; helper libraries + &clsql; uses functions that require 64-bit integer parameters and return values. The &ffi; in most &clsql; -implementations do not support 64-bit integers. Thus, a C helper -library is required to break these 64-bit integers into two compatible +implementations do not support 64-bit integers. Thus, C helper +libraries are required to break these 64-bit integers into two compatible 32-bit integers. -Makefile's for Microsoft Windows and GNU/Solaris systems -are supplied to build this library. In addition, the DLL and LIB +Makefiles for Microsoft Windows and GNU/Solaris systems +are supplied to build the libraries. Since many Microsoft Windows +users don't have access to a compiler, the DLL and LIB files for Microsoft Windows are supplied with the distribution. -To build the library, first move to the directory -interfaces/mysql directory. You may need to -edit Makefile or Makefile.msvc to -correctly specify the location of your &mysql; installation. On UNIX systems, use -the command: - make -On a Microsoft Windows system, -use the command: - -nmake /f -Makefile.msvc - +To build the libraries on a GNU or Solaris, use the shell and +change to the root directory of &clsql;. You may need to edit the file +interfaces/mysql/Makefile to specify the location of your +MySQL installation. Then, you can give the command + +make libs + +in the root directory of &clsql; to build the libraries +interfaces/mysql/clsql-mysql.so and +interfaces/clsql-uffi/clsql-uffi.so. + diff --git a/doc/ref.sgml b/doc/ref.sgml index bb77f59..a24ae22 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -1832,10 +1832,8 @@ ignored. :int Field is imported as a - 32-bit signed integer. - - :longlong Field is imported as a - 64-bit signed integer. + signed integer, from 8-bits to 64-bits depending + upon the field type. :double Field is imported as a double-float number. diff --git a/interfaces/clsql-uffi/clsql-uffi.cl b/interfaces/clsql-uffi/clsql-uffi.cl index 27059e2..a4cb44b 100644 --- a/interfaces/clsql-uffi/clsql-uffi.cl +++ b/interfaces/clsql-uffi/clsql-uffi.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: clsql-uffi.cl,v 1.1 2002/03/27 07:58:42 kevin Exp $ +;;;; $Id: clsql-uffi.cl,v 1.2 2002/03/27 12:09:39 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -20,18 +20,30 @@ (in-package :clsql-uffi) -(defun canonicalize-type-list (types num-fields) +(defun canonicalize-type-list (types auto-list) "Ensure a field type list meets expectations" (let ((length-types (length types)) (new-types '())) - (loop for i from 0 below num-fields + (loop for i from 0 below (length auto-list) do (if (>= i length-types) (push t new-types) ;; types is shorted than num-fields (push (case (nth i types) - ((:int :long :double :longlong t) - (nth i types)) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) (t t)) new-types))) @@ -68,18 +80,16 @@ (nth index types) types))) (case type - (:int - (atoi char-ptr)) - (:long - (atol char-ptr)) (:double (atof char-ptr)) - (:longlong + (:int32 + (atoi char-ptr)) + (:int64 (uffi:with-foreign-object (high32-ptr :int) (let ((low32 (atol64 char-ptr high32-ptr)) (high32 (uffi:deref-pointer high32-ptr :int))) (if (zerop high32) low32 (make-64-bit-integer high32 low32))))) - (otherwise + (t (uffi:convert-from-foreign-string char-ptr))))) diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl index 138cd7d..2623aed 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.14 2002/03/27 08:09:25 kevin Exp $ +;;;; $Id: mysql-sql.cl,v 1.15 2002/03/27 12:09:39 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,37 +41,41 @@ ;;; Field conversion functions +(defun make-type-list-for-auto (num-fields res-ptr) + (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 (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) + :int32) + (#.mysql-field-types#longlong + :int64) + ((#.mysql-field-types#double + #.mysql-field-types#float + #.mysql-field-types#decimal) + :double) + (otherwise + t)) + new-types))) + (nreverse new-types))) + (defun canonicalize-types (types num-fields res-ptr) - (cond - ((listp types) - (canonicalize-type-list types num-fields)) - ((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 (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#longlong - :longlong) - ((#.mysql-field-types#double - #.mysql-field-types#float - #.mysql-field-types#decimal) - :double) - (otherwise - t)) - new-types))) - (nreverse new-types))) - (t - nil))) + (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil)))) (defmethod database-initialize-database-type ((database-type (eql :mysql))) t) diff --git a/interfaces/postgresql-socket/postgresql-socket-api.cl b/interfaces/postgresql-socket/postgresql-socket-api.cl index 0c64353..0ee7d8a 100644 --- a/interfaces/postgresql-socket/postgresql-socket-api.cl +++ b/interfaces/postgresql-socket/postgresql-socket-api.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-socket-api.cl,v 1.11 2002/03/27 11:13:27 kevin Exp $ +;;;; $Id: postgresql-socket-api.cl,v 1.12 2002/03/27 12:09:39 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -569,7 +569,7 @@ connection, if it is still open." (defun read-field (socket type) (let ((length (- (read-socket-value 'int32 socket) 4))) (case type - ((:int :long :longlong) + ((:int32 :int64) (read-integer-from-socket socket length)) (:double (read-double-from-socket socket length)) diff --git a/interfaces/postgresql-socket/postgresql-socket-sql.cl b/interfaces/postgresql-socket/postgresql-socket-sql.cl index 703b3dd..0c99be0 100644 --- a/interfaces/postgresql-socket/postgresql-socket-sql.cl +++ b/interfaces/postgresql-socket/postgresql-socket-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-socket-sql.cl,v 1.7 2002/03/27 08:09:25 kevin Exp $ +;;;; $Id: postgresql-socket-sql.cl,v 1.8 2002/03/27 12:09:39 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,6 +30,15 @@ ;; Field type conversion +(defun make-type-list-for-auto (cursor) + (let* ((fields (postgresql-cursor-fields cursor)) + (num-fields (length fields)) + (new-types '())) + (dotimes (i num-fields) + (declare (fixnum i)) + (push (canonical-field-type fields i) new-types)) + (nreverse new-types))) + (defun canonical-field-type (fields index) "Extracts canonical field type from fields list" (let ((oid (cadr (nth index fields)))) @@ -37,49 +46,56 @@ ((#.pgsql-ftype#bytea #.pgsql-ftype#int2 #.pgsql-ftype#int4) - :int) + :int32) (#.pgsql-ftype#int8 - :longlong) + :int64) ((#.pgsql-ftype#float4 #.pgsql-ftype#float8) :double) (otherwise t)))) +(defun canonicalize-types (types cursor) + (let ((auto-list (make-type-list-for-auto cursor))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil)))) -(defun canonicalize-type-list (types num-fields) +(defun canonicalize-type-list (types auto-list) "Ensure a field type list meets expectations. Duplicated from clsql-uffi package so that this interface doesn't depend on UFFI." (let ((length-types (length types)) (new-types '())) - (loop for i from 0 below num-fields + (loop for i from 0 below (length auto-list) do (if (>= i length-types) (push t new-types) ;; types is shorted than num-fields (push (case (nth i types) - ((:int :long :double :longlong t) - (nth i types)) + (:int + (case (nth i auto-list) + (:int32 + :int32) + (:int64 + :int64) + (t + t))) + (:double + (case (nth i auto-list) + (:double + :double) + (t + t))) (t t)) new-types))) (nreverse new-types))) -(defun canonicalize-types (types cursor) - (let* ((fields (postgresql-cursor-fields cursor)) - (num-fields (length fields))) - (cond - ((listp types) - (canonicalize-type-list types num-fields)) - ((eq types :auto) - (let ((new-types '())) - (dotimes (i num-fields) - (declare (fixnum i)) - (push (canonical-field-type fields i) new-types)) - (nreverse new-types))) - (t - nil)))) (defun convert-to-clsql-warning (database condition) (warn 'clsql-database-warning :database database diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index 2f33992..24def53 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.10 2002/03/27 08:09:25 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.11 2002/03/27 12:09:39 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,33 +30,36 @@ ;;; Field conversion functions -(defun canonicalize-types (types num-fields res-ptr) - (cond - ((listp types) - (canonicalize-type-list types num-fields)) - ((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#int8 - :longlong) - ((#.pgsql-ftype#float4 - #.pgsql-ftype#float8) - :double) - (otherwise - t)) - new-types))) +(defun make-type-list-for-auto (num-fields res-ptr) + (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) + :int32) + (#.pgsql-ftype#int8 + :int64) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)) + new-types))) (nreverse new-types))) - (t - nil))) +(defun canonicalize-types (types num-fields res-ptr) + (let ((auto-list (make-type-list-for-auto num-fields res-ptr))) + (cond + ((listp types) + (canonicalize-type-list types auto-list)) + ((eq types :auto) + auto-list) + (t + nil)))) (defun tidy-error-message (message) (unless (stringp message) diff --git a/test-suite/xptest-clsql.cl b/test-suite/xptest-clsql.cl index 6d08227..397577a 100644 --- a/test-suite/xptest-clsql.cl +++ b/test-suite/xptest-clsql.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: xptest-clsql.cl,v 1.6 2002/03/27 11:13:27 kevin Exp $ +;;;; $Id: xptest-clsql.cl,v 1.7 2002/03/27 12:09:39 kevin Exp $ ;;;; ;;;; The XPTest package can be downloaded from ;;;; http://alpha.onshored.com/lisp-software/ @@ -19,6 +19,17 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* + +;;; This test suite looks for a configuration file named "test.config" +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) + (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :cl-user) (mk:load-system "XPTest") @@ -89,10 +100,10 @@ (when (map-query nil #'list "select * from test_clsql" :database db :types :auto) (failure "Expected NIL result from map-query nil")) - (do-query ((int float str) "select * from test_clsql") - (test-table-row (list int float str) nil)) - (do-query ((int float str) "select * from test_clsql" :types :auto) - (test-table-row (list int float str) :auto)) + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto)) (drop-test-table db) ) (disconnect :database db))))) @@ -108,7 +119,8 @@ (dotimes (i 10) (clsql-mysql::database-execute-command (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" - i (sqrt i) (format nil "~d" (sqrt i))) + i (number-to-sql-string (sqrt i)) + (number-to-sql-string (sqrt i))) db)) (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) @@ -121,16 +133,16 @@ (make-test-suite "CLSQL Test Suite" "Basic test suite for database operations." - ("MySQL Low Level Interface Test" 'clsql-fixture + ("MySQL Low Level Interface" 'clsql-fixture :test-thunk 'mysql-low-level :description "A test of MySQL low-level interface") - ("MySQL Test" 'clsql-fixture + ("MySQL Table" 'clsql-fixture :test-thunk 'mysql-table-test :description "A test of MySQL") - ("PostgreSQL Test" 'clsql-fixture + ("PostgreSQL Table" 'clsql-fixture :test-thunk 'pgsql-table-test :description "A test of PostgreSQL tables") - ("PostgreSQL Socket Table Test" 'clsql-fixture + ("PostgreSQL Socket Table" 'clsql-fixture :test-thunk 'pgsql-socket-table-test :description "A test of PostgreSQL Socket tables") )) @@ -143,24 +155,29 @@ ;;;; Testing functions -(defun transform1 (i) +(defun transform-float-1 (i) (* i (abs (/ i 2)) (expt 10 (* 2 i)))) +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + (defun create-test-table (db) (ignore-errors (clsql:execute-command "DROP TABLE test_clsql" :database db)) (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_str CHAR(20))" + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(20))" :database db) (dotimes (i 11) (let* ((test-int (- i 5)) - (test-flt (transform1 test-int))) + (test-flt (transform-float-1 test-int))) (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')" + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" test-int (number-to-sql-string test-flt) - (number-to-sql-string test-flt)) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) :database db)))) (defun parse-double (num-str) @@ -169,30 +186,32 @@ (defun test-table-row (row types) (unless (and (listp row) - (= 3 (length row))) + (= 4 (length row))) (failure "Row ~S is incorrect format" row)) - (destructuring-bind (int float str) row + (destructuring-bind (int float bigint str) row (cond ((eq types :auto) (unless (and (integerp int) (typep float 'double-float) + (integerp bigint) (stringp str)) (failure "Incorrect field type for row ~S" row))) ((null types) (unless (and (stringp int) (stringp float) + (stringp bigint) (stringp str)) (failure "Incorrect field type for row ~S" row)) - (setq int (parse-integer int)) - (setq float (parse-double float))) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) ((listp types) + (error "NYI") ) (t (failure "Invalid types field (~S) passed to test-table-row" types))) -#+ignore - (unless (= float (transform1 int)) + (unless (= float (transform-float-1 int)) (failure "Wrong float value ~A for int ~A (row ~S)" float int row)) -#+ignore (unless (= float (parse-double str)) (failure "Wrong string value ~A" str))))