Update of /project/pg/cvsroot/pg
In directory clnet:/tmp/cvs-serv11805
Modified Files:
v3-protocol.lisp
Log Message:
Fixes to the prepared statement support, in order to implement precise
error reporting. Deadlocks were possible with previous version, where
pg-dot-lisp would be blocked waiting for input from the backend that
never arrived.
Also some code cleanups.
--- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/10/22 15:48:45 1.26
+++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/10/22 19:25:51 1.27
@@ -2,6 +2,11 @@
;;;
;;; Author: Peter Van Eynde <pvaneynd(a)debian.org>
+
+
+(declaim (optimize (speed 3) (safety 1)))
+
+
(in-package :postgresql)
(defclass pgcon-v3 (pgcon)
@@ -98,7 +103,7 @@
;; FIXME remove the duplication between this an HANDLE-NOTIFICATION/V3 at end of file
-(defun read-and-generate-error-response (packet)
+(defun read-and-generate-error-response (connection packet)
(let ((args nil))
(loop :for field-type = (read-from-packet packet :byte)
:until (= field-type 0)
@@ -118,25 +123,24 @@
((#\L) :line)
((#\R) :routine))
args)))
+ (send-packet connection #\S nil)
;; we are trying to recover from errors too:
(apply #'cerror
"Try to continue, should do a rollback"
'error-response
(append (list :reason "Backend error") args))))
-
(defun read-and-handle-notification-response (connection packet)
(declare (type pg-packet packet)
(type pgcon-v3 connection))
-
(let* ((pid (read-from-packet packet :int32))
- (name-condition (read-from-packet packet :cstring))
+ (condition-name (read-from-packet packet :cstring))
(additional-information (read-from-packet packet :cstring)))
(setf (pgcon-pid connection) pid)
- (format t "~&Got notice: ~S, ~S"
- name-condition
+ (format *debug-io* "~&Got notification: ~S, ~S~%"
+ condition-name
additional-information)
- (push name-condition (pgcon-notices connection))))
+ (push condition-name (pgcon-notices connection))))
@@ -166,12 +170,18 @@
:data data
:connection connection)))
(case (pg-packet-type packet)
- (( #\E) ; error
- (read-and-generate-error-response packet)
+ ((#\E) ; error
+ (read-and-generate-error-response connection packet)
packet)
- (( #\N) ; Notice
+
+ ((#\N) ; Notice
(handle-notice/v3 connection packet)
packet)
+
+ ((#\A)
+ (read-and-handle-notification-response connection packet)
+ packet)
+
(t
;; return the packet
packet)))))
@@ -182,16 +192,12 @@
(:documentation
"Reads an integer from the given PACKET with type TYPE")
(:method ((packet pg-packet) (type (eql :char)))
- (with-slots (data position)
- packet
-
+ (with-slots (data position) packet
(prog1
(elt data position)
(incf position))))
(:method ((packet pg-packet) (type (eql :byte)))
- (with-slots (data position)
- packet
-
+ (with-slots (data position) packet
(let ((result (elt data position)))
(incf position)
(when (= 1 (ldb (byte 1 7) result))
@@ -201,9 +207,7 @@
#xFF)))))
result)))
(:method ((packet pg-packet) (type (eql :int16)))
- (with-slots (data position)
- packet
-
+ (with-slots (data position) packet
(let ((result (+ (* 256 (elt data position))
(elt data (1+ position)))))
(incf position 2)
@@ -214,9 +218,7 @@
#xFFFF)))))
result)))
(:method ((packet pg-packet) (type (eql :int32)))
- (with-slots (data position)
- packet
-
+ (with-slots (data position) packet
(let ((result (+ (* 256 256 256 (elt data position))
(* 256 256 (elt data (1+ position)))
(* 256 (elt data (+ 2 position)))
@@ -241,12 +243,11 @@
(loop :for i :from position :below end
:for j :from 0
:do
- (setf (elt result j)
- (code-char
- (elt data i))))
+ (setf (aref result j)
+ (code-char (aref data i))))
(setf position (1+ end))
result))))
-
+
;; a string that does get encoded, if the current connection has set
;; its prefered encoding
(:method ((packet pg-packet) (type (eql :cstring)))
@@ -354,6 +355,7 @@
((:cstring)
(check-type value string)
(let ((encoded (convert-string-to-bytes value)))
+ (declare (type (vector (unsigned-byte 8) *) encoded))
(replace data encoded :start1 position)
(incf position (length encoded)))
(setf (elt data position) 0)
@@ -363,6 +365,7 @@
((:string)
(check-type value string)
(let ((encoded (convert-string-to-bytes value)))
+ (declare (type (vector (unsigned-byte 8) *) encoded))
(replace data encoded :start1 position)
(incf position (length encoded))))
@@ -437,6 +440,7 @@
:reason "SCM authentication not supported"))
(t (error 'authentication-failure
:reason "unknown authentication type")))))
+
(( #\K)
;; Cancelation
(let* ((pid (read-from-packet packet :int32))
@@ -446,19 +450,18 @@
(setf (pgcon-pid connection) pid)
(setf (pgcon-secret connection) secret)))
- (( #\S)
+
+ ((#\S)
;; Status
(let* ((parameter (read-from-packet packet :ucstring))
(value (read-from-packet packet :ucstring)))
(push (cons parameter value) (pgcon-parameters connection))))
+
((#\Z)
;; Ready for Query
(let* ((status (read-from-packet packet :byte)))
- (unless (= status
- (char-code #\I))
- (warn "~&Got status ~S but wanted I~%"
- (code-char status)))
-
+ (unless (= status (char-code #\I))
+ (warn "~&Got status ~S but wanted I~%" (code-char status)))
(when *pg-client-encoding*
(setf (pg-client-encoding connection) *pg-client-encoding*))
(and (not *pg-disable-type-coercion*)
@@ -467,176 +470,165 @@
(when *pg-date-style*
(setf (pg-date-style connection) *pg-date-style*))
(return connection)))
+
((#\E)
;; an error, we should abort.
(return nil))
- ((#\N)
- ;; We ignore Notices
+
+ ((#\N) ;; a notice, that has already been handled in READ-PACKET
t)
+
(t (error 'protocol-error
:reason "expected an authentication response"))))))
(defun do-followup-query (connection)
"Does the followup of a query"
-
(let ((tuples '())
(attributes '())
(result (make-pgresult :connection connection)))
-
- (%flush connection)
-
(loop
:for packet = (read-packet connection)
:with got-data-p = nil
:with receive-data-p = nil
- :do
- (when packet
- (case (pg-packet-type packet)
- ((#\S)
- ;; Parameter status? not documented as return!
- ;; XXX investigate
- (let* ((parameter (read-from-packet packet :cstring))
- (value (read-from-packet packet :cstring)))
- (push (cons parameter value) (pgcon-parameters connection))))
- ((#\A)
- ;; NotificationResponse
- ;; Not documented?
- ;; XXX investigate
- (read-and-handle-notification-response connection packet))
- ((#\C)
- ;; CommandComplete
- (let ((status (read-from-packet packet :cstring)))
- (setf (pgresult-status result) status)
- (setf (pgresult-tuples result) (nreverse tuples))
- (setf (pgresult-attributes result) attributes))
- (setf got-data-p t))
- ((#\G)
- ;; CopyInResponse
- (cond
- ((and (streamp (pgcon-sql-stream connection))
- (input-stream-p (pgcon-sql-stream connection)))
- ;; we ignore the data stuff.
- (handler-case
- (progn
- (loop :with buffer = (make-array 4096
- :element-type '(unsigned-byte 8)
- :adjustable t)
- :for length = (read-sequence buffer (pgcon-sql-stream connection))
- :until (= length 0)
- :do
- ;; send data
- (unless (= length 4096)
- (setf buffer
- (adjust-array buffer (list length))))
- (send-packet connection
- #\d
- `((:rawdata ,buffer))))
-
- ;; CopyDone
- (send-packet connection
- #\c
- nil))
- ((or error serious-condition) (condition)
- (warn "Got an error while writing sql data: ~S aborting transfer!"
- condition)
- (send-packet connection
- #\f
- ;;CopyFail
- '((:cstring "No input data provided")))))
- (%flush connection))
- (t
- (warn "We had to provide data, but my sql-stream isn't an input-stream. Aborting transfer")
-
- (send-packet connection
- #\f
- ;;CopyFail
- '((:cstring "No input data provided"))))))
- ((#\H)
- ;; CopyOutResponse
- (cond
- ((and (streamp (pgcon-sql-stream connection))
- (output-stream-p (pgcon-sql-stream connection)))
- (setf receive-data-p t))
- (t
- (setf receive-data-p nil)
- (warn "I should receive data but my sql-stream isn't an outputstream!~%Ignoring data"))))
- (( #\d)
- ;; CopyData
- (when receive-data-p
- ;; we break the nice packet abstraction here to
- ;; get some speed:
- (let ((length (- (pg-packet-length packet) 4)))
- (write-sequence (make-array length
- :element-type '(unsigned-byte 8)
- :displaced-to (slot-value packet
- 'data)
- :displaced-index-offset
- (slot-value packet 'position))
- (pgcon-sql-stream connection)))))
- (( #\c )
- ;;CopyDone
- ;; we do nothing (the exec will return and the user
- ;; can do something if he/she wants
- (setf receive-data-p nil)
- t)
- ((#\T)
- ;; RowDescription (metadata for subsequent tuples), #\T
- (and attributes (error "Cannot handle multiple result group"))
- (setq attributes (read-attributes/v3 packet)))
- ((#\D)
- ;; AsciiRow (text data transfer), #\D
- (setf got-data-p t)
- (setf (pgcon-binary-p connection) nil)
- (unless attributes
- (error 'protocol-error :reason "Tuple received before metadata"))
- (push (read-tuple/v3 packet attributes) tuples))
- ((#\I)
- ;; EmptyQueryResponse, #\I
- ;; so no result.
- (setf got-data-p t)
- (setf (pgresult-status result) "SELECT")
- (setf (pgresult-tuples result) nil)
- (setf (pgresult-attributes result) nil))
- ((#\Z)
- ;; ReadyForQuery
- ;;
- ;; it might be a result from a previous
- ;; query
- (when got-data-p
- (return result)))
- ((#\s)
- ;; PortalSuspend
- ;; we're done in any case:
- (return result))
- ((#\V)
- ;; FunctionCallResponse -- not clear why we would get these here instead of in FN
- (let* ((length (read-from-packet packet :int32))
- (response (unless (= length -1)
- (read-string-from-packet packet length))))
- (setf (pgresult-status result) response)))
- ((#\2
- ;; BindComplete
- #\1
- ;; ParseComplete
- #\3
- ;; CloseComplete
- #\n
- ;; NoData
- )
- ;; we ignore these messages
- t)
- ((#\E
- ;; an error, we bravely try to recover...
- #\N)
- ;; and we ignore Notices
- t)
- (t
- (warn "Got unexpected packet: ~S, resetting connection"
- packet)
- ;; sync
- (send-packet connection #\S nil)
- (%flush connection)))))))
+ :do (case (pg-packet-type packet)
+ ((#\S) ;; ParameterStatus
+ (let* ((parameter (read-from-packet packet :cstring))
+ (value (read-from-packet packet :cstring)))
+ (push (cons parameter value) (pgcon-parameters connection)))
+ (setf got-data-p t))
+
+ ((#\A) ;; NotificationResponse, that has already been handled in READ-PACKET
+ (setf got-data-p t))
+
+ ((#\C)
+ ;; CommandComplete
+ (let ((status (read-from-packet packet :cstring)))
+ (setf (pgresult-status result) status)
+ (setf (pgresult-tuples result) (nreverse tuples))
+ (setf (pgresult-attributes result) attributes))
+ (setf got-data-p t))
+
+ ((#\G)
+ ;; CopyInResponse
+ (cond
+ ((and (streamp (pgcon-sql-stream connection))
+ (input-stream-p (pgcon-sql-stream connection)))
+ ;; we ignore the data stuff.
+ (handler-case
+ (progn
+ (loop :with buffer = (make-array 4096
+ :element-type '(unsigned-byte 8)
+ :adjustable t)
+ :for length = (read-sequence buffer (pgcon-sql-stream connection))
+ :until (= length 0)
+ :do
+ ;; send data
+ (unless (= length 4096)
+ (setf buffer
+ (adjust-array buffer (list length))))
+ (send-packet connection #\d `((:rawdata ,buffer))))
+ ;; CopyDone
+ (send-packet connection #\c nil))
+ ((or error serious-condition) (condition)
[282 lines skipped]
