pg-cvs

pg-cvs@common-lisp.net

76 discussions

[pg-cvs] CVS pg
by emarsden 16 Dec '06

16 Dec '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv32279 Modified Files: v3-protocol.lisp Log Message: Don't flush the network stream in SEND-PACKET, because it slows down API calls that have multiple SEND-PACKET calls in them. From attila.lendvai(a)gmail.com. --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/26 18:05:11 1.30 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/12/16 13:29:28 1.31 @@ -375,9 +375,8 @@ (incf position (length value))))) (%send-net-int stream (char-code code) 1) - (%send-net-int stream length 4 ) - (write-sequence data stream) - (%flush connection))) + (%send-net-int stream length 4) + (write-sequence data stream))) (defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) @@ -540,7 +539,8 @@ (t (warn "We had to provide data, but my sql-stream isn't an input-stream. Aborting transfer") ;; CopyFail - (send-packet connection #\f '((:cstring "No input data provided")))))) + (send-packet connection #\f '((:cstring "No input data provided"))) + (%flush connection)))) ((#\H) ;; CopyOutResponse

1 0

[pg-cvs] CVS pg
by emarsden 16 Dec '06

16 Dec '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv31715 Modified Files: parsers.lisp Log Message: Fix numeric parser for negative numbers. From levente.meszaros(a)gmail.com --- /project/pg/cvsroot/pg/parsers.lisp 2006/10/22 19:29:47 1.9 +++ /project/pg/cvsroot/pg/parsers.lisp 2006/12/16 13:24:09 1.10 @@ -133,7 +133,9 @@ (when (> dec-str-len 0) ;; parse integer after #\. and divide by 10^(digits), i.e. ".023" => 23/1000 (setq decimal-part (/ (parse-integer decimal-str) (expt 10 dec-str-len)))))) - (+ integer-part decimal-part))) + (if (eq #\- (elt str 0)) + (- integer-part decimal-part) + (+ integer-part decimal-part)))) ;; FIXME switch to a specialized float parser that conses less (defun float-parser (str)

1 0

[pg-cvs] CVS pg
by emarsden 26 Nov '06

26 Nov '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv5864 Modified Files: v3-protocol.lisp Log Message: Make sure we consume the ReadyForQuery packet that is generated when closing a prepared statement or portal, or the packet can be misinterpreted by a later query, leading to data loss. Fix from Robert J. Macomber. --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/20 20:50:36 1.29 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/26 18:05:11 1.30 @@ -485,8 +485,8 @@ (defun do-followup-query (connection) "Does the followup of a query" - (let ((tuples '()) - (attributes '()) + (let ((tuples (list)) + (attributes (list)) (result (make-pgresult :connection connection))) (loop :for packet = (read-packet connection) @@ -592,6 +592,7 @@ ((#\Z) ;; ReadyForQuery (let ((status (read-from-packet packet :byte))) + (declare (ignore status)) (when got-data-p (return-from do-followup-query result)))) @@ -613,12 +614,11 @@ ((#\2 #\1 #\3) (return-from do-followup-query result)) - ((#\n) + ((#\n) ;; NoData (setf got-data-p t)) ;; error messages will already have been handled in READ-PACKET ((#\E) - (error "not reached!") (setq got-data-p t)) ;; notice messages will already have been handled in READ-PACKET @@ -929,7 +929,9 @@ (loop :for packet = (read-packet connection) :do (case (pg-packet-type packet) - ((#\3 #\Z) ;; CloseComplete or ReadyForQuery + ((#\3) + t) + ((#\Z) ;; CloseComplete or ReadyForQuery (return)) (t (warn "Got unexpected packet in PG-CLOSE: ~S, resetting connection" packet)

1 0

[pg-cvs] CVS pg
by emarsden 20 Nov '06

20 Nov '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv3853 Modified Files: README pg.lisp utility.lisp v2-protocol.lisp v3-protocol.lisp Log Message: Add an ABORT keyword argument to PG-DISCONNECT (from Robert J. Macomber <pgsql(a)rojoma.com>), as per CL:CLOSE. "I've run into a problem with pg-disconnect if something abnormal happens to the database connection -- if the database goes away for a restart while pg has a connection open, for example. When this happens, pg-disconnect fails, and the socket file descriptor is left open (presumably for a finalizer to clean up), also raising a new error from the unwind-protect in with-pg-connection. To guard against the possibility, I've added an :abort parameter to pg-disconnect, like cl:close has, and made with-pg-connection call it with :abort t if the body exits abnormally, in the same way that with-open-file operates. When :abort is true, the modified pg-disconnect closes the database connection ungracefully, including making the close call abort (otherwise, sbcl at keast tries to flush the stream, raising another error if the database isn't there anymore)." --- /project/pg/cvsroot/pg/README 2006/09/23 12:24:28 1.9 +++ /project/pg/cvsroot/pg/README 2006/11/20 20:50:36 1.10 @@ -102,8 +102,11 @@ you have a large amount of data to handle, this usage is more efficient than fetching all the tuples in one go. - (pg-disconnect connection) -> nil - Close the database connection. + (pg-disconnect connection &key abort) -> nil + Close the database connection. If the keyword argument ABORT is + non-NIL, the database connection is closed immediately, without + first attempting to send a disconnect packet to the PostgreSQL + backend. === Support for prepared statements ==================================== --- /project/pg/cvsroot/pg/pg.lisp 2006/11/19 18:47:58 1.10 +++ /project/pg/cvsroot/pg/pg.lisp 2006/11/20 20:50:36 1.11 @@ -174,7 +174,7 @@ 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) +(defgeneric pg-disconnect (connection &key abort) (:documentation "Disconnects from the DB")) --- /project/pg/cvsroot/pg/utility.lisp 2006/10/22 19:22:39 1.2 +++ /project/pg/cvsroot/pg/utility.lisp 2006/11/20 20:50:36 1.3 @@ -36,10 +36,14 @@ CONNECTION. If the connection is unsuccessful, the forms are not evaluated. Otherwise, the BODY forms are executed, and upon termination, normal or otherwise, the database connection is closed." - `(let ((,con (pg-connect ,@open-args))) - (unwind-protect - (progn ,@body) - (when ,con (pg-disconnect ,con))))) + (let ((ok (gensym))) + `(let ((,con (pg-connect ,@open-args)) + (,ok nil)) + (unwind-protect + (multiple-value-prog1 + (progn ,@body) + (setf ,ok t)) + (when ,con (pg-disconnect ,con :abort (not ,ok))))))) ;; this is the old version #+(or) --- /project/pg/cvsroot/pg/v2-protocol.lisp 2006/11/19 18:47:59 1.6 +++ /project/pg/cvsroot/pg/v2-protocol.lisp 2006/11/20 20:50:36 1.7 @@ -237,10 +237,14 @@ :reason (format nil "Unexpected byte ~s" b))))))) -(defmethod pg-disconnect ((connection pgcon-v2)) - (write-byte 88 (pgcon-stream connection)) - (%flush connection) - (close (pgcon-stream connection)) +(defmethod pg-disconnect ((connection pgcon-v2) &key abort) + (cond + (abort + (close (pgcon-stream connection) :abort t)) + (t + (write-byte 88 (pgcon-stream connection)) + (%flush connection) + (close (pgcon-stream connection)))) (values)) --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/19 18:47:59 1.28 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/20 20:50:36 1.29 @@ -641,10 +641,14 @@ (do-followup-query connection))) -(defmethod pg-disconnect ((connection pgcon-v3)) - (send-packet connection #\X nil) - (%flush connection) - (close (pgcon-stream connection)) +(defmethod pg-disconnect ((connection pgcon-v3) &key abort) + (cond + (abort + (close (pgcon-stream connection) :abort t)) + (t + (send-packet connection #\X nil) + (%flush connection) + (close (pgcon-stream connection)))) (values))

