Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv7425

Modified Files: pg.lisp v3-protocol.lisp Log Message: pg.lisp: - make print-object more robust - added documentation to the defgenerics - added some declarations v3-protocol.lisp: - make errors restartable as we hope to sync again with the db - return errors from read-packet because sometimes it is the only clue we get that there is no more output - replaced arefs with the faster elt - unified query followup into do-followup-query - added pbe (prepare bind execute) support

Date: Mon Mar 8 09:37:31 2004 Author: pvaneynde

Index: pg/pg.lisp diff -u pg/pg.lisp:1.2 pg/pg.lisp:1.3 --- pg/pg.lisp:1.2 Fri Mar 5 13:08:08 2004 +++ pg/pg.lisp Mon Mar 8 09:37:31 2004 @@ -40,7 +40,7 @@ ;; Exceptions are Corman Common Lisp whose socket streams do not ;; support binary I/O. ;; -;; See the README for API documentation. +;; See the README for API documentation.

;; This code has been tested or reported to work with ;; @@ -81,7 +81,7 @@ (port :initarg :port :reader connection-failure-port) (transport-error :initarg :transport-error - :reader connection-failure-transport-error)) + :reader connection-failure-transport-error)) (:report (lambda (exc stream) (declare (type stream stream)) @@ -90,7 +90,7 @@ Is the postmaster running and accepting TCP connections?~%" (connection-failure-host exc) (connection-failure-port exc) - (connection-failure-transport-error exc))))) + (connection-failure-transport-error exc)))))

(define-condition authentication-failure (postgresql-error) ((reason :initarg :reason @@ -162,21 +162,66 @@ :initform nil)))

(defmethod print-object ((self pgcon) stream) - (print-unreadable-object (self stream :type nil) - (with-slots (pid host port) self - (format stream "PostgreSQL connection to backend pid ~d at ~a:~d" - pid host port)))) + (print-unreadable-object (self stream :type nil) + (with-slots (pid host port) self + (format stream "PostgreSQL connection to backend pid ~d at ~a:~d" + (when (slot-boundp self 'pid) + pid) + (when (slot-boundp self 'host) + host) + (when (slot-boundp self 'port) + port)))))

(defstruct pgresult connection status attributes tuples)

-(defgeneric pg-exec (connection &rest args)) - -(defgeneric fn (connection fn integer-result &rest args)) - -(defgeneric pg-disconnect (connection)) - - +(defgeneric pg-exec (connection &rest args) + (:documentation + "Execute the SQL command given by the concatenation of ARGS +on the database to which we are connected via CONNECTION. Return +a result structure which can be decoded using `pg-result'.")) + +(defgeneric fn (connection fn integer-result &rest args) + (:documentation + "Execute one of the large-object functions (lo_open, lo_close etc). + 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.")) + +(defgeneric pg-disconnect (connection) + (:documentation + "Disconnects from the DB")) + +(defgeneric pg-supports-pbe (connection) + (:documentation + "Returns true if the connection supports pg-prepare/-bind and -execute") + (:method (connection) + (declare (ignore connection)) + nil)) + +(defgeneric pg-prepare (connection statement-name sql-statement &optional type-of-parameters) + (:documentation + "Prepares a sql-statement give a given statement-name (can be empty) +and optionally declares the types of the parameters as a list of strings. +You can define parameters to be filled in later by using $1 and so on.")) + +(defgeneric pg-bind (connection portal statement-name list-of-types-and-values) + (:documentation + "Gives the values for the parameters defined in the statement-name. The types +can be one of :char :byte :int16 :int32 or :cstring")) + +(defgeneric pg-execute (connection portal &optional maxinum-number-of-rows) + (:documentation + "Executes the portal defined previously and return (optionally) up to maximum-number-of-row. +For an unlimited number of rows use 0")) + +(defgeneric pg-close-statement (connection statement-name) + (:documentation + "Closes a prepared statement")) + +(defgeneric pg-close-portal (connection portal) + (:documentation + "Closes a prepared statement"))

;; first attempt to connect to connect using the v3 protocol; if this ;; results in an ErrorResponse we close the connection and retry using @@ -196,6 +241,7 @@ :port port :password password) (protocol-error (c) + (declare (ignore c)) (warn "reconnecting using protocol version 2") (pg-connect/v2 dbname user :host host @@ -214,6 +260,7 @@ :tuple n -> return the nth component of the data :oid -> return the OID (a unique identifier generated by PostgreSQL for each row resulting from an insertion" + (declare (type pgresult result)) (cond ((eq :connection what) (pgresult-connection result)) ((eq :status what) (pgresult-status result)) ((eq :attributes what) (pgresult-attributes result)) @@ -238,6 +285,9 @@

;; read an integer in network byte order (defun read-net-int (connection bytes) + (declare (type (integer 0) bytes) + (type pgcon connection)) + (do ((i bytes (- i 1)) (stream (pgcon-stream connection)) (accum 0)) @@ -271,8 +321,8 @@ (let ((v (make-array howmany :element-type '(unsigned-byte 8))) (s (pgcon-stream connection))) (do ((continue-at (read-sequence v s :start 0 :end howmany) - (read-sequence v s :start continue-at :end howmany))) - ((= continue-at howmany)) + (read-sequence v s :start continue-at :end howmany))) + ((= continue-at howmany)) ) v))

Index: pg/v3-protocol.lisp diff -u pg/v3-protocol.lisp:1.1 pg/v3-protocol.lisp:1.2 --- pg/v3-protocol.lisp:1.1 Fri Mar 5 13:08:08 2004 +++ pg/v3-protocol.lisp Mon Mar 8 09:37:31 2004 @@ -15,46 +15,46 @@ ((severity :initarg :severity :reader error-response-severity) (code :initarg :code - :reader error-response-code) + :reader error-response-code) (message :initarg :message - :reader error-response-message) + :reader error-response-message) (detail :initarg :detail - :reader error-response-detail) + :reader error-response-detail) (hint :initarg :hint - :reader error-response-hint) + :reader error-response-hint) (position :initarg :position - :reader error-response-position) + :reader error-response-position) (where :initarg :where - :reader error-response-where) + :reader error-response-where) (file :initarg :file - :reader error-response-file) + :reader error-response-file) (line :initarg :line - :reader error-response-line) + :reader error-response-line) (routine :initarg :routine - :reader error-response-routine)) + :reader error-response-routine)) (:report (lambda (exc stream) (format stream "PostgreSQL ~A: (~A) ~A, ~A. Hint: ~A File: ~A, line ~A/~A ~A -> ~A" - (ignore-errors - (error-response-severity exc)) - (ignore-errors - (error-response-code exc)) - (ignore-errors - (error-response-message exc)) - (ignore-errors - (error-response-detail exc)) - (ignore-errors - (error-response-hint exc)) - (ignore-errors - (error-response-file exc)) - (ignore-errors - (error-response-line exc)) - (ignore-errors - (error-response-position exc)) - (ignore-errors - (error-response-routine exc)) - (ignore-errors - (error-response-where exc)))))) + (ignore-errors + (error-response-severity exc)) + (ignore-errors + (error-response-code exc)) + (ignore-errors + (error-response-message exc)) + (ignore-errors + (error-response-detail exc)) + (ignore-errors + (error-response-hint exc)) + (ignore-errors + (error-response-file exc)) + (ignore-errors + (error-response-line exc)) + (ignore-errors + (error-response-position exc)) + (ignore-errors + (error-response-routine exc)) + (ignore-errors + (error-response-where exc))))))

