[pg-cvs] CVS update: pg/pg.lisp pg/v3-protocol.lisp
Peter Van Eynde
pvaneynde at common-lisp.net
Mon Mar 8 14:37:32 UTC 2004
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))
+ , at formats
+ (:int16 ,(length formats))
+ , at 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
More information about the Pg-cvs
mailing list