1 0

[pg-cvs] CVS pg
by emarsden 19 Nov '06

19 Nov '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv29766 Modified Files: pg-tests.lisp pg.lisp sysdep.lisp v2-protocol.lisp v3-protocol.lisp Log Message: Allow encoding used for socket communication with the backend to be specified as a keyword argument to PG-CONNECT, for cases where rebinding *PG-CLIENT-ENCODING* is inconvenient. Add a simple test for encoding support. (From Attila Lendvai <attila.lendvai(a)gmail.com>) --- /project/pg/cvsroot/pg/pg-tests.lisp 2006/09/24 21:19:30 1.12 +++ /project/pg/cvsroot/pg/pg-tests.lisp 2006/11/19 18:47:58 1.13 @@ -21,16 +21,17 @@ (when ,con (pg-disconnect ,con))))) ;; !!! CHANGE THE VALUES HERE !!! -(defun call-with-test-connection (function) - (with-pg-connection (conn "test" "pgdotlisp" - :host "localhost" - ;; :host "/var/run/postgresql/" - ) - (funcall function conn))) - -(defmacro with-test-connection ((conn) &body body) - `(call-with-test-connection - (lambda (,conn) ,@body))) +(defmacro with-test-connection ((conn &key (database "test") + (user-name "pgdotlisp") + (password "secret") + (host "localhost") ;; or "/var/run/postgresql/" + (port 5432) + (encoding *pg-client-encoding*)) + &body body) + `(with-pg-connection (,conn ,database ,user-name :password ,password + :host ,host :port ,port :encoding ,encoding) + ,@body)) + (defun check-single-return (conn sql expected &key (test #'eql)) (let ((res (pg-exec conn sql))) @@ -40,8 +41,7 @@ (defun test-insert () (format *debug-io* "Testing INSERT & SELECT on integers ...~%") (with-test-connection (conn) - (let ((res nil) - (count 0) + (let ((count 0) (created nil)) (unwind-protect (progn @@ -65,8 +65,7 @@ (defun test-insert/float () (format *debug-io* "Testing INSERT & SELECT on floats ...~%") (with-test-connection (conn) - (let ((res nil) - (sum 0.0) + (let ((sum 0.0) (created nil)) (flet ((float-eql (a b) (< (/ (abs (- a b)) b) 1e-5))) @@ -110,7 +109,7 @@ (pg-for-each conn "SELECT val FROM count_test_numeric" (lambda (tuple) (incf sum (first tuple)))) (assert (eql 500500 sum))) - (check-single-return conn "SELECT 'infinity'::float4 + 'NaN'::float4" 'NAN) + ;; (check-single-return conn "SELECT 'infinity'::float4 + 'NaN'::float4" 'NAN) (check-single-return conn "SELECT 1 / (!! 2)" 1/2) (when created (pg-exec conn "DROP TABLE count_test_numeric")))))) @@ -384,6 +383,20 @@ ;; (format t "stat(\"/tmp\"): ~S~%" (pg-result res :tuples))))) +(defun test-encoding () + (let ((octets (coerce '(105 97 122 115 124) '(vector (unsigned-byte 8))))) + (dolist (encoding '("UTF8" "LATIN1" "LATIN2")) + (let ((encoded (pg::convert-string-from-bytes octets encoding))) + (with-test-connection (conn :encoding encoding) + (ignore-errors + (pg-exec conn "DROP TABLE encoding_test")) + (pg-exec conn "CREATE TABLE encoding_test (a VARCHAR(40))") + (pg-exec conn "INSERT INTO encoding_test VALUES ('" encoded "')") + (check-single-return conn "SELECT * FROM encoding_test" encoded :test #'string=) + (pg-exec conn "DROP TABLE encoding_test")))))) + + + ;; Fibonnaci numbers with memoization via a database table (defun fib (n) (declare (type integer n)) @@ -532,7 +545,7 @@ (with-test-connection (con) (dotimes (i 5000) (if (= (mod i 1000) 0) (format dio "~s connected over ~S producing ~a~%" - sb-thread:*current-thread* mycony i)) + sb-thread:*current-thread* con i)) (pg-exec con (format nil "INSERT INTO pgmt VALUES (~S, ~D, ~F)" i i i)) (when (zerop (mod i 100)) (pg-exec con "COMMIT WORK"))))) @@ -556,8 +569,7 @@ (with-test-connection (conn) (when (pg-supports-pbe conn) (format *debug-io* "~&Testing PBE/int4 ...") - (let ((res nil) - (count 0) + (let ((count 0) (created nil)) (unwind-protect (progn @@ -574,11 +586,8 @@ (:int32 ,(* i i)))) (pg-execute conn "ct_portal") (pg-close-portal conn "ct_portal")) - (format *debug-io* "~&data inserted") - (setq res (pg-exec conn "SELECT count(val) FROM count_test")) - (assert (eql 100 (first (pg-result res :tuple 0)))) - (setq res (pg-exec conn "SELECT sum(key) FROM count_test")) - (assert (eql 5050 (first (pg-result res :tuple 0)))) + (check-single-return conn "SELECT count(val) FROM count_test" 100) + (check-single-return conn "SELECT sum(key) FROM count_test" 5050) ;; this iterator does the equivalent of the sum(key) SQL statement ;; above, but on the client side. (pg-for-each conn "SELECT key FROM count_test" @@ -591,8 +600,7 @@ (with-test-connection (conn) (when (pg-supports-pbe conn) (format *debug-io* "~&Testing PBE/text...") - (let ((res nil) - (count 0) + (let ((count 0) (created nil)) (unwind-protect (progn @@ -609,11 +617,8 @@ (:string ,(format nil "~a" (* i i))))) (pg-execute conn "ct_portal/text") (pg-close-portal conn "ct_portal/text")) - (format *debug-io* "~&data inserted") - (setq res (pg-exec conn "SELECT count(val) FROM pbe_text_test")) - (assert (eql 100 (first (pg-result res :tuple 0)))) - (setq res (pg-exec conn "SELECT sum(key) FROM pbe_text_test")) - (assert (eql 5050 (first (pg-result res :tuple 0)))) + (check-single-return conn "SELECT count(val) FROM pbe_text_test" 100) + (check-single-return conn "SELECT sum(key) FROM pbe_text_test" 5050) ;; this iterator does the equivalent of the sum(key) SQL statement ;; above, but on the client side. (pg-for-each conn "SELECT key FROM pbe_text_test" --- /project/pg/cvsroot/pg/pg.lisp 2006/09/18 19:10:38 1.9 +++ /project/pg/cvsroot/pg/pg.lisp 2006/11/19 18:47:58 1.10 @@ -1,7 +1,7 @@ ;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp ;; ;; Author: Eric Marsden <eric.marsden(a)free.fr> -;; Time-stamp: <2006-09-15 emarsden> +;; Time-stamp: <2006-11-19 emarsden> ;; Version: 0.22 ;; ;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005 Eric Marsden @@ -121,7 +121,8 @@ (defconstant +MAX_MESSAGE_LEN+ 8192) ; libpq-fe.h (defvar *pg-client-encoding* "LATIN1" - "The encoding to use for text data, for example \"LATIN1\", \"UTF8\", \"EUC_JP\". + "The encoding that will be used for communication with the PostgreSQL backend, +for example \"LATIN1\", \"UTF8\", \"EUC_JP\". See <http://www.postgresql.org/docs/7.3/static/multibyte.html>.") (defvar *pg-date-style* "ISO") @@ -142,7 +143,9 @@ (notices :accessor pgcon-notices :initform (list)) (binary-p :accessor pgcon-binary-p - :initform nil))) + :initform nil) + (encoding :accessor pgcon-encoding + :initarg :encoding))) (defmethod print-object ((self pgcon) stream) (print-unreadable-object (self stream :type nil) @@ -217,25 +220,28 @@ ;; the v2 protocol. This allows us to connect to PostgreSQL 7.4 ;; servers using the benefits of the new protocol, but still interact ;; with older servers. -(defun pg-connect (dbname user &key (host "localhost") (port 5432) (password "")) +(defun pg-connect (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend. -Connect to the database DBNAME with the username USER, -on PORT of HOST, providing PASSWORD if necessary. Return a -connection to the database (as an opaque type). If HOST is nil, attempt -to connect to the database using a Unix socket. -We first attempt to speak the PostgreSQL 7.4 protocol, and fall back to -the older network protocol if necessary." +Connect to the database DBNAME with the username USER, on PORT of +HOST, providing PASSWORD if necessary. Return a connection to the +database (as an opaque type). If HOST is a pathname or a string +starting with #\/, it designates the directory containing the Unix +socket on which PostgreSQL's backend is waiting for local connections. +We first attempt to speak the PostgreSQL 7.4 protocol, and fall back +to the older network protocol if necessary." (handler-case (pg-connect/v3 dbname user :host host :port port - :password password) + :password password + :encoding encoding) (protocol-error (c) (declare (ignore c)) (warn "reconnecting using protocol version 2") (pg-connect/v2 dbname user :host host :port port - :password password)))) + :password password + :encoding encoding)))) (defun pg-result (result what &rest args) --- /project/pg/cvsroot/pg/sysdep.lisp 2006/10/22 19:22:39 1.18 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/11/19 18:47:59 1.19 @@ -1,7 +1,7 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden <eric.marsden(a)free.fr> -;;; Time-stamp: <2006-09-30 emarsden> +;;; Time-stamp: <2006-11-19 emarsden> ;; ;; @@ -333,6 +333,7 @@ #+(and clisp unicode) (cond ((string-equal encoding "SQL_ASCII") charset:ascii) ((string-equal encoding "LATIN1") charset:iso-8859-1) + ((string-equal encoding "LATIN2") charset:iso-8859-2) ((string-equal encoding "LATIN9") charset:iso-8859-9) ((string-equal encoding "UTF8") charset:utf-8) (t (error "unknown encoding ~A" encoding))) @@ -344,14 +345,15 @@ (t (error "unknown encoding ~A" encoding))) #+(and sbcl sb-unicode) (cond ((string-equal encoding "SQL_ASCII") :ascii) - ((string-equal encoding "LATIN1") :latin1) - ((string-equal encoding "LATIN9") :latin9) + ((string-equal encoding "LATIN1") :iso-8859-1) + ((string-equal encoding "LATIN2") :iso-8859-2) + ((string-equal encoding "LATIN9") :iso-8859-9) ((string-equal encoding "UTF8") :utf8) (t (error "unknown encoding ~A" encoding))) #+(or cmu gcl ecl abcl openmcl lispworks) nil)) -(defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*)) +(defun convert-string-to-bytes (string encoding) (declare (type string string)) (%sysdep "convert string to octet-array" #+(and clisp unicode) @@ -368,7 +370,7 @@ (map-into octets #'char-code string)) (error "Can't convert ~A string to octets" encoding)))) -(defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*)) +(defun convert-string-from-bytes (bytes encoding) (declare (type (vector (unsigned-byte 8)) bytes)) (%sysdep "convert octet-array to string" #+(and clisp unicode) --- /project/pg/cvsroot/pg/v2-protocol.lisp 2005/07/17 15:48:06 1.5 +++ /project/pg/cvsroot/pg/v2-protocol.lisp 2006/11/19 18:47:59 1.6 @@ -10,14 +10,15 @@ -(defun pg-connect/v2 (dbname user &key (host "localhost") (port 5432) (password "")) +(defun pg-connect/v2 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend, using protocol v2. -Connect to the database DBNAME with the username USER, -on PORT of HOST, providing PASSWORD if necessary. Return a -connection to the database (as an opaque type). If HOST is nil, attempt -to connect to the database using a Unix socket." +Connect to the database DBNAME with the username USER, on PORT of +HOST, providing PASSWORD if necessary. Return a connection to the +database (as an opaque type). If HOST is a pathname or a string whose +first character is #\/, it designates the directory containing the +Unix socket on which the PostgreSQL backend is listening." (let* ((stream (socket-connect port host)) - (connection (make-instance 'pgcon-v2 :stream stream :host host :port port)) + (connection (make-instance 'pgcon-v2 :stream stream :host host :port port :encoding encoding)) (user-packet-length (+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+))) ;; send the startup packet (send-int connection +STARTUP_PACKET_SIZE+ 4) @@ -43,8 +44,8 @@ (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*)) + (when encoding + (setf (pg-client-encoding connection) encoding)) (return connection)) ((3) ; AuthUnencryptedPassword (send-int connection (+ 5 (length password)) 4) --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/10/22 19:25:51 1.27 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/11/19 18:47:59 1.28 @@ -12,8 +12,6 @@ (defclass pgcon-v3 (pgcon) ((parameters :accessor pgcon-parameters :initform (list)) - (encoding :accessor pgcon-encoding - :initform nil) (sql-stream :initform nil :accessor pgcon-sql-stream :type (or null stream)))) @@ -255,7 +253,8 @@ (cond ((pgcon-encoding connection) (let* ((end (position 0 data :start position)) (result (unless (eql end position) - (convert-string-from-bytes (subseq data position end))))) + (convert-string-from-bytes (subseq data position end) + (pgcon-encoding connection))))) (when result (setf position (1+ end))) result)) ;; the encoding has not yet been set, so revert to :ucstring behaviour @@ -275,13 +274,14 @@ (when (< length 0) (error "length cannot be negative. is: ~S" length)) - (let* ((octets (read-octets-from-packet packet length)) - (encoding (if (or (eql #\R (pg-packet-type packet)) - (eql #\E (pg-packet-type packet))) - "LATIN1" - *pg-client-encoding*)) - (string (convert-string-from-bytes octets encoding))) - string))) + (with-slots (connection) packet + (let* ((octets (read-octets-from-packet packet length)) + (encoding (if (or (eql #\R (pg-packet-type packet)) + (eql #\E (pg-packet-type packet))) + "LATIN1" + (pgcon-encoding connection))) + (string (convert-string-from-bytes octets encoding))) + string)))) (defgeneric read-octets-from-packet (packet length)) @@ -310,8 +310,8 @@ ((:int16) 2) ((:int32) 4) ((:rawdata) (length value)) - ((:string) (length (convert-string-to-bytes value))) - ((:cstring) (1+ (length (convert-string-to-bytes value)))) + ((:string) (length (convert-string-to-bytes value (pgcon-encoding connection)))) + ((:cstring) (1+ (length (convert-string-to-bytes value (pgcon-encoding connection))))) ((:ucstring) (1+ (length value))))))) (data (make-array (- length 4) :element-type '(unsigned-byte 8))) @@ -354,7 +354,7 @@ ((:cstring) (check-type value string) - (let ((encoded (convert-string-to-bytes value))) + (let ((encoded (convert-string-to-bytes value (pgcon-encoding connection)))) (declare (type (vector (unsigned-byte 8) *) encoded)) (replace data encoded :start1 position) (incf position (length encoded))) @@ -364,7 +364,7 @@ ;; a string without the trailing NUL character ((:string) (check-type value string) - (let ((encoded (convert-string-to-bytes value))) + (let ((encoded (convert-string-to-bytes value (pgcon-encoding connection)))) (declare (type (vector (unsigned-byte 8) *) encoded)) (replace data encoded :start1 position) (incf position (length encoded)))) @@ -380,14 +380,15 @@ (%flush connection))) -(defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password "")) +(defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend. -Connect to the database DBNAME with the username USER, -on PORT of HOST, providing PASSWORD if necessary. Return a -connection to the database (as an opaque type). If HOST is nil, attempt -to connect to the database using a Unix socket." +Connect to the database DBNAME with the username USER, on PORT of +HOST, providing PASSWORD if necessary. Return a connection to the +database (as an opaque type). If HOST is a pathname or a string whose +first character is #\/, it designates the directory containing the +Unix socket on which the PostgreSQL backend is listening." (let* ((stream (socket-connect port host)) - (connection (make-instance 'pgcon-v3 :stream stream :host host :port port)) + (connection (make-instance 'pgcon-v3 :stream stream :host host :port port :encoding encoding)) (connect-options `("user" ,user "database" ,dbname)) (user-packet-length (+ 4 4 (loop :for item :in connect-options :sum (1+ (length item))) 1))) @@ -441,7 +442,7 @@ (t (error 'authentication-failure :reason "unknown authentication type"))))) - (( #\K) + ((#\K) ;; Cancelation (let* ((pid (read-from-packet packet :int32)) (secret (read-from-packet packet :int32))) @@ -462,8 +463,8 @@ (let* ((status (read-from-packet packet :byte))) (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*)) + (when encoding + (setf (pg-client-encoding connection) encoding)) (and (not *pg-disable-type-coercion*) (null *parsers*) (initialize-parsers connection))

1 0

[pg-cvs] CVS pg
by emarsden 22 Oct '06

22 Oct '06

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-SYN… +;; +;; 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

1 0

[pg-cvs] CVS pg
by emarsden 22 Oct '06

22 Oct '06

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

1 0

[pg-cvs] CVS pg
by emarsden 22 Oct '06

22 Oct '06

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 <emarsden(a)laas.fr> -;;; Time-stamp: <2004-03-05 emarsden> +;;; Time-stamp: <2006-09-30 emarsden> (in-package :postgresql) @@ -41,7 +41,8 @@ (progn ,@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

1 0

[pg-cvs] CVS pg
by emarsden 22 Oct '06

22 Oct '06

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 <steve(a)sanityinc.com>. --- /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

1 0

[pg-cvs] CVS pg
by emarsden 30 Sep '06

30 Sep '06

Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv6047 Modified Files: sysdep.lisp pg.asd Log Message: Add unix-domain socket support for Allegro CL (tested with Express edition for Linux/x86). --- /project/pg/cvsroot/pg/sysdep.lisp 2006/09/24 15:50:18 1.16 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/09/30 16:51:12 1.17 @@ -1,14 +1,13 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden <eric.marsden(a)free.fr> -;;; Time-stamp: <2006-09-24 emarsden> +;;; Time-stamp: <2006-09-30 emarsden> ;; ;; (in-package :postgresql) (eval-when (:compile-toplevel :load-toplevel :execute) - #+allegro (require :socket) #+lispworks (require "comm") #+cormanlisp (require :sockets) #+armedbear (require :socket)) @@ -165,14 +164,22 @@ (defun socket-connect (port host) (declare (type integer port)) (handler-case - (socket:make-socket :remote-host host - :remote-port port - :format :binary) - (error (e) + (if (eql #\/ (char host 0)) + (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 + :remote-port port + :connect :active + :format :binary)) + (error (e) (error 'connection-failure - :host host - :port port - :transport-error e)))) + :host host + :port port + :transport-error e)))) ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary ;; streams. Fixed in version 4.3. @@ -283,6 +290,9 @@ (eval-when (:load-toplevel :execute :compile-toplevel) (require :socket)) +;; could provide support for connections via a unix-domain socket by +;; using http://freshmeat.net/projects/j-buds/ (requires linking to a +;; shared libary) #+armedbear (defun socket-connect (port host) (declare (type integer port)) --- /project/pg/cvsroot/pg/pg.asd 2006/09/18 19:10:01 1.10 +++ /project/pg/cvsroot/pg/pg.asd 2006/09/30 16:51:12 1.11 @@ -17,9 +17,8 @@ (defsystem :pg :name "Socket-level PostgreSQL interface" :author "Eric Marsden" - :version "0.22" + :version "0.24" :depends-on ( - #+allegro :socket #+lispworks "comm" #+cormanlisp :sockets #+sbcl :sb-bsd-sockets

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

pg-cvs