From pvaneynde at common-lisp.net  Tue Aug 10 10:52:33 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 10 Aug 2004 03:52:33 -0700
Subject: [pg-cvs] CVS update: pg/debian/changelog 
Message-ID: <E1BuUF7-0003DH-00@common-lisp.net>

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

Modified Files:
	changelog 
Log Message:
Changed to a version-less date-oriented versioning system.

Date: Tue Aug 10 03:52:32 2004
Author: pvaneynde

Index: pg/debian/changelog
diff -u pg/debian/changelog:1.1 pg/debian/changelog:1.2
--- pg/debian/changelog:1.1	Tue Mar  9 08:25:27 2004
+++ pg/debian/changelog	Tue Aug 10 03:52:32 2004
@@ -1,11 +1,11 @@
-cl-pg (0.21) unstable; urgency=low
+cl-pg (20040810) unstable; urgency=low
 
   * Now a debian-native package.
   * Support for the v3 protocol
   * Support for parse/bind/execute parts of that protocol
   * Support for COPY IN/OUT modes
 
- -- Peter Van Eynde <pvaneynd at debian.org>  Tue,  9 Mar 2004 16:04:57 +0100
+ -- Peter Van Eynde <pvaneynd at debian.org>  Tue, 10 Aug 2004 12:51:30 +0200
 
 cl-pg (0.19-1) unstable; urgency=low
 




From pvaneynde at common-lisp.net  Tue Aug 10 11:00:33 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 10 Aug 2004 04:00:33 -0700
Subject: [pg-cvs] CVS update: pg/debian/rules 
Message-ID: <E1BuUMr-0006UK-00@common-lisp.net>

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

Modified Files:
	rules 
Log Message:
adapted the rules fire for  the extra files needed
Date: Tue Aug 10 04:00:32 2004
Author: pvaneynde

Index: pg/debian/rules
diff -u pg/debian/rules:1.1 pg/debian/rules:1.2
--- pg/debian/rules:1.1	Tue Mar  9 08:25:27 2004
+++ pg/debian/rules	Tue Aug 10 04:00:32 2004
@@ -53,7 +53,9 @@
 	dh_installdirs
 
 	# Add here commands to install the package into debian/pg.
-	install -g root -o root -m 0644 defpackage.lisp pg-tests.lisp pg.lisp sysdep.lisp \
+	install -g root -o root -m 0644 defpackage.lisp  large-object.lisp \
+	  lowlevel.lisp  md5.lisp  meta-queries.lisp  parsers.lisp  pg-tests.lisp \
+	  pg.lisp  sysdep.lisp  utility.lisp  v2-protocol.lisp  v3-protocol.lisp \
 		$(CURDIR)/debian/cl-pg/usr/share/common-lisp/source/pg
 	install -g root -o root -m 0644 pg.asd \
 		$(CURDIR)/debian/cl-pg/usr/share/common-lisp/source/pg




From pvaneynde at common-lisp.net  Tue Aug 10 11:09:13 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 10 Aug 2004 04:09:13 -0700
Subject: [pg-cvs] CVS update: pg/debian/changelog 
Message-ID: <E1BuUVF-0006UX-00@common-lisp.net>

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

Modified Files:
	changelog 
Log Message:
added note about fixed bug
Date: Tue Aug 10 04:09:13 2004
Author: pvaneynde

Index: pg/debian/changelog
diff -u pg/debian/changelog:1.2 pg/debian/changelog:1.3
--- pg/debian/changelog:1.2	Tue Aug 10 03:52:32 2004
+++ pg/debian/changelog	Tue Aug 10 04:09:13 2004
@@ -4,8 +4,9 @@
   * Support for the v3 protocol
   * Support for parse/bind/execute parts of that protocol
   * Support for COPY IN/OUT modes
+  * New implementation fixes many bugs, among then: Closes: #244816 
 
