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@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]