;;;;
;;;; 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
;;;; - 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)))
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)))
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+
(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)))
(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"))
(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
;;;; 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
;;;;
(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
;;;; 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
(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)
(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)))
: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
(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
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)
;;;; 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
;;;;
: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)
)
+(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)
(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)))
)
projects / clsql.git / commitdiff