- -- Peter Van Eynde <pvaneynd at debian.org>  Tue, 10 Aug 2004 12:51:30 +0200
+ -- Peter Van Eynde <pvaneynd at debian.org>  Tue, 10 Aug 2004 13:08:31 +0200
 
 cl-pg (0.19-1) unstable; urgency=low
 




From emarsden at common-lisp.net  Wed Aug 11 13:26:41 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 11 Aug 2004 06:26:41 -0700
Subject: [pg-cvs] CVS update: pg/CREDITS pg/NEWS pg/TODO 
Message-ID: <E1But7p-0001Qm-00@common-lisp.net>

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

Modified Files:
	CREDITS NEWS TODO 
Log Message:
layout of documentation
Date: Wed Aug 11 06:26:41 2004
Author: emarsden

Index: pg/CREDITS
diff -u pg/CREDITS:1.2 pg/CREDITS:1.3
--- pg/CREDITS:1.2	Mon Mar  8 07:01:53 2004
+++ pg/CREDITS	Wed Aug 11 06:26:41 2004
@@ -4,10 +4,28 @@
 Peter Van Eynde:
   Wrote the support for the v3 PostgreSQL protocol.
 
+Marc Battyani:
+  Lispworks port and bugfixes
+
+Johannes Gr?dem <johs at copyleft.no>:
+  Fix to parsing of DATE types
+
+Doug McNaught:
+  Bugfixes
+
+Howard Ding:
+  Bugfixes
+
+Ernst Jeschek:
+  Pointed out a bug in float parsing
+
+Brian Lui:
+  Provided fixes for ACL6
+  
+James Anderson:
+  Provided a fix for a change in PostgreSQL timestamp format
+
+Brian Mastenbrook:
+  Implemented MD5 authentication support
+
 
-Thanks to Marc Battyani for the LW port and for bugfixes, to Johannes
-Gr?dem <johs at copyleft.no> for a fix to parsing of DATE types, to Doug
-McNaught and Howard Ding for bugfixes, to Ernst Jeschek for pointing
-out a bug in float parsing, to Brian Lui for providing fixes for ACL6,
-to James Anderson for providing a fix for a change in PostgreSQL
-timestamp format.


Index: pg/NEWS
diff -u pg/NEWS:1.2 pg/NEWS:1.3
--- pg/NEWS:1.2	Mon Mar  8 07:01:53 2004
+++ pg/NEWS	Wed Aug 11 06:26:41 2004
@@ -1,3 +1,4 @@
+
 === Version 0.21, 2003-xxxx ============================================
 
  - added support for the v3 frontend/backend protocol, used by
@@ -9,6 +10,10 @@
    instead of PG-CONNECT. 
  
  - split out functionality into more files
+
+ - added preliminary support for character encodings, for when the
+   encoding used by PostgreSQL for TEXT data differs from that used
+   by the Common Lisp implementation for strings.
 
 
 === Version 0.20 (unreleased) ==========================================


Index: pg/TODO
diff -u pg/TODO:1.1 pg/TODO:1.2
--- pg/TODO:1.1	Fri Mar  5 10:08:08 2004
+++ pg/TODO	Wed Aug 11 06:26:41 2004
@@ -1,8 +1,3 @@
- -  update to protocol version 3, as per
-    http://developer.postgresql.org/docs/postgres/protocol-changes.html
-    esp with respect to error responses
-
-
  - SSL support
  
 
@@ -11,7 +6,22 @@
    SERVE-EVENT support
 
 
+ - add support for the SQL bit string data type
+   CREATE TABLE test (a BUT(3), b BIT VARYING(5))
+     INSERT INTO TEST VALUES (B'101', B'00');
+
  - in PG-CONNECT, use getaddrinfo_all() to try connecting to each
    possible address for a hostname
 
    
+ - the whole bind saga
+
+ - maybe use CancelRequest to back out of error with grace?
+
+ - we should return the oid of the object on inserts
+
+ - use CopyData #\d methods
+
+ - handle CopyInResponse and CopyOutResponse in pg-exec 
+
+ - use Describe 