;; packets send/received are always: @@ -68,24 +68,24 @@

(defclass pg-packet () ((type :initarg :type - :type base-char - :reader pg-packet-type) + :type base-char + :reader pg-packet-type) (length :initarg :length - :type (integer 32)) + :type (integer 32)) (data :initarg :data - :type (array (unsigned-byte 8) *)) + :type (array (unsigned-byte 8) *)) (position :initform 0 - :type integer))) + :type integer)))

(defmethod print-object ((object pg-packet) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "type: ~A length: ~A position: ~A" - (and (slot-boundp object 'type) - (slot-value object 'type)) - (and (slot-boundp object 'length) - (slot-value object 'length)) - (and (slot-boundp object 'position) - (slot-value object 'position))))) + (and (slot-boundp object 'type) + (slot-value object 'type)) + (and (slot-boundp object 'length) + (slot-value object 'length)) + (and (slot-boundp object 'position) + (slot-value object 'position)))))

;; first some help functions:

@@ -98,8 +98,8 @@ (when (= 1 (ldb (byte 1 7) result)) ;; negative (setf result (- - (1+ (logxor result - #xFF))))) + (1+ (logxor result + #xFF))))) result))

(defun %read-net-int16 (stream) @@ -107,12 +107,12 @@ The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 (read-byte stream)) - (read-byte stream)))) + (read-byte stream)))) (when (= 1 (ldb (byte 1 15) result)) ;; negative (setf result (- - (1+ (logxor result - #xFFFF))))) + (1+ (logxor result + #xFFFF))))) result))

(defun %read-net-int32 (stream) @@ -120,14 +120,14 @@ The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 256 256 (read-byte stream)) - (* 256 256 (read-byte stream)) - (* 256 (read-byte stream)) - (read-byte stream)))) + (* 256 256 (read-byte stream)) + (* 256 (read-byte stream)) + (read-byte stream)))) (when (= 1 (ldb (byte 1 31) result)) ;; negative (setf result (- - (1+ (logxor result - #xFFFFFFFF))))) + (1+ (logxor result + #xFFFFFFFF))))) result))

#-cmu @@ -149,8 +149,8 @@ Returns the array of " (let ((v (make-array howmany :element-type '(unsigned-byte 8)))) (do ((continue-at (read-sequence v stream :start 0 :end howmany) - (read-sequence v stream :start continue-at :end howmany))) - ((= continue-at howmany)) + (read-sequence v stream :start continue-at :end howmany))) + ((= continue-at howmany)) ) v))

@@ -161,38 +161,41 @@ (defun read-and-generate-error-response (packet) (let ((args nil)) (loop :for field-type = (read-from-packet packet :byte) - :until (= field-type 0) - :do - (let ((message (read-from-packet packet :cstring))) - (push message args) - (push - (ecase (code-char field-type) - ((#\S) :severity) - ((#\C) :code) - ((#\M) :message) - ((#\D) :detail) - ((#\H) :hint) - ((#\P) :position) - ((#\W) :where) - ((#\F) :file) - ((#\L) :line) - ((#\R) :routine)) - args))) - (apply #'error - 'error-response - args))) + :until (= field-type 0) + :do + (let ((message (read-from-packet packet :cstring))) + (push message args) + (push + (ecase (code-char field-type) + ((#\S) :severity) + ((#\C) :code) + ((#\M) :message) + ((#\D) :detail) + ((#\H) :hint) + ((#\P) :position) + ((#\W) :where) + ((#\F) :file) + ((#\L) :line) + ((#\R) :routine)) + args))) + ;; we are trying to recover from errors too: + (apply #'cerror + "Try to continue, should do a rollback" + 'error-response + args)))

(defun read-and-handle-notification-response (connection packet) - (declare (type pg-packet packet)) - + (declare (type pg-packet packet) + (type pgcon-v3 connection)) + (let* ((pid (read-from-packet packet :int32)) - (name-condition (read-from-packet packet :cstring)) - (additional-information (read-from-packet packet :cstring))) + (name-condition (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 - additional-information) + name-condition + additional-information) (push name-condition (pgcon-notices connection))))

@@ -201,10 +204,11 @@

(defun read-packet (connection) "Reads a packet from the connection. -Returns the packet, handles errors and notices automagically" +Returns the packet, handles errors and notices automagically, +but will still return them" (let* ((stream (pgcon-stream connection)) - (type (%read-net-int8 stream)) - (length (%read-net-int32 stream))) + (type (%read-net-int8 stream)) + (length (%read-net-int32 stream))) ;; detect a bogus protocol response from the backend, which ;; probably means that we're in PG-CONNECT/V3 but talking to an ;; old backend that only understands the V2 protocol. Heuristics @@ -221,16 +225,16 @@ :length length :data data))) (case (pg-packet-type packet) - (( #\E) ; error + (( #\E) ; error (read-and-generate-error-response packet) - ;; in case we handled it: - (read-packet connection)) - (( #\N) ; Notice - (handle-notice/v3 connection packet)) + packet) + (( #\N) ; Notice + (handle-notice/v3 connection packet) + packet) (t ;; return the packet packet))))) - + ;; Not to get at the data:

(defgeneric read-from-packet (packet type) @@ -238,70 +242,70 @@ "Reads an integer from the given PACKET with type TYPE") (:method ((packet pg-packet) (type (eql :char))) (with-slots (data position) - packet + packet

(prog1 - (aref data position) - (incf position)))) + (elt data position) + (incf position)))) (:method ((packet pg-packet) (type (eql :byte))) (with-slots (data position) - packet + packet

- (let ((result (aref data position))) - (incf position) - (when (= 1 (ldb (byte 1 7) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFF))))) - result))) + (let ((result (elt data position))) + (incf position) + (when (= 1 (ldb (byte 1 7) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFF))))) + result))) (:method ((packet pg-packet) (type (eql :int16))) (with-slots (data position) - packet + packet

- (let ((result (+ (* 256 (aref data position)) - (aref data (1+ position))))) - (incf position 2) - (when (= 1 (ldb (byte 1 15) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFFFF))))) - result))) + (let ((result (+ (* 256 (elt data position)) + (elt data (1+ position))))) + (incf position 2) + (when (= 1 (ldb (byte 1 15) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFFFF))))) + result))) (:method ((packet pg-packet) (type (eql :int32))) (with-slots (data position) - packet + packet

- (let ((result (+ (* 256 256 256 (aref data position)) - (* 256 256 (aref data (1+ position))) - (* 256 (aref data (+ 2 position))) - (aref data (+ 3 position))))) - - (incf position 4) - (when (= 1 (ldb (byte 1 31) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFFFFFFFF))))) - result))) + (let ((result (+ (* 256 256 256 (elt data position)) + (* 256 256 (elt data (1+ position))) + (* 256 (elt data (+ 2 position))) + (elt data (+ 3 position))))) + + (incf position 4) + (when (= 1 (ldb (byte 1 31) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFFFFFFFF))))) + result))) (:method ((packet pg-packet) (type (eql :cstring))) (with-slots (data position) - packet + packet

(let* ((end (position 0 data :start position)) - ;; end is where the 0 byte is - (result (unless (= end position) - (make-array (- end position) - :element-type 'base-char)))) - (when result - (loop :for i :from position :below end - :for j :from 0 - :do - (setf (aref result j) - (code-char - (aref data i)))) - (setf position (1+ end)) - result))))) + ;; end is where the 0 byte is + (result (unless (= end position) + (make-array (- end position) + :element-type 'base-char)))) + (when result + (loop :for i :from position :below end + :for j :from 0 + :do + (setf (elt result j) + (code-char + (elt data i)))) + (setf position (1+ end)) + result)))))

