From emarsden at common-lisp.net  Wed Mar  3 13:11:50 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 03 Mar 2004 08:11:50 -0500
Subject: [pg-cvs] CVS update: Module imported: pg
Message-ID: <E1AyWAA-0002P7-00@common-lisp.net>

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

Log Message:
initial import

Status:

Vendor Tag:	clnet
Release Tags:	start
		
N pg/pg.lisp
N pg/README
N pg/pg-tests.lisp
N pg/defpackage.lisp
N pg/pg.asd
N pg/sysdep.lisp
N pg/NEWS
N pg/cmucl-install-subsystem.lisp

No conflicts created by this import

Date: Wed Mar  3 08:11:50 2004
Author: emarsden
New module pg added



From emarsden at common-lisp.net  Fri Mar  5 18:08:09 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Fri, 05 Mar 2004 13:08:09 -0500
Subject: [pg-cvs] CVS update: pg/CREDITS pg/TODO pg/large-object.lisp
	pg/meta-queries.lisp pg/parsers.lisp pg/utility.lisp
	pg/v2-protocol.lisp pg/v3-protocol.lisp pg/pg-tests.lisp
	pg/pg.asd pg/pg.lisp pg/sysdep.lisp 
Message-ID: <E1AzJk1-0002kK-00@common-lisp.net>

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

Modified Files:
	pg-tests.lisp pg.asd pg.lisp sysdep.lisp 
Added Files:
	CREDITS TODO large-object.lisp meta-queries.lisp parsers.lisp 
	utility.lisp v2-protocol.lisp v3-protocol.lisp 
Log Message:

Integrate Peter Van Eynde's v3 protocol support:

   - create PGCON-V2 and PGCON-V3 classes
   - PG-CONNECT attempts to connect using v3 protocol, and falls back
     to v2 protocol for older backends; return a PGCON-V2 or PGCON-V3
     object 
   - PG-EXEC and FN and PG-DISCONNECT are generic functions that
     dispatch on the connection type
   - protocol code split into v2-protocol.lisp and v3-protocol.lisp

TBD: cleaning up the notification & error reporting support, and
factorizing more code between the two protocol versions.


Also split code out into multiple files:

   - large-object support
   - metainformation about databases
   - parsing and type coercion support
   - utility functions and macros



Date: Fri Mar  5 13:08:08 2004
Author: emarsden

















Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.1.1.1 pg/pg-tests.lisp:1.2
--- pg/pg-tests.lisp:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/pg-tests.lisp	Fri Mar  5 13:08:08 2004
@@ -1,4 +1,8 @@
-;; == testing ==============================================================
+;;; pg-tests.lisp -- incomplete test suite
+;;;
+;;; Author: Eric Marsden <emarsden at laas.fr>
+;;; Time-stamp: <2004-03-05 emarsden>
+;;
 ;;
 ;;
 ;; These tests assume that a table named "test" is defined in the
@@ -13,7 +17,7 @@
 
 ;; !!! CHANGE THE VALUES HERE !!!
 (defun call-with-test-connection (function)
-  (with-pg-connection (conn "test" "emarsden" :host "melbourne" :port 5433)
+  (with-pg-connection (conn "template1" "emarsden" :host nil :port 5432)
     (funcall function conn)))
 
 (defmacro with-test-connection ((conn) &body body)
@@ -301,5 +305,6 @@
   (test-lo)
   (test-lo-read)
   #+cmu (test-lo-import))
+
 
 ;; EOF


Index: pg/pg.asd
diff -u pg/pg.asd:1.1.1.1 pg/pg.asd:1.2
--- pg/pg.asd:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/pg.asd	Fri Mar  5 13:08:08 2004
@@ -15,8 +15,14 @@
 (defsystem :pg
     :name "Socket-level PostgreSQL interface"
     :author "Eric Marsden"
-    :version "0.19"
+    :version "0.21"
     :components ((:file "defpackage")
                  (:file "sysdep" :depends-on ("defpackage"))
-                 (:pg-component "pg" :depends-on ("sysdep"))))
+                 (:file "meta-queries" :depends-on ("defpackage"))
+                 (:file "parsers" :depends-on ("defpackage"))
+                 (:file "utility" :depends-on ("defpackage"))
+                 (:pg-component "pg" :depends-on ("sysdep" "parsers"))
+                 (:file "large-object" :depends-on ("pg"))
+                 (:file "v2-protocol" :depends-on ("pg" "large-object" "utility"))
+                 (:file "v3-protocol" :depends-on ("pg" "large-object" "utility"))))
 


Index: pg/pg.lisp
diff -u pg/pg.lisp:1.1.1.1 pg/pg.lisp:1.2
--- pg/pg.lisp:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/pg.lisp	Fri Mar  5 13:08:08 2004
@@ -1,8 +1,8 @@
 ;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp
 ;;
 ;; Author: Eric Marsden <emarsden at laas.fr>
-;; Time-stamp: <2004-02-18 emarsden>
-;; Version: 0.20
+;; Time-stamp: <2004-03-05 emarsden>
+;; Version: 0.21
 ;;
 ;;     Copyright (C) 1999,2000,2001,2002,2003  Eric Marsden
 ;;
@@ -69,28 +69,10 @@
 ;; a change in PostgreSQL timestamp format.
 
 
-;;; TODO ============================================================
-;;
-;; * add a mechanism for parsing user-defined types. The user should
-;;   be able to define a parse function and a type-name; we query
-;;   pg_type to get the type's OID and add the information to
-;;   pg:*parsers*.
-;;
-;; * update to protocol version 3, as per
-;;   http://developer.postgresql.org/docs/postgres/protocol-changes.html
-;;   esp with respect to error responses
-
 (declaim (optimize (speed 3) (safety 1)))
 
 (in-package :postgresql)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  #+allegro (require :socket)
-  #+lispworks (require "comm")
-  #+cormanlisp (require :sockets)
-  #+sbcl (progn (require :asdf) (require :sb-bsd-sockets))
-  #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
-
 
 (define-condition postgresql-error (simple-error) ())
 (define-condition connection-failure (postgresql-error)
@@ -102,6 +84,7 @@
 	 :reader connection-failure-transport-error))
   (:report
    (lambda (exc stream)
+     (declare (type stream stream))
      (format stream "Couldn't connect to PostgreSQL database at ~a:~a.
 Connection attempt reported ~A.
 Is the postmaster running and accepting TCP connections?~%"
@@ -114,6 +97,7 @@
            :reader authentication-failure-reason))
   (:report
    (lambda (exc stream)
+     (declare (type stream stream))
      (format stream "PostgreSQL authentication failure: ~a~%"
              (authentication-failure-reason exc)))))
 
@@ -122,6 +106,7 @@
            :reader protocol-error-reason))
   (:report
    (lambda (exc stream)
+     (declare (type stream stream))
      (format stream "PostgreSQL protocol error: ~a~%"
              (protocol-error-reason exc)))))
 
@@ -130,15 +115,12 @@
            :reader backend-error-reason))
   (:report
    (lambda (exc stream)
+     (declare (type stream stream))
      (format stream "PostgreSQL backend error: ~a~%"
              (backend-error-reason exc)))))
 
 
 (defconstant +NAMEDATALEN+ 32)          ; postgres_ext.h
-(defconstant +PG_PROTOCOL_LATEST_MAJOR+ 2) ; libpq/pgcomm.h
-(defconstant +PG_PROTOCOL_63_MAJOR+     1)
-(defconstant +PG_PROTOCOL_62_MAJOR+     0)
-(defconstant +PG_PROTOCOL_LATEST_MINOR+ 0)
 (defconstant +SM_DATABASE+ 64)
 (defconstant +SM_USER+     32)
 (defconstant +SM_OPTIONS+  64)
@@ -155,289 +137,70 @@
 
 (defconstant +MAX_MESSAGE_LEN+    8192)     ; libpq-fe.h
 
-(defconstant +INV_ARCHIVE+ #x10000)     ; fe-lobj.c
-(defconstant +INV_WRITE+   #x20000)
-(defconstant +INV_READ+    #x40000)
-(defconstant +LO_BUFSIZ+   1024)
-
-;; alist of (oid . parser) pairs. This is built dynamically at
-;; initialization of the connection with the database (once generated,
-;; the information is shared between connections).
-(defvar *parsers* '())
-
 (defvar *pg-client-encoding* "LATIN1"
   "The encoding to use for text data, for example \"LATIN1\", \"UNICODE\", \"EUC_JP\".
 See <http://www.postgresql.org/docs/7.3/static/multibyte.html>.")
 
 (defvar *pg-date-style* "ISO")
 
-(defvar *pg-disable-type-coercion* nil
-  "Non-nil disables the type coercion mechanism.
-The default is nil, which means that data recovered from the
-database is coerced to the corresponding Common Lisp type before
-being returned; for example numeric data is transformed to CL
-numbers, and booleans to booleans.
-
-The coercion mechanism requires an initialization query to the
-database, in order to build a table mapping type names to OIDs. This
-option is provided mainly in case you wish to avoid the overhead of
-this initial query. The overhead is only incurred once per session
-(not per connection to the backend).")
 
+(defclass pgcon ()
+  ((stream    :accessor pgcon-stream
+              :initarg :stream
+              :initform nil)
+   (host      :accessor pgcon-host
+              :initarg :host
+              :initform nil)
+   (port      :accessor pgcon-port
+              :initarg :port
+              :initform 0)
+   (pid       :accessor pgcon-pid)
+   (secret    :accessor pgcon-secret)
+   (notices   :accessor pgcon-notices
+              :initform (list))
+   (binary-p  :accessor pgcon-binary-p
+              :initform nil)))
 
+(defmethod print-object ((self pgcon) stream)
+  (print-unreadable-object (self stream :type nil)
+    (with-slots (pid host port) self
+      (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
+              pid host port))))
 
-(defstruct (pgcon (:print-function print-pgcon))
-  stream pid secret notices (binary-p nil) host port)
 (defstruct pgresult connection status attributes tuples)
 
-(defun print-pgcon (self &optional (stream t) depth)
-  (declare (ignore depth))
-  (print-unreadable-object (self stream :type nil)
-     (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
-             (pgcon-pid self)
-             (pgcon-host self)
-             (pgcon-port self))))
-
-(defun pg-date-style (conn)
-  (let ((res (pg-exec conn "SHOW datestyle")))
-    (first (pg-result res :tuple 0))))
-
-(defun set-pg-date-style (conn new-date-style)
-  (declare (type simple-string new-date-style))
-  (pg-exec conn "SET datestyle TO " new-date-style))
-
-(defsetf pg-date-style set-pg-date-style)
-
-;; see http://www.postgresql.org/docs/7.3/static/multibyte.html
-(defun pg-client-encoding (conn)
-  "Return a string identifying the client encoding."
-  (let ((res (pg-exec conn "SHOW client_encoding")))
-    (first (pg-result res :tuple 0))))
-
-(defun set-pg-client-encoding (conn new-encoding)
-  "Set the client_encoding."
-  (declare (type simple-string new-encoding))
-  (pg-exec conn "SET client_encoding TO " new-encoding))
-
-(defsetf pg-client-encoding set-pg-client-encoding)
-
-
-(defmacro with-pg-connection ((con &rest open-args) &body body)
-  "Bindspec is of the form (connection open-args), where OPEN-ARGS are
-as for PG-CONNECT. The database connection is bound to the variable
-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 , at open-args)))
-     (unwind-protect
-         (progn , at body)
-       (when ,con (pg-disconnect ,con)))))
-
-#-old-version
-(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
-a ROLLBACK command.
-Large-object manipulations _must_ occur within a transaction, since
-the large object descriptors are only valid within the context of a
-transaction."
-  `(progn
-     (pg-exec ,con "BEGIN WORK")
-     (handler-case (prog1 (progn , at body) (pg-exec ,con "COMMIT WORK"))
-      (error (e)
-       (pg-exec ,con "ROLLBACK WORK")
-       (error e)))))
-
-
-;;; this version thanks to Daniel Barlow. The old version would abort
-;;; the transaction before entering the debugger, which made
-;;; debugging difficult. 
-(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
-a ROLLBACK command.
-Large-object manipulations _must_ occur within a transaction, since
-the large object descriptors are only valid within the context of a
-transaction."
-  (let ((success (gensym "SUCCESS")))
-    `(let (,success)
-       (unwind-protect
-	    (prog2
-		(pg-exec ,con "BEGIN WORK")
-		(progn , at body)
-	      (setf ,success t))
-	 (pg-exec ,con (if ,success "COMMIT WORK" "ROLLBACK WORK"))))))
-
-(defun pg-for-each (conn select-form callback)
-  "Create a cursor for SELECT-FORM, and call CALLBACK for each result.
-Uses the PostgreSQL database connection CONN. SELECT-FORM must be an
-SQL SELECT statement. The cursor is created using an SQL DECLARE
-CURSOR command, then results are fetched successively until no results
-are left. The cursor is then closed.
-
-The work is performed within a transaction. The work can be
-interrupted before all tuples have been handled by THROWing to a tag
-called 'pg-finished."
-  (let ((cursor (symbol-name (gensym "PGCURSOR"))))
-    (catch 'pg-finished
-      (with-pg-transaction conn
-         (pg-exec conn "DECLARE " cursor " CURSOR FOR " select-form)
-         (unwind-protect
-             (loop :for res = (pg-result (pg-exec conn "FETCH 1 FROM " cursor) :tuples)
-                   :until (zerop (length res))
-                   :do (funcall callback (first res)))
-           (pg-exec conn "CLOSE " cursor))))))
 
+(defgeneric pg-exec (connection &rest args))
+
+(defgeneric fn (connection fn integer-result &rest args))
 
+(defgeneric pg-disconnect (connection))
+
+
+
+;; first attempt to connect to connect using the v3 protocol; if this
+;; results in an ErrorResponse we close the connection and retry using
+;; 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 ""))
   "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."