From emarsden at common-lisp.net  Wed Aug 11 13:27:49 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 11 Aug 2004 06:27:49 -0700
Subject: [pg-cvs] CVS update: pg/stone-age-load.lisp pg/parsers.lisp
	pg/pg-tests.lisp pg/pg.asd pg/sysdep.lisp pg/v3-protocol.lisp
Message-ID: <E1But8v-0004oq-00@common-lisp.net>

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

Modified Files:
	parsers.lisp pg-tests.lisp pg.asd sysdep.lisp v3-protocol.lisp 
Added Files:
	stone-age-load.lisp 
Log Message:
add a file that does a manual load of pg
Date: Wed Aug 11 06:27:48 2004
Author: emarsden



Index: pg/parsers.lisp
diff -u pg/parsers.lisp:1.3 pg/parsers.lisp:1.4
--- pg/parsers.lisp:1.3	Wed Apr 21 12:23:18 2004
+++ pg/parsers.lisp	Wed Aug 11 06:27:48 2004
@@ -82,7 +82,7 @@
     ("money"     . ,'text-parser)       ; "$12.34"
     ("abstime"   . ,'timestamp-parser)
     ("date"      . ,'date-parser)
-    ("timestamp" . ,'timestamp-parser)
+    ("timestamp" . ,'timestamp-parser)  ; or 'precise-timestamp-parser if you want milliseconds
     ("timestamptz" . ,'timestamp-parser)
     ("datetime"  . ,'timestamp-parser)
     ("time"      . ,'text-parser)     ; preparsed "15:32:45"


Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.6 pg/pg-tests.lisp:1.7
--- pg/pg-tests.lisp:1.6	Sat Mar 20 13:48:41 2004
+++ pg/pg-tests.lisp	Wed Aug 11 06:27:48 2004
@@ -1,8 +1,6 @@
 ;;; pg-tests.lisp -- incomplete test suite
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-08 emarsden>
-;;
 ;;
 ;;
 ;; These tests assume that a table named "test" is defined in the
@@ -17,7 +15,7 @@
 
 ;; !!! CHANGE THE VALUES HERE !!!
 (defun call-with-test-connection (function)
-  (with-pg-connection (conn "template1" "emarsden" :host nil :port 5432)
+  (with-pg-connection (conn "test" "pgdotlisp" :host "melbourne" :port 5433 :password "lisp")
     (funcall function conn)))
 
 (defmacro with-test-connection ((conn) &body body)
@@ -348,31 +346,32 @@
     (pg-exec conn "DROP TABLE foo")))
 
 (defun test ()
-  (with-test-connection (conn)
-   (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn))
-   ;; client encoding supported since PostgreSQL v7.1
-   (format t "Client encoding is ~A~%" (pg-client-encoding conn))
-   (format t "Date style is ~A~%" (pg-date-style conn))
-   (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c money)"))
-         (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, '$123.45')"))
-         (r4 (pg-exec conn "DROP TABLE pgltest")))
-     (format t "~%==============================================~%")
-     (format t "status of CREATE is ~s~%" (pg-result r2 :status))
-     (format t "status of INSERT is ~s~%" (pg-result r3 :status))
-     (format t "oid of INSERT is ~s~%" (pg-result r3 :oid))
-     (format t "status of DROP is ~s~%" (pg-result r4 :status))
-     (format t "==============================================~%")))
-  (test-simple)
-  (test-insert)
-  (test-insert/float)
-  (test-date)
-  (test-booleans)
-  (test-integrity)
-  (test-notifications)
-  (test-lo)
-  (test-lo-read)
-  #+cmu (test-lo-import)
-  (test-pbe))
+  (let ((*pg-client-encoding* "UNICODE"))
+    (with-test-connection (conn)
+      (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn))
+      ;; client encoding supported since PostgreSQL v7.1
+      (format t "Client encoding is ~A~%" (pg-client-encoding conn))
+      (format t "Date style is ~A~%" (pg-date-style conn))
+      (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c money)"))
+            (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, '$123.45')"))
+            (r4 (pg-exec conn "DROP TABLE pgltest")))
+        (format t "~%==============================================~%")
+        (format t "status of CREATE is ~s~%" (pg-result r2 :status))
+        (format t "status of INSERT is ~s~%" (pg-result r3 :status))
+        (format t "oid of INSERT is ~s~%" (pg-result r3 :oid))
+        (format t "status of DROP is ~s~%" (pg-result r4 :status))
+        (format t "==============================================~%")))
+    (test-simple)
+    (test-insert)
+    (test-insert/float)
+    (test-date)
+    (test-booleans)
+    (test-integrity)
+    (test-notifications)
+    (test-lo)
+    (test-lo-read)
+    #+cmu (test-lo-import)
+    (test-pbe)))
 
 
 ;; EOF


Index: pg/pg.asd
diff -u pg/pg.asd:1.5 pg/pg.asd:1.6
--- pg/pg.asd:1.5	Thu Apr  1 10:35:19 2004
+++ pg/pg.asd	Wed Aug 11 06:27:48 2004
@@ -10,7 +10,7 @@
 
 #+cmu
 (defmethod perform :before ((o load-op) (c pg-component))
-  (ext:load-foreign "/usr/lib/libcrypt.a"))
+  (ext:load-foreign "/usr/lib/libcrypt.so"))
 
 (defsystem :pg
     :name "Socket-level PostgreSQL interface"


Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.5 pg/sysdep.lisp:1.6
--- pg/sysdep.lisp:1.5	Thu Apr  1 10:35:19 2004
+++ pg/sysdep.lisp	Wed Aug 11 06:27:48 2004
@@ -1,7 +1,7 @@
 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-04-01 emarsden>
+;;; Time-stamp: <2004-04-23 emarsden>
 ;;
 ;;
 
@@ -15,6 +15,13 @@
   #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
 
 
+
+(defmacro %sysdep (desc &rest forms)
+  (when (null forms)
+    (error "No system dependent code to ~A" desc))
+  (car forms))
+
+
 #+(and cmu glibc2)
 (eval-when (:compile-toplevel :load-toplevel)
   (format t ";; Loading libcrypt~%")
@@ -292,6 +299,37 @@
              :host host
              :port port
              :transport-error e))))