(defgeneric read-string-from-packet (packet length) (:documentation @@ -311,19 +315,19 @@ (:method ((packet pg-packet) (length integer)) (when (<= length 0) (error "length cannot be negative. is: ~S" - length)) + length)) (let ((result (make-array length - :element-type 'base-char))) + :element-type 'base-char))) (with-slots (data position) - packet - (loop :for i :from 0 :below length - :do - (setf (aref result i) - (code-char - (the (unsigned-byte 8) - (aref data (+ i position)))))) - (incf position length) - result)))) + packet + (loop :for i :from 0 :below length + :do + (setf (elt result i) + (code-char + (the (unsigned-byte 8) + (elt data (+ i position)))))) + (incf position length) + result))))

;; now sending data: @@ -331,10 +335,10 @@ (defun %send-net-int (stream int bytes) (let ((v (make-array bytes :element-type '(unsigned-byte 8)))) (loop for offset from (* 8 (1- bytes)) downto 0 by 8 - for data = (ldb (byte 8 offset) int) - for i from 0 - do - (setf (aref v i) data)) + for data = (ldb (byte 8 offset) int) + for i from 0 + do + (setf (elt v i) data)) #+debug (format t "~&writing: ~S~%" v) (write-sequence v stream))) @@ -345,7 +349,7 @@ (v (make-array len :element-type '(unsigned-byte 8)))) ;; convert the string to a vector of bytes (dotimes (i len) - (setf (aref v i) (char-code (aref str i)))) + (setf (elt v i) (char-code (elt str i)))) (write-sequence v stream) (write-byte 0 stream)))

