[pg-cvs] CVS update: pg/large-object.lisp pg/pg-tests.lisp pg/v3-protocol.lisp
Eric Marsden
emarsden at common-lisp.net
Fri Aug 13 16:50:37 UTC 2004
Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv1507
Modified Files:
large-object.lisp pg-tests.lisp v3-protocol.lisp
Log Message:
Implement binary-mode transfers for large-object operations in the v3
protocol. The v2 protocol transfers arguments in binary mode, but the
v3 protocol requires the client to specify for each argument of a
FunctionCall whether it is encoded as binary or as text.
- add possibility to send (unsigned-byte 8) arguments to function calls
- add a method READ-OCTETS-FROM-PACKET that reads raw octets
- make PG-IMPORT and PG-EXPORT use binary I/O
- PGLO-READ reads data in binary
- change the large-object tests to use binary I/O (fixes the pglo test)
Date: Fri Aug 13 09:50:37 2004
Author: emarsden
Index: pg/large-object.lisp
diff -u pg/large-object.lisp:1.1 pg/large-object.lisp:1.2
--- pg/large-object.lisp:1.1 Fri Mar 5 10:08:08 2004
+++ pg/large-object.lisp Fri Aug 13 09:50:37 2004
@@ -1,7 +1,6 @@
;;; large-object.lisp -- support for BLOBs
;;;
;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
;;
;;
;; Sir Humphrey: Who is Large and to what does he object?
@@ -82,8 +81,10 @@
(defun pglo-close (connection fd)
(fn connection "lo_close" t fd))
+;; note that the 3rd argument means that we are reading data in binary
+;; format, not text
(defun pglo-read (connection fd bytes)
- (fn connection "loread" nil fd bytes))
+ (fn connection "loread" t fd bytes))
(defun pglo-write (connection fd buf)
(fn connection "lowrite" t fd buf))
@@ -98,9 +99,10 @@
(fn connection "lo_unlink" t oid))
(defun pglo-import (connection filename)
- (let ((buf (make-string +LO_BUFSIZ+))
+ (let ((buf (make-array +LO_BUFSIZ+ :element-type '(unsigned-byte 8)))
(oid (pglo-create connection "rw")))
- (with-open-file (in filename :direction :input)
+ (with-open-file (in filename :direction :input
+ :element-type '(unsigned-byte 8))
(loop :with fdout = (pglo-open connection oid "w")
:for bytes = (read-sequence buf in)
:until (< bytes +LO_BUFSIZ+)
@@ -111,7 +113,8 @@
oid))
(defun pglo-export (connection oid filename)
- (with-open-file (out filename :direction :output)
+ (with-open-file (out filename :direction :output
+ :element-type '(unsigned-byte 8))
(loop :with fdin = (pglo-open connection oid "r")
:for str = (pglo-read connection fdin +LO_BUFSIZ+)
:until (zerop (length str))
Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.7 pg/pg-tests.lisp:1.8
--- pg/pg-tests.lisp:1.7 Wed Aug 11 06:27:48 2004
+++ pg/pg-tests.lisp Fri Aug 13 09:50:37 2004
@@ -13,9 +13,15 @@
#+cmu :fwrappers))
(in-package :pg-tests)
+(defmacro with-pg-connection/2 ((con &rest open-args) &body body)
+ `(let ((,con (pg::pg-connect/v2 , at open-args)))
+ (unwind-protect
+ (progn , at body)
+ (when ,con (pg-disconnect ,con)))))
+
;; !!! CHANGE THE VALUES HERE !!!
(defun call-with-test-connection (function)
- (with-pg-connection (conn "test" "pgdotlisp" :host "melbourne" :port 5433 :password "lisp")
+ (with-pg-connection (conn "test" "pgdotlisp")
(funcall function conn)))
(defmacro with-test-connection ((conn) &body body)
@@ -194,24 +200,27 @@
(sleep 1)
(pglo-unlink conn oid)))))
-;; test of large-object interface
+;; test of large-object interface. We are careful to use vectors of
+;; bytes instead of strings, because with the v3 protocol strings
+;; undergo \\xxx encoding (for instance #\newline is transformed to \\012).
(defun test-lo-read ()
(format *debug-io* "Testing read of large object ...~%")
(with-test-connection (conn)
(with-pg-transaction conn
(let* ((oid (pglo-create conn "rw"))
(fd (pglo-open conn oid "rw")))
- (pglo-write conn fd "Hi there mate")
+ (pglo-write conn fd (map '(vector (unsigned-byte 8)) #'char-code (format nil "Hi there mate~%What's up?~%")))
(pglo-lseek conn fd 3 0) ; SEEK_SET = 0
- (assert (= 3 (pglo-tell conn fd)))
+ (assert (eql 3 (pglo-tell conn fd)))
;; this should print "there mate"
- (format *debug-io* "Read ~s from lo~%" (pglo-read conn fd 10))
+ (format *debug-io* "Read ~s from lo~%" (map 'string #'code-char (pglo-read conn fd 10)))
+ (format *debug-io* "Rest is ~s~%" (map 'string #'code-char (pglo-read conn fd 1024)))
(pglo-close conn fd)
- (pglo-unlink conn oid)))))
+ #+nil (pglo-unlink conn oid)))))
#+cmu
(defun test-lo-import ()
- (format *debug-io* "Testing import of large object ...~%")
+ (format *debug-io* "Testing import of large object ...~%")
(with-test-connection (conn)
(with-pg-transaction conn
(let ((oid (pglo-import conn "/etc/group")))
Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.12 pg/v3-protocol.lisp:1.13
--- pg/v3-protocol.lisp:1.12 Wed Aug 11 06:27:48 2004
+++ pg/v3-protocol.lisp Fri Aug 13 09:50:37 2004
@@ -267,7 +267,7 @@
;; that really want READ-OCTET-ARRAY-FROM-PACKET
(defgeneric read-string-from-packet (packet length)
(:documentation
- "Reads an array of LENGTH bytes from the packet")
+ "Reads a string of LENGTH characters from the packet")
(:method ((packet pg-packet) (length (eql -1)))
nil)
(:method ((packet pg-packet) (length (eql 0)))
@@ -289,6 +289,13 @@
(incf position length)
result))))
+(defmethod read-octets-from-packet ((packet pg-packet) (length integer))
+ (let ((result (make-array length :element-type '(unsigned-byte 8))))
+ (with-slots (data position) packet
+ (replace result data :start2 position :end2 (+ position length))
+ (incf position length)
+ result)))
+
(defun send-packet (connection code description)
@@ -305,8 +312,9 @@
((:byte :char) 1)
((:int16) 2)
((:int32) 4)
+ ((:rawdata) (length value))
((:cstring) (1+ (length (convert-string-to-bytes value))))
- ((:ucstring :rawdata) (1+ (length value)))))))
+ ((:ucstring) (1+ (length value)))))))
(data (make-array (- length 4)
:element-type '(unsigned-byte 8)))
(stream (pgcon-stream connection)))
@@ -698,7 +706,7 @@
;; Argument FN is either an integer, in which case it is the OID of an
;; element in the pg_proc table, and otherwise it is a string which we
;; look up in the alist *lo-functions* to find the corresponding OID.
-(defmethod fn ((connection pgcon-v3) fn integer-result &rest args)
+(defmethod fn ((connection pgcon-v3) fn binary-result &rest args)
(or *lo-initialized* (lo-init connection))
(let ((fnid (cond ((integerp fn) fn)
((not (stringp fn))
@@ -711,33 +719,31 @@
`((:int32 ,fnid)
(:int16 ,(length args))
,@(let ((result nil))
- (loop for arg in args
- do
- (cond
- ((integerp arg)
- (push `(:int16 1)
- result))
- ((stringp arg)
- (push `(:int16 0)
- result))
- (t (error 'protocol-error
- :reason (format nil "Unknown fastpath type ~s" arg)))))
+ (dolist (arg args)
+ (etypecase arg
+ (integer
+ (push `(:int16 1) result))
+ ((vector (unsigned-byte 8))
+ (push `(:int16 1) result))
+ (string
+ (push `(:int16 0) result))))
(nreverse result))
(:int16 ,(length args))
,@(let ((result nil))
- (loop for arg in args
- do
- (cond
- ((integerp arg)
- (push '(:int32 4) result)
- (push `(:int32 ,arg) result))
- ((stringp arg)
- (push `(:int32 ,(1+ (length arg))) result)
- (push `(:cstring ,arg) result))
- (t (error 'protocol-error
- :reason (format nil "Unknown fastpath type ~s" arg)))))
+ (dolist (arg args)
+ (etypecase arg
+ (integer
+ (push '(:int32 4) result)
+ (push `(:int32 ,arg) result))
+ ((vector (unsigned-byte 8))
+ (push `(:int32 ,(length arg)) result)
+ (push `(:rawdata ,arg) result))
+ (string
+ ;; FIXME this should be STRING-OCTET-LENGTH instead of LENGTH
+ (push `(:int32 ,(1+ (length arg))) result)
+ (push `(:cstring ,arg) result))))
(nreverse result))
- (:int16 ,(if integer-result 1 0))))
+ (:int16 ,(if binary-result 1 0))))
(%flush connection)
(loop :with result = nil
:for packet = (read-packet connection)
@@ -746,14 +752,16 @@
((#\V) ; FunctionCallResponse
(let* ((length (read-from-packet packet :int32))
(data (unless (= length -1)
- (if integer-result
- (ecase length
+ (if binary-result
+ (case length
((1)
(read-from-packet packet :byte))
((2)
(read-from-packet packet :int16))
((4)
- (read-from-packet packet :int32)))
+ (read-from-packet packet :int32))
+ (t
+ (read-octets-from-packet packet length)))
(read-string-from-packet packet length)))))
(if data
(setf result data)
More information about the Pg-cvs
mailing list