+
+
+
+;;; character encoding support
+
+(defvar *pg-client-encoding*)
+
+(defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
+  (declare (type string string))
+  (%sysdep "convert string to bytes"
+     #+(and clisp unicode)
+     (ext:convert-string-to-bytes string encoding)
+     #+(and acl ics)
+     (excl:string-to-octets string :external-format encoding)
+     #+(or cmu sbcl gcl ecl)
+     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
+       (map-into octets #'char-code string))))
+
+(defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
+  (declare (type (vector (unsigned-byte 8)) bytes))
+  (%sysdep "convert octet-array to string"
+    #+(and clisp unicode)
+    (ext:convert-string-from-bytes bytes encoding)
+    #+(and acl ics)
+    (ext:octets-to-string bytes :external-format encoding)
+    ;; for implementations that have no support for character
+    ;; encoding, we assume that the encoding is an octet-for-octet
+    ;; encoding, and convert directly
+    #+(or cmu sbcl gcl ecl)
+    (let ((string (make-string (length bytes))))
+      (map-into string #'code-char bytes))))
 
 
 ;; EOF


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.11 pg/v3-protocol.lisp:1.12
--- pg/v3-protocol.lisp:1.11	Thu Apr 22 10:00:12 2004
+++ pg/v3-protocol.lisp	Wed Aug 11 06:27:48 2004
@@ -7,6 +7,8 @@
 (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))))
@@ -77,7 +79,9 @@
    (data :initarg :data
          :type (array (unsigned-byte 8) *))
    (position :initform 0
-             :type integer)))
+             :type integer)
+   (connection  :initarg :connection
+                :type pgcon-v3)))
 
 (defmethod print-object ((object pg-packet) stream)
     (print-unreadable-object (object stream :type t :identity t)
@@ -159,7 +163,8 @@
            (packet (make-instance 'pg-packet
                                   :type (code-char type)
                                   :length length
-                                  :data data)))
+                                  :data data
+                                  :connection connection)))
       (case (pg-packet-type packet)
         (( #\E)                                ; error
          (read-and-generate-error-response packet)
@@ -224,16 +229,14 @@
                         (1+ (logxor result
                                     #xFFFFFFFF)))))
         result)))
-  (:method ((packet pg-packet) (type (eql :cstring)))
-    (with-slots (data position)
-        packet
 
+  ;; a string that does not get encoded
+  (:method ((packet pg-packet) (type (eql :ucstring)))
+    (with-slots (data position) packet
       (let* ((end (position 0 data :start position))
-             ;; end is where the 0 byte is
-             (result (unless (= end position)
+             (result (unless (eql end position)
                        (make-array (- end position)
                                    :element-type 'base-char))))
-        ;; FIXME need to handle charset encoding issues here
         (when result
           (loop :for i :from position :below end
                 :for j :from 0
@@ -242,7 +245,22 @@
                       (code-char
                        (elt data i))))
           (setf position (1+ end))
-          result)))))
+          result))))
+
+  ;; a string that does get encoded, if the current connection has set
+  ;; its prefered encoding
+  (:method ((packet pg-packet) (type (eql :cstring)))
+    (with-slots (data position connection) packet
+      (cond ((pgcon-encoding connection)
+             (let* ((end (position 0 data :start position))
+                    (result (unless (eql end position)
+                              (convert-string-from-bytes (subseq data position end)))))
+               (when result (setf position (1+ end)))
+               result))
+            ;; the encoding has not yet been set, so revert to :ucstring behaviour
+            (t
+             (read-from-packet packet :ucstring))))))
+
 
 ;; FIXME need to check all callers of this function to distinguish
 ;; between uses that expect charset encoding to be handled, and those
@@ -287,10 +305,8 @@
                                 ((:byte :char) 1)
                                 ((:int16) 2)
                                 ((:int32) 4)
-                                ((:cstring
-				  :rawdata)
-                                 (+ 1
-                                    (length value)))))))
+                                ((:cstring) (1+ (length (convert-string-to-bytes value))))
+                                ((:ucstring :rawdata) (1+ (length value)))))))
          (data (make-array (- length 4)
                            :element-type '(unsigned-byte 8)))
          (stream (pgcon-stream connection)))
@@ -320,12 +336,9 @@
              (setf (elt data (+ 2 position)) (ldb (byte 8 8) value))
              (setf (elt data (+ 3 position)) (ldb (byte 8 0) value))
              (incf position 4))