@@ -360,57 +364,56 @@ of items with as first element one of :byte, :char :int16 :int32 or :cstring and as second element the value of the parameter" - #+nil (declare (type base-char code))

(let* ((length (+ 4 - (loop for (type value) in description - sum (ecase type - ((:byte :char) 1) - ((:int16) 2) - ((:int32) 4) - ((:cstring) - (+ 1 - (length value))))))) - (data (make-array (- length 4) - :element-type '(unsigned-byte 8))) - (stream (pgcon-stream connection))) + (loop for (type value) in description + sum (ecase type + ((:byte :char) 1) + ((:int16) 2) + ((:int32) 4) + ((:cstring) + (+ 1 + (length value))))))) + (data (make-array (- length 4) + :element-type '(unsigned-byte 8))) + (stream (pgcon-stream connection)))

(loop for (type value) in description - with position = 0 - do - (ecase type - ((:byte) - (check-type value (unsigned-byte 8)) - (setf (aref data position) value) - (incf position)) - ((:char) - (check-type value base-char) - (setf (aref data position) (char-code value)) - (incf position)) - ((:int16) - (check-type value (unsigned-byte 16)) - (setf (aref data position) (ldb (byte 8 8) value)) - (setf (aref data (+ 1 position)) (ldb (byte 8 0) value)) - (incf position 2)) - ((:int32) - (check-type value (unsigned-byte 32)) - - (setf (aref data position) (ldb (byte 8 24) value)) - (setf (aref data (+ 1 position)) (ldb (byte 8 16) value)) - (setf (aref data (+ 2 position)) (ldb (byte 8 8) value)) - (setf (aref data (+ 3 position)) (ldb (byte 8 0) value)) - (incf position 4)) - ((:cstring) - (check-type value string) - - (loop for char across value - do - (setf (aref data position) - (char-code char)) - (incf position)) - (setf (aref data position) 0) - (incf position)))) + with position = 0 + do + (ecase type + ((:byte) + (check-type value (unsigned-byte 8)) + (setf (elt data position) value) + (incf position)) + ((:char) + (check-type value base-char) + (setf (elt data position) (char-code value)) + (incf position)) + ((:int16) + (check-type value (unsigned-byte 16)) + (setf (elt data position) (ldb (byte 8 8) value)) + (setf (elt data (+ 1 position)) (ldb (byte 8 0) value)) + (incf position 2)) + ((:int32) + (check-type value (unsigned-byte 32)) + + (setf (elt data position) (ldb (byte 8 24) value)) + (setf (elt data (+ 1 position)) (ldb (byte 8 16) value)) + (setf (elt data (+ 2 position)) (ldb (byte 8 8) value)) + (setf (elt data (+ 3 position)) (ldb (byte 8 0) value)) + (incf position 4)) + ((:cstring) + (check-type value string) + + (loop for char across value + do + (setf (elt data position) + (char-code char)) + (incf position)) + (setf (elt data position) 0) + (incf position))))

