[pg-cvs] CVS pg

emarsden emarsden at common-lisp.net
Sun Nov 19 18:47:59 UTC 2006


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 at 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) , at 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)
+    , at 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 at 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 at 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))




More information about the Pg-cvs mailing list