From emarsden at common-lisp.net Sun Oct 22 15:48:46 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 22 Oct 2006 11:48:46 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20061022154846.0DA18232C7@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv11251 Modified Files: v3-protocol.lisp Log Message: Allow NULL values for bound variables in prepared statements. Bug pointed out by Steve Purcell . --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/24 15:50:18 1.25 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/10/22 15:48:45 1.26 @@ -321,7 +321,7 @@ do (ecase type ((:byte) - (check-type value (unsigned-byte 8)) + (check-type value (signed-byte 8)) (setf (elt data position) value) (incf position)) ((:char) @@ -329,13 +329,12 @@ (setf (elt data position) (char-code value)) (incf position)) ((:int16) - (check-type value (unsigned-byte 16)) + (check-type value (signed-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)) - + (check-type value (signed-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)) @@ -859,25 +858,28 @@ (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)) - ;; this is not a NUL-terminated string, so send exactly - ;; the string length rather than 1+ - ((:string) - (let ((encoded-length (length (convert-string-to-bytes value (pg-client-encoding connection))))) - (push `(:int32 ,encoded-length) data) - (push `(:string ,value) data))))) + (cond ((null value) + (push '(:int32 -1) data)) + (t + (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)) + ;; this is not a NUL-terminated string, so send exactly + ;; the string length rather than 1+ + ((:string) + (let ((encoded-length (length (convert-string-to-bytes value (pg-client-encoding connection))))) + (push `(:int32 ,encoded-length) data) + (push `(:string ,value) data))))))) (setf data (nreverse data))) (cond From emarsden at common-lisp.net Sun Oct 22 19:22:39 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 22 Oct 2006 15:22:39 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20061022192239.B5BD916@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv11615 Modified Files: utility.lisp sysdep.lisp Log Message: Code cleanups. --- /project/pg/cvsroot/pg/utility.lisp 2004/03/05 18:08:08 1.1 +++ /project/pg/cvsroot/pg/utility.lisp 2006/10/22 19:22:39 1.2 @@ -1,7 +1,7 @@ ;;; utility.lisp -- wrapper functions and macros ;;; ;;; Author: Eric Marsden -;;; Time-stamp: <2004-03-05 emarsden> +;;; Time-stamp: <2006-09-30 emarsden> (in-package :postgresql) @@ -41,7 +41,8 @@ (progn , at body) (when ,con (pg-disconnect ,con))))) -#-old-version +;; this is the old version +#+(or) (defmacro with-pg-transaction (con &body body) "Execute BODY forms in a BEGIN..END block. If a PostgreSQL error occurs during execution of the forms, execute --- /project/pg/cvsroot/pg/sysdep.lisp 2006/09/30 16:51:12 1.17 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/10/22 19:22:39 1.18 @@ -168,7 +168,6 @@ (socket:make-socket :type :stream :address-family :file :connect :active - ;; :local-filename (format nil "~A.s.PGSQL.~D" (string host) port) :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port) :format :binary) (socket:make-socket :remote-host host From emarsden at common-lisp.net Sun Oct 22 19:25:51 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 22 Oct 2006 15:25:51 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20061022192551.2D0541014@common-lisp.net> 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 + + +(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] From emarsden at common-lisp.net Sun Oct 22 19:29:48 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 22 Oct 2006 15:29:48 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20061022192948.08D151E001@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv12033 Modified Files: parsers.lisp Log Message: - implement basic parsing support for the PostgreSQL record type - supply a utility function to escape binary data into a format that can be used within an SQL string to initialize a field of type BYTEA - add optimize declarations for improved performance --- /project/pg/cvsroot/pg/parsers.lisp 2005/12/19 22:29:59 1.8 +++ /project/pg/cvsroot/pg/parsers.lisp 2006/10/22 19:29:47 1.9 @@ -36,6 +36,9 @@ ;; +(declaim (optimize (speed 3) (safety 1))) + + (in-package :postgresql) @@ -82,6 +85,10 @@ ;; oidvector ;; bit ;; varbit + ;; record + ;; cstring + ;; any + ("row" . ,'row-parser) ("float4" . ,'float-parser) ("float8" . ,'float-parser) ("money" . ,'text-parser) ; "$12.34" @@ -225,6 +232,19 @@ (day (parse-integer str :start 8 :end 10))) (encode-universal-time 0 0 0 day month year))) + +;; http://www.postgresql.org/docs/8.1/interactive/sql-expressions.html#SQL-SYNTAX-ROW-CONSTRUCTORS +;; +;; these are in the format "(foo,bar,baz)" +(defun row-parser (str) + (assert (char= #\( (char str 0))) + (loop :with start = 1 + :with last = (- (length str) 1) + :for end = (or (position #\, str :start start) last) + :collect (subseq str start end) + :do (setq start (1+ end)) + :until (>= end last))) + (defun initialize-parsers (connection) (let* ((pgtypes (pg-exec connection "SELECT typname,oid FROM pg_type")) (tuples (pg-result pgtypes :tuples))) @@ -265,4 +285,29 @@ (intern type :keyword))))) (gethash type *type-to-oid*))) + + +;; PQescapeBytea - converts from binary string to the +;; minimal encoding necessary to include the string in an SQL +;; INSERT statement with a bytea type column as the target. +;; +;; The following transformations are applied +;; '\0' == ASCII 0 == \000 +;; '\'' == ASCII 39 == '' +;; '\\' == ASCII 92 == \\ +;; anything < 0x20, or > 0x7e ---> \ooo +;; (where ooo is an octal expression) +;; If not std_strings, all backslashes sent to the output are doubled. +;; +;; http://www.postgresql.org/docs/8.1/static/datatype-binary.html +(defun bytea->string (data) + (declare (type (vector (unsigned-byte 8) *) data)) + (with-output-to-string (out) + (loop :for octet :across data :do + (cond ((<= 32 octet 126) + (write-char (code-char octet) out)) + (t + (format out "\\~3,'0O" octet)))))) + + ;; EOF