(%send-net-int stream (char-code code) 1) (%send-net-int stream length 4 ) @@ -426,16 +429,16 @@ (let* ((stream (socket-connect port host)) (connection (make-instance 'pgcon-v3 :stream stream :host host :port port)) (user-packet-length (+ 4 ; length - 4 ; protocol version - (length "user") - 1 - (length user) - 1 - (length "database") - 1 - (length dbname) - 1 - 1))) + 4 ; protocol version + (length "user") + 1 + (length user) + 1 + (length "database") + 1 + (length dbname) + 1 + 1))) ;; send the startup packet ;; this is one of the only non-standard packets! (%send-net-int stream user-packet-length 4) @@ -453,138 +456,205 @@ :for packet = (read-packet connection) :do (case (pg-packet-type packet) - ;; Authentication Request: - (( #\R) - (let* ((code (read-from-packet packet :int32))) - (case code - ((0) ;; AuthOK - ) - ((1) ; AuthKerberos4 - (error 'authentication-failure - :reason "Kerberos4 authentication not supported")) - ((2) ; AuthKerberos5 - (error 'authentication-failure - :reason "Kerberos5 authentication not supported")) - ((3) ; AuthUnencryptedPassword - (send-packet connection - #\p - `((:cstring ,password))) - (%flush connection)) - ((4) ; AuthEncryptedPassword - (let* ((salt (read-string-from-packet packet 2)) - (crypted (crypt password salt))) - #+debug - (format *debug-io* "Got salt of ~s~%" salt) - (send-packet connection - #\p - `((:cstring ,crypted))) - (%flush connection))) - ((5) ; AuthMD5Password - (error 'authentication-failure - :reason "MD5 authentication not supported")) - ((6) ; AuthSCMPassword - (error 'authentication-failure - :reason "SCM authentication not supported")) - (t (error 'authentication-failure - :reason "unknown authentication type"))))) - (( #\K) ; Cancelation - (let* ((pid (read-from-packet packet :int32)) - (secret (read-from-packet packet :int32))) - #+debug - (format t "~&Got cancelation data") - - (setf (pgcon-pid connection) pid) - (setf (pgcon-secret connection) secret))) - (( #\S) ; Status - (let* ((parameter (read-from-packet packet :cstring)) - (value (read-from-packet packet :cstring))) + ((#\R) + ;; Authentication Request: + (let* ((code (read-from-packet packet :int32))) + (case code + ((0) ;; AuthOK + ) + ((1) ; AuthKerberos4 + (error 'authentication-failure + :reason "Kerberos4 authentication not supported")) + ((2) ; AuthKerberos5 + (error 'authentication-failure + :reason "Kerberos5 authentication not supported")) + ((3) ; AuthUnencryptedPassword + (send-packet connection + #\p + `((:cstring ,password))) + (%flush connection)) + ((4) ; AuthEncryptedPassword + (let* ((salt (read-string-from-packet packet 2)) + (crypted (crypt password salt))) + #+debug + (format *debug-io* "Got salt of ~s~%" salt) + (send-packet connection + #\p + `((:cstring ,crypted))) + (%flush connection))) + ((5) ; AuthMD5Password + (error 'authentication-failure + :reason "MD5 authentication not supported")) + ((6) ; AuthSCMPassword + (error 'authentication-failure + :reason "SCM authentication not supported")) + (t (error 'authentication-failure + :reason "unknown authentication type"))))) + (( #\K) + ;; Cancelation + (let* ((pid (read-from-packet packet :int32)) + (secret (read-from-packet packet :int32))) + #+debug + (format t "~&Got cancelation data") + + (setf (pgcon-pid connection) pid) + (setf (pgcon-secret connection) secret))) + (( #\S) + ;; Status + (let* ((parameter (read-from-packet packet :cstring)) + (value (read-from-packet packet :cstring))) (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))) - - (and (not *pg-disable-type-coercion*) - (null *parsers*) - (initialize-parsers connection)) - (when *pg-date-style* - (setf (pg-date-style connection) *pg-date-style*)) - (when *pg-client-encoding* - (setf (pg-client-encoding connection) *pg-client-encoding*)) - (return 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))) + + (and (not *pg-disable-type-coercion*) + (null *parsers*) + (initialize-parsers connection)) + (when *pg-date-style* + (setf (pg-date-style connection) *pg-date-style*)) + (when *pg-client-encoding* + (setf (pg-client-encoding connection) *pg-client-encoding*)) + (return connection))) + ((#\E) + ;; an error, we should abort. + (return nil)) + ((#\N) + ;; We ignore Notices + 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 + :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))) + ;;#+debug + (warn "~&Got unexpected parameter ~S = ~S" + parameter + value))) + ((#\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 + (cerror "Just ignore it" "What to do with #\G?") + ;; The backend is ready to copy data from the frontend to a table; + ;; see Section 44.2.5 in http://www.postgresql.org/docs/7.4/interactive/protocol-flow.html + ;; for now we make it fail gracefully: + (send-packet connection + #\f + ;;CopyFail + '((:cstring "not implemented by pg.lisp yet"))) + ) + ((#\H) + ;; CopyOutResponse + (cerror "Just ignore it" "What to do with #\H?") + ;; The backend is ready to copy data from a table to the frontend; + ;; see Section 44.2.5. + ;; for now we make it fail gracefully (we cannot stop the transfer... + ) + (( #\d + ;; CopyData + #\c + ;;CopyDone + ) + 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)) + ((#\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))))))) + (defmethod pg-exec ((connection pgcon-v3) &rest args) "Execute the SQL command given by the concatenation of ARGS on the database to which we are connected via CONNECTION. Return a result structure which can be decoded using `pg-result'." - (let ((sql (apply #'concatenate 'simple-string args)) - (tuples '()) - (attributes '()) - (result (make-pgresult :connection connection))) + (let ((sql (apply #'concatenate 'simple-string args))) (when (> (length sql) +MAX_MESSAGE_LEN+) (error "SQL statement too long: ~A" sql))

(send-packet connection #\Q `((:cstring ,sql))) (%flush connection) - (loop - for packet = (read-packet connection) - do - (ecase (pg-packet-type packet) - ((#\S) - (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))) - ((#\G) - ;; CopyInResponse - (error "What to do with #\G?") - ;; The backend is ready to copy data from the frontend to a table; - ;; see Section 44.2.5. - ) - ((#\H) - ;; CopyOutResponse - (error "What to do with #\H") - ;; The backend is ready to copy data from a table to the frontend; - ;; see Section 44.2.5. - ) - ((#\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 (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 (pgresult-status result) "SELECT") - (setf (pgresult-tuples result) nil) - (setf (pgresult-attributes result) nil)) - ((#\N) ; NotificationResponse - ;; the notification has already been handled - t) - ((#\Z) - ;; ReadyForQuery - ;; we're done: - (return result)))))) + (do-followup-query connection)))

(defmethod pg-disconnect ((connection pgcon-v3)) @@ -601,41 +671,41 @@ (do ((i attribute-count (- i 1))) ((zerop i) (nreverse attributes)) (let* ((type-name (read-from-packet packet :cstring)) - (table-id (read-from-packet packet :int32)) - (column-id (read-from-packet packet :int16)) - (type-id (read-from-packet packet :int32)) - (type-len (read-from-packet packet :int16)) - (type-mod (read-from-packet packet :int32)) - (format-code (read-from-packet packet :int16))) + (table-id (read-from-packet packet :int32)) + (column-id (read-from-packet packet :int16)) + (type-id (read-from-packet packet :int32)) + (type-len (read-from-packet packet :int16)) + (type-mod (read-from-packet packet :int32)) + (format-code (read-from-packet packet :int16))) (declare (ignore type-mod format-code - table-id column-id)) + table-id column-id)) (push (list type-name type-id type-len) attributes)))))