-            ;; FIXME need to deal with text encoding issues here:
-            ;; transform from the Lisp string representation to the
-            ;; encoding selected by *PG-CLIENT-ENCODING*. 
-            ((:cstring)
-             (check-type value string)
 
+            ((:ucstring)
+             (check-type value string)
              (loop for char across value
                    do
                    (setf (elt data position)
@@ -333,9 +346,17 @@
                    (incf position))
              (setf (elt data position) 0)
              (incf position))
+
+            ((:cstring)
+             (check-type value string)
+             (let ((encoded (convert-string-to-bytes value)))
+               (replace data encoded :start1 position)
+               (incf position (length encoded)))
+             (setf (elt data position) 0)
+             (incf position))
+
 	    ((:rawdata)
              (check-type value (array (unsigned-byte 8) *))
-
 	     (replace data value :start1 position)
 	     (incf position (length value)))))
 
@@ -392,14 +413,14 @@
              (error 'authentication-failure
                     :reason "Kerberos5 authentication not supported"))
             ((3)                          ; AuthUnencryptedPassword
-             (send-packet connection #\p `((:cstring ,password)))
+             (send-packet connection #\p `((:ucstring ,password)))
              (%flush connection))
             ((4)                          ; AuthEncryptedPassword
              (let* ((salt (read-string-from-packet packet 2))
                     (crypted (crypt password salt)))
                #+debug
                (format *debug-io* "CryptAuth: Got salt of ~s~%" salt)
-               (send-packet connection #\p `((:cstring ,crypted)))
+               (send-packet connection #\p `((:ucstring ,crypted)))
                (%flush connection)))
             ((5)                          ; AuthMD5Password
              #+debug
@@ -407,7 +428,7 @@
              (force-output *debug-io*)
              (let* ((salt (read-string-from-packet packet 4))
                     (ciphered (md5-encode-password user password salt)))
-               (send-packet connection #\p `((:cstring ,ciphered)))
+               (send-packet connection #\p `((:ucstring ,ciphered)))
                (%flush connection)))
             ((6)                          ; AuthSCMPassword
              (error 'authentication-failure
@@ -425,8 +446,8 @@
           (setf (pgcon-secret connection) secret)))
        (( #\S)
         ;; Status
-        (let* ((parameter (read-from-packet packet :cstring))
-               (value (read-from-packet packet :cstring)))
+        (let* ((parameter (read-from-packet packet :ucstring))
+               (value (read-from-packet packet :ucstring)))
           (push (cons parameter value) (pgcon-parameters connection))))
        ((#\Z)
         ;; Ready for Query
@@ -435,14 +456,14 @@
                      (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*)
                (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.




From emarsden at common-lisp.net  Fri Aug 13 16:45:08 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Fri, 13 Aug 2004 09:45:08 -0700
Subject: [pg-cvs] CVS update: pg/parsers.lisp 
Message-ID: <E1BvfAy-0008G1-00@common-lisp.net>

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

Modified Files:
	parsers.lisp 
Log Message:
Trivial.


Date: Fri Aug 13 09:45:07 2004
Author: emarsden

Index: pg/parsers.lisp
diff -u pg/parsers.lisp:1.4 pg/parsers.lisp:1.5
--- pg/parsers.lisp:1.4	Wed Aug 11 06:27:48 2004
+++ pg/parsers.lisp	Fri Aug 13 09:45:07 2004
@@ -204,7 +204,7 @@
             (push (cons oid (cdr type)) *parsers*))
            (t
             #+debug
-            (warn "Unknown postgresSQL type found: '~A' oid: '~A'"
+            (warn "Unknown PostgreSQL type found: '~A' oid: '~A'"
                    typname
                    oid)))))
      tuples)))




From emarsden at common-lisp.net  Fri Aug 13 16:50:37 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Fri, 13 Aug 2004 09:50:37 -0700
Subject: [pg-cvs] CVS update: pg/large-object.lisp pg/pg-tests.lisp
	pg/v3-protocol.lisp 
Message-ID: <E1BvfGH-0006k6-00@common-lisp.net>

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

Modified Files:
	large-object.lisp pg-tests.lisp v3-protocol.lisp 
Log Message:
Implement binary-mode transfers for large-object operations in the v3
protocol. The v2 protocol transfers arguments in binary mode, but the
v3 protocol requires the client to specify for each argument of a
FunctionCall whether it is encoded as binary or as text. 

  - add possibility to send (unsigned-byte 8) arguments to function calls

  - add a method READ-OCTETS-FROM-PACKET that reads raw octets

  - make PG-IMPORT and PG-EXPORT use binary I/O

  - PGLO-READ reads data in binary

  - change the large-object tests to use binary I/O (fixes the pglo test)


Date: Fri Aug 13 09:50:37 2004
Author: emarsden

Index: pg/large-object.lisp
diff -u pg/large-object.lisp:1.1 pg/large-object.lisp:1.2
--- pg/large-object.lisp:1.1	Fri Mar  5 10:08:08 2004
+++ pg/large-object.lisp	Fri Aug 13 09:50:37 2004
@@ -1,7 +1,6 @@
 ;;; large-object.lisp -- support for BLOBs
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
 ;;
 ;;
 ;; Sir Humphrey: Who is Large and to what does he object?
@@ -82,8 +81,10 @@
 (defun pglo-close (connection fd)
   (fn connection "lo_close" t fd))
 
+;; note that the 3rd argument means that we are reading data in binary
+;; format, not text
 (defun pglo-read (connection fd bytes)
-  (fn connection "loread" nil fd bytes))
+  (fn connection "loread" t fd bytes))
 
 (defun pglo-write (connection fd buf)
   (fn connection "lowrite" t fd buf))
@@ -98,9 +99,10 @@
   (fn connection "lo_unlink" t oid))
 
 (defun pglo-import (connection filename)
-  (let ((buf (make-string +LO_BUFSIZ+))
+  (let ((buf (make-array +LO_BUFSIZ+ :element-type '(unsigned-byte 8)))
         (oid (pglo-create connection "rw")))
-    (with-open-file (in filename :direction :input)
+    (with-open-file (in filename :direction :input
+                        :element-type '(unsigned-byte 8))
        (loop :with fdout = (pglo-open connection oid "w")
              :for bytes = (read-sequence buf in)
              :until (< bytes +LO_BUFSIZ+)
@@ -111,7 +113,8 @@
     oid))
 
 (defun pglo-export (connection oid filename)
-  (with-open-file (out filename :direction :output)
+  (with-open-file (out filename :direction :output
+                       :element-type '(unsigned-byte 8))
      (loop :with fdin = (pglo-open connection oid "r")
            :for str = (pglo-read connection fdin +LO_BUFSIZ+)
            :until (zerop (length str))


Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.7 pg/pg-tests.lisp:1.8
--- pg/pg-tests.lisp:1.7	Wed Aug 11 06:27:48 2004
+++ pg/pg-tests.lisp	Fri Aug 13 09:50:37 2004
@@ -13,9 +13,15 @@
         #+cmu :fwrappers))
 (in-package :pg-tests)
 
+(defmacro with-pg-connection/2 ((con &rest open-args) &body body)
+  `(let ((,con (pg::pg-connect/v2 , at open-args)))
+     (unwind-protect
+         (progn , at body)
+       (when ,con (pg-disconnect ,con)))))
+
 ;; !!! CHANGE THE VALUES HERE !!!
 (defun call-with-test-connection (function)
-  (with-pg-connection (conn "test" "pgdotlisp" :host "melbourne" :port 5433 :password "lisp")
+  (with-pg-connection (conn "test" "pgdotlisp")
     (funcall function conn)))
 
 (defmacro with-test-connection ((conn) &body body)
@@ -194,24 +200,27 @@
       (sleep 1)
       (pglo-unlink conn oid)))))
 
-;; test of large-object interface
+;; test of large-object interface. We are careful to use vectors of
+;; bytes instead of strings, because with the v3 protocol strings
+;; undergo \\xxx encoding (for instance #\newline is transformed to \\012). 
 (defun test-lo-read ()
   (format *debug-io* "Testing read of large object ...~%")
   (with-test-connection (conn)
    (with-pg-transaction conn
     (let* ((oid (pglo-create conn "rw"))
            (fd (pglo-open conn oid "rw")))
-      (pglo-write conn fd "Hi there mate")
+      (pglo-write conn fd (map '(vector (unsigned-byte 8)) #'char-code (format nil "Hi there mate~%What's up?~%")))
       (pglo-lseek conn fd 3 0)           ; SEEK_SET = 0
-      (assert (= 3 (pglo-tell conn fd)))
+      (assert (eql 3 (pglo-tell conn fd)))
       ;; this should print "there mate"
-      (format *debug-io* "Read ~s from lo~%" (pglo-read conn fd 10))
+      (format *debug-io* "Read ~s from lo~%" (map 'string #'code-char (pglo-read conn fd 10)))
+      (format *debug-io* "Rest is ~s~%" (map 'string #'code-char (pglo-read conn fd 1024)))
       (pglo-close conn fd)
-      (pglo-unlink conn oid)))))
+      #+nil (pglo-unlink conn oid)))))
 
 #+cmu
 (defun test-lo-import ()
-    (format *debug-io* "Testing import of large object ...~%")
+  (format *debug-io* "Testing import of large object ...~%")
   (with-test-connection (conn)
    (with-pg-transaction conn
     (let ((oid (pglo-import conn "/etc/group")))


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.12 pg/v3-protocol.lisp:1.13
--- pg/v3-protocol.lisp:1.12	Wed Aug 11 06:27:48 2004
+++ pg/v3-protocol.lisp	Fri Aug 13 09:50:37 2004
@@ -267,7 +267,7 @@
 ;; that really want READ-OCTET-ARRAY-FROM-PACKET
 (defgeneric read-string-from-packet (packet length)
   (:documentation
-   "Reads an array of LENGTH bytes from the packet")
+   "Reads a string of LENGTH characters from the packet")
   (:method ((packet pg-packet) (length (eql -1)))
     nil)
   (:method ((packet pg-packet) (length (eql 0)))
@@ -289,6 +289,13 @@
         (incf position length)
         result))))
 
+(defmethod read-octets-from-packet ((packet pg-packet) (length integer))
+  (let ((result (make-array length :element-type '(unsigned-byte 8))))
+    (with-slots (data position) packet
+      (replace result data :start2 position :end2 (+ position length))
+      (incf position length)
+      result)))
+  
 
 
 (defun send-packet (connection code description)
@@ -305,8 +312,9 @@
                                 ((:byte :char) 1)
                                 ((:int16) 2)
                                 ((:int32) 4)
+                                ((:rawdata) (length value))
                                 ((:cstring) (1+ (length (convert-string-to-bytes value))))
-                                ((:ucstring :rawdata) (1+ (length value)))))))
+                                ((:ucstring) (1+ (length value)))))))
          (data (make-array (- length 4)
                            :element-type '(unsigned-byte 8)))
          (stream (pgcon-stream connection)))
@@ -698,7 +706,7 @@
 ;; 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)
+(defmethod fn ((connection pgcon-v3) fn binary-result &rest args)
     (or *lo-initialized* (lo-init connection))
   (let ((fnid (cond ((integerp fn) fn)
                     ((not (stringp fn))
@@ -711,33 +719,31 @@
                  `((: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)))))
+                          (dolist (arg args)
+                            (etypecase arg
+                              (integer
+                               (push `(:int16 1) result))
+                              ((vector (unsigned-byte 8))
+                               (push `(:int16 1) result))
+                              (string
+                               (push `(:int16 0) result))))
                           (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)))))
+                          (dolist (arg args)
+                            (etypecase arg
+                              (integer
+                               (push '(:int32 4) result)
+                               (push `(:int32 ,arg) result))
+                              ((vector (unsigned-byte 8))
+                               (push `(:int32 ,(length arg)) result)
+                               (push `(:rawdata ,arg) result))
+                              (string
+                               ;; FIXME this should be STRING-OCTET-LENGTH instead of LENGTH
+                               (push `(:int32 ,(1+ (length arg))) result)
+                               (push `(:cstring ,arg) result))))
                           (nreverse result))
-                   (:int16 ,(if integer-result 1 0))))
+                   (:int16 ,(if binary-result 1 0))))
     (%flush connection)
     (loop :with result = nil
           :for packet = (read-packet connection)
@@ -746,14 +752,16 @@
             ((#\V) ; FunctionCallResponse
              (let* ((length (read-from-packet packet :int32))
                     (data (unless (= length -1)
-                            (if integer-result
-                                (ecase length
+                            (if binary-result
+                                (case length
                                   ((1)
                                    (read-from-packet packet :byte))
                                   ((2)
                                    (read-from-packet packet :int16))
                                   ((4)
-                                   (read-from-packet packet :int32)))
+                                   (read-from-packet packet :int32))
+                                  (t
+                                   (read-octets-from-packet packet length)))
                                 (read-string-from-packet packet length)))))
                (if data
                    (setf result data)