From 68a2a2bd6a380a61dce06a0510dab3441400d795 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 25 Mar 2002 23:22:07 +0000 Subject: [PATCH] r1659: More field type updates --- .../postgresql-socket-api.cl | 52 ++++++++++++----- .../postgresql-socket-package.cl | 11 +++- .../postgresql-socket-sql.cl | 57 +++++++++++++++++-- test-clsql.cl | 48 +++++++++------- 4 files changed, 129 insertions(+), 39 deletions(-) diff --git a/interfaces/postgresql-socket/postgresql-socket-api.cl b/interfaces/postgresql-socket/postgresql-socket-api.cl index 3d58496..46024c1 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.2 2002/03/24 04:01:26 kevin Exp $ +;;;; $Id: postgresql-socket-api.cl,v 1.3 2002/03/25 23:22:07 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -26,10 +26,18 @@ ;;;; - Added necessary (force-output) for socket streams on ;;;; Allegro and Lispworks ;;;; - Added initialization variable +;;;; - Added field type processing + (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :postgresql-socket) +(uffi:def-enum pgsql-ftype + ((:bytea 17) + (:int2 21) + (:int4 23) + (:float4 700) + (:float8 701))) (defmethod database-type-library-loaded ((database-type (eql :postgresql-socket))) @@ -555,7 +563,20 @@ connection, if it is still open." do (setf (aref result index) (ldb (byte 1 weight) byte)))) result)) -(defun read-cursor-row (cursor) +(defun read-field (socket type) + (let* ((length (read-socket-value 'int32 socket)) + (result (make-string (- length 4)))) + (read-socket-sequence result socket) + (case type + (:int + (parse-integer result)) + (:double + (let ((*read-default-float-format* 'double-float)) + (read-from-string result))) + (t + result)))) + +(defun read-cursor-row (cursor field-types) (let* ((connection (postgresql-cursor-connection cursor)) (socket (postgresql-connection-socket connection)) (fields (postgresql-cursor-fields cursor))) @@ -569,15 +590,13 @@ connection, if it is still open." with null-vector = (read-null-bit-vector socket count) repeat count for null-bit across null-vector + for i from 0 for null-p = (zerop null-bit) if null-p collect nil else collect - (let* ((length (read-socket-value 'int32 socket)) - (result (make-string (- length 4)))) - (read-socket-sequence result socket) - result)))) + (read-field socket (nth i field-types))))) (#.+binary-row-message+ (error "NYI")) (#.+completed-response-message+ @@ -601,7 +620,8 @@ connection, if it is still open." (error 'postgresql-fatal-error :connection connection :message "Received garbled message from backend"))))))) -(defun copy-cursor-row (cursor sequence) + +(defun copy-cursor-row (cursor sequence field-types) (let* ((connection (postgresql-cursor-connection cursor)) (socket (postgresql-connection-socket connection)) (fields (postgresql-cursor-fields cursor))) @@ -611,15 +631,21 @@ connection, if it is still open." (case code (#.+ascii-row-message+ (return + #+ignore + (let* ((count (length sequence)) + (null-vector (read-null-bit-vector socket count))) + (dotimes (i count) + (declare (fixnum i)) + (if (zerop (elt null-vector i)) + (setf (elt sequence i) nil) + (let ((value (read-field socket (nth i field-types)))) + (setf (elt sequence i) value))))) (map-into sequence #'(lambda (null-bit) (if (zerop null-bit) nil - (let* ((length (read-socket-value 'int32 socket)) - (result (make-string (- length 4)))) - (read-socket-sequence result socket) - result))) + (read-field socket t))) (read-null-bit-vector socket (length sequence))))) (#.+binary-row-message+ (error "NYI")) @@ -682,12 +708,12 @@ connection, if it is still open." (error 'postgresql-fatal-error :connection connection :message "Received garbled message from backend"))))))) -(defun run-query (connection query) +(defun run-query (connection query &optional (field-types nil)) (start-query-execution connection query) (multiple-value-bind (status cursor) (wait-for-query-results connection) (assert (eq status :cursor)) - (loop for row = (read-cursor-row cursor) + (loop for row = (read-cursor-row cursor field-types) while row collect row finally diff --git a/interfaces/postgresql-socket/postgresql-socket-package.cl b/interfaces/postgresql-socket/postgresql-socket-package.cl index b9ccd8b..ec8634b 100644 --- a/interfaces/postgresql-socket/postgresql-socket-package.cl +++ b/interfaces/postgresql-socket/postgresql-socket-package.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-socket-package.cl,v 1.1 2002/03/23 14:04:53 kevin Exp $ +;;;; $Id: postgresql-socket-package.cl,v 1.2 2002/03/25 23:22:07 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -23,7 +23,14 @@ (defpackage :postgresql-socket (:use :common-lisp) - (:export #:+crypt-library+ + (:export #:pgsql-ftype + #:pgsql-ftype#bytea + #:pgsql-ftype#int2 + #:pgsql-ftype#int4 + #:pgsql-ftype#float4 + #:pgsql-ftype#float8 + + #:+crypt-library+ #:postgresql-condition #:postgresql-condition-connection #:postgresql-condition-message diff --git a/interfaces/postgresql-socket/postgresql-socket-sql.cl b/interfaces/postgresql-socket/postgresql-socket-sql.cl index b98836f..61dddb4 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.4 2002/03/24 22:25:51 kevin Exp $ +;;;; $Id: postgresql-socket-sql.cl,v 1.5 2002/03/25 23:22:07 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -21,7 +21,6 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :cl-user) - (defpackage :clsql-postgresql-socket (:use :common-lisp :clsql-sys :postgresql-socket) (:export #:postgresql-socket-database) @@ -29,6 +28,50 @@ (in-package :clsql-postgresql-socket) +;; Field type conversion + +(defun canonical-field-type (fields index) + "Extracts canonical field type from fields list" + (let ((oid (cadr (nth index fields)))) + (case oid + ((#.pgsql-ftype#bytea + #.pgsql-ftype#int2 + #.pgsql-ftype#int4) + :int) + ((#.pgsql-ftype#float4 + #.pgsql-ftype#float8) + :double) + (otherwise + t)))) + +(defun canonicalize-field-types (types cursor) + (let* ((fields (postgresql-cursor-fields cursor)) + (num-fields (length fields))) + (cond + ((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))) + ((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 :message (postgresql-condition-message condition))) @@ -123,7 +166,8 @@ :expression expression :errno 'missing-result :error "Didn't receive result cursor for query.")) - (loop for row = (read-cursor-row cursor) + (setq field-types (canonicalize-field-types field-types cursor)) + (loop for row = (read-cursor-row cursor field-types) while row collect row finally @@ -193,7 +237,7 @@ (values (make-postgresql-socket-result-set :done nil :cursor cursor - :field-types field-types) + :field-types (canonicalize-field-types field-types cursor)) (length (postgresql-cursor-fields cursor))))))) (defmethod database-dump-result-set (result-set @@ -210,7 +254,10 @@ list) (let ((cursor (postgresql-socket-result-set-cursor result-set))) (with-postgresql-handlers (database) - (if (copy-cursor-row cursor list) + (if (copy-cursor-row cursor + list + (postgresql-socket-result-set-field-types + result-set)) t (prog1 nil (setf (postgresql-socket-result-set-done result-set) t) diff --git a/test-clsql.cl b/test-clsql.cl index 2aed163..78f83de 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.6 2002/03/25 14:13:41 kevin Exp $ +;;;; $Id: test-clsql.cl,v 1.7 2002/03/25 23:22:07 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -25,13 +25,15 @@ :defaults *load-truename*)) (defparameter *config* nil) -(defun do-test () - (if (probe-file *config-pathname*) - (with-open-file (stream *config-pathname* :direction :input) - (setq *config* (read stream)) - (test-automated *config*)) - (test-interactive))) - +(defun do-test (&optional (interactive nil)) + (if interactive + (test-interactive) + (if (probe-file *config-pathname*) + (with-open-file (stream *config-pathname* :direction :input) + (setq *config* (read stream)) + (test-automated *config*)) + (test-interactive)))) + (defun test-interactive () (do ((done nil)) (done) @@ -52,6 +54,20 @@ ) +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (i integer, sqrt float, sqrt_str CHAR(20))" :database db) + (dotimes (i 10) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (sqrt i) (format nil "~d" (sqrt i))) + :database db))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql")) (defun clsql-test-table (spec type) (when (eq type :mysql) @@ -59,20 +75,14 @@ (let ((db (clsql:connect spec :database-type type :if-exists :new))) (unwind-protect (progn - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (i integer, sqrt float, sqrt_str CHAR(20))" :database db) - (dotimes (i 10) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" - i (sqrt i) (format nil "~d" (sqrt i))) - :database db)) + (create-test-table db) + (pprint (clsql:query "select * from test_clsql" + :database db + :field-types :auto)) (pprint (clsql:map-query 'vector #'list "select * from test_clsql" :database db :field-types :auto)) ;;'(:int :double t))) - (clsql:execute-command "DROP TABLE test_clsql")) + (drop-test-table db)) (clsql:disconnect :database db))) ) -- 2.34.1