-  (let* ((stream (socket-connect port host))
-         (connection (make-pgcon :stream stream :host host :port port))
-         (user-packet-length (+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+)))
-    ;; send the startup packet
-    (send-int connection +STARTUP_PACKET_SIZE+ 4)
-    (send-int connection +PG_PROTOCOL_LATEST_MAJOR+ 2)
-    (send-int connection +PG_PROTOCOL_LATEST_MINOR+ 2)
-    (send-string connection dbname +SM_DATABASE+)
-    (send-string connection user user-packet-length)
-    (flush connection)
-    #+cmu (ext:finalize connection (lambda () (pg-disconnect connection)))
-    (loop
-     (case (read-byte stream)
-       ;; ErrorResponse
-       ((69) (error 'authentication-failure
-                    :reason (read-cstring connection 4096)))
-
-       ;; Authentication
-       ((82)
-        (case (read-net-int connection 4)
-          ((0)                          ; AuthOK
-           (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))
-          ((3)                          ; AuthUnencryptedPassword
-           (send-int connection (+ 5 (length password)) 4)
-           (send-string connection password)
-           (send-int connection 0 1)
-           (flush connection))
-          ((4)                          ; AuthEncryptedPassword
-           (let* ((salt (read-chars connection 2))
-                  (crypted (crypt password salt)))
-             #+debug
-             (format *debug-io* "Got salt of ~s~%" salt)
-             (send-int connection (+ 5 (length crypted)) 4)
-             (send-string connection crypted)
-             (send-int connection 0 1)
-             (flush connection)))
-          ((1)                          ; AuthKerberos4
-           (error 'authentication-failure
-                  :reason "Kerberos4 authentication not supported"))
-          ((2)                          ; AuthKerberos5
-           (error 'authentication-failure
-                  :reason "Kerberos5 authentication not supported"))
-          (t (error 'authentication-failure
-                    :reason "unknown authentication type"))))
-
-       (t (error 'protocol-error
-                 :reason "expected an authentication response"))))))
-
-(defun pg-exec (connection &rest args)
-  "Execute the SQL command given by the concatenation of ARGS
-on the database to which we are connected via CONNECTION. Return
-a result structure which can be decoded using `pg-result'."
-  (let ((sql (apply #'concatenate 'simple-string args))
-        (stream (pgcon-stream connection))
-        (tuples '())
-        (attributes '())
-        (result (make-pgresult :connection connection)))
-    (when (> (length sql) +MAX_MESSAGE_LEN+)
-      (error "SQL statement too long: ~A" sql))
-    (write-byte 81 stream)
-    (send-string connection sql)
-    (write-byte 0 stream)
-    (flush connection)
-    (do ((b (read-byte stream nil :eof)
-            (read-byte stream nil :eof)))
-        ((eq b :eof) (error 'protocol-error :reason "unexpected EOF from backend"))
-      (case b
-        ;; asynchronous notify, #\A
-        ((65)
-         ;; read the pid
-         (read-net-int connection 4)
-         (handle-notice connection))
-
-        ;; BinaryRow, #\B
-        ((66)
-         (setf (pgcon-binary-p connection) t)
-         (unless attributes
-           (error 'protocol-error :reason "Tuple received before metadata"))
-         (push (read-tuple connection attributes) tuples))
-
-        ;; CompletedResponse, #\C
-        ((67)
-         (let ((status (read-cstring connection +MAX_MESSAGE_LEN+)))
-           (setf (pgresult-status result) status)
-           (setf (pgresult-tuples result) (nreverse tuples))
-           (setf (pgresult-attributes result) attributes)
-           (return result)))
-
-        ;; AsciiRow (text data transfer), #\D
-        ((68)
-         (setf (pgcon-binary-p connection) nil)
-         (unless attributes
-           (error 'protocol-error :reason "Tuple received before metadata"))
-         (push (read-tuple connection attributes) tuples))
-
-        ;; ErrorResponse, #\E
-        ((69)
-         (let ((msg (read-cstring connection +MAX_MESSAGE_LEN+)))
-           (error 'backend-error :reason msg)))
-
-        ;; #\G and #\H: start copy in, start copy out
-
-        ;; EmptyQueryResponse, #\I
-        ((73)
-         (let ((c (read-byte stream)))
-           (when (< 0 c)
-             (error 'protocol-error :reason "Garbled data"))))
-
-        ;; BackendKeyData, #\K
-        ((75)
-         (setf (pgcon-pid connection) (read-net-int connection 4))
-         (setf (pgcon-secret connection) (read-net-int connection 4)))
-
-        ;; NotificationResponse, #\N
-        ((78)
-         (setf (pgcon-pid connection) (read-net-int connection 4))
-         (handle-notice connection))
-
-        ;; CursorResponse, #\P
-        ((80)
-         (let ((str (read-cstring connection +MAX_MESSAGE_LEN+)))
-           (declare (ignore str))
-           ;; (format *debug-io* "Portal name ~a~%" str)
-           ))
-
-        ;; RowDescription (metadata for subsequent tuples), #\T
-        ((84)
-         (and attributes (error "Cannot handle multiple result group"))
-         (setq attributes (read-attributes connection)))
-
-        ;; ReadyForQuery
-        ((90) t)
-
-        (t
-         (error 'protocol-error
-                :reason (format nil "Unknown response type from backend ~d" b)))))))
+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."
+  (handler-case (pg-connect/v3 dbname user
+                               :host host
+                               :port port
+                               :password password)
+    (protocol-error (c)
+      (warn "reconnecting using protocol version 2")
+      (pg-connect/v2 dbname user
+                     :host host
+                     :port port
+                     :password password))))
 
 
 (defun pg-result (result what &rest args)
@@ -466,420 +229,9 @@
                (error "Only INSERT commands generate an oid: ~s" status))))
         (t (error "Unknown result request: ~s" what))))
 
-(defun pg-disconnect (connection)
-  (write-byte 88 (pgcon-stream connection))
-  (flush connection)
-  (close (pgcon-stream connection))
-  (values))
-
-
-
-;; Attribute information is as follows
-;;    attribute-name (string)
-;;    attribute-type as an oid from table pg_type
-;;    attribute-size (in bytes?)
-(defun read-attributes (connection)
-  (let ((attribute-count (read-net-int connection 2))
-        (attributes '()))
-    (do ((i attribute-count (- i 1)))
-        ((zerop i) (nreverse attributes))
-      (let ((type-name (read-cstring connection +MAX_MESSAGE_LEN+))
-            (type-id   (read-net-int connection 4))
-            (type-len  (read-net-int connection 2))
-            ;; this doesn't exist in the 6.3 protocol !!
-            (type-modifier (read-net-int connection 4)))
-        (declare (ignore type-modifier))
-        (push (list type-name type-id type-len) attributes)))))
-
-;; the bitmap is a string, which we interpret as a sequence of bytes
-(defun bitmap-ref (bitmap ref)
-  (multiple-value-bind (char-ref bit-ref)
-      (floor ref 8)
-    (logand #b10000000 (ash (aref bitmap char-ref) bit-ref))))
-
-;; the server starts by sending a bitmap indicating which tuples are
-;; NULL. "A bit map with one bit for each field in the row. The 1st
-;; field corresponds to bit 7 (MSB) of the 1st byte, the 2nd field
-;; corresponds to bit 6 of the 1st byte, the 8th field corresponds to
-;; bit 0 (LSB) of the 1st byte, the 9th field corresponds to bit 7 of
-;; the 2nd byte, and so on. Each bit is set if the value of the
-;; corresponding field is not NULL. If the number of fields is not a
-;; multiple of 8, the remainder of the last byte in the bit map is
-;; wasted."
-(defun read-tuple (connection attributes)
-  (let* ((num-attributes (length attributes))
-         (num-bytes (ceiling (/ num-attributes 8)))
-         (bitmap (read-bytes connection num-bytes))
-         (correction (if (pgcon-binary-p connection) 0 -4))
-         (tuples '()))
-    (do ((i 0 (+ i 1))
-         (type-ids (mapcar #'second attributes) (cdr type-ids)))
-        ((= i num-attributes) (nreverse tuples))
-      (cond ((zerop (bitmap-ref bitmap i))
-             (push nil tuples))
-            (t
-             (let* ((len (+ (read-net-int connection 4) correction))
-                    (raw (read-chars connection (max 0 len)))
-                    (parsed (parse raw (car type-ids))))
-               (push parsed tuples)))))))
-
-;; FIXME could signal a postgresql-notification condition
-(defun handle-notice (connection)
-  (push (read-cstring connection +MAX_MESSAGE_LEN+)
-        (pgcon-notices connection)))
-
-
-;; type coercion support ==============================================
-;;
-;; When returning data from a SELECT statement, PostgreSQL starts by
-;; sending some metadata describing the attributes. This information
-;; is read by `PG:READ-ATTRIBUTES', and consists of each attribute's
-;; name (as a string), its size (in bytes), and its type (as an oid
-;; which points to a row in the PostgreSQL system table pg_type). Each
-;; row in pg_type includes the type's name (as a string).
-;;
-;; We are able to parse a certain number of the PostgreSQL types (for
-;; example, numeric data is converted to a numeric Common Lisp type,
-;; dates are converted to the CL date representation, booleans to
-;; lisp booleans). However, there isn't a fixed mapping from a
-;; type to its OID which is guaranteed to be stable across database
-;; installations, so we need to build a table mapping OIDs to parser
-;; functions.
-;;
-;; This is done by the procedure `PG:INITIALIZE-PARSERS', which is run
-;; the first time a connection is initiated with the database from
-;; this invocation of CL, and which issues a SELECT statement to
-;; extract the required information from pg_type. This initialization
-;; imposes a slight overhead on the first request, which you can avoid
-;; by setting `*PG-DISABLE-TYPE-COERCION*' to non-nil if it bothers you.
-;; ====================================================================
-
-(defvar type-parsers
-  `(("bool"      . ,'bool-parser)
-    ("char"      . ,'text-parser)
-    ("char2"     . ,'text-parser)
-    ("char4"     . ,'text-parser)
-    ("char8"     . ,'text-parser)
-    ("char16"    . ,'text-parser)
-    ("text"      . ,'text-parser)
-    ("varchar"   . ,'text-parser)
-    ("numeric"   . ,'integer-parser)
-    ("int2"      . ,'integer-parser)
-    ("int4"      . ,'integer-parser)
-    ("int8"      . ,'integer-parser)
-    ("oid"       . ,'integer-parser)
-    ("float4"    . ,'float-parser)
-    ("float8"    . ,'float-parser)
-    ("money"     . ,'text-parser)       ; "$12.34"
-    ("abstime"   . ,'timestamp-parser)
-    ("date"      . ,'date-parser)
-    ("timestamp" . ,'timestamp-parser)
-    ("timestamptz" . ,'timestamp-parser)
-    ("datetime"  . ,'timestamp-parser)
-    ("time"      . ,'text-parser)     ; preparsed "15:32:45"
-    ("timetz"    . ,'text-parser)
-    ("reltime"   . ,'text-parser)     ; don't know how to parse these
-    ("timespan"  . ,'interval-parser)
-    ("interval"  . ,'interval-parser)
-    ("tinterval" . ,'interval-parser)))
-
-
-;; see `man pgbuiltin' for details on PostgreSQL builtin types
-(defun integer-parser (str) (parse-integer str))
-
-(defun float-parser (str) (read-from-string str))
-
-;; FIXME this may need support for charset decoding
-(defun text-parser (str) str)
-
-(defun bool-parser (str)
-  (cond ((string= "t" str) t)
-        ((string= "f" str) nil)
-        (t (error "Badly formed boolean from backend: ~s" str))))
-
-(defun parse-timestamp (str)
-  (let* ((year (parse-integer (subseq str 0 4)))
-         (month (parse-integer (subseq str 5 7)))
-         (day (parse-integer (subseq str 8 10)))
-         (hours (parse-integer (subseq str 11 13)))
-         (minutes (parse-integer (subseq str 14 16)))
-         (seconds (parse-integer (subseq str 17 19)))
-         (start-tz (if (eql #\+ (char str (- (length str) 3)))
-                       (- (length str) 3)))
-         (tz (when start-tz
-               (parse-integer (subseq str start-tz))))
-         (milliseconds (if (eql (char str 19) #\.)
-                           (parse-integer (subseq str 20 start-tz)) 0)))
-    (values year month day hours minutes seconds milliseconds tz)))
-
-;; format for abstime/timestamp etc with ISO output syntax is
-;;
-;;    "1999-01-02 05:11:23.0345645+01"
-;;
-;; which we convert to a CL universal time. Thanks to James Anderson
-;; for a fix for timestamp format in PostgreSQL 7.3 (with or without
-;; tz, with or without milliseconds).
-(defun timestamp-parser (str)
-  (multiple-value-bind (year month day hours minutes seconds)
-      (parse-timestamp str)
-    (encode-universal-time seconds minutes hours day month year)))
-
-(defun precise-timestamp-parser (str)
-  (multiple-value-bind (year month day hours minutes seconds milliseconds)
-      (parse-timestamp str)
-    (+ (encode-universal-time seconds minutes hours day month year)
-       (/ milliseconds 1000.0))))
-
-;; An interval is what you get when you subtract two timestamps. We
-;; convert to a number of seconds.
-(defun interval-parser (str)
-  (let* ((hours (parse-integer (subseq str 0 2)))
-         (minutes (parse-integer (subseq str 3 5)))
-         (seconds (parse-integer (subseq str 6 8)))
-         (milliseconds (parse-integer (subseq str 9))))
-    (+ (/ milliseconds (expt 10.0 (- (length str) 9)))
-       seconds
-       (* 60 minutes)
-       (* 60 60 hours))))
-
-
-;; format for abstime/timestamp etc with ISO output syntax is
-;;;    "1999-01-02 00:00:00+01"
-;; which we convert to a CL universal time
-(defun isodate-parser (str)
-  (let ((year    (parse-integer (subseq str 0 4)))
-        (month   (parse-integer (subseq str 5 7)))
-        (day     (parse-integer (subseq str 8 10)))
-        (hours   (parse-integer (subseq str 11 13)))
-        (minutes (parse-integer (subseq str 14 16)))
-        (seconds (parse-integer (subseq str 17 19)))
-        (tz      (parse-integer (subseq str 19 22))))
-    (encode-universal-time seconds minutes hours day month year tz)))
-
-;; format for date with ISO output syntax is
-;;;    "1999-01-02"
-;; which we convert to a CL universal time
-(defun date-parser (str)
-  (let ((year    (parse-integer (subseq str 0 4)))
-	(month   (parse-integer (subseq str 5 7)))
-	(day     (parse-integer (subseq str 8 10))))
-    (encode-universal-time 0 0 0 day month year)))
-
-(defun initialize-parsers (connection)
-  (let* ((pgtypes (pg-exec connection "SELECT typname,oid FROM pg_type"))
-         (tuples (pg-result pgtypes :tuples)))
-    (setq *parsers* '())
-    (map nil
-     (lambda (tuple)
-       (let* ((typname (first tuple))
-              (oid (parse-integer (second tuple)))
-              (type (assoc typname type-parsers :test #'string=)))
-         (if (consp type)
-             (push (cons oid (cdr type)) *parsers*))))
-     tuples)))
-
-(defun parse (str oid)
-  (let ((parser (assoc oid *parsers* :test #'eql)))
-    (if (consp parser)
-        (funcall (cdr parser) str)
-        str)))
-
-;; large objects support ===============================================
-;;
-;; Sir Humphrey: Who is Large and to what does he object?
-;;
-;; Large objects are the PostgreSQL way of doing what most databases
-;; call BLOBs (binary large objects). In addition to being able to
-;; stream data to and from large objects, PostgreSQL's
-;; object-relational capabilities allow the user to provide functions
-;; which act on the objects.
-;;
-;; For example, the user can define a new type called "circle", and
-;; define a C or Tcl function called `circumference' which will act on
-;; circles. There is also an inheritance mechanism in PostgreSQL.
-;;
-;; The PostgreSQL large object interface is similar to the Unix file
-;; system, with open, read, write, lseek etc.
-;;
-;; Implementation note: the network protocol for large objects changed
-;; around version 6.5 to use network order for integers.
-;; =====================================================================
-
-(defvar *lo-initialized* nil)
-(defvar *lo-functions* '())
-
-(defun lo-init (connection)
-  (let ((res (pg-exec connection
-                    "SELECT proname, oid from pg_proc WHERE "
-                    "proname = 'lo_open' OR "
-                    "proname = 'lo_close' OR "
-                    "proname = 'lo_creat' OR "
-                    "proname = 'lo_unlink' OR "
-                    "proname = 'lo_lseek' OR "
-                    "proname = 'lo_tell' OR "
-                    "proname = 'loread' OR "
-                    "proname = 'lowrite'")))
-    (setq *lo-functions* '())
-    (dolist (tuple (pg-result res :tuples))
-      (push (cons (car tuple) (cadr tuple)) *lo-functions*))
-    (unless (= 8 (length *lo-functions*))
-      (error "Couldn't find OIDs for all the large object functions"))
-    (setq *lo-initialized* t)))
-
-;; Execute one of the large-object functions (lo_open, lo_close etc).
-;; Argument FN is either an integer, in which case it is the OID of an
-;; element in the pg_proc table, and otherwise it is a string which we
-;; look up in the alist *lo-functions* to find the corresponding OID.
-(defun fn (connection fn integer-result &rest args)
-  (or *lo-initialized* (lo-init connection))
-  (let ((fnid (cond ((integerp fn) fn)
-                    ((not (stringp fn))
-                     (error "Expecting a string or an integer: ~s" fn))
-                    ((assoc fn *lo-functions* :test #'string=)
-                     (cdr (assoc fn *lo-functions* :test #'string=)))
-                    (t (error "Unknown builtin function ~s" fn)))))
-    (send-int connection 70 1)          ; function call
-    (send-int connection 0 1)
-    (send-int connection fnid 4)
-    (send-int connection (length args) 4)
-    (dolist (arg args)
-      (cond ((integerp arg)
-             (send-int connection 4 4)
-             (send-int connection arg 4))
-            ((stringp arg)
-             (send-int connection (length arg) 4)
-             (send-string connection arg))
-            (t (error 'protocol-error
-                      :reason (format nil "Unknown fastpath type ~s" arg)))))
-    (flush connection)
-    (loop :with result = nil
-          :with ready = nil
-          :for b = (read-byte (pgcon-stream connection) nil :eof) :do
-          (case b
-            ;; FunctionResultResponse
-            ((86)
-             (let ((res (read-byte (pgcon-stream connection) nil :eof)))
-               (cond ((= res 0)         ; empty result
-                      (return-from fn nil))
-                     ((= res 71)        ; nonempty result
-                      (let ((len (read-net-int connection 4)))
-                        (if integer-result
-                            (setq result (read-net-int connection len))
-                          (setq result (read-chars connection len)))))
-                     (t (error 'protocol-error :reason "wierd FunctionResultResponse")))))
-
-            ;; end of FunctionResult
-            ((48) (return-from fn result))
-
-            ((69) (error 'backend-error :reason (read-cstring connection 4096)))
-
-            ;; NoticeResponse
-            ((78)
-             (setf (pgcon-pid connection) (read-net-int connection 4))
-             (handle-notice connection))
-
-            ;; ReadyForQuery
-            ((90) (setq ready t))
-
-            (t (error 'protocol-error
-                      :reason (format nil "Unexpected byte ~s" b)))))))
-
-;; returns an OID
-(defun pglo-create (connection &optional (modestr "r"))
-  (let* ((mode (cond ((integerp modestr) modestr)
-                     ((string= "r" modestr) +INV_READ+)
-                     ((string= "w" modestr) +INV_WRITE+)
-                     ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
-                     (t (error "Bad mode ~s" modestr))))
-         (oid (fn connection "lo_creat" t mode)))
-    (unless (integerp oid)
-      (error 'backend-error :reason "Didn't return an OID"))
-    (when (zerop oid)
-      (error 'backend-error :reason "Can't create large object"))
-    oid))
-
-;; args = modestring (default "r", or "w" or "rw")
-;; returns a file descriptor for use in later lo-* procedures
-(defun pglo-open (connection oid &optional (modestr "r"))
-  (let* ((mode (cond ((integerp modestr) modestr)
-                     ((string= "r" modestr) +INV_READ+)
-                     ((string= "w" modestr) +INV_WRITE+)
-                     ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
-                     (t (error "Bad mode ~s" modestr))))
-         (fd (fn connection "lo_open" t oid mode)))
-    (assert (integerp fd))
-    fd))
-
-(defun pglo-close (connection fd)
-  (fn connection "lo_close" t fd))
-
-(defun pglo-read (connection fd bytes)
-  (fn connection "loread" nil fd bytes))
-
-(defun pglo-write (connection fd buf)
-  (fn connection "lowrite" t fd buf))
-
-(defun pglo-lseek (connection fd offset whence)
-  (fn connection "lo_lseek" t fd offset whence))
-
-(defun pglo-tell (connection fd)
-  (fn connection "lo_tell" t fd))
-
-(defun pglo-unlink (connection oid)
-  (fn connection "lo_unlink" t oid))
-
-(defun pglo-import (connection filename)
-  (let ((buf (make-string +LO_BUFSIZ+))
-        (oid (pglo-create connection "rw")))
-    (with-open-file (in filename :direction :input)
-       (loop :with fdout = (pglo-open connection oid "w")
-             :for bytes = (read-sequence buf in)
-             :until (< bytes +LO_BUFSIZ+)
-             :do (pglo-write connection fdout buf)
-             :finally
-             (pglo-write connection fdout (subseq buf 0 bytes))
-             (pglo-close connection fdout)))
-    oid))
-
-(defun pglo-export (connection oid filename)
-  (with-open-file (out filename :direction :output)
-     (loop :with fdin = (pglo-open connection oid "r")
-           :for str = (pglo-read connection fdin +LO_BUFSIZ+)
-           :until (zerop (length str))
-           :do (write-sequence str out)
-           :finally (pglo-close connection fdin))))
-
-
-;; DBMS metainformation ================================================
-;;
-;; Metainformation such as the list of databases present in the
-;; database management system, list of tables, attributes per table.
-;; This information is not available directly, but can be deduced by
-;; querying the system tables.
-;;
-;; Based on the queries issued by psql in response to user commands
-;; `\d' and `\d tablename'; see file pgsql/src/bin/psql/psql.c
-;; =====================================================================
-(defun pg-databases (conn)
-  "Return a list of the databases available at this site."
-  (let ((res (pg-exec conn "SELECT datname FROM pg_database")))
-    (reduce #'append (pg-result res :tuples))))
-
-(defun pg-tables (conn)
-  "Return a list of the tables present in this database."
-  (let ((res (pg-exec conn "SELECT relname FROM pg_class, pg_user WHERE "
-                      "(relkind = 'r') AND relname !~ '^pg_' AND usesysid = relowner ORDER BY relname")))
-    (reduce #'append (pg-result res :tuples))))
-
-(defun pg-columns (conn table)
-  "Return a list of the columns present in TABLE."
-  (let ((res (pg-exec conn (format nil "SELECT * FROM ~s WHERE 0 = 1" table))))
-    (mapcar #'first (pg-result res :attributes))))
-
-(defun pg-backend-version (conn)
-  "Return a string identifying the version and operating environment of the backend."
-  (let ((res (pg-exec conn "SELECT version()")))
-    (first (pg-result res :tuple 0))))
+
+
+
 
 
 ;; support routines ===================================================
@@ -934,7 +286,7 @@
 
 (defun read-cstring (connection maxbytes)
   "Read a null-terminated string from CONNECTION."
-  (declare (type fixnum howmany))
+  (declare (type fixnum maxbytes))
   (let ((stream (pgcon-stream connection))
         (chars nil))
     (do ((b (read-byte stream nil nil) (read-byte stream nil nil))


Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.1.1.1 pg/sysdep.lisp:1.2
--- pg/sysdep.lisp:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/sysdep.lisp	Fri Mar  5 13:08:08 2004
@@ -1,6 +1,11 @@
-;;; system-dependent parts of pg-dot-lisp
+;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
+;;;
+;;; Author: Eric Marsden <emarsden at laas.fr>
+;;; Time-stamp: <2004-03-05 emarsden>
+;;
+;;
 
-(in-package :pg)
+(in-package :postgresql)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   #+allegro (require :socket)




From pvaneynde at common-lisp.net  Sat Mar  6 22:59:39 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Sat, 06 Mar 2004 17:59:39 -0500
Subject: [pg-cvs] CVS update: pg/pg.asd 
Message-ID: <E1Azklf-0002LE-00@common-lisp.net>

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

Modified Files:
	pg.asd 
Log Message:
the crypt library actually is loaded in sysdep.lisp
Date: Sat Mar  6 17:59:39 2004
Author: pvaneynde

Index: pg/pg.asd
diff -u pg/pg.asd:1.2 pg/pg.asd:1.3
--- pg/pg.asd:1.2	Fri Mar  5 13:08:08 2004
+++ pg/pg.asd	Sat Mar  6 17:59:39 2004
@@ -17,11 +17,11 @@
     :author "Eric Marsden"
     :version "0.21"
     :components ((:file "defpackage")
-                 (:file "sysdep" :depends-on ("defpackage"))
+                 (:pg-component "sysdep" :depends-on ("defpackage"))
                  (:file "meta-queries" :depends-on ("defpackage"))
                  (:file "parsers" :depends-on ("defpackage"))
                  (:file "utility" :depends-on ("defpackage"))
-                 (:pg-component "pg" :depends-on ("sysdep" "parsers"))
+                 (:file "pg" :depends-on ("sysdep" "parsers"))
                  (:file "large-object" :depends-on ("pg"))
                  (:file "v2-protocol" :depends-on ("pg" "large-object" "utility"))
                  (:file "v3-protocol" :depends-on ("pg" "large-object" "utility"))))




From pvaneynde at common-lisp.net  Mon Mar  8 14:37:37 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Mon, 08 Mar 2004 09:37:37 -0500
Subject: [pg-cvs] CVS update: pg/parsers.lisp 
Message-ID: <E1B0Lsv-0003JB-00@common-lisp.net>

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

Modified Files:
	parsers.lisp 
Log Message:
added type-to-oid table and lookup-type function to aid in bpe operations
Date: Mon Mar  8 09:37:37 2004
Author: pvaneynde

Index: pg/parsers.lisp
diff -u pg/parsers.lisp:1.1 pg/parsers.lisp:1.2
--- pg/parsers.lisp:1.1	Fri Mar  5 13:08:08 2004
+++ pg/parsers.lisp	Mon Mar  8 09:37:36 2004
@@ -59,7 +59,10 @@
 (defvar *parsers* '())
 
 
-
+(defvar *type-to-oid*
+  (make-hash-table :test #'eq)
+  "Is a hashtable for turning a typename into a OID.
+Needed to define the type of objects in pg-prepare")
 
 (defvar *type-parsers*
   `(("bool"      . ,'bool-parser)
@@ -96,6 +99,8 @@
 
 ;; FIXME switch to a specialized float parser
 (defun float-parser (str)
+  (declare (type simple-string str))
+
   (let ((*read-eval* nil))
     (read-from-string str)))
 
@@ -103,12 +108,14 @@
 (defun text-parser (str) str)
 
 (defun bool-parser (str)
+  (declare (type simple-string str))
   (cond ((string= "t" str) t)
         ((string= "f" str) nil)
         (t (error 'protocol-error
                   :reason "Badly formed boolean from backend: ~s" str))))
 
 (defun parse-timestamp (str)
+  (declare (type simple-string str))
   (let* ((year (parse-integer (subseq str 0 4)))
          (month (parse-integer (subseq str 5 7)))
          (day (parse-integer (subseq str 8 10)))
@@ -172,8 +179,8 @@
 ;; which we convert to a CL universal time
 (defun date-parser (str)
   (let ((year    (parse-integer (subseq str 0 4)))
-	(month   (parse-integer (subseq str 5 7)))
-	(day     (parse-integer (subseq str 8 10))))
+        (month   (parse-integer (subseq str 5 7)))
+        (day     (parse-integer (subseq str 8 10))))
     (encode-universal-time 0 0 0 day month year)))
 
 (defun initialize-parsers (connection)
@@ -185,14 +192,33 @@
        (let* ((typname (first tuple))
               (oid (parse-integer (second tuple)))
               (type (assoc typname *type-parsers* :test #'string=)))
-         (if (consp type)
-             (push (cons oid (cdr type)) *parsers*))))
+         (cond
+           ((consp type)
+            (setf (gethash (intern typname :keyword) *type-to-oid*)
+                  oid)
+            (push (cons oid (cdr type)) *parsers*))
+           (t
+            #+debug
+            (warn "Unknown postgresSQL type found: '~A' oid: '~A'"
+                   typname
+                   oid)))))
      tuples)))
 
 (defun parse (str oid)
+  (declare (type simple-string str))
   (let ((parser (assoc oid *parsers* :test #'eql)))
     (if (consp parser)
         (funcall (cdr parser) str)
         str)))
+
+(defun lookup-type (type)
+  "Given the name of a type, returns the oid of the type or NIL if
+not found"
+  (let ((type (etypecase type
+                (symbol
+                 type)
+                (string
+                 (intern type :keyword)))))
+    (gethash type *type-to-oid*)))
 
 ;; EOF




From pvaneynde at common-lisp.net  Mon Mar  8 14:37:43 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Mon, 08 Mar 2004 09:37:43 -0500
Subject: [pg-cvs] CVS update: pg/pg-tests.lisp 
Message-ID: <E1B0Lt1-0003Xu-00@common-lisp.net>

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

Modified Files:
	pg-tests.lisp 
Log Message:
added pbe test
Date: Mon Mar  8 09:37:43 2004
Author: pvaneynde

Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.2 pg/pg-tests.lisp:1.3
--- pg/pg-tests.lisp:1.2	Fri Mar  5 13:08:08 2004
+++ pg/pg-tests.lisp	Mon Mar  8 09:37:43 2004
@@ -7,7 +7,7 @@
 ;;
 ;; These tests assume that a table named "test" is defined in the
 ;; system catalog, and that the user identified in
-;; CALL-WITH-TEST-CONNECTION has the rights to access that table. 
+;; CALL-WITH-TEST-CONNECTION has the rights to access that table.
 
 (defpackage :pg-tests
   (:use :cl
@@ -279,6 +279,42 @@
     (pg-exec conn "DROP TABLE pgmt")))
 
 
+(defun test-pbe ()
+  (with-test-connection (conn)
+    (when (pg-supports-pbe conn)
+      (format *debug-io* "~&Testing pbe...")
+      (let ((res nil)
+            (count 0)
+            (created nil))
+        (unwind-protect
+             (progn
+               (pg-exec conn "CREATE TABLE count_test(key int, val int)")
+               (setq created t)
+               (format *debug-io* "~&table created")
+               (pg-prepare conn "ct_insert"
+                           "INSERT INTO count_test VALUES ($1, $2)"
+                           '("int4" "int4"))
+               (loop :for i :from 1 :to 100
+                     :do
+                     (pg-bind conn
+                              "ct_portal" "ct_insert"
+                              `((:int32 ,i)
+                                (: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))))
+               ;; 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"
+                            (lambda (tuple) (incf count (first tuple))))
+               (assert (= 5050 count)))
+          (when created
+            (pg-exec conn "DROP TABLE count_test")))))))
+
 
 (defun test ()
   (with-test-connection (conn)
@@ -304,7 +340,8 @@
   (test-notifications)
   (test-lo)
   (test-lo-read)
-  #+cmu (test-lo-import))
+  #+cmu (test-lo-import)
+  (test-pbe))
 
 
 ;; EOF




From pvaneynde at common-lisp.net  Mon Mar  8 14:38:07 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Mon, 08 Mar 2004 09:38:07 -0500
Subject: [pg-cvs] CVS update: pg/defpackage.lisp 
Message-ID: <E1B0LtP-00063k-00@common-lisp.net>

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

Modified Files:
	defpackage.lisp 
Log Message:
added pbe functions
Date: Mon Mar  8 09:38:07 2004
Author: pvaneynde

Index: pg/defpackage.lisp
diff -u pg/defpackage.lisp:1.1.1.1 pg/defpackage.lisp:1.2
--- pg/defpackage.lisp:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/defpackage.lisp	Mon Mar  8 09:38:07 2004
@@ -24,6 +24,12 @@
            #:pglo-unlink
            #:pglo-import
            #:pglo-export
+           #:pg-supports-pbe
+           #:pg-prepare
+           #:pg-bind
+           #:pg-execute
+           #:pg-close-portal
+           #:pg-close-statement
            #:postgresql-error
            #:connection-failure
            #:authentication-failure




From pvaneynde at common-lisp.net  Mon Mar  8 14:37:32 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Mon, 08 Mar 2004 09:37:32 -0500
Subject: [pg-cvs] CVS update: pg/pg.lisp pg/v3-protocol.lisp 
Message-ID: <E1B0Lsq-0003Dy-00@common-lisp.net>

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

Modified Files:
	pg.lisp v3-protocol.lisp 
Log Message:
pg.lisp:
 - make print-object more robust
 - added documentation to the defgenerics
 - added some declarations
v3-protocol.lisp:
 - make errors restartable as we hope to 
    sync again with the db
 - return errors from read-packet because 
   sometimes it is the only clue we get 
    that there is no more output
 - replaced arefs with the faster elt
 - unified query followup into do-followup-query
 - added pbe (prepare bind execute) support

Date: Mon Mar  8 09:37:31 2004
Author: pvaneynde

Index: pg/pg.lisp
diff -u pg/pg.lisp:1.2 pg/pg.lisp:1.3
--- pg/pg.lisp:1.2	Fri Mar  5 13:08:08 2004
+++ pg/pg.lisp	Mon Mar  8 09:37:31 2004
@@ -40,7 +40,7 @@
 ;; Exceptions are Corman Common Lisp whose socket streams do not
 ;; support binary I/O.
 ;;
-;; See the README for API documentation. 
+;; See the README for API documentation.
 
 ;; This code has been tested or reported to work with
 ;;
@@ -81,7 +81,7 @@
    (port :initarg :port
          :reader connection-failure-port)
    (transport-error :initarg :transport-error
-	 :reader connection-failure-transport-error))
+         :reader connection-failure-transport-error))
   (:report
    (lambda (exc stream)
      (declare (type stream stream))
@@ -90,7 +90,7 @@
 Is the postmaster running and accepting TCP connections?~%"
              (connection-failure-host exc)
              (connection-failure-port exc)
-	     (connection-failure-transport-error exc)))))
+             (connection-failure-transport-error exc)))))
 
 (define-condition authentication-failure (postgresql-error)
   ((reason :initarg :reason
@@ -162,21 +162,66 @@
               :initform nil)))
 
 (defmethod print-object ((self pgcon) stream)
-  (print-unreadable-object (self stream :type nil)
-    (with-slots (pid host port) self
-      (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
-              pid host port))))
+    (print-unreadable-object (self stream :type nil)
+      (with-slots (pid host port) self
+        (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
+                (when (slot-boundp self 'pid)
+                  pid)
+                (when (slot-boundp self 'host)
+                  host)
+                (when (slot-boundp self 'port)
+                  port)))))
 
 (defstruct pgresult connection status attributes tuples)
 
 
-(defgeneric pg-exec (connection &rest args))
-
-(defgeneric fn (connection fn integer-result &rest args))
-
-(defgeneric pg-disconnect (connection))
-
-
+(defgeneric pg-exec (connection &rest args)
+  (:documentation
+   "Execute the SQL command given by the concatenation of ARGS
+on the database to which we are connected via CONNECTION. Return
+a result structure which can be decoded using `pg-result'."))
+
+(defgeneric fn (connection fn integer-result &rest args)
+  (:documentation
+   "Execute one of the large-object functions (lo_open, lo_close etc).
+ Argument FN is either an integer, in which case it is the OID of an
+ element in the pg_proc table, and otherwise it is a string which we
+look up in the alist *lo-functions* to find the corresponding OID."))
+
+(defgeneric pg-disconnect (connection)
+  (:documentation
+   "Disconnects from the DB"))
+
+(defgeneric pg-supports-pbe (connection)
+  (:documentation
+   "Returns true if the connection supports pg-prepare/-bind and -execute")
+  (:method (connection)
+    (declare (ignore connection))
+    nil))
+
+(defgeneric pg-prepare (connection statement-name sql-statement &optional type-of-parameters)
+  (:documentation
+   "Prepares a sql-statement give a given statement-name (can be empty)
+and optionally declares the types of the parameters as a list of strings.
+You can define parameters to be filled in later by using $1 and so on."))
+
+(defgeneric pg-bind (connection portal statement-name list-of-types-and-values)
+  (:documentation
+   "Gives the values for the parameters defined in the statement-name. The types
+can be one of :char :byte :int16 :int32 or :cstring"))
+
+(defgeneric pg-execute (connection portal &optional maxinum-number-of-rows)
+  (:documentation
+   "Executes the portal defined previously and return (optionally) up to maximum-number-of-row.
+For an unlimited number of rows use 0"))
+
+(defgeneric pg-close-statement (connection statement-name)
+  (:documentation
+   "Closes a prepared statement"))
+
+(defgeneric pg-close-portal (connection portal)
+  (:documentation
+   "Closes a prepared statement"))
 
 ;; first attempt to connect to connect using the v3 protocol; if this
 ;; results in an ErrorResponse we close the connection and retry using
@@ -196,6 +241,7 @@
                                :port port
                                :password password)
     (protocol-error (c)
+      (declare (ignore c))
       (warn "reconnecting using protocol version 2")
       (pg-connect/v2 dbname user
                      :host host
@@ -214,6 +260,7 @@
    :tuple n -> return the nth component of the data
    :oid -> return the OID (a unique identifier generated by PostgreSQL
            for each row resulting from an insertion"
+  (declare (type pgresult result))
   (cond ((eq :connection what) (pgresult-connection result))
         ((eq :status what)     (pgresult-status result))
         ((eq :attributes what) (pgresult-attributes result))
@@ -238,6 +285,9 @@
 
 ;; read an integer in network byte order
 (defun read-net-int (connection bytes)
+  (declare (type (integer 0) bytes)
+           (type pgcon connection))
+
   (do ((i bytes (- i 1))
        (stream (pgcon-stream connection))
        (accum 0))
@@ -271,8 +321,8 @@
   (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
         (s (pgcon-stream connection)))
     (do ((continue-at (read-sequence v s :start 0 :end howmany)
-		      (read-sequence v s :start continue-at :end howmany)))
-	((= continue-at howmany))
+                      (read-sequence v s :start continue-at :end howmany)))
+        ((= continue-at howmany))
       )
     v))
 


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.1 pg/v3-protocol.lisp:1.2
--- pg/v3-protocol.lisp:1.1	Fri Mar  5 13:08:08 2004
+++ pg/v3-protocol.lisp	Mon Mar  8 09:37:31 2004
@@ -15,46 +15,46 @@
   ((severity :initarg :severity
              :reader error-response-severity)
   (code     :initarg :code
-	     :reader error-response-code)
+             :reader error-response-code)
   (message     :initarg :message
-		:reader error-response-message)
+                :reader error-response-message)
   (detail     :initarg :detail
-	       :reader error-response-detail)
+               :reader error-response-detail)
   (hint     :initarg :hint
-	     :reader error-response-hint)
+             :reader error-response-hint)
   (position     :initarg :position
-		 :reader error-response-position)
+                 :reader error-response-position)
   (where     :initarg :where
-	      :reader error-response-where)
+              :reader error-response-where)
   (file     :initarg :file
-	     :reader error-response-file)
+             :reader error-response-file)
   (line     :initarg :line
-	     :reader error-response-line)
+             :reader error-response-line)
   (routine     :initarg :routine
-		:reader error-response-routine))
+                :reader error-response-routine))
   (:report
     (lambda (exc stream)
        (format stream "PostgreSQL ~A: (~A) ~A, ~A. Hint: ~A File: ~A, line ~A/~A ~A -> ~A"
-	       (ignore-errors
-		   (error-response-severity exc))
-	       (ignore-errors
-		   (error-response-code exc))
-	       (ignore-errors
-		   (error-response-message exc))
-	       (ignore-errors
-		   (error-response-detail exc))
-	       (ignore-errors
-		   (error-response-hint exc))
-	       (ignore-errors
-		   (error-response-file exc))
-	       (ignore-errors
-		   (error-response-line exc))
-	       (ignore-errors
-		   (error-response-position exc))
-	       (ignore-errors
-		   (error-response-routine exc))
-	       (ignore-errors
-		   (error-response-where exc))))))
+               (ignore-errors
+                   (error-response-severity exc))
+               (ignore-errors
+                   (error-response-code exc))
+               (ignore-errors
+                   (error-response-message exc))
+               (ignore-errors
+                   (error-response-detail exc))
+               (ignore-errors
+                   (error-response-hint exc))
+               (ignore-errors
+                   (error-response-file exc))
+               (ignore-errors
+                   (error-response-line exc))
+               (ignore-errors
+                   (error-response-position exc))
+               (ignore-errors
+                   (error-response-routine exc))
+               (ignore-errors
+                   (error-response-where exc))))))
 
 
 ;; packets send/received are always:
@@ -68,24 +68,24 @@
 
 (defclass pg-packet ()
   ((type :initarg :type
-	 :type base-char
-	 :reader pg-packet-type)
+         :type base-char
+         :reader pg-packet-type)
    (length :initarg :length
-	   :type (integer 32))
+           :type (integer 32))
    (data :initarg :data
-	 :type (array (unsigned-byte 8) *))
+         :type (array (unsigned-byte 8) *))
    (position :initform 0
-	     :type integer)))
+             :type integer)))
 
 (defmethod print-object ((object pg-packet) stream)
     (print-unreadable-object (object stream :type t :identity t)
       (format stream "type: ~A length: ~A position: ~A"
-	      (and (slot-boundp object 'type)
-		   (slot-value object 'type))
-	      (and (slot-boundp object 'length)
-		   (slot-value object 'length))
-	      (and (slot-boundp object 'position)
-		   (slot-value object 'position)))))
+              (and (slot-boundp object 'type)
+                   (slot-value object 'type))
+              (and (slot-boundp object 'length)
+                   (slot-value object 'length))
+              (and (slot-boundp object 'position)
+                   (slot-value object 'position)))))
 
 ;; first some help functions:
 
@@ -98,8 +98,8 @@
     (when (= 1 (ldb (byte 1 7) result))
       ;; negative
       (setf result (-
-		    (1+ (logxor result
-				#xFF)))))
+                    (1+ (logxor result
+                                #xFF)))))
     result))
 
 (defun %read-net-int16 (stream)
@@ -107,12 +107,12 @@
 The signed integer is presumed to be in network order.
 Returns the integer."
   (let ((result (+ (* 256 (read-byte stream))
-		   (read-byte stream))))
+                   (read-byte stream))))
     (when (= 1 (ldb (byte 1 15) result))
       ;; negative
       (setf result (-
-		    (1+ (logxor result
-				#xFFFF)))))
+                    (1+ (logxor result
+                                #xFFFF)))))
     result))
 
 (defun %read-net-int32 (stream)
@@ -120,14 +120,14 @@
 The signed integer is presumed to be in network order.
 Returns the integer."
   (let ((result (+ (* 256 256 256 (read-byte stream))
-		   (* 256 256 (read-byte stream))
-		   (* 256 (read-byte stream))
-		   (read-byte stream))))
+                   (* 256 256 (read-byte stream))
+                   (* 256 (read-byte stream))
+                   (read-byte stream))))
     (when (= 1 (ldb (byte 1 31) result))
       ;; negative
       (setf result (-
-		    (1+ (logxor result
-				#xFFFFFFFF)))))
+                    (1+ (logxor result
+                                #xFFFFFFFF)))))
     result))
 
 #-cmu
@@ -149,8 +149,8 @@
 Returns the array of "
   (let ((v (make-array howmany :element-type '(unsigned-byte 8))))
     (do ((continue-at (read-sequence v stream :start 0 :end howmany)
-		      (read-sequence v stream :start continue-at :end howmany)))
-	((= continue-at howmany))
+                      (read-sequence v stream :start continue-at :end howmany)))
+        ((= continue-at howmany))
       )
     v))
 
@@ -161,38 +161,41 @@
 (defun read-and-generate-error-response (packet)
   (let ((args nil))
     (loop :for field-type = (read-from-packet packet :byte)
-	  :until (= field-type 0)
-	  :do
-	  (let ((message (read-from-packet packet :cstring)))
-	    (push message args)
-	    (push
-	     (ecase (code-char field-type)
-	       ((#\S) :severity)
-	       ((#\C) :code)
-	       ((#\M) :message)
-	       ((#\D) :detail)
-	       ((#\H) :hint)
-	       ((#\P) :position)
-	       ((#\W) :where)
-	       ((#\F) :file)
-	       ((#\L) :line)
-	       ((#\R) :routine))
-	     args)))
-    (apply #'error
-	   'error-response
-	   args)))
+          :until (= field-type 0)
+          :do
+          (let ((message (read-from-packet packet :cstring)))
+            (push message args)
+            (push
+             (ecase (code-char field-type)
+               ((#\S) :severity)
+               ((#\C) :code)
+               ((#\M) :message)
+               ((#\D) :detail)
+               ((#\H) :hint)
+               ((#\P) :position)
+               ((#\W) :where)
+               ((#\F) :file)
+               ((#\L) :line)
+               ((#\R) :routine))
+             args)))
+    ;; we are trying to recover from errors too:
+    (apply #'cerror
+           "Try to continue, should do a rollback"
+           'error-response
+           args)))
 
 
 (defun read-and-handle-notification-response (connection packet)
-  (declare (type pg-packet packet))
-  
+  (declare (type pg-packet packet)
+           (type pgcon-v3 connection))
+
   (let* ((pid (read-from-packet packet :int32))
-	 (name-condition (read-from-packet packet :cstring))
-	 (additional-information (read-from-packet packet :cstring)))
+         (name-condition (read-from-packet packet :cstring))
+         (additional-information (read-from-packet packet :cstring)))
     (setf (pgcon-pid connection) pid)
     (format t "~&Got notice: ~S, ~S"
-	    name-condition
-	    additional-information)
+            name-condition
+            additional-information)
     (push name-condition (pgcon-notices connection))))
 
 
@@ -201,10 +204,11 @@
 
 (defun read-packet (connection)
   "Reads a packet from the connection.
-Returns the packet, handles errors and notices automagically"
+Returns the packet, handles errors and notices automagically,
+but will still return them"
   (let* ((stream (pgcon-stream connection))
-	 (type   (%read-net-int8 stream))
-	 (length (%read-net-int32 stream)))
+         (type   (%read-net-int8 stream))
+         (length (%read-net-int32 stream)))
     ;; detect a bogus protocol response from the backend, which
     ;; probably means that we're in PG-CONNECT/V3 but talking to an
     ;; old backend that only understands the V2 protocol. Heuristics
@@ -221,16 +225,16 @@
                                   :length length
                                   :data data)))
       (case (pg-packet-type packet)
-        (( #\E)				; error
+        (( #\E)                                ; error
          (read-and-generate-error-response packet)
-         ;; in case we handled it:
-         (read-packet connection))
-        (( #\N)				; Notice
-         (handle-notice/v3 connection packet))
+         packet)
+        (( #\N)                                ; Notice
+         (handle-notice/v3 connection packet)
+         packet)
         (t
          ;; return the packet
          packet)))))
-  
+
 ;; Not to get at the data:
 
 (defgeneric read-from-packet (packet type)
@@ -238,70 +242,70 @@
    "Reads an integer from the given PACKET with type TYPE")
   (:method ((packet pg-packet) (type (eql :char)))
     (with-slots (data position)
-	packet
+        packet
 
       (prog1
-	  (aref data position)
-	(incf position))))
+          (elt data position)
+        (incf position))))
   (:method ((packet pg-packet) (type (eql :byte)))
     (with-slots (data position)
-	packet
+        packet
 
-      (let ((result (aref data position)))
-	(incf position)
-	(when (= 1 (ldb (byte 1 7) result))
-	  ;; negative
-	  (setf result (-
-			(1+ (logxor result
-				    #xFF)))))
-	result)))
+      (let ((result (elt data position)))
+        (incf position)
+        (when (= 1 (ldb (byte 1 7) result))
+          ;; negative
+          (setf result (-
+                        (1+ (logxor result
+                                    #xFF)))))
+        result)))
   (:method ((packet pg-packet) (type (eql :int16)))
     (with-slots (data position)
-	packet
+        packet
 
-      (let ((result (+ (* 256 (aref data position))
-		       (aref data (1+ position)))))
-	(incf position 2)
-	(when (= 1 (ldb (byte 1 15) result))
-	  ;; negative
-	  (setf result (-
-			(1+ (logxor result
-				    #xFFFF)))))
-	result)))
+      (let ((result (+ (* 256 (elt data position))
+                       (elt data (1+ position)))))
+        (incf position 2)
+        (when (= 1 (ldb (byte 1 15) result))
+          ;; negative
+          (setf result (-
+                        (1+ (logxor result
+                                    #xFFFF)))))
+        result)))
   (:method ((packet pg-packet) (type (eql :int32)))
     (with-slots (data position)
-	packet
+        packet
 
-      (let ((result (+ (* 256 256 256 (aref data position))
-		       (* 256 256 (aref data (1+ position)))
-		       (* 256 (aref data (+ 2 position)))
-		       (aref data (+ 3 position)))))
-
-	(incf position 4)
-	(when (= 1 (ldb (byte 1 31) result))
-	  ;; negative
-	  (setf result (-
-			(1+ (logxor result
-				    #xFFFFFFFF)))))
-	result)))
+      (let ((result (+ (* 256 256 256 (elt data position))
+                       (* 256 256 (elt data (1+ position)))
+                       (* 256 (elt data (+ 2 position)))
+                       (elt data (+ 3 position)))))
+
+        (incf position 4)
+        (when (= 1 (ldb (byte 1 31) result))
+          ;; negative
+          (setf result (-
+                        (1+ (logxor result
+                                    #xFFFFFFFF)))))
+        result)))
   (:method ((packet pg-packet) (type (eql :cstring)))
     (with-slots (data position)
-	packet
+        packet
 
       (let* ((end (position 0 data :start position))
-	     ;; end is where the 0 byte is
-	     (result (unless (= end position)
-		       (make-array (- end position)
-				   :element-type 'base-char))))
-	(when result
-	  (loop :for i :from position :below end
-		:for j :from 0
-		:do
-		(setf (aref result j)
-		      (code-char
-		       (aref data i))))
-	  (setf position (1+ end))
-	  result)))))
+             ;; end is where the 0 byte is
+             (result (unless (= end position)
+                       (make-array (- end position)
+                                   :element-type 'base-char))))
+        (when result
+          (loop :for i :from position :below end
+                :for j :from 0
+                :do
+                (setf (elt result j)
+                      (code-char
+                       (elt data i))))
+          (setf position (1+ end))
+          result)))))
 
 (defgeneric read-string-from-packet (packet length)
   (:documentation
@@ -311,19 +315,19 @@
   (:method ((packet pg-packet) (length integer))
     (when (<= length 0)
       (error "length cannot be negative. is: ~S"
-	     length))
+             length))
     (let ((result (make-array length
-			      :element-type 'base-char)))
+                              :element-type 'base-char)))
       (with-slots (data position)
-	  packet
-	(loop :for i :from 0 :below length
-	      :do
-	      (setf (aref result i)
-		    (code-char
-		     (the (unsigned-byte 8)
-		       (aref data (+ i position))))))
-	(incf position length)
-	result))))
+          packet
+        (loop :for i :from 0 :below length
+              :do
+              (setf (elt result i)
+                    (code-char
+                     (the (unsigned-byte 8)
+                       (elt data (+ i position))))))
+        (incf position length)
+        result))))
 
 
 ;; now sending data:
@@ -331,10 +335,10 @@
 (defun %send-net-int (stream int bytes)
   (let ((v (make-array bytes :element-type '(unsigned-byte 8))))
     (loop for offset from (* 8 (1- bytes)) downto 0 by 8
-	  for data = (ldb (byte 8 offset) int)
-	  for i from 0
-	  do
-	  (setf (aref v i) data))
+          for data = (ldb (byte 8 offset) int)
+          for i from 0
+          do
+          (setf (elt v i) data))
     #+debug
     (format t "~&writing: ~S~%" v)
     (write-sequence v stream)))
@@ -345,7 +349,7 @@
          (v (make-array len :element-type '(unsigned-byte 8))))
     ;; convert the string to a vector of bytes
     (dotimes (i len)
-      (setf (aref v i) (char-code (aref str i))))
+      (setf (elt v i) (char-code (elt str i))))
     (write-sequence v stream)
     (write-byte 0 stream)))
 
@@ -360,57 +364,56 @@
 of items with as first element one of :byte, :char
 :int16 :int32 or :cstring and as second element the
 value of the parameter"
-  #+nil
   (declare (type base-char code))
 
   (let* ((length (+ 4
-		    (loop for (type value) in description
-			  sum (ecase type
-				((:byte :char) 1)
-				((:int16) 2)
-				((:int32) 4)
-				((:cstring)
-				 (+ 1
-				    (length value)))))))
-	 (data (make-array (- length 4)
-			   :element-type '(unsigned-byte 8)))
-	 (stream (pgcon-stream connection)))
+                    (loop for (type value) in description
+                          sum (ecase type
+                                ((:byte :char) 1)
+                                ((:int16) 2)
+                                ((:int32) 4)
+                                ((:cstring)
+                                 (+ 1
+                                    (length value)))))))
+         (data (make-array (- length 4)
+                           :element-type '(unsigned-byte 8)))
+         (stream (pgcon-stream connection)))
 
     (loop for (type value) in description
-	  with position = 0
-	  do
-	  (ecase type
-	    ((:byte)
-	     (check-type value (unsigned-byte 8))
-	     (setf (aref data position) value)
-	     (incf position))
-	    ((:char)
-	     (check-type value base-char)
-	     (setf (aref data position) (char-code value))
-	     (incf position))
-	    ((:int16)
-	     (check-type value (unsigned-byte 16))
-	     (setf (aref data position) (ldb (byte 8 8) value))
-	     (setf (aref data (+ 1 position)) (ldb (byte 8 0) value))
-	     (incf position 2))
-	    ((:int32)
-	     (check-type value (unsigned-byte 32))
-
-	     (setf (aref data position) (ldb (byte 8 24) value))
-	     (setf (aref data (+ 1 position)) (ldb (byte 8 16) value))
-	     (setf (aref data (+ 2 position)) (ldb (byte 8 8) value))
-	     (setf (aref data (+ 3 position)) (ldb (byte 8 0) value))
-	     (incf position 4))
-	    ((:cstring)
-	     (check-type value string)
-
-	     (loop for char across value
-		   do
-		   (setf (aref data position)
-			 (char-code char))
-		   (incf position))
-	     (setf (aref data position) 0)
-	     (incf position))))
+          with position = 0
+          do
+          (ecase type
+            ((:byte)
+             (check-type value (unsigned-byte 8))
+             (setf (elt data position) value)
+             (incf position))
+            ((:char)
+             (check-type value base-char)
+             (setf (elt data position) (char-code value))
+             (incf position))
+            ((:int16)
+             (check-type value (unsigned-byte 16))
+             (setf (elt data position) (ldb (byte 8 8) value))
+             (setf (elt data (+ 1 position)) (ldb (byte 8 0) value))
+             (incf position 2))
+            ((:int32)
+             (check-type value (unsigned-byte 32))
+
+             (setf (elt data position) (ldb (byte 8 24) value))
+             (setf (elt data (+ 1 position)) (ldb (byte 8 16) value))
+             (setf (elt data (+ 2 position)) (ldb (byte 8 8) value))
+             (setf (elt data (+ 3 position)) (ldb (byte 8 0) value))
+             (incf position 4))
+            ((:cstring)
+             (check-type value string)
+
+             (loop for char across value
+                   do
+                   (setf (elt data position)
+                         (char-code char))
+                   (incf position))
+             (setf (elt data position) 0)
+             (incf position))))
 
     (%send-net-int stream (char-code code) 1)
     (%send-net-int stream length 4 )
@@ -426,16 +429,16 @@
   (let* ((stream (socket-connect port host))
          (connection (make-instance 'pgcon-v3 :stream stream :host host :port port))
          (user-packet-length (+ 4 ; length
-				4 ; protocol version
-				(length "user")
-				1
-				(length user)
-				1
-				(length "database")
-				1
-				(length dbname)
-				1
-				1)))
+                                4 ; protocol version
+                                (length "user")
+                                1
+                                (length user)
+                                1
+                                (length "database")
+                                1
+                                (length dbname)
+                                1
+                                1)))
     ;; send the startup packet
     ;; this is one of the only non-standard packets!
     (%send-net-int stream user-packet-length 4)
@@ -453,138 +456,205 @@
      :for packet = (read-packet connection)
      :do
      (case (pg-packet-type packet)
-       ;; Authentication Request:
-       (( #\R)
-	(let* ((code (read-from-packet packet :int32)))
-	  (case code
-	    ((0)                        ;; AuthOK
-	     )
-	    ((1)                          ; AuthKerberos4
-	     (error 'authentication-failure
-		    :reason "Kerberos4 authentication not supported"))
-	    ((2)                          ; AuthKerberos5
-	     (error 'authentication-failure
-		    :reason "Kerberos5 authentication not supported"))
-	    ((3)                          ; AuthUnencryptedPassword
-	     (send-packet connection
-			  #\p
-			  `((:cstring ,password)))
-	     (%flush connection))
-	    ((4)                          ; AuthEncryptedPassword
-	     (let* ((salt (read-string-from-packet packet 2))
-		    (crypted (crypt password salt)))
-	       #+debug
-	       (format *debug-io* "Got salt of ~s~%" salt)
-	       (send-packet connection
-			     #\p
-			     `((:cstring ,crypted)))
-	       (%flush connection)))
-	    ((5)                          ; AuthMD5Password
-	     (error 'authentication-failure
-		    :reason "MD5 authentication not supported"))
-	    ((6)                          ; AuthSCMPassword
-	     (error 'authentication-failure
-		    :reason "SCM authentication not supported"))
-	    (t (error 'authentication-failure
-		      :reason "unknown authentication type")))))
-       (( #\K) ; Cancelation
-	(let* ((pid  (read-from-packet packet :int32))
-	       (secret (read-from-packet packet :int32)))
-	  #+debug
-	  (format t "~&Got cancelation data")
-
-	  (setf (pgcon-pid connection) pid)
-	  (setf (pgcon-secret connection) secret)))
-       (( #\S) ; Status
-	(let* ((parameter (read-from-packet packet :cstring))
-	       (value (read-from-packet packet :cstring)))
+       ((#\R)
+        ;; Authentication Request:
+        (let* ((code (read-from-packet packet :int32)))
+          (case code
+            ((0)                        ;; AuthOK
+             )
+            ((1)                          ; AuthKerberos4
+             (error 'authentication-failure
+                    :reason "Kerberos4 authentication not supported"))
+            ((2)                          ; AuthKerberos5
+             (error 'authentication-failure
+                    :reason "Kerberos5 authentication not supported"))
+            ((3)                          ; AuthUnencryptedPassword
+             (send-packet connection
+                          #\p
+                          `((:cstring ,password)))
+             (%flush connection))
+            ((4)                          ; AuthEncryptedPassword
+             (let* ((salt (read-string-from-packet packet 2))
+                    (crypted (crypt password salt)))
+               #+debug
+               (format *debug-io* "Got salt of ~s~%" salt)
+               (send-packet connection
+                             #\p
+                             `((:cstring ,crypted)))
+               (%flush connection)))
+            ((5)                          ; AuthMD5Password
+             (error 'authentication-failure
+                    :reason "MD5 authentication not supported"))
+            ((6)                          ; AuthSCMPassword
+             (error 'authentication-failure
+                    :reason "SCM authentication not supported"))
+            (t (error 'authentication-failure
+                      :reason "unknown authentication type")))))
+       (( #\K)
+        ;; Cancelation
+        (let* ((pid  (read-from-packet packet :int32))
+               (secret (read-from-packet packet :int32)))
+          #+debug
+          (format t "~&Got cancelation data")
+
+          (setf (pgcon-pid connection) pid)
+          (setf (pgcon-secret connection) secret)))
+       (( #\S)
+        ;; Status
+        (let* ((parameter (read-from-packet packet :cstring))
+               (value (read-from-packet packet :cstring)))
           (push (cons parameter value) (pgcon-parameters connection))))
-       ((#\Z) ; Ready for Query
-	(let* ((status (read-from-packet packet :byte)))
-	  (unless (= status
-		     (char-code #\I))
-	    (warn "~&Got status ~S but wanted I~%"
-		  (code-char status)))
-
-	  (and (not *pg-disable-type-coercion*)
-	       (null *parsers*)
-	       (initialize-parsers connection))
-	  (when *pg-date-style*
-	    (setf (pg-date-style connection) *pg-date-style*))
-	  (when *pg-client-encoding*
-	    (setf (pg-client-encoding connection) *pg-client-encoding*))
-	  (return connection)))
+       ((#\Z)
+        ;; Ready for Query
+        (let* ((status (read-from-packet packet :byte)))
+          (unless (= status
+                     (char-code #\I))
+            (warn "~&Got status ~S but wanted I~%"
+                  (code-char status)))
+
+          (and (not *pg-disable-type-coercion*)
+               (null *parsers*)
+               (initialize-parsers connection))
+          (when *pg-date-style*
+            (setf (pg-date-style connection) *pg-date-style*))
+          (when *pg-client-encoding*
+            (setf (pg-client-encoding connection) *pg-client-encoding*))
+          (return connection)))
+       ((#\E)
+        ;; an error, we should abort.
+        (return nil))
+       ((#\N)
+        ;; We ignore Notices
+        t)
        (t (error 'protocol-error
                  :reason "expected an authentication response"))))))
 
 
+(defun do-followup-query (connection)
+  "Does the followup of a query"
+
+  (let ((tuples '())
+        (attributes '())
+        (result (make-pgresult :connection connection)))
+
+    (%flush connection)
+
+    (loop
+     :for packet = (read-packet connection)
+     :with got-data-p = nil
+     :do
+     (when packet
+       (case (pg-packet-type packet)
+         ((#\S)
+          ;; Parameter status? not documented as return!
+          ;; XXX investigate
+          (let* ((parameter (read-from-packet packet :cstring))
+                 (value (read-from-packet packet :cstring)))
+            ;;#+debug
+            (warn "~&Got unexpected parameter ~S = ~S"
+                  parameter
+                  value)))
+         ((#\A)
+          ;; NotificationResponse
+          ;; Not documented?
+          ;; XXX investigate
+          (read-and-handle-notification-response connection packet))
+         ((#\C)
+          ;; CommandComplete
+          (let ((status (read-from-packet packet :cstring)))
+            (setf (pgresult-status result) status)
+            (setf (pgresult-tuples result) (nreverse tuples))
+            (setf (pgresult-attributes result) attributes))
+          (setf got-data-p t))
+         ((#\G)
+          ;; CopyInResponse
+          (cerror "Just ignore it" "What to do with #\G?")
+          ;; The backend is ready to copy data from the frontend to a table;
+          ;; see Section 44.2.5 in http://www.postgresql.org/docs/7.4/interactive/protocol-flow.html
+          ;; for now we make it fail gracefully:
+          (send-packet connection
+                       #\f
+                       ;;CopyFail
+                       '((:cstring "not implemented by pg.lisp yet")))
+          )
+         ((#\H)
+          ;; CopyOutResponse
+          (cerror "Just ignore it" "What to do with #\H?")
+          ;; The backend is ready to copy data from a table to the frontend;
+          ;; see Section 44.2.5.
+          ;; for now we make it fail gracefully (we cannot stop the transfer...
+          )
+         (( #\d
+            ;; CopyData
+            #\c
+            ;;CopyDone
+            )
+          t)
+         ((#\T)
+          ;; RowDescription (metadata for subsequent tuples), #\T
+          (and attributes (error "Cannot handle multiple result group"))
+          (setq attributes (read-attributes/v3 packet)))
+         ((#\D)
+          ;; AsciiRow (text data transfer), #\D
+          (setf got-data-p t)
+          (setf (pgcon-binary-p connection) nil)
+          (unless attributes
+            (error 'protocol-error :reason "Tuple received before metadata"))
+          (push (read-tuple/v3 packet attributes) tuples))
+         ((#\I)
+          ;; EmptyQueryResponse, #\I
+          ;; so no result.
+          (setf got-data-p t)
+          (setf (pgresult-status result) "SELECT")
+          (setf (pgresult-tuples result) nil)
+          (setf (pgresult-attributes result) nil))
+         ((#\Z)
+          ;; ReadyForQuery
+          ;;
+          ;; it might be a result from a previous
+          ;; query
+          (when got-data-p
+            (return result)))
+          ((#\s)
+           ;; PortalSuspend
+           ;; we're done in any case:
+           (return result))
+         ((#\2
+           ;; BindComplete
+           #\1
+           ;; ParseComplete
+           #\3
+           ;; CloseComplete
+           #\n
+           ;; NoData
+           )
+          ;; we ignore these messages
+          t)
+         ((#\E
+          ;; an error, we bravely try to recover...
+           #\N)
+          ;; and we ignore Notices
+          t)
+         (t
+          (warn "Got unexpected packet: ~S, resetting connection"
+                packet)
+          ;; sync
+          (send-packet connection
+                       #\S
+                       nil)
+          (%flush connection)))))))
+
 (defmethod pg-exec ((connection pgcon-v3) &rest args)
   "Execute the SQL command given by the concatenation of ARGS
 on the database to which we are connected via CONNECTION. Return
 a result structure which can be decoded using `pg-result'."
-  (let ((sql (apply #'concatenate 'simple-string args))
-        (tuples '())
-        (attributes '())
-        (result (make-pgresult :connection connection)))
+  (let ((sql (apply #'concatenate 'simple-string args)))
     (when (> (length sql) +MAX_MESSAGE_LEN+)
       (error "SQL statement too long: ~A" sql))
 
     (send-packet connection #\Q `((:cstring ,sql)))
     (%flush connection)
-    (loop
-     for packet = (read-packet connection)
-     do
-     (ecase (pg-packet-type packet)
-       ((#\S)
-	(let* ((parameter (read-from-packet packet :cstring))
-	       (value (read-from-packet packet :cstring)))
-          (push (cons parameter value) (pgcon-parameters connection))))
-       ((#\A)
-	;; NotificationResponse
-	;; Not documented?
-	;; XXX investigate
-	(read-and-handle-notification-response connection packet))
-       ((#\C)
-	;; CommandComplete
-	(let ((status (read-from-packet packet :cstring)))
-	  (setf (pgresult-status result) status)
-	  (setf (pgresult-tuples result) (nreverse tuples))
-	  (setf (pgresult-attributes result) attributes)))
-       ((#\G)
-	;; CopyInResponse
-	(error "What to do with #\G?")
-	;; The backend is ready to copy data from the frontend to a table;
-	;; see Section 44.2.5.
-	)
-       ((#\H)
-	;; CopyOutResponse
-	(error "What to do with #\H")
-	;; The backend is ready to copy data from a table to the frontend;
-	;; see Section 44.2.5.
-	)
-       ((#\T)
-	;; RowDescription (metadata for subsequent tuples), #\T
-	(and attributes (error "Cannot handle multiple result group"))
-	(setq attributes (read-attributes/v3 packet)))
-       ((#\D)
-	;; AsciiRow (text data transfer), #\D
-	(setf (pgcon-binary-p connection) nil)
-	(unless attributes
-	  (error 'protocol-error :reason "Tuple received before metadata"))
-	(push (read-tuple/v3 packet attributes) tuples))
-       ((#\I)
-	;; EmptyQueryResponse, #\I
-	;; so no result.
-	(setf (pgresult-status result) "SELECT")
-	(setf (pgresult-tuples result) nil)
-	(setf (pgresult-attributes result) nil))
-       ((#\N)                           ; NotificationResponse
-        ;; the notification has already been handled
-        t)
-       ((#\Z)
-	;; ReadyForQuery
-	;; we're done:
-	(return result))))))
+    (do-followup-query connection)))
 
 
 (defmethod pg-disconnect ((connection pgcon-v3))
@@ -601,41 +671,41 @@
     (do ((i attribute-count (- i 1)))
         ((zerop i) (nreverse attributes))
       (let* ((type-name (read-from-packet packet :cstring))
-	     (table-id (read-from-packet packet :int32))
-	     (column-id (read-from-packet packet :int16))
-	     (type-id (read-from-packet packet :int32))
-	     (type-len   (read-from-packet packet :int16))
-	     (type-mod  (read-from-packet packet :int32))
-	     (format-code (read-from-packet packet :int16)))
+             (table-id (read-from-packet packet :int32))
+             (column-id (read-from-packet packet :int16))
+             (type-id (read-from-packet packet :int32))
+             (type-len   (read-from-packet packet :int16))
+             (type-mod  (read-from-packet packet :int32))
+             (format-code (read-from-packet packet :int16)))
         (declare (ignore type-mod format-code
-			 table-id column-id))
+                         table-id column-id))
         (push (list type-name type-id type-len) attributes)))))
 
 (defun read-tuple/v3 (packet attributes)
   (let* ((num-attributes (length attributes))
-	 (number (read-from-packet packet :int16))
+         (number (read-from-packet packet :int16))
          (tuples '()))
     (unless (= num-attributes
-	       number)
+               number)
       (error "Should ~S not be equal to ~S"
-	    num-attributes
-	    number))
+            num-attributes
+            number))
     (do ((i 0 (+ i 1))
          (type-ids (mapcar #'second attributes) (cdr type-ids)))
         ((= i num-attributes) (nreverse tuples))
       (let* ((length (read-from-packet packet :int32))
-	     (raw   (unless (= length -1)
-		      (read-string-from-packet packet length))))
-	(if raw
-	    (push (parse raw (car type-ids)) tuples)
-	    (push nil tuples))))))
+             (raw   (unless (= length -1)
+                      (read-string-from-packet packet length))))
+        (if raw
+            (push (parse raw (car type-ids)) tuples)
+            (push nil tuples))))))
 
 ;; Execute one of the large-object functions (lo_open, lo_close etc).
 ;; Argument FN is either an integer, in which case it is the OID of an
 ;; element in the pg_proc table, and otherwise it is a string which we
 ;; look up in the alist *lo-functions* to find the corresponding OID.
 (defmethod fn ((connection pgcon-v3) fn integer-result &rest args)
-  (or *lo-initialized* (lo-init connection))
+    (or *lo-initialized* (lo-init connection))
   (let ((fnid (cond ((integerp fn) fn)
                     ((not (stringp fn))
                      (error "Expecting a string or an integer: ~s" fn))
@@ -643,59 +713,73 @@
                      (cdr (assoc fn *lo-functions* :test #'string=)))
                     (t (error "Unknown builtin function ~s" fn)))))
     (send-packet connection
-		 #\F
-		 `((:int32 ,fnid)
-		   (:int16 ,(length args))
-		   ,@(let ((result nil))
-			  (loop for arg in args
-				do
-				(cond
-				  ((integerp arg)
-				   (push `(:int16 1)
-					 result))
-				  ((stringp arg)
-				   (push `(:int16 0)
-					 result))
-				  (t (error 'protocol-error
-					    :reason (format nil "Unknown fastpath type ~s" arg)))))
-			  (nreverse result))
-		   (:int16 ,(length args))
-		   ,@(let ((result nil))
-			  (loop for arg in args
-				do
-				(cond
-				  ((integerp arg)
-				   (push '(:int32 4) result)
-				   (push `(:int32 ,arg) result))
-				  ((stringp arg)
-				   (push `(:int32 ,(1+ (length arg))) result)
-				   (push `(:cstring ,arg) result))
-				  (t (error 'protocol-error
-					    :reason (format nil "Unknown fastpath type ~s" arg)))))
-			  (nreverse result))
-		   (:int16 ,(if integer-result 1 0))))
+                 #\F
+                 `((:int32 ,fnid)
+                   (:int16 ,(length args))
+                   ,@(let ((result nil))
+                          (loop for arg in args
+                                do
+                                (cond
+                                  ((integerp arg)
+                                   (push `(:int16 1)
+                                         result))
+                                  ((stringp arg)
+                                   (push `(:int16 0)
+                                         result))
+                                  (t (error 'protocol-error
+                                            :reason (format nil "Unknown fastpath type ~s" arg)))))
+                          (nreverse result))
+                   (:int16 ,(length args))
+                   ,@(let ((result nil))
+                          (loop for arg in args
+                                do
+                                (cond
+                                  ((integerp arg)
+                                   (push '(:int32 4) result)
+                                   (push `(:int32 ,arg) result))
+                                  ((stringp arg)
+                                   (push `(:int32 ,(1+ (length arg))) result)
+                                   (push `(:cstring ,arg) result))
+                                  (t (error 'protocol-error
+                                            :reason (format nil "Unknown fastpath type ~s" arg)))))
+                          (nreverse result))
+                   (:int16 ,(if integer-result 1 0))))
     (%flush connection)
     (loop :with result = nil
-	  :for packet = (read-packet connection)
-	  :do
-	  (ecase (pg-packet-type packet)
-	    ((#\V)
-	     (let* ((length (read-from-packet packet :int32))
-		    (data (unless (= length -1)
-			    (if integer-result
-				(ecase length
-				  ((1)
-				   (read-from-packet packet :byte))
-				  ((2)
-				   (read-from-packet packet :int16))
-				  ((4)
-				   (read-from-packet packet :int32)))
-				(read-string-from-packet packet length)))))
-	       (if data
-		   (setf result data)
-		   (return-from fn nil))))
-	    ((#\Z)
-	     (return-from fn result))))))
+          :for packet = (read-packet connection)
+          :do
+          (case (pg-packet-type packet)
+            ((#\V)
+             (let* ((length (read-from-packet packet :int32))
+                    (data (unless (= length -1)
+                            (if integer-result
+                                (ecase length
+                                  ((1)
+                                   (read-from-packet packet :byte))
+                                  ((2)
+                                   (read-from-packet packet :int16))
+                                  ((4)
+                                   (read-from-packet packet :int32)))
+                                (read-string-from-packet packet length)))))
+               (if data
+                   (setf result data)
+                   (return-from fn nil))))
+            ((#\Z)
+             (return-from fn result))
+            ((#\E)
+             ;; an error, we should abort.
+             (return nil))
+            ((#\N)
+             ;; We ignore Notices
+             t)
+            (t
+             (warn "Got unexpected packet: ~S, resetting connection"
+                   packet)
+             ;; sync
+             (send-packet connection
+                          #\S
+                          nil)
+             (%flush connection))))))
 
 
 
@@ -722,8 +806,8 @@
 (defun handle-notice/v3 (connection packet)
   (loop :with notification = (make-instance 'backend-notification)
         :for field-type = (read-from-packet packet :byte)
-	:until (= field-type 0)
-	:do (let ((message (read-from-packet packet :cstring))
+        :until (= field-type 0)
+        :do (let ((message (read-from-packet packet :cstring))
                   (slot (ecase (code-char field-type)
                           ((#\S) 'severity)
                           ((#\C) 'code)
@@ -739,5 +823,142 @@
         :finally (push notification (pgcon-notices connection)))
   packet)
 
+
+
+;; prepare/bind/execute functions
+
+(defmethod pg-supports-pbe ((connection pgcon-v3))
+    (declare (ignore connection))
+  t)
+
+(defmethod pg-prepare ((connection pgcon-v3) (statement-name string) (sql-statement string) &optional type-of-parameters)
+    (let ((types (when type-of-parameters
+                 (loop :for type :in type-of-parameters
+                       :for oid = (or (lookup-type type)
+                                      (error "type not found"))
+                       :collect `(:int32 ,oid)))))
+
+    (cond
+      (types
+       (send-packet connection
+                    #\P
+                    `((:cstring ,statement-name)
+                      (:cstring ,sql-statement)
+                      (:int16 ,(length types))
+                      ,@(when types
+                              types))))
+      (t
+       (send-packet connection
+                    #\P
+                    `((:cstring ,statement-name)
+                      (:cstring ,sql-statement)
+                      (:int16 0)))))
+      t))
+
+(defmethod pg-bind ((connection pgcon-v3) (portal string)  (statement-name string) list-of-types-and-values)
+    (let ((formats (when list-of-types-and-values
+                   (loop :for (type value) :in list-of-types-and-values
+                         :collect
+                         (ecase type
+                           ((:string) `(:int16 0))
+                           ((:byte :int16 :int32 :char) `(:int16 1))))))
+        (data  nil))
+
+    (when list-of-types-and-values
+      (loop :for  (type value) :in list-of-types-and-values
+            :do
+            (ecase type
+              ((:int32)
+               (push '(:int32 4) data)
+               (push `(:int32 ,value) data))
+              ((:int16)
+               (push '(:int32 2) data)
+               (push `(:int16 ,value) data))
+              ((:byte)
+               (push '(:int32 1) data)
+               (push `(:int8 ,value) data))
+              ((:char)
+               (push '(:int32 1) data)
+               (push `(:int8 ,(char-code value)) data))
+              ((:string)
+               (push `(:int32 ,(1+ (length value))) data)
+               (push `(:cstring ,value) data))))
+
+      (setf data (nreverse data)))
+
+    (cond
+      (list-of-types-and-values
+       (send-packet connection
+                    #\B
+                    `((:cstring ,portal)
+                      (:cstring ,statement-name)
+                      (:int16 ,(length formats))
+                      , at formats
+                      (:int16 ,(length formats))
+                      , at data
+                      (:int16 0))))
+      (t
+       (send-packet connection
+                    #\B
+                    `((:cstring ,portal)
+                      (:cstring ,statement-name)
+                      (:int16 0)
+                      (:int16 0)
+                      (:int16 0)))))
+    t))
+
+(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maxinum-number-of-rows 0))
+
+  ;; have it describe the result:
+  (send-packet connection
+               #\D
+               `((:char #\P)
+                 (:cstring ,portal)))
+  ;; execute the query:
+  (send-packet connection
+               #\E
+               `((:cstring ,portal)
+                 (:int32 ,maxinum-number-of-rows)))
+  ;; send all data:
+  (send-packet connection
+               #\S
+               nil)
+  (%flush connection)
+
+  (do-followup-query connection))
+
+(defun pg-close (connection name type)
+  (declare (type pgcon connection)
+           (type string name)
+           (type base-char type))
+
+  (send-packet connection
+               #\C
+               `((:char ,type)
+                 (:cstring ,name)))
+  (%flush connection)
+  (loop :for packet = (read-packet connection)
+        :do
+        (case (pg-packet-type packet)
+          ((#\B #\Z)
+           ;; Close Complete
+           ;; or
+           ;; ReadyForQuery
+           (return))
+          (t
+           (warn "Got unexpected packet: ~S, resetting connection"
+                 packet)
+           ;; sync
+           (send-packet connection
+                        #\S
+                        nil)
+           (%flush connection))))
+  t)
+
+(defmethod pg-close-statement ((connection pgcon-v3) (statement-name string))
+    (pg-close connection statement-name #\s))
+
+(defmethod pg-close-portal ((connection pgcon-v3) (portal string))
+    (pg-close connection portal #\P))
 
 ;; EOF




From emarsden at common-lisp.net  Mon Mar  8 15:01:55 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Mon, 08 Mar 2004 10:01:55 -0500
Subject: [pg-cvs] CVS update: pg/lowlevel.lisp pg/CREDITS pg/NEWS pg/README
	pg/pg-tests.lisp pg/pg.asd pg/pg.lisp pg/v2-protocol.lisp
	pg/v3-protocol.lisp 
Message-ID: <E1B0MGR-00051k-00@common-lisp.net>

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

Modified Files:
	CREDITS NEWS README pg-tests.lisp pg.asd pg.lisp 
	v2-protocol.lisp v3-protocol.lisp 
Added Files:
	lowlevel.lisp 
Log Message:
More factorization of lowlevel functions between v2 and v3 protocols. 



Date: Mon Mar  8 10:01:53 2004
Author: emarsden



Index: pg/CREDITS
diff -u pg/CREDITS:1.1 pg/CREDITS:1.2
--- pg/CREDITS:1.1	Fri Mar  5 13:08:08 2004
+++ pg/CREDITS	Mon Mar  8 10:01:53 2004
@@ -4,3 +4,10 @@
 Peter Van Eynde:
   Wrote the support for the v3 PostgreSQL protocol.
 
+
+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.1.1.1 pg/NEWS:1.2
--- pg/NEWS:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/NEWS	Mon Mar  8 10:01:53 2004
@@ -1,4 +1,17 @@
-=== Version 0.20, 2003-xxxx ============================================
+=== Version 0.21, 2003-xxxx ============================================
+
+ - added support for the v3 frontend/backend protocol, used by
+   PostgreSQL version 7.4 and up (thanks for Peter Van Eynde).
+   pg-dot-lisp will attempt to connect to your database server using
+   the new protocol, and upon failure will reconnect using the older
+   protocol. To avoid this once-per-connection overhead if you know
+   you're only using older PostgreSQL versions, use PG-CONNECT/V2
+   instead of PG-CONNECT. 
+ 
+ - split out functionality into more files
+
+
+=== Version 0.20 (unreleased) ==========================================
 
  - added more tests for BOOLEAN types, to check the handling of
    PostgreSQL errors (violation of an integrity constraint leads to an


Index: pg/README
diff -u pg/README:1.1.1.1 pg/README:1.2
--- pg/README:1.1.1.1	Wed Mar  3 08:11:50 2004
+++ pg/README	Mon Mar  8 10:01:53 2004
@@ -1,10 +1,10 @@
 pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp
 
  Author: Eric Marsden <emarsden at laas.fr>
- Time-stamp: <2003-10-10 emarsden>
- Version: 0.20
+ Time-stamp: <2004-03-08 emarsden>
+ Version: 0.21
 
-     Copyright (C) 1999,2000,2001,2002,2003  Eric Marsden
+     Copyright (C) 1999,2000,2001,2002,2003,2004  Eric Marsden
 
      This library is free software; you can redistribute it and/or
      modify it under the terms of the GNU Library General Public
@@ -20,10 +20,10 @@
      License along with this library; if not, write to the Free
      Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
- Please send suggestions and bug reports to <emarsden at laas.fr>
- The latest version of this package should be available from
+ For download information, mailing lists for suggestions and bug
+ reports, see 
 
-     <URL:http://purl.org/net/emarsden/home/downloads/>
+     <URL:http://www.common-lisp.net/project/pg/>
 
 
 == Overview =========================================================
@@ -240,19 +240,12 @@
     end of the tunnel, since pg.lisp defaults to this value.
 
 
- This code has been tested or reported to work with
+This code has been tested or reported to work with
 
-   * CMUCL 18d on Solaris/SPARC and Linux/x86
+   * CMUCL 18d and 18e on Solaris/SPARC and Linux/x86
    * CLISP 2.30 on LinuxPPC and SPARC
    * ACL 6.1 trial/x86
-   * PostgreSQL 6.5, 7.0, 7.1.2, 7.2.
-
-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.
+   * PostgreSQL 6.5, 7.0, 7.1.2, 7.2, 7.3, 7.4
 
 
 You may be interested in using "pg-psql" by Harley Gorrell, which
@@ -260,15 +253,5 @@
 tabulated output), on top of this library. See
 
   <URL:http://www.mahalito.net/~harley/cl/pg-psql.lisp>
-
-
-
-
-== TODO ============================================================
-
- * add a mechanism for parsing user-defined types. The user should
-   be able to define a parse function and a type-name; we query
-   pg_type to get the type's OID and add the information to
-   pg:*parsers*.
 
 


Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.3 pg/pg-tests.lisp:1.4
--- pg/pg-tests.lisp:1.3	Mon Mar  8 09:37:43 2004
+++ pg/pg-tests.lisp	Mon Mar  8 10:01:53 2004
@@ -1,7 +1,7 @@
 ;;; pg-tests.lisp -- incomplete test suite
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
+;;; Time-stamp: <2004-03-08 emarsden>
 ;;
 ;;
 ;;
@@ -17,7 +17,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 "template1" "emarsden" :host "locke" :port 5432)
     (funcall function conn)))
 
 (defmacro with-test-connection ((conn) &body body)


Index: pg/pg.asd
diff -u pg/pg.asd:1.3 pg/pg.asd:1.4
--- pg/pg.asd:1.3	Sat Mar  6 17:59:39 2004
+++ pg/pg.asd	Mon Mar  8 10:01:53 2004
@@ -21,6 +21,7 @@
                  (:file "meta-queries" :depends-on ("defpackage"))
                  (:file "parsers" :depends-on ("defpackage"))
                  (:file "utility" :depends-on ("defpackage"))
+                 (:file "lowlevel" :depends-on ("defpackage"))
                  (:file "pg" :depends-on ("sysdep" "parsers"))
                  (:file "large-object" :depends-on ("pg"))
                  (:file "v2-protocol" :depends-on ("pg" "large-object" "utility"))


Index: pg/pg.lisp
diff -u pg/pg.lisp:1.3 pg/pg.lisp:1.4
--- pg/pg.lisp:1.3	Mon Mar  8 09:37:31 2004
+++ pg/pg.lisp	Mon Mar  8 10:01:53 2004
@@ -1,7 +1,7 @@
 ;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp
 ;;
 ;; Author: Eric Marsden <emarsden at laas.fr>
-;; Time-stamp: <2004-03-05 emarsden>
+;; Time-stamp: <2004-03-08 emarsden>
 ;; Version: 0.21
 ;;
 ;;     Copyright (C) 1999,2000,2001,2002,2003  Eric Marsden
@@ -275,107 +275,6 @@
                (parse-integer (subseq status 7 (position #\space status :start 7)))
                (error "Only INSERT commands generate an oid: ~s" status))))
         (t (error "Unknown result request: ~s" what))))
-
-
-
-
-
-
-;; support routines ===================================================
-
-;; read an integer in network byte order
-(defun read-net-int (connection bytes)
-  (declare (type (integer 0) bytes)
-           (type pgcon connection))
-
-  (do ((i bytes (- i 1))
-       (stream (pgcon-stream connection))
-       (accum 0))
-      ((zerop i) accum)
-    (setq accum (+ (* 256 accum) (read-byte stream)))))
-
-(defun read-int (connection bytes)
-  (do ((i bytes (- i 1))
-       (stream (pgcon-stream connection))
-       (multiplier 1 (* multiplier 256))
-       (accum 0))
-      ((zerop i) accum)
-    (incf accum (* multiplier (read-byte stream)))))
-
-#-cmu
-(defun read-bytes (connection howmany)
-  (declare (type fixnum howmany))
-  (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
-        (s (pgcon-stream connection)))
-    (read-sequence v s)
-    v))
-
-;; There is a bug in CMUCL's implementation of READ-SEQUENCE on
-;; network streams, which can return without reading to the end of the
-;; sequence when it has to wait for data. It confuses the end-of-file
-;; condition with no-more-data-currently-available. This workaround is
-;; thanks to Wayne Iba.
-#+cmu
-(defun read-bytes (connection howmany)
-  (declare (type fixnum howmany))
-  (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
-        (s (pgcon-stream connection)))
-    (do ((continue-at (read-sequence v s :start 0 :end howmany)
-                      (read-sequence v s :start continue-at :end howmany)))
-        ((= continue-at howmany))
-      )
-    v))
-
-(defun read-chars (connection howmany)
-  (declare (type fixnum howmany))
-  (let ((bytes (read-bytes connection howmany))
-        (str (make-string howmany)))
-    (dotimes (i howmany)
-      (setf (aref str i) (code-char (aref bytes i))))
-    str))
-
-(defun read-cstring (connection maxbytes)
-  "Read a null-terminated string from CONNECTION."
-  (declare (type fixnum maxbytes))
-  (let ((stream (pgcon-stream connection))
-        (chars nil))
-    (do ((b (read-byte stream nil nil) (read-byte stream nil nil))
-         (i 0 (+ i 1)))
-        ((or (= i maxbytes)             ; reached allowed length
-             (null b)                   ; eof
-             (zerop b))                 ; end of string
-         (concatenate 'string (nreverse chars)))
-      (push (code-char b) chars))))
-
-;; highest order bits first
-(defun send-int (connection int bytes)
-  (declare (type fixnum int bytes))
-  (let ((v (make-array bytes :element-type '(unsigned-byte 8)))
-        (stream (pgcon-stream connection)))
-    (do ((i (- bytes 1) (- i 1)))
-        ((< i 0))
-      (setf (aref v i) (rem int 256))
-      (setq int (floor int 256)))
-    (write-sequence v stream)))
-
-(defun send-string (connection str &optional pad-to)
-  (let* ((stream (pgcon-stream connection))
-         (len (length str))
-         (v (make-array len :element-type '(unsigned-byte 8))))
-    ;; convert the string to a vector of bytes
-    (dotimes (i len)
-      (setf (aref v i) (char-code (aref str i))))
-    (write-sequence v stream)
-    ;; pad if necessary
-    (when pad-to
-      (write-sequence (make-array (- pad-to len)
-                                  :initial-element 0
-                                  :element-type '(unsigned-byte 8))
-                      stream))))
-
-(declaim (inline flush))
-(defun flush (connection)
-  (force-output (pgcon-stream connection)))
 
 
 ;; EOF


Index: pg/v2-protocol.lisp
diff -u pg/v2-protocol.lisp:1.1 pg/v2-protocol.lisp:1.2
--- pg/v2-protocol.lisp:1.1	Fri Mar  5 13:08:08 2004
+++ pg/v2-protocol.lisp	Mon Mar  8 10:01:53 2004
@@ -1,7 +1,7 @@
 ;;; v2-protocol.lisp -- frontend/backend protocol prior to PostgreSQL 7.4
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
+;;; Time-stamp: <2004-03-08 emarsden>
 
 
 (in-package :postgresql)
@@ -26,7 +26,7 @@
     (send-int connection 0 2)           ; protocol 6.3 minor
     (send-string connection dbname +SM_DATABASE+)
     (send-string connection user user-packet-length)
-    (flush connection)
+    (%flush connection)
     #+cmu (ext:finalize connection (lambda () (pg-disconnect connection)))
     (loop
      (case (read-byte stream)
@@ -34,7 +34,7 @@
        ((69)
         (close stream)
         (error 'authentication-failure
-               :reason (read-cstring connection 4096)))
+               :reason (%read-cstring connection 4096)))
 
        ;; Authentication
        ((82)
@@ -52,16 +52,16 @@
            (send-int connection (+ 5 (length password)) 4)
            (send-string connection password)
            (send-int connection 0 1)
-           (flush connection))
+           (%flush connection))
           ((4)                          ; AuthEncryptedPassword
-           (let* ((salt (read-chars connection 2))
+           (let* ((salt (%read-chars connection 2))
                   (crypted (crypt password salt)))
              #+debug
              (format *debug-io* "Got salt of ~s~%" salt)
              (send-int connection (+ 5 (length crypted)) 4)
              (send-string connection crypted)
              (send-int connection 0 1)
-             (flush connection)))
+             (%flush connection)))
           ((1)                          ; AuthKerberos4
            (error 'authentication-failure
                   :reason "Kerberos4 authentication not supported"))
@@ -89,7 +89,7 @@
     (write-byte 81 stream)
     (send-string connection sql)
     (write-byte 0 stream)
-    (flush connection)
+    (%flush connection)
     (do ((b (read-byte stream nil :eof)
             (read-byte stream nil :eof)))
         ((eq b :eof) (error 'protocol-error :reason "unexpected EOF from backend"))
@@ -109,7 +109,7 @@
 
         ;; CompletedResponse, #\C
         ((67)
-         (let ((status (read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((status (%read-cstring connection +MAX_MESSAGE_LEN+)))
            (setf (pgresult-status result) status)
            (setf (pgresult-tuples result) (nreverse tuples))
            (setf (pgresult-attributes result) attributes)
@@ -124,7 +124,7 @@
 
         ;; ErrorResponse, #\E
         ((69)
-         (let ((msg (read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((msg (%read-cstring connection +MAX_MESSAGE_LEN+)))
            (error 'backend-error :reason msg)))
 
         ;; #\G and #\H: start copy in, start copy out
@@ -147,7 +147,7 @@
 
         ;; CursorResponse, #\P
         ((80)
-         (let ((str (read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((str (%read-cstring connection +MAX_MESSAGE_LEN+)))
            (declare (ignore str))
            ;; (format *debug-io* "Portal name ~a~%" str)
            ))
@@ -190,7 +190,7 @@
              (send-string connection arg))
             (t (error 'protocol-error
                       :reason (format nil "Unknown fastpath type ~s" arg)))))
-    (flush connection)
+    (%flush connection)
     (loop :with result = nil
           :with ready = nil
           :for b = (read-byte (pgcon-stream connection) nil :eof) :do
@@ -204,13 +204,13 @@
                       (let ((len (read-net-int connection 4)))
                         (if integer-result
                             (setq result (read-net-int connection len))
-                          (setq result (read-chars connection len)))))
+                          (setq result (%read-chars connection len)))))
                      (t (error 'protocol-error :reason "wierd FunctionResultResponse")))))
 
             ;; end of FunctionResult
             ((48) (return-from fn result))
 
-            ((69) (error 'backend-error :reason (read-cstring connection 4096)))
+            ((69) (error 'backend-error :reason (%read-cstring connection 4096)))
 
             ;; NoticeResponse
             ((78)
@@ -226,7 +226,7 @@
 
 (defmethod pg-disconnect ((connection pgcon-v2))
   (write-byte 88 (pgcon-stream connection))
-  (flush connection)
+  (%flush connection)
   (close (pgcon-stream connection))
   (values))
 
@@ -240,7 +240,7 @@
         (attributes '()))
     (do ((i attribute-count (- i 1)))
         ((zerop i) (nreverse attributes))
-      (let ((type-name (read-cstring connection +MAX_MESSAGE_LEN+))
+      (let ((type-name (%read-cstring connection +MAX_MESSAGE_LEN+))
             (type-id   (read-net-int connection 4))
             (type-len  (read-net-int connection 2))
             ;; this doesn't exist in the 6.3 protocol !!
@@ -266,7 +266,7 @@
 (defun read-tuple/v2 (connection attributes)
   (let* ((num-attributes (length attributes))
          (num-bytes (ceiling (/ num-attributes 8)))
-         (bitmap (read-bytes connection num-bytes))
+         (bitmap (%read-bytes connection num-bytes))
          (correction (if (pgcon-binary-p connection) 0 -4))
          (tuples '()))
     (do ((i 0 (+ i 1))
@@ -276,13 +276,13 @@
              (push nil tuples))
             (t
              (let* ((len (+ (read-net-int connection 4) correction))
-                    (raw (read-chars connection (max 0 len)))
+                    (raw (%read-chars connection (max 0 len)))
                     (parsed (parse raw (car type-ids))))
                (push parsed tuples)))))))
 
 ;; FIXME could signal a postgresql-notification condition
 (defun handle-notice (connection)
-  (push (read-cstring connection +MAX_MESSAGE_LEN+)
+  (push (%read-cstring connection +MAX_MESSAGE_LEN+)
         (pgcon-notices connection)))
 
 


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.2 pg/v3-protocol.lisp:1.3
--- pg/v3-protocol.lisp:1.2	Mon Mar  8 09:37:31 2004
+++ pg/v3-protocol.lisp	Mon Mar  8 10:01:53 2004
@@ -1,7 +1,7 @@
 ;;; v3-protocol.lisp -- frontend/backend protocol from PostgreSQL v7.4
 ;;;
 ;;; Author: Peter Van Eynde <pvaneynd at debian.org>
-;;; Time-stamp: <2004-03-05 emarsden>
+;;; Time-stamp: <2004-03-08 emarsden>
 
 (in-package :postgresql)
 
@@ -87,72 +87,6 @@
               (and (slot-boundp object 'position)
                    (slot-value object 'position)))))
 
-;; first some help functions:
-
-;; read an integer in network byte order
-(defun %read-net-int8 (stream)
-  "Reads an integer BYTES bytes long from the STREAM.
-The signed integer is presumed to be in network order.
-Returns the integer."
-  (let ((result (read-byte stream)))
-    (when (= 1 (ldb (byte 1 7) result))
-      ;; negative
-      (setf result (-
-                    (1+ (logxor result
-                                #xFF)))))
-    result))
-
-(defun %read-net-int16 (stream)
-  "Reads an integer BYTES bytes long from the STREAM.
-The signed integer is presumed to be in network order.
-Returns the integer."
-  (let ((result (+ (* 256 (read-byte stream))
-                   (read-byte stream))))
-    (when (= 1 (ldb (byte 1 15) result))
-      ;; negative
-      (setf result (-
-                    (1+ (logxor result
-                                #xFFFF)))))
-    result))
-
-(defun %read-net-int32 (stream)
-  "Reads an integer BYTES bytes long from the STREAM.
-The signed integer is presumed to be in network order.
-Returns the integer."
-  (let ((result (+ (* 256 256 256 (read-byte stream))
-                   (* 256 256 (read-byte stream))
-                   (* 256 (read-byte stream))
-                   (read-byte stream))))
-    (when (= 1 (ldb (byte 1 31) result))
-      ;; negative
-      (setf result (-
-                    (1+ (logxor result
-                                #xFFFFFFFF)))))
-    result))
-
-#-cmu
-(defun %read-bytes (stream howmany)
-  "Reads HOWMANY bytes from the STREAM.
-Returns the array of "
-  (let ((v (make-array howmany :element-type '(unsigned-byte 8))))
-    (read-sequence v stream)
-    v))
-
-;; There is a bug in CMUCL's implementation of READ-SEQUENCE on
-;; network streams, which can return without reading to the end of the
-;; sequence when it has to wait for data. It confuses the end-of-file
-;; condition with no-more-data-currently-available. This workaround is
-;; thanks to Wayne Iba.
-#+cmu
-(defun %read-bytes (stream howmany)
-  "Reads HOWMANY bytes from the STREAM.
-Returns the array of "
-  (let ((v (make-array howmany :element-type '(unsigned-byte 8))))
-    (do ((continue-at (read-sequence v stream :start 0 :end howmany)
-                      (read-sequence v stream :start continue-at :end howmany)))
-        ((= continue-at howmany))
-      )
-    v))
 
 ;; the error and notice functions:
 
@@ -329,33 +263,6 @@
         (incf position length)
         result))))
 
-
-;; now sending data:
-
-(defun %send-net-int (stream int bytes)
-  (let ((v (make-array bytes :element-type '(unsigned-byte 8))))
-    (loop for offset from (* 8 (1- bytes)) downto 0 by 8
-          for data = (ldb (byte 8 offset) int)
-          for i from 0
-          do
-          (setf (elt v i) data))
-    #+debug
-    (format t "~&writing: ~S~%" v)
-    (write-sequence v stream)))
-
-(defun %send-cstring (stream str)
-  "Sends a null-terminated string to CONNECTION"
-  (let* ((len (length str))
-         (v (make-array len :element-type '(unsigned-byte 8))))
-    ;; convert the string to a vector of bytes
-    (dotimes (i len)
-      (setf (elt v i) (char-code (elt str i))))
-    (write-sequence v stream)
-    (write-byte 0 stream)))
-
-(declaim (inline %flush))
-(defun %flush (connection)
-  (force-output (pgcon-stream connection)))
 
 
 (defun send-packet (connection code description)




From emarsden at common-lisp.net  Mon Mar  8 16:45:17 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Mon, 08 Mar 2004 11:45:17 -0500
Subject: [pg-cvs] CVS update: pg/lowlevel.lisp pg/pg-tests.lisp
	pg/v3-protocol.lisp 
Message-ID: <E1B0NsT-0000oa-00@common-lisp.net>

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

Modified Files:
	lowlevel.lisp pg-tests.lisp v3-protocol.lisp 
Log Message:

 - fix to the lowlevel factorization

 - modify parameter handling in v3 protocol to add parameters to the
   connection object, instead of issuing a warning


Date: Mon Mar  8 11:45:17 2004
Author: emarsden

Index: pg/lowlevel.lisp
diff -u pg/lowlevel.lisp:1.1 pg/lowlevel.lisp:1.2
--- pg/lowlevel.lisp:1.1	Mon Mar  8 10:01:53 2004
+++ pg/lowlevel.lisp	Mon Mar  8 11:45:16 2004
@@ -74,7 +74,7 @@
 
 (defun %read-chars (connection howmany)
   (declare (type fixnum howmany))
-  (let ((bytes (read-bytes connection howmany))
+  (let ((bytes (%read-bytes connection howmany))
         (str (make-string howmany)))
     (dotimes (i howmany)
       (setf (aref str i) (code-char (aref bytes i))))


Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.4 pg/pg-tests.lisp:1.5
--- pg/pg-tests.lisp:1.4	Mon Mar  8 10:01:53 2004
+++ pg/pg-tests.lisp	Mon Mar  8 11:45:16 2004
@@ -17,7 +17,7 @@
 
 ;; !!! CHANGE THE VALUES HERE !!!
 (defun call-with-test-connection (function)
-  (with-pg-connection (conn "template1" "emarsden" :host "locke" :port 5432)
+  (with-pg-connection (conn "template1" "emarsden" :host nil :port 5432)
     (funcall function conn)))
 
 (defmacro with-test-connection ((conn) &body body)


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.3 pg/v3-protocol.lisp:1.4
--- pg/v3-protocol.lisp:1.3	Mon Mar  8 10:01:53 2004
+++ pg/v3-protocol.lisp	Mon Mar  8 11:45:16 2004
@@ -457,10 +457,7 @@
           ;; XXX investigate
           (let* ((parameter (read-from-packet packet :cstring))
                  (value (read-from-packet packet :cstring)))
-            ;;#+debug
-            (warn "~&Got unexpected parameter ~S = ~S"
-                  parameter
-                  value)))
+            (push (cons parameter value) (pgcon-parameters connection))))
          ((#\A)
           ;; NotificationResponse
           ;; Not documented?




From emarsden at common-lisp.net  Mon Mar  8 18:12:46 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Mon, 08 Mar 2004 13:12:46 -0500
Subject: [pg-cvs] CVS update: pg/lowlevel.lisp pg/sysdep.lisp
	pg/v2-protocol.lisp pg/v3-protocol.lisp 
Message-ID: <E1B0PF8-0001pY-00@common-lisp.net>

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

Modified Files:
	lowlevel.lisp sysdep.lisp v2-protocol.lisp v3-protocol.lisp 
Log Message:
  - improvements to the system-dependent functionality: OpenMCL is
    able to use a local connection to the backend; most
    implementations resignal connection errors as a postgres-error.

  - fixes to the lowlevel code


Date: Mon Mar  8 13:12:45 2004
Author: emarsden

Index: pg/lowlevel.lisp
diff -u pg/lowlevel.lisp:1.2 pg/lowlevel.lisp:1.3
--- pg/lowlevel.lisp:1.2	Mon Mar  8 11:45:16 2004
+++ pg/lowlevel.lisp	Mon Mar  8 13:12:45 2004
@@ -52,6 +52,7 @@
 (defun %read-bytes (stream howmany)
   "Reads HOWMANY bytes from the STREAM.
 Returns the array of "
+  (declare (type stream stream))
   (let ((v (make-array howmany :element-type '(unsigned-byte 8))))
     (read-sequence v stream)
     v))
@@ -65,6 +66,7 @@
 (defun %read-bytes (stream howmany)
   "Reads HOWMANY bytes from the STREAM.
 Returns the array of "
+  (declare (type stream stream))
   (let ((v (make-array howmany :element-type '(unsigned-byte 8))))
     (do ((continue-at (read-sequence v stream :start 0 :end howmany)
 		      (read-sequence v stream :start continue-at :end howmany)))
@@ -72,19 +74,18 @@
       )
     v))
 
-(defun %read-chars (connection howmany)
+(defun %read-chars (stream howmany)
   (declare (type fixnum howmany))
-  (let ((bytes (%read-bytes connection howmany))
+  (let ((bytes (%read-bytes stream howmany))
         (str (make-string howmany)))
     (dotimes (i howmany)
       (setf (aref str i) (code-char (aref bytes i))))
     str))
 
-(defun %read-cstring (connection maxbytes)
+(defun %read-cstring (stream maxbytes)
   "Read a null-terminated string from CONNECTION."
   (declare (type fixnum maxbytes))
-  (let ((stream (pgcon-stream connection))
-        (chars nil))
+  (let ((chars nil))
     (do ((b (read-byte stream nil nil) (read-byte stream nil nil))
          (i 0 (+ i 1)))
         ((or (= i maxbytes)             ; reached allowed length


Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.2 pg/sysdep.lisp:1.3
--- pg/sysdep.lisp:1.2	Fri Mar  5 13:08:08 2004
+++ pg/sysdep.lisp	Mon Mar  8 13:12:45 2004
@@ -1,7 +1,7 @@
 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
+;;; Time-stamp: <2004-03-08 emarsden>
 ;;
 ;;
 
@@ -159,7 +159,7 @@
                        :remote-port port
                        :format :binary)
    (error (e)
-      (signal 'connection-failure
+      (error 'connection-failure
               :host host
               :port port
               :transport-error e))))
@@ -169,9 +169,15 @@
 #+lispworks
 (defun socket-connect (port host)
   (declare (type integer port))
-  (comm:open-tcp-stream host port
-			:element-type '(unsigned-byte 8)
-			:direction :io))
+  (handler-case
+      (comm:open-tcp-stream host port
+                            :element-type '(unsigned-byte 8)
+                            :direction :io)
+    (error (e)
+      (error 'connection-failure
+             :host host
+             :port port
+             :transport-error e))))
 
 ;; this doesn't work, since the Corman sockets module doesn't support
 ;; binary I/O on socket streams.
@@ -184,18 +190,32 @@
         (let ((sock (sockets:make-client-socket :host host :port port)))
           (sockets:make-socket-stream sock)))
     (error (e)
-      (declare (ignore e))
-      (error 'connection-failure :host host :port port))))
+      (error 'connection-failure
+             :host host
+             :port port
+             :transport-error e))))
 
 #+openmcl
 (defun socket-connect (port host)
   (declare (type integer port))
-  (let ((sock (make-socket :type :stream
-                           :connect :active
-                           :format :binary
-                           :remote-host host
-                           :remote-port port)))
-    sock))
+  (handler-case
+      (if host
+          (make-socket :address-family :internet
+                       :type :stream
+                       :connect :active
+                       :format :binary
+                       :remote-host host
+                       :remote-port port)
+          (make-socket :address-family :file
+                       :type :stream
+                       :connect :active
+                       :format :binary
+                       :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
+    (error (e)
+      (error 'connection-failure
+             :host host
+             :port port
+             :transport-error e))))
 
 ;; from John DeSoi
 #+(and mcl (not openmcl))
@@ -226,27 +246,13 @@
 #+ecl
 (defun socket-connect (port host)
   (declare (type integer port))
-  (si:open-client-stream host port))
-
-;; #+ecl
-;; (defun write-sequence (seq stream &key start end)
-;;   (declare (ignore start end))
-;;   (loop :for element :across seq
-;;         :do (write-byte element stream)))
-;; 
-;; #+ecl
-;; (defun read-bytes (connection howmany)
-;;   (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
-;;         (s (pgcon-stream connection)))
-;;     (loop :for pos :below howmany
-;;           :do (setf (aref v pos) (read-byte s)))
-;;     v))
-;; 
-;; #+ecl
-;; (defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))
-;;   (loop :for pos :from start :below end
-;;         :do (setf (aref seq pos) (read-byte stream))))
-
+  (handler-case 
+      (si:open-client-stream host port)
+    (error (e)
+      (error 'connection-failure
+             :host host
+             :port port
+             :transport-error e))))
 
 
 
@@ -261,25 +267,13 @@
 #+armedbear
 (defun socket-connect (port host)
   (declare (type integer port))
-  (ext:make-binary-socket host port))
-
-#+armedbear
-(defun cl:write-sequence (seq stream &key (start 0) (end (length seq)))
-  (declare (ignore start end))
-  (loop :for element :across seq
-        :do (write-byte element stream)))
-
-#+armedbear
-(defun read-bytes (connection howmany)
-  (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
-        (s (pgcon-stream connection)))
-    (loop :for pos :below howmany
-          :do (setf (aref v pos) (read-byte s)))
-    v))
+  (handler-case 
+      (ext:make-binary-socket host port)
+    (error (e)
+      (error 'connection-failure
+             :host host
+             :port port
+             :transport-error e))))
 
-#+armedbear
-(defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))
-  (loop :for pos :from start :below end
-        :do (setf (aref seq pos) (read-byte stream))))
 
 ;; EOF


Index: pg/v2-protocol.lisp
diff -u pg/v2-protocol.lisp:1.2 pg/v2-protocol.lisp:1.3
--- pg/v2-protocol.lisp:1.2	Mon Mar  8 10:01:53 2004
+++ pg/v2-protocol.lisp	Mon Mar  8 13:12:45 2004
@@ -34,7 +34,7 @@
        ((69)
         (close stream)
         (error 'authentication-failure
-               :reason (%read-cstring connection 4096)))
+               :reason (%read-cstring stream 4096)))
 
        ;; Authentication
        ((82)
@@ -54,7 +54,7 @@
            (send-int connection 0 1)
            (%flush connection))
           ((4)                          ; AuthEncryptedPassword
-           (let* ((salt (%read-chars connection 2))
+           (let* ((salt (%read-chars stream 2))
                   (crypted (crypt password salt)))
              #+debug
              (format *debug-io* "Got salt of ~s~%" salt)
@@ -109,7 +109,7 @@
 
         ;; CompletedResponse, #\C
         ((67)
-         (let ((status (%read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((status (%read-cstring stream +MAX_MESSAGE_LEN+)))
            (setf (pgresult-status result) status)
            (setf (pgresult-tuples result) (nreverse tuples))
            (setf (pgresult-attributes result) attributes)
@@ -124,7 +124,7 @@
 
         ;; ErrorResponse, #\E
         ((69)
-         (let ((msg (%read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((msg (%read-cstring stream +MAX_MESSAGE_LEN+)))
            (error 'backend-error :reason msg)))
 
         ;; #\G and #\H: start copy in, start copy out
@@ -147,7 +147,7 @@
 
         ;; CursorResponse, #\P
         ((80)
-         (let ((str (%read-cstring connection +MAX_MESSAGE_LEN+)))
+         (let ((str (%read-cstring stream +MAX_MESSAGE_LEN+)))
            (declare (ignore str))
            ;; (format *debug-io* "Portal name ~a~%" str)
            ))
@@ -204,13 +204,13 @@
                       (let ((len (read-net-int connection 4)))
                         (if integer-result
                             (setq result (read-net-int connection len))
-                          (setq result (%read-chars connection len)))))
+                          (setq result (%read-chars (pgcon-stream connection) len)))))
                      (t (error 'protocol-error :reason "wierd FunctionResultResponse")))))
 
             ;; end of FunctionResult
             ((48) (return-from fn result))
 
-            ((69) (error 'backend-error :reason (%read-cstring connection 4096)))
+            ((69) (error 'backend-error :reason (%read-cstring (pgcon-stream connection) 4096)))
 
             ;; NoticeResponse
             ((78)
@@ -240,7 +240,7 @@
         (attributes '()))
     (do ((i attribute-count (- i 1)))
         ((zerop i) (nreverse attributes))
-      (let ((type-name (%read-cstring connection +MAX_MESSAGE_LEN+))
+      (let ((type-name (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+))
             (type-id   (read-net-int connection 4))
             (type-len  (read-net-int connection 2))
             ;; this doesn't exist in the 6.3 protocol !!
@@ -266,7 +266,7 @@
 (defun read-tuple/v2 (connection attributes)
   (let* ((num-attributes (length attributes))
          (num-bytes (ceiling (/ num-attributes 8)))
-         (bitmap (%read-bytes connection num-bytes))
+         (bitmap (%read-bytes (pgcon-stream connection) num-bytes))
          (correction (if (pgcon-binary-p connection) 0 -4))
          (tuples '()))
     (do ((i 0 (+ i 1))
@@ -276,13 +276,13 @@
              (push nil tuples))
             (t
              (let* ((len (+ (read-net-int connection 4) correction))
-                    (raw (%read-chars connection (max 0 len)))
+                    (raw (%read-chars (pgcon-stream connection) (max 0 len)))
                     (parsed (parse raw (car type-ids))))
                (push parsed tuples)))))))
 
 ;; FIXME could signal a postgresql-notification condition
 (defun handle-notice (connection)
-  (push (%read-cstring connection +MAX_MESSAGE_LEN+)
+  (push (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+)
         (pgcon-notices connection)))
 
 


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.4 pg/v3-protocol.lisp:1.5
--- pg/v3-protocol.lisp:1.4	Mon Mar  8 11:45:16 2004
+++ pg/v3-protocol.lisp	Mon Mar  8 13:12:45 2004
@@ -71,7 +71,7 @@
          :type base-char
          :reader pg-packet-type)
    (length :initarg :length
-           :type (integer 32))
+           :type (unsigned-byte 32))
    (data :initarg :data
          :type (array (unsigned-byte 8) *))
    (position :initform 0




From root at common-lisp.net  Tue Mar  9 14:37:41 2004
From: root at common-lisp.net (root)
Date: Tue, 09 Mar 2004 09:37:41 -0500
Subject: [pg-cvs] CVS update: CVSROOT/config 
Message-ID: <E1B0iMX-0007do-00@common-lisp.net>

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

Modified Files:
	config 
Log Message:
fixing broken anonncvs

Date: Tue Mar  9 09:37:41 2004
Author: root

Index: CVSROOT/config
diff -u CVSROOT/config:1.2 CVSROOT/config:1.3
--- CVSROOT/config:1.2	Tue Mar  2 15:29:48 2004
+++ CVSROOT/config	Tue Mar  9 09:37:41 2004
@@ -0,0 +1,14 @@
+# Set this to "no" if pserver shouldn't check system users/passwords
+#SystemAuth=no
+
+# Put CVS lock files in this directory rather than directly in the repository.
+LockDir=/var/lock/pg
+
+# Set `TopLevelAdmin' to `yes' to create a CVS directory at the top
+# level of the new working directory when using the `cvs checkout'
+# command.
+#TopLevelAdmin=no
+
+# Set `LogHistory' to `all' or `TOFEWGCMAR' to log all transactions to the
+# history file, or a subset as needed (ie `TMAR' logs all write operations)
+#LogHistory=TOFEWGCMAR




From pvaneynde at common-lisp.net  Tue Mar  9 16:24:27 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 09 Mar 2004 11:24:27 -0500
Subject: [pg-cvs] CVS update: Directory change: pg/debian
Message-ID: <E1B0k1r-0005QK-00@common-lisp.net>

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

Log Message:
Directory /project/pg/cvsroot/pg/debian added to the repository

Date: Tue Mar  9 11:24:27 2004
Author: pvaneynde
New directory pg/debian added



From pvaneynde at common-lisp.net  Tue Mar  9 16:25:28 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 09 Mar 2004 11:25:28 -0500
Subject: [pg-cvs] CVS update: pg/debian/changelog pg/debian/control
	pg/debian/copyright pg/debian/dirs pg/debian/links
	pg/debian/postinst pg/debian/prerm pg/debian/rules 
Message-ID: <E1B0k2q-0007yA-00@common-lisp.net>

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

Added Files:
	changelog control copyright dirs links postinst prerm rules 
Log Message:
debian directory import
Date: Tue Mar  9 11:25:27 2004
Author: pvaneynde



















From pvaneynde at common-lisp.net  Tue Mar  9 16:27:20 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Tue, 09 Mar 2004 11:27:20 -0500
Subject: [pg-cvs] CVS update: pg/defpackage.lisp pg/v3-protocol.lisp 
Message-ID: <E1B0k4e-0002RE-00@common-lisp.net>

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

Modified Files:
	defpackage.lisp v3-protocol.lisp 
Log Message:
untested COPY IN/OUT code. I am not happy about how this looks...
Date: Tue Mar  9 11:27:20 2004
Author: pvaneynde

Index: pg/defpackage.lisp
diff -u pg/defpackage.lisp:1.2 pg/defpackage.lisp:1.3
--- pg/defpackage.lisp:1.2	Mon Mar  8 09:38:07 2004
+++ pg/defpackage.lisp	Tue Mar  9 11:27:20 2004
@@ -6,6 +6,7 @@
         #+openmcl :ccl)
   #+openmcl (:shadow ccl:socket-connect)
   (:export #:pg-connect #:pg-exec #:pg-result #:pg-disconnect
+	   #:pgcon-sql-stream
            #:*pg-disable-type-coercion*
            #:pg-databases #:pg-tables #:pg-columns
            #:pg-backend-version


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.5 pg/v3-protocol.lisp:1.6
--- pg/v3-protocol.lisp:1.5	Mon Mar  8 13:12:45 2004
+++ pg/v3-protocol.lisp	Tue Mar  9 11:27:20 2004
@@ -7,8 +7,10 @@
 
 (defclass pgcon-v3 (pgcon)
   ((parameters  :accessor pgcon-parameters
-                :initform (list))))
-
+                :initform (list))
+   (sql-stream  :initform nil
+		:accessor pgcon-sql-stream
+		:type (or nil stream))))
 
 
 (define-condition error-response (postgresql-error)
@@ -279,7 +281,8 @@
                                 ((:byte :char) 1)
                                 ((:int16) 2)
                                 ((:int32) 4)
-                                ((:cstring)
+                                ((:cstring
+				  :rawdata)
                                  (+ 1
                                     (length value)))))))
          (data (make-array (- length 4)
@@ -320,7 +323,12 @@
                          (char-code char))
                    (incf position))
              (setf (elt data position) 0)
-             (incf position))))
+             (incf position))
+	    ((:rawdata)
+             (check-type value (array (unsigned-byte 8) *))
+
+	     (replace data value :start1 position)
+	     (incf position (length value)))))
 
     (%send-net-int stream (char-code code) 1)
     (%send-net-int stream length 4 )
@@ -449,6 +457,7 @@
     (loop
      :for packet = (read-packet connection)
      :with got-data-p = nil
+     :with receive-data-p = nil
      :do
      (when packet
        (case (pg-packet-type packet)
@@ -472,27 +481,72 @@
           (setf got-data-p t))
          ((#\G)
           ;; CopyInResponse
-          (cerror "Just ignore it" "What to do with #\G?")
-          ;; The backend is ready to copy data from the frontend to a table;
-          ;; see Section 44.2.5 in http://www.postgresql.org/docs/7.4/interactive/protocol-flow.html
-          ;; for now we make it fail gracefully:
-          (send-packet connection
-                       #\f
-                       ;;CopyFail
-                       '((:cstring "not implemented by pg.lisp yet")))
-          )
+	  (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
-          (cerror "Just ignore it" "What to do with #\H?")
-          ;; The backend is ready to copy data from a table to the frontend;
-          ;; see Section 44.2.5.
-          ;; for now we make it fail gracefully (we cannot stop the transfer...
-          )
-         (( #\d
-            ;; CopyData
-            #\c
-            ;;CopyDone
-            )
+	  (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 (read-from-packet packet :int32)))
+	      (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




From emarsden at common-lisp.net  Wed Mar 17 18:13:10 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 17 Mar 2004 13:13:10 -0500
Subject: [pg-cvs] CVS update: pg/sysdep.lisp 
Message-ID: <E1B3fXS-0003DE-00@common-lisp.net>

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

Modified Files:
	sysdep.lisp 
Log Message:
 - changes for Armed Bear Lisp: change to new API for binary socket
   streams; autoload a working FORMAT


Date: Wed Mar 17 13:13:10 2004
Author: emarsden

Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.3 pg/sysdep.lisp:1.4
--- pg/sysdep.lisp:1.3	Mon Mar  8 13:12:45 2004
+++ pg/sysdep.lisp	Wed Mar 17 13:13:10 2004
@@ -1,7 +1,7 @@
 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-08 emarsden>
+;;; Time-stamp: <2004-03-17 emarsden>
 ;;
 ;;
 
@@ -112,7 +112,7 @@
       (error 'connection-failure :host host :port port))))
 
 
-#+db-sockets
+#+(and db-sockets broken)
 (defun socket-connect (port host)
   (declare (type integer port))
   (handler-case
@@ -264,11 +264,17 @@
   (si::socket port :host host))
 
 
+
+#+armedbear
+(eval-when (:load-toplevel :execute :compile-toplevel)
+  (require 'format))
+
+;; MAKE-SOCKET with :element-type as per 2004-03-09
 #+armedbear
 (defun socket-connect (port host)
   (declare (type integer port))
   (handler-case 
-      (ext:make-binary-socket host port)
+      (ext:make-socket host port :element-type '(unsigned-byte 8))
     (error (e)
       (error 'connection-failure
              :host host




From emarsden at common-lisp.net  Wed Mar 17 18:15:27 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 17 Mar 2004 13:15:27 -0500
Subject: [pg-cvs] CVS update: pg/v3-protocol.lisp 
Message-ID: <E1B3fZf-00029B-00@common-lisp.net>

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

Modified Files:
	v3-protocol.lisp 
Log Message:

 - fix bogus type declaration

 - remove bogus use of CMUCL's finalization (can't reference dying
   object from the finalizer)
        

Date: Wed Mar 17 13:15:27 2004
Author: emarsden

Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.6 pg/v3-protocol.lisp:1.7
--- pg/v3-protocol.lisp:1.6	Tue Mar  9 11:27:20 2004
+++ pg/v3-protocol.lisp	Wed Mar 17 13:15:26 2004
@@ -1,7 +1,6 @@
 ;;; v3-protocol.lisp -- frontend/backend protocol from PostgreSQL v7.4
 ;;;
 ;;; Author: Peter Van Eynde <pvaneynd at debian.org>
-;;; Time-stamp: <2004-03-08 emarsden>
 
 (in-package :postgresql)
 
@@ -10,7 +9,7 @@
                 :initform (list))
    (sql-stream  :initform nil
 		:accessor pgcon-sql-stream
-		:type (or nil stream))))
+		:type (or null stream))))
 
 
 (define-condition error-response (postgresql-error)
@@ -365,7 +364,6 @@
     (%send-cstring stream dbname)
     (%send-net-int stream 0 1)
     (%flush connection)
-    #+cmu (ext:finalize connection (lambda () (pg-disconnect connection)))
 
     (loop
      :for packet = (read-packet connection)




From pvaneynde at common-lisp.net  Sat Mar 20 21:48:42 2004
From: pvaneynde at common-lisp.net (Peter Van Eynde)
Date: Sat, 20 Mar 2004 16:48:42 -0500
Subject: [pg-cvs] CVS update: pg/pg-tests.lisp pg/v3-protocol.lisp 
Message-ID: <E1B4oKg-0007sG-00@common-lisp.net>

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

Modified Files:
	pg-tests.lisp v3-protocol.lisp 
Log Message:
now COPY IN/OUT actually works, also created test-case

Date: Sat Mar 20 16:48:42 2004
Author: pvaneynde

Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.5 pg/pg-tests.lisp:1.6
--- pg/pg-tests.lisp:1.5	Mon Mar  8 11:45:16 2004
+++ pg/pg-tests.lisp	Sat Mar 20 16:48:41 2004
@@ -315,6 +315,37 @@
           (when created
             (pg-exec conn "DROP TABLE count_test")))))))
 
+(defun test-copy-in-out ()
+  (with-test-connection (conn)
+    (ignore-errors
+      (pg-exec conn "DROP TABLE foo"))
+    (pg-exec conn "CREATE TABLE foo (a int, b int)")
+    (pg-exec conn "INSERT INTO foo VALUES (1, 2)")
+    (pg-exec conn "INSERT INTO foo VALUES (2, 4)")
+    
+    (with-open-file (stream "/tmp/foo-out"
+			    :direction :output
+			    :element-type '(unsigned-byte 8)
+			    :if-does-not-exist :create
+			    :if-exists :overwrite)
+      (setf (pgcon-sql-stream conn) stream)
+      (pg-exec conn "COPY foo TO stdout"))
+
+    (pg-exec conn "DELETE FROM foo")
+    (with-open-file (stream "/tmp/foo-out"
+			    :direction :input
+			    :element-type '(unsigned-byte 8)
+			    :if-does-not-exist :error
+			    :if-exists :overwrite)
+      (setf (pgcon-sql-stream conn) stream)
+      (pg-exec conn "COPY foo FROM stdout"))
+
+    (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 1")))
+      (assert (eql 2 (first (pg-result res :tuple 0)))))
+    (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 2")))
+      (assert (eql 4 (first (pg-result res :tuple 0)))))
+
+    (pg-exec conn "DROP TABLE foo")))
 
 (defun test ()
   (with-test-connection (conn)


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.7 pg/v3-protocol.lisp:1.8
--- pg/v3-protocol.lisp:1.7	Wed Mar 17 13:15:26 2004
+++ pg/v3-protocol.lisp	Sat Mar 20 16:48:41 2004
@@ -72,7 +72,8 @@
          :type base-char
          :reader pg-packet-type)
    (length :initarg :length
-           :type (unsigned-byte 32))
+           :type (unsigned-byte 32)
+	   :reader pg-packet-length)
    (data :initarg :data
          :type (array (unsigned-byte 8) *))
    (position :initform 0
@@ -532,7 +533,7 @@
 	  (when receive-data-p
 	    ;; we break the nice packet abstraction here to
 	    ;; get some speed:
-	    (let ((length (read-from-packet packet :int32)))
+	    (let ((length (- (pg-packet-length packet) 4)))
 	      (write-sequence (make-array length
 					  :element-type '(unsigned-byte 8)
 					  :displaced-to (slot-value packet