(defun read-tuple/v3 (packet attributes) (let* ((num-attributes (length attributes)) - (number (read-from-packet packet :int16)) + (number (read-from-packet packet :int16)) (tuples '())) (unless (= num-attributes - number) + number) (error "Should ~S not be equal to ~S" - num-attributes - number)) + num-attributes + number)) (do ((i 0 (+ i 1)) (type-ids (mapcar #'second attributes) (cdr type-ids))) ((= i num-attributes) (nreverse tuples)) (let* ((length (read-from-packet packet :int32)) - (raw (unless (= length -1) - (read-string-from-packet packet length)))) - (if raw - (push (parse raw (car type-ids)) tuples) - (push nil tuples)))))) + (raw (unless (= length -1) + (read-string-from-packet packet length)))) + (if raw + (push (parse raw (car type-ids)) tuples) + (push nil tuples))))))

;; Execute one of the large-object functions (lo_open, lo_close etc). ;; 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) - (or *lo-initialized* (lo-init connection)) + (or *lo-initialized* (lo-init connection)) (let ((fnid (cond ((integerp fn) fn) ((not (stringp fn)) (error "Expecting a string or an integer: ~s" fn)) @@ -643,59 +713,73 @@ (cdr (assoc fn *lo-functions* :test #'string=))) (t (error "Unknown builtin function ~s" fn))))) (send-packet connection - #\F - `((: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))))) - (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))))) - (nreverse result)) - (:int16 ,(if integer-result 1 0)))) + #\F + `((: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))))) + (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))))) + (nreverse result)) + (:int16 ,(if integer-result 1 0)))) (%flush connection) (loop :with result = nil - :for packet = (read-packet connection) - :do - (ecase (pg-packet-type packet) - ((#\V) - (let* ((length (read-from-packet packet :int32)) - (data (unless (= length -1) - (if integer-result - (ecase length - ((1) - (read-from-packet packet :byte)) - ((2) - (read-from-packet packet :int16)) - ((4) - (read-from-packet packet :int32))) - (read-string-from-packet packet length))))) - (if data - (setf result data) - (return-from fn nil)))) - ((#\Z) - (return-from fn result)))))) + :for packet = (read-packet connection) + :do + (case (pg-packet-type packet) + ((#\V) + (let* ((length (read-from-packet packet :int32)) + (data (unless (= length -1) + (if integer-result + (ecase length + ((1) + (read-from-packet packet :byte)) + ((2) + (read-from-packet packet :int16)) + ((4) + (read-from-packet packet :int32))) + (read-string-from-packet packet length))))) + (if data + (setf result data) + (return-from fn nil)))) + ((#\Z) + (return-from fn result)) + ((#\E) + ;; an error, we should abort. + (return nil)) + ((#\N) + ;; We ignore Notices + t) + (t + (warn "Got unexpected packet: ~S, resetting connection" + packet) + ;; sync + (send-packet connection + #\S + nil) + (%flush connection))))))

@@ -722,8 +806,8 @@ (defun handle-notice/v3 (connection packet) (loop :with notification = (make-instance 'backend-notification) :for field-type = (read-from-packet packet :byte) - :until (= field-type 0) - :do (let ((message (read-from-packet packet :cstring)) + :until (= field-type 0) + :do (let ((message (read-from-packet packet :cstring)) (slot (ecase (code-char field-type) ((#\S) 'severity) ((#\C) 'code) @@ -739,5 +823,142 @@ :finally (push notification (pgcon-notices connection))) packet)

+ + +;; prepare/bind/execute functions + +(defmethod pg-supports-pbe ((connection pgcon-v3)) + (declare (ignore connection)) + t) + +(defmethod pg-prepare ((connection pgcon-v3) (statement-name string) (sql-statement string) &optional type-of-parameters) + (let ((types (when type-of-parameters + (loop :for type :in type-of-parameters + :for oid = (or (lookup-type type) + (error "type not found")) + :collect `(:int32 ,oid))))) + + (cond + (types + (send-packet connection + #\P + `((:cstring ,statement-name) + (:cstring ,sql-statement) + (:int16 ,(length types)) + ,@(when types + types)))) + (t + (send-packet connection + #\P + `((:cstring ,statement-name) + (:cstring ,sql-statement) + (:int16 0))))) + t)) + +(defmethod pg-bind ((connection pgcon-v3) (portal string) (statement-name string) list-of-types-and-values) + (let ((formats (when list-of-types-and-values + (loop :for (type value) :in list-of-types-and-values + :collect + (ecase type + ((:string) `(:int16 0)) + ((:byte :int16 :int32 :char) `(:int16 1)))))) + (data nil)) + + (when list-of-types-and-values + (loop :for (type value) :in list-of-types-and-values + :do + (ecase type + ((:int32) + (push '(:int32 4) data) + (push `(:int32 ,value) data)) + ((:int16) + (push '(:int32 2) data) + (push `(:int16 ,value) data)) + ((:byte) + (push '(:int32 1) data) + (push `(:int8 ,value) data)) + ((:char) + (push '(:int32 1) data) + (push `(:int8 ,(char-code value)) data)) + ((:string) + (push `(:int32 ,(1+ (length value))) data) + (push `(:cstring ,value) data)))) + + (setf data (nreverse data))) + + (cond + (list-of-types-and-values + (send-packet connection + #\B + `((:cstring ,portal) + (:cstring ,statement-name) + (:int16 ,(length formats)) + ,@formats + (:int16 ,(length formats)) + ,@data + (:int16 0)))) + (t + (send-packet connection + #\B + `((:cstring ,portal) + (:cstring ,statement-name) + (:int16 0) + (:int16 0) + (:int16 0))))) + t)) + +(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maxinum-number-of-rows 0)) + + ;; have it describe the result: + (send-packet connection + #\D + `((:char #\P) + (:cstring ,portal))) + ;; execute the query: + (send-packet connection + #\E + `((:cstring ,portal) + (:int32 ,maxinum-number-of-rows))) + ;; send all data: + (send-packet connection + #\S + nil) + (%flush connection) + + (do-followup-query connection)) + +(defun pg-close (connection name type) + (declare (type pgcon connection) + (type string name) + (type base-char type)) + + (send-packet connection + #\C + `((:char ,type) + (:cstring ,name))) + (%flush connection) + (loop :for packet = (read-packet connection) + :do + (case (pg-packet-type packet) + ((#\B #\Z) + ;; Close Complete + ;; or + ;; ReadyForQuery + (return)) + (t + (warn "Got unexpected packet: ~S, resetting connection" + packet) + ;; sync + (send-packet connection + #\S + nil) + (%flush connection)))) + t) + +(defmethod pg-close-statement ((connection pgcon-v3) (statement-name string)) + (pg-close connection statement-name #\s)) + +(defmethod pg-close-portal ((connection pgcon-v3) (portal string)) + (pg-close connection portal #\P))

;; EOF