Initial port of PostgreSQL egg to CHICKEN 54.0.0

11 files changed, 2516 insertions, 0 deletions

diff --git a/TODO b/TODO
new file mode 100644
index 0000000..afb9160
--- /dev/null
+++ b/TODO
@@ -0,0 +1,6 @@
+- Add Batch (pipeline) API support (http://blog.2ndquadrant.com/postgresql-latency-pipelining-batching/)
+- Add LISTEN/NOTIFY support
+- Add support for range types
+- Add large object support
+- Add namespace support for types?
+
diff --git a/benchmarks/run.scm b/benchmarks/run.scm
new file mode 100644
index 0000000..2994710
--- /dev/null
+++ b/benchmarks/run.scm
@@ -0,0 +1,127 @@
+(import postgresql (chicken string) (chicken format) srfi-13)
+
+(define conn (connect '((dbname . test))))
+(define raw-conn (connect '((dbname . test)) '() '()))
+
+(print "--- Connecting/disconnecting ---")
+(print "Full connection")
+(time (do ((i 0 (add1 i)))
+          ((= i 1000))
+        (disconnect (connect '((dbname . test))))))
+
+(print "Raw connection")
+(time (do ((i 0 (add1 i)))
+          ((= i 1000))
+        (disconnect (connect '((dbname . test)) '() '()))))
+
+(let ((str (make-string 1000 #\x)))
+  (newline)
+  (print "---  Quotation ---")
+  (print "Escaping many strings")
+  (time (do ((i 0 (add1 i)))
+            ((= i 100000))
+          (escape-string conn str)))
+
+  (print "Quoting many identifiers")
+  (time (do ((i 0 (add1 i)))
+            ((= i 100000))
+          (quote-identifier conn str)))
+
+  (print "Escaping many byteas")
+  (time (do ((i 0 (add1 i)))
+            ((= i 100000))
+          (escape-bytea conn str)))
+
+  (print "Unescaping many byteas")
+  (let ((bytea (escape-bytea conn str)))
+    (time (do ((i 0 (add1 i)))
+              ((= i 100000))
+            (unescape-bytea bytea)))))
+
+(begin (newline)
+       (print "---  Reading data ---")
+       (print "Raw query with no result processing (postgres/libpq benchmark)")
+       (time (query conn "SELECT generate_series(0, 100000)"))
+
+       (newline)
+       (print "Fetching all values, no type conversion (string)")
+       (time (row-for-each (lambda (values) #f)
+                           (query raw-conn "SELECT generate_series(0, 1000000)::text")))
+       (print "Fetching all values, with type conversion (string)")
+       (time (row-for-each (lambda (values) #f)
+                           (query conn "SELECT generate_series(0, 1000000)::text")))
+
+       (newline)
+       (print "Fetching all values, no type conversion (integer)")
+       (time (row-for-each (lambda (values) #f)
+                           (query raw-conn "SELECT generate_series(0, 1000000)")))
+       (print "Fetching all values, with type conversion (integer)")
+       (time (row-for-each (lambda (values) #f)
+                           (query conn "SELECT generate_series(0, 1000000)")))
+
+       (newline)
+       (print "COPY TO")
+       (time (copy-query-for-each (lambda (values) #f)
+                                  raw-conn "COPY (SELECT generate_series(0, 1000000)) TO STDOUT")))
+
+(begin (newline)
+       (print "--- Inserting data ---")
+       (query raw-conn "CREATE TEMPORARY TABLE foo (bar int)")
+       (print "INSERT in a loop, no type conversion")
+       (time (do ((i 0 (add1 i)))
+                 ((= i 65535))
+               (query raw-conn "INSERT INTO foo VALUES ($1)" (->string i))))
+       (query raw-conn "TRUNCATE foo")
+
+       (query conn "CREATE TEMPORARY TABLE foo (bar int)")
+       (print "INSERT in a loop, with type conversion")
+       (time (do ((i 0 (add1 i)))
+                 ((= i 65535))
+               (query conn "INSERT INTO foo VALUES ($1)" i)))
+       (query conn "TRUNCATE foo")
+
+       (newline)
+       
+       (print "Parameterized INSERT statement, no type conversion")
+       (time (do ((i 0 (add1 i))
+                  (values '() (cons (->string i) values))
+                  (values-string '() (cons (sprintf "($~A)" (add1 i)) values-string)))
+                 ((= i 65535)
+                  (query* raw-conn (sprintf "INSERT INTO foo VALUES ~A"
+                                     (string-join values-string ","))
+                          values))))
+       (query raw-conn "TRUNCATE foo")
+
+       (print "Parameterized INSERT statement, with type conversion")
+       (time (do ((i 0 (add1 i))
+                  (values '() (cons i values))
+                  (values-string '() (cons (sprintf "($~A)" (add1 i)) values-string)))
+                 ((= i 65535)
+                  (query* conn (sprintf "INSERT INTO foo VALUES ~A"
+                                 (string-join values-string ","))
+                          values))))
+       (query conn "TRUNCATE foo")
+
+       (newline)
+
+       (print "Unparameterized INSERT statement")
+       (time (do ((i 0 (add1 i))
+                  (values-string '() (cons (sprintf "(~A)" i) values-string)))
+                 ((= i 65535)
+                  (query raw-conn (sprintf "INSERT INTO foo VALUES ~A"
+                                    (string-join values-string ","))))))
+       (query raw-conn "TRUNCATE foo")
+
+       (newline)
+       (print "COPY FROM")
+       (time (call-with-output-copy-query
+              (lambda (p)
+                (do ((i 0 (add1 i)))
+                    ((= i 65535))
+                  (display i p)
+                  (newline p)))
+              raw-conn "COPY foo (bar) FROM STDIN"))
+       (query raw-conn "TRUNCATE foo"))
+
+(disconnect raw-conn)
+(disconnect conn)
diff --git a/build-postgresql b/build-postgresql
new file mode 100755
index 0000000..fb15976
--- /dev/null
+++ b/build-postgresql
@@ -0,0 +1,23 @@
+# -*- sh -*-
+
+# Determine if pkg-config exists and knows about libpq, otherwise
+# fall back on pg_config to determine compiler and linker flags.
+if pkg-config --exists libpq >/dev/null 2>/dev/null; then
+   CFLAGS="`pkg-config --cflags libpq`"
+   LDFLAGS="`pkg-config --libs libpq`"
+else
+   CFLAGS="-I`pg_config --includedir`"
+   LDFLAGS="-L`pg_config --libdir` -Wl,-rpath `pg_config --libdir` -lpq"
+fi
+
+known_features="escape-identifier connectdb-params diag-query-position diag-schema-info"
+
+feature_flags=""
+for feature in $known_features; do
+    if "$CHICKEN_CSC" -C "$CFLAGS" -L "$LDFLAGS" "feature-tests/$feature.c" >/dev/null 2>/dev/null; then
+	feature_flags="$feature_flags -Dhas-$feature"
+    fi
+    rm -f feature-tests/$feature.o feature-tests/$feature
+done
+
+"$CHICKEN_CSC" $feature_flags -C "$CFLAGS" -L "$LDFLAGS" "$@"
diff --git a/feature-tests/connectdb-params.c b/feature-tests/connectdb-params.c
new file mode 100644
index 0000000..d79a2e0
--- /dev/null
+++ b/feature-tests/connectdb-params.c
@@ -0,0 +1,7 @@
+#include <libpq-fe.h>
+int main(void)
+{
+   const char *kw[] = {"a", NULL};
+   const char *val[] = {"b", NULL};
+   return PQconnectdbParams(kw, val, 0) != NULL;
+}
diff --git a/feature-tests/diag-query-position.c b/feature-tests/diag-query-position.c
new file mode 100644
index 0000000..8feb629
--- /dev/null
+++ b/feature-tests/diag-query-position.c
@@ -0,0 +1,7 @@
+#include <libpq-fe.h>
+int main(void)
+{
+   int foo = PG_DIAG_INTERNAL_QUERY;
+   int bar = PG_DIAG_INTERNAL_POSITION;
+   return foo + bar;
+}
diff --git a/feature-tests/diag-schema-info.c b/feature-tests/diag-schema-info.c
new file mode 100644
index 0000000..e64e990
--- /dev/null
+++ b/feature-tests/diag-schema-info.c
@@ -0,0 +1,10 @@
+#include <libpq-fe.h>
+int main(void)
+{
+   int s = PG_DIAG_SCHEMA_NAME;
+   int t = PG_DIAG_TABLE_NAME;
+   int col = PG_DIAG_COLUMN_NAME;
+   int d = PG_DIAG_DATATYPE_NAME;
+   int con = PG_DIAG_CONSTRAINT_NAME;
+   return s + t + col + d + con;
+}
diff --git a/feature-tests/escape-identifier.c b/feature-tests/escape-identifier.c
new file mode 100644
index 0000000..8188cbf
--- /dev/null
+++ b/feature-tests/escape-identifier.c
@@ -0,0 +1,6 @@
+#include <libpq-fe.h>
+int main(void)
+{
+   PGconn *conn = NULL; /* Bork */
+   return PQescapeIdentifier(conn, "test", 4) != NULL;
+}
diff --git a/postgresql.egg b/postgresql.egg
new file mode 100644
index 0000000..3848b3e
--- /dev/null
+++ b/postgresql.egg
@@ -0,0 +1,18 @@
+;;; postgresql.meta -*- Scheme -*-
+
+((synopsis "Bindings for PostgreSQL's C-api")
+ (category db)
+ (version 4.0.0)
+ (author "Johannes Groedem")
+ (maintainer "Peter Bex")
+ (license "BSD")
+ (dependencies sql-null srfi-1 srfi-18 srfi-13 srfi-69)
+ (test-dependencies test)
+ (foreign-dependencies libpq) ;; Or libpq-dev?  Highly OS-dependent!
+ (components (extension postgresql
+                        (custom-build "build-postgresql")
+                        (source-dependencies
+                         "feature-tests/connectdb-params.c"
+                         "feature-tests/escape-identifier.c"
+                         "feature-tests/diag-query-position.c"
+                         "feature-tests/diag-schema-info.c"))))
diff --git a/postgresql.release-info b/postgresql.release-info
new file mode 100644
index 0000000..57d33b4
--- /dev/null
+++ b/postgresql.release-info
@@ -0,0 +1,3 @@
+(repo git "https://code.more-magic.net/chicken-postgresql")
+(uri targz "https://code.more-magic.net/chicken-postgresql/snapshot/chicken-postgresql-{egg-release}.tar.gz")
+(release "4.0.0")
diff --git a/postgresql.scm b/postgresql.scm
new file mode 100644
index 0000000..3f1baf4
--- /dev/null
+++ b/postgresql.scm
@@ -0,0 +1,1360 @@
+;;; Bindings to the PostgreSQL C library
+;;
+;; Copyright (C) 2008-2014 Peter Bex
+;; Copyright (C) 2004 Johannes Grødem <johs@copyleft.no>
+;; Redistribution and use in source and binary forms, with or without
+;; modification, is permitted.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;; DAMAGE.
+
+(module postgresql
+ (type-parsers update-type-parsers! default-type-parsers
+  char-parser bool-parser bytea-parser numeric-parser
+  make-array-parser make-composite-parser
+  scheme-value->db-value type-unparsers update-type-unparsers!
+  default-type-unparsers bool-unparser vector-unparser list-unparser
+  
+  connect reset-connection disconnect connection? connected?
+  
+  query query* with-transaction in-transaction?
+  
+  result? clear-result! row-count column-count
+  column-index column-name column-names column-format
+  column-type column-type-modifier table-oid table-column-index
+  value-at row-values row-alist column-values affected-rows inserted-oid
+
+  invalid-oid
+  
+  escape-string escape-bytea unescape-bytea quote-identifier
+
+  put-copy-data put-copy-end get-copy-data
+  
+  row-fold row-fold* row-fold-right row-fold-right*
+  row-for-each row-for-each* row-map row-map*
+  column-fold column-fold* column-fold-right column-fold-right*
+  column-for-each column-for-each* column-map column-map*
+  copy-query-fold copy-query*-fold copy-query-fold-right copy-query*-fold-right
+  copy-query-for-each copy-query*-for-each copy-query-map copy-query*-map
+  call-with-output-copy-query call-with-output-copy-query*
+  with-output-to-copy-query with-output-to-copy-query*)
+
+ (import scheme
+         (chicken base)
+         (chicken foreign)
+         (chicken string)
+         (chicken port)
+         (chicken memory)
+         (chicken condition)
+         (chicken format)
+         (chicken gc)
+         (chicken blob)
+         srfi-1
+         srfi-4
+         srfi-13
+         srfi-18
+         srfi-69
+         sql-null)
+
+(import-for-syntax (chicken string))
+
+(foreign-declare "#include <libpq-fe.h>")
+
+(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType"))
+(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status)
+(define-foreign-variable PGRES_POLLING_READING pg-polling-status)
+(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status)
+(define-foreign-variable PGRES_POLLING_OK pg-polling-status)
+
+(define-foreign-type pg-exec-status (enum "ExecStatusType"))
+(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status)
+(define-foreign-variable PGRES_COMMAND_OK pg-exec-status)
+(define-foreign-variable PGRES_TUPLES_OK pg-exec-status)
+(define-foreign-variable PGRES_COPY_OUT pg-exec-status)
+(define-foreign-variable PGRES_COPY_IN pg-exec-status)
+(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status)
+(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status)
+(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status)
+
+(define-foreign-type pgconn* (c-pointer "PGconn"))
+
+(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
+(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
+(define PQresetStart (foreign-lambda bool PQresetStart pgconn*))
+(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*))
+(define PQfinish (foreign-lambda void PQfinish pgconn*))
+(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
+(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
+
+;(define-foreign-type oid "Oid")
+(define-foreign-type oid unsigned-int)
+
+(define invalid-oid (foreign-value "InvalidOid" oid))
+
+(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
+(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*))
+
+(define-foreign-type pgresult* (c-pointer "PGresult"))
+
+(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*))
+(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*)))
+(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*)))
+(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int))
+
+(define PQclear (foreign-lambda void PQclear pgresult*))
+(define PQnfields (foreign-lambda int PQnfields (const pgresult*)))
+(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
+(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
+(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
+(define PQftable (foreign-lambda oid PQftable (const pgresult*) int))
+(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int))
+(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int))
+(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
+(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
+(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
+(define PQgetlength (foreign-lambda int PQgetlength (const pgresult*) int int))
+(define PQgetvalue-ptr (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int))
+(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
+(define PQoidValue (foreign-lambda oid PQoidValue pgresult*))
+
+(define PQputCopyData (foreign-lambda int PQputCopyData pgconn* scheme-pointer int))
+(define PQputCopyEnd (foreign-lambda int PQputCopyEnd pgconn* (const c-string)))
+(define PQgetCopyData (foreign-lambda int PQgetCopyData pgconn* (c-pointer (c-pointer char)) bool))
+
+(define memcpy (foreign-lambda c-pointer "C_memcpy" scheme-pointer c-pointer size_t))
+
+(define (srfi-4-vector? x) ; Copied from ##sys#srfi-4-vector? from 4.8.3
+  (and (##core#inline "C_blockp" x)
+       (##sys#generic-structure? x)
+       (memq (##sys#slot x 0)
+             '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector))))
+
+;; TODO: Create a real callback system?
+(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
+
+(define-syntax define-foreign-int
+  (er-macro-transformer
+   (lambda (e r c)
+     ;; cannot rename define-foreign-variable; it's a really special form
+     `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
+
+(define-syntax define-pgdiag-constants
+  (syntax-rules ()
+    ((_ (?condition ?constant0 ...) ?more ...)
+     (begin (cond-expand
+              (?condition (define-foreign-int ?constant0) ...)
+              (else (define ?constant0 #f) ...))
+            (define-pgdiag-constants ?more ...)))
+    ((_ ?constant0 ?more ...)
+     (begin (define-foreign-int ?constant0)
+            (define-pgdiag-constants ?more ...)))
+    ((_) (void))))
+
+(define-pgdiag-constants
+  PG_DIAG_SEVERITY PG_DIAG_SQLSTATE PG_DIAG_CONTEXT PG_DIAG_MESSAGE_PRIMARY
+  PG_DIAG_MESSAGE_DETAIL PG_DIAG_MESSAGE_HINT PG_DIAG_STATEMENT_POSITION
+  PG_DIAG_SOURCE_FILE PG_DIAG_SOURCE_LINE PG_DIAG_SOURCE_FUNCTION
+  
+  (has-diag-query-position
+   PG_DIAG_INTERNAL_QUERY PG_DIAG_INTERNAL_POSITION)
+  
+  (has-diag-schema-info
+   PG_DIAG_SCHEMA_NAME PG_DIAG_TABLE_NAME PG_DIAG_COLUMN_NAME
+   PG_DIAG_DATATYPE_NAME PG_DIAG_CONSTRAINT_NAME))
+
+;; Helper procedure for lists (TODO: use ANY instead of IN with an array?)
+(define (in-list len)
+  (string-intersperse
+   (list-tabulate len (lambda (p) (conc "$" (add1 p)))) ","))
+
+(define (postgresql-error subtype loc message . args)
+  (signal (apply make-pg-condition subtype loc message args)))
+
+(define (make-pg-condition subtype loc message . args)
+  (make-composite-condition
+   (make-property-condition
+    'exn 'location loc 'message message 'arguments args)
+   (make-property-condition 'postgresql)
+   (if (condition? subtype) subtype (make-property-condition subtype))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Type parsers
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (char-parser str) (string-ref str 0))
+
+(define (bool-parser str) (string=? str "t"))
+
+(define (numeric-parser str)
+  (or (string->number str)
+      (postgresql-error 'parse 'numeric-parser "Unable to parse number" str)))
+
+(define (bytea-parser str)
+  (unescape-bytea str))
+
+;; Here be dragons
+(define (make-array-parser element-parser #!optional (delim #\,))
+  (define (parse str)
+    (if (string-ci=? "NULL" str)
+        (sql-null)
+        (element-parser str)))
+  (lambda (str)
+    (let loop ((chars (let ignore-bounds ((chars (string->list str)))
+                        (if (char=? (car chars) #\{)
+                            chars
+                            (ignore-bounds (cdr chars)))))
+               (result (list)))
+      (if (null? chars)
+          (car result)                ; Should contain only one vector
+          (case (car chars)
+            ((#\{) (receive (value rest-chars)
+                       (loop (cdr chars) (list))
+                     (loop rest-chars (cons value result))))
+            ((#\}) (values (list->vector (reverse! result)) (cdr chars)))
+            ((#\") (let consume-string ((chars (cdr chars))
+                                        (consumed (list)))
+                     (case (car chars)
+                       ((#\\) (consume-string ; Don't interpret, just add it
+                               (cddr chars) (cons (cadr chars) consumed)))
+                       ((#\") (loop (cdr chars)
+                                    (cons (element-parser
+                                           (reverse-list->string consumed))
+                                          result)))
+                       (else (consume-string (cdr chars)
+                                             (cons (car chars) consumed))))))
+            ((#\tab #\newline #\space) (loop (cdr chars) result))
+            (else
+             (if (char=? (car chars) delim)
+                 (loop (cdr chars) result)
+                 (let consume-string ((chars chars)
+                                      (consumed (list)))
+                   (cond
+                    ((char=? (car chars) delim)
+                     (loop (cdr chars)
+                           (cons (parse (reverse-list->string consumed))
+                                 result)))
+                    ((or (char=? (car chars) #\})
+                         (char=? (car chars) #\}))
+                     (loop chars
+                           (cons (parse (reverse-list->string consumed))
+                                 result)))
+                    (else (consume-string (cdr chars)
+                                          (cons (car chars) consumed))))))))))))
+
+(define (make-composite-parser element-parsers)
+  (define (parse str element-parser)
+    (if (string=? "" str)
+        (sql-null)
+        (element-parser str)))
+  (lambda (str)
+    (let loop ((chars (cdr (string->list (string-trim str)))) ; skip leading (
+               (maybe-null? #t)
+               (result (list))
+               (parsers element-parsers))
+      (case (car chars)
+        ((#\)) (reverse! (if maybe-null?
+                             (cons (sql-null) result)
+                             result)))
+        ((#\") (let consume-string ((chars (cdr chars))
+                                    (consumed (list)))
+                 (case (car chars)
+                   ((#\\) (consume-string ; Don't interpret, just add it
+                           (cddr chars) (cons (cadr chars) consumed)))
+                   ((#\") (if (char=? #\" (cadr chars)) ; double escapes
+                              (consume-string (cddr chars)
+                                              (cons #\" consumed))
+                              (let skip-spaces ((chars (cdr chars)))
+                                (case (car chars)
+                                  ((#\space #\newline #\tab)
+                                   (skip-spaces (cdr chars)))
+                                  ((#\,)
+                                   (loop (cdr chars)
+                                         #t
+                                         (cons ((car parsers)
+                                                (reverse-list->string consumed))
+                                               result)
+                                         (cdr parsers)))
+                                  ((#\)) (loop chars
+                                               #f
+                                               (cons ((car parsers)
+                                                      (reverse-list->string consumed))
+                                                     result)
+                                               (cdr parsers)))
+                                  (else
+                                   (postgresql-error
+                                    'parse 'make-composite-parser
+                                    "Bogus trailing characters" str))))))
+                   (else (consume-string (cdr chars)
+                                         (cons (car chars) consumed))))))
+        (else (let consume-string ((chars chars)
+                                   (consumed (list)))
+                (case (car chars)
+                  ((#\,) (loop (cdr chars)
+                               #t
+                               (cons (parse (reverse-list->string consumed)
+                                            (car parsers))
+                                     result)
+                               (cdr parsers)))
+                  ;; Nothing should precede this one
+                  ((#\)) (loop chars
+                               #f
+                               (cons (parse (reverse-list->string consumed)
+                                            (car parsers))
+                                     result)
+                               (cdr parsers)))
+                  (else (consume-string (cdr chars)
+                                        (cons (car chars) consumed))))))))))
+
+;; Array parsers and composite parsers are automatically cached when such
+;; a value is requested.
+(define default-type-parsers
+  (make-parameter
+   `(("text" . ,identity)
+     ("bytea" . ,bytea-parser)
+     ("char" . ,char-parser)
+     ("bpchar" . ,identity)
+     ("bool" . ,bool-parser)
+     ("int8" . ,numeric-parser)
+     ("int4" . ,numeric-parser)
+     ("int2" . ,numeric-parser)
+     ("float4" . ,numeric-parser)
+     ("float8" . ,numeric-parser)
+     ("numeric" . ,numeric-parser)
+     ("oid" . ,numeric-parser)
+     ;; Nasty hack, or clever hack? :)
+     ("record" . ,(make-composite-parser (circular-list identity))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Type unparsers
+;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (scheme-value->db-value conn value)
+  (cond ((find (lambda (parse?)
+                 ((car parse?) value))
+               (pg-connection-type-unparsers conn)) =>
+               (lambda (parse)
+                 ((cdr parse) conn value)))
+        (else value)))
+
+(define (bool-unparser conn b)
+  (if b "TRUE" "FALSE"))
+
+(define (vector-unparser conn v)
+  (let loop ((result (list))
+             (pos 0)
+             (len (vector-length v)))
+    (if (= pos len)
+        (string-append "{" (string-intersperse (reverse! result) ",") "}")
+        (let* ((value (vector-ref v pos))
+               (unparsed-value (scheme-value->db-value conn value))
+               (serialized (cond
+                            ((sql-null? unparsed-value) "NULL")
+                            ((not (string? unparsed-value))
+                             (postgresql-error
+                              'unparse 'vector-unparser
+                              "Param value is not string" unparsed-value))
+                            ((vector? value) unparsed-value) ;; don't quote!
+                            (else
+                             (sprintf "\"~A\""
+                               (string-translate*
+                                unparsed-value
+                                '(("\\" . "\\\\") ("\"" . "\\\""))))))))
+          (loop (cons serialized result) (add1 pos) len)))))
+
+(define (list-unparser conn l)
+  (let loop ((result (list))
+             (items l))
+    (if (null? items)
+        (string-append "(" (string-intersperse (reverse! result) ",") ")")
+        (let* ((unparsed-value (scheme-value->db-value conn (car items)))
+               (serialized (cond
+                            ((sql-null? unparsed-value) "")
+                            ((not (string? unparsed-value))
+                             (postgresql-error
+                              'unparse 'list-unparser
+                              "Param value is not string" unparsed-value))
+                            (else
+                             (sprintf "\"~A\""
+                               (string-translate*
+                                unparsed-value
+                                '(("\\" . "\\\\") ("\"" . "\\\""))))))))
+          (loop (cons serialized result) (cdr items))))))
+
+(define default-type-unparsers
+  (make-parameter
+   `((,string? . ,(lambda (conn s) s))
+     (,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v)))
+     (,char? . ,(lambda (conn c) (string c)))
+     (,boolean? . ,bool-unparser)
+     (,number? . ,(lambda (conn n) (number->string n)))
+     (,vector? . ,vector-unparser)
+     (,pair? . ,list-unparser))))
+
+;; Retrieve type-oids from PostgreSQL:
+(define (update-type-parsers! conn #!optional new-type-parsers)
+  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
+        (ht (make-hash-table))
+        (result '()))
+    (pg-connection-oid-parsers-set! conn ht)
+    (pg-connection-type-parsers-set! conn type-parsers)
+    (unless (null? type-parsers)   ; empty IN () clause is not allowed
+      (row-for-each*
+       (lambda (oid typname)
+         (and-let* ((procedure (assoc typname type-parsers)))
+           (hash-table-set! ht (string->number oid) (cdr procedure))))
+       (query* conn
+               (sprintf
+                   "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
+                 (in-list (length type-parsers)))
+               (map car type-parsers) raw: #t)))))
+
+(define (update-type-unparsers! conn new-type-unparsers)
+  (pg-connection-type-unparsers-set! conn new-type-unparsers))
+
+;;;;;;;;;;;;;;;;;;;;
+;;;; Connections
+;;;;;;;;;;;;;;;;;;;;
+
+(define-record pg-connection
+  ptr type-parsers oid-parsers type-unparsers transaction-depth)
+(define connection? pg-connection?)
+(define type-parsers pg-connection-type-parsers)
+(define type-unparsers pg-connection-type-unparsers)
+
+(define (connected? conn) (not (not (pg-connection-ptr conn))))
+
+(define (pgsql-connection->fd conn)
+  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
+
+(define (wait-for-connection! conn poll-function)
+  (let ((conn-fd (pgsql-connection->fd conn))
+        (conn-ptr (pg-connection-ptr conn)))
+    (let loop ((result (poll-function conn-ptr)))
+      (cond ((= result PGRES_POLLING_OK) (void))
+            ((= result PGRES_POLLING_FAILED)
+             (let ((message (PQerrorMessage conn-ptr)))
+               (disconnect conn)
+               (postgresql-error
+                'connect 'connect
+                (conc "Polling Postgres database failed: " message) conn)))
+            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
+             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
+                                               #:input
+                                               #:output))
+             (loop (poll-function conn-ptr)))
+            (else
+             (postgresql-error
+              'internal 'connect
+              (conc "Internal error! Unknown status code: " result) conn))))))
+
+(cond-expand
+  ((not has-connectdb-params)
+   (define (alist->connection-spec alist)
+     (string-join
+      (map (lambda (subspec)
+             (sprintf "~A='~A'"
+               (car subspec) ;; this had better not contain [ =\']
+               (string-translate* (->string (cdr subspec))
+                                  '(("\\" . "\\\\") ("'" . "\\'")))))
+           alist))))
+  (else))
+
+(define (connect-start spec)
+  (if (string? spec)
+      (PQconnectStart spec)
+      (cond-expand
+        (has-connectdb-params
+         (let ((len (length spec)))
+           ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf)
+                                      (scheme-pointer valbuf) (int len))
+              "const char **key = (const char **)keybuf;"
+              "const char **val = (const char **)valbuf;"
+              "int i;"
+              "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
+              "    C_word kvpair = C_u_i_car(cons);"
+              "    key[i] = C_c_string(C_u_i_car(kvpair));"
+              "    val[i] = C_c_string(C_u_i_cdr(kvpair));"
+              "}"
+              "key[len] = NULL;"
+              "val[len] = NULL;"
+              "C_return(PQconnectStartParams(key, val, 0));")
+            (map (lambda (x) (cons (string-append (->string (car x)) "\x00")
+                                   (string-append (->string (cdr x)) "\x00"))) spec)
+            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
+            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
+            len)))
+        (else (PQconnectStart (alist->connection-spec spec))))))
+
+(define (connect #!optional (conn-spec '())
+                 (type-parsers (default-type-parsers))
+                 (type-unparsers (default-type-unparsers)))
+  (let ((conn-ptr (connect-start conn-spec)))
+    (cond
+     ((not conn-ptr)
+      (postgresql-error
+       'internal 'connect
+       "Unable to allocate a Postgres connection structure" conn-spec))
+     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
+      (let ((message (PQerrorMessage conn-ptr)))
+        (PQfinish conn-ptr)
+        (postgresql-error
+         'connect 'connect
+         (conc "Connection to Postgres database failed: " message) conn-spec)))
+     (else
+      (let ((conn (make-pg-connection conn-ptr type-parsers
+                                      (make-hash-table) type-unparsers 0)))
+        ;; We don't want libpq to piss in our stderr stream
+        ((foreign-lambda* void ((pgconn* conn))
+           "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
+        (wait-for-connection! conn PQconnectPoll)
+        (set-finalizer! conn disconnect)
+        ;; Retrieve type-information from PostgreSQL metadata for use by
+        ;; the various value-parsers.
+        (update-type-parsers! conn)
+        conn)))))
+
+(define (reset-connection connection)
+  (let ((conn-ptr (pg-connection-ptr connection)))
+    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
+        (wait-for-connection! connection PQresetPoll)
+        (let ((error-message (PQerrorMessage conn-ptr)))
+          (disconnect connection)
+          (postgresql-error
+           'connect 'reset-connection
+           (conc "Reset of connection failed: " error-message) connection)))))
+
+(define (disconnect connection)
+  (and-let* ((conn-ptr (pg-connection-ptr connection)))
+    (pg-connection-ptr-set! connection #f)
+    (pg-connection-type-parsers-set! connection #f)
+    (pg-connection-oid-parsers-set! connection #f)
+    (PQfinish conn-ptr))
+  (void))
+
+;;;;;;;;;;;;;;;
+;;;; Results
+;;;;;;;;;;;;;;;
+
+(define-record pg-result ptr value-parsers)
+(define result? pg-result?)
+
+(define (clear-result! result)
+  (and-let* ((result-ptr (pg-result-ptr result)))
+    (pg-result-ptr-set! result #f)
+    (PQclear result-ptr)))
+
+(define (row-count result)
+  (PQntuples (pg-result-ptr result)))
+
+(define (column-count result)
+  (PQnfields (pg-result-ptr result)))
+
+;; Helper procedures for bounds checking; so we can distinguish between
+;; out of bounds and nonexistant columns, and signal it.
+(define (check-column-index! result index location)
+  (when (>= index (column-count result))
+    (postgresql-error
+     'bounds location
+     (sprintf "Result column ~A out of bounds" index) result index)))
+
+(define (check-row-index! result index location)
+  (when (>= index (row-count result))
+    (postgresql-error
+     'bounds location
+     (sprintf "Result row ~A out of bounds" index) result index)))
+
+(define (column-name result index)
+  (check-column-index! result index 'column-name)
+  (string->symbol (PQfname (pg-result-ptr result) index)))
+
+(define (column-names result)
+  (let ((ptr (pg-result-ptr result)))
+    (let loop ((names '())
+               (column (column-count result)))
+      (if (= column 0)
+          names
+          (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
+                (sub1 column))))))
+
+(define (column-index result name)
+  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
+    (and (>= idx 0) idx)))
+
+(define (table-oid result index)
+  (check-column-index! result index 'table-oid)
+  (let ((oid (PQftable (pg-result-ptr result) index)))
+    (and (not (= oid invalid-oid)) oid)))
+
+;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
+;; consistent with the rest of Scheme.  However, this is inconsistent with
+;; almost all other PostgreSQL interfaces...
+(define (table-column-index result index)
+  (check-column-index! result index 'table-column-index)
+  (let ((idx (PQftablecol (pg-result-ptr result) index)))
+    (and (> idx 0) (sub1 idx))))
+
+(define format-table
+  '((0 . text) (1 . binary)))
+
+(define (format->symbol format)
+  (or (alist-ref format format-table eq?)
+      (postgresql-error 'type 'format->symbol "Unknown format" format)))
+
+(define (symbol->format symbol)
+  (or (and-let* ((res (rassoc symbol format-table eq?)))
+        (car res))
+      (postgresql-error 'type 'format->symbol "Unknown format" symbol)))
+
+(define (column-format result index)
+  (check-column-index! result index 'column-format)
+  (format->symbol (PQfformat (pg-result-ptr result) index)))
+
+(define (column-type result index)
+  (check-column-index! result index 'column-type)
+  (PQftype (pg-result-ptr result) index))
+
+;; This is really not super-useful as it requires intimate knowledge
+;; about the internal implementations of types in PostgreSQL.
+(define (column-type-modifier result index)
+  (check-column-index! result index 'column-type)
+  (let ((mod (PQfmod (pg-result-ptr result) index)))
+    (and (>= mod 0) mod)))
+
+;; Unchecked version, for speed
+(define (value-at* result column row raw)
+  (let ((ptr (pg-result-ptr result)))
+    (if (PQgetisnull ptr row column)
+        (sql-null)
+        (let* ((len (PQgetlength ptr row column))
+               (fmt (PQfformat ptr column))
+               (value (case fmt
+                        ((0) (make-string len))
+                        ((1) (make-blob len))
+                        (else (postgresql-error
+                               'internal 'value-at
+                               (conc "Unknown column format type: " fmt)
+                               result column row raw)))))
+          (memcpy value (PQgetvalue-ptr ptr row column) len)
+          (if (or raw (blob? value))
+              value
+              ((vector-ref (pg-result-value-parsers result) column) value))))))
+
+(define (value-at result #!optional (column 0) (row 0) #!key raw)
+  (check-row-index! result row 'value)
+  (check-column-index! result column 'value)
+  (value-at* result column row raw))
+
+(define (row-values* result row column-count raw)
+  (let loop ((list '())
+             (column column-count))
+    (if (= column 0)
+        list
+        (loop (cons (value-at* result (sub1 column) row raw) list)
+              (sub1 column)))))
+
+(define (row-values result #!optional (row 0) #!key raw)
+  (check-row-index! result row 'row)
+  (row-values* result row (column-count result) raw))
+
+(define (column-values* result column row-count raw)
+  (let loop ((list '())
+             (row row-count))
+    (if (= row 0)
+        list
+        (loop (cons (value-at* result column (sub1 row) raw) list)
+              (sub1 row)))))
+
+(define (column-values result #!optional (column 0) #!key raw)
+  (check-column-index! result column 'column)
+  (column-values* result column (row-count result) raw))
+
+;; (define (row-alist result #!optional (row 0) #!key raw)
+;;   (map cons (column-names result) (row-values result row raw: raw)))
+(define (row-alist result #!optional (row 0) #!key raw)
+  (check-row-index! result row 'row-alist)
+  (let loop ((alist '())
+             (column (column-count result)))
+    (if (= column 0)
+        alist
+        (loop (cons (cons (string->symbol
+                           (PQfname (pg-result-ptr result) (sub1 column)))
+                          (value-at* result (sub1 column) row raw)) alist)
+              (sub1 column)))))
+
+;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
+
+(define (affected-rows result)
+  (string->number (PQcmdTuples (pg-result-ptr result))))
+
+(define (inserted-oid result)
+  (let ((oid (PQoidValue (pg-result-ptr result))))
+    (and (not (= oid invalid-oid)) oid)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Query procedures
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Buffer all available input, yielding if nothing is available:
+(define (buffer-available-input! conn)
+  (let ((conn-ptr (pg-connection-ptr conn))
+        (conn-fd (pgsql-connection->fd conn)))
+    (let loop ()
+      (if (PQconsumeInput conn-ptr)
+          (when (PQisBusy conn-ptr)
+            (thread-wait-for-i/o! conn-fd #:input)
+            (loop))
+          (postgresql-error
+           'i/o 'buffer-available-input!
+           (conc "Error reading reply from server: " (PQerrorMessage conn-ptr))
+           conn)))))
+
+;; Here be more dragons
+(define (resolve-unknown-types! conn oids)
+  (unless (null? oids)
+    (let* ((parsers (pg-connection-oid-parsers conn))
+           (q (conc "SELECT t.oid, t.typtype, t.typelem, t.typdelim, "
+                    "       t.typbasetype, t.typarray, a.attrelid, a.atttypid "
+                    "FROM pg_type t "
+                    "     LEFT JOIN pg_attribute a "
+                    "     ON t.typrelid = a.attrelid AND a.attnum > 0 "
+                    "WHERE t.oid IN (~A)  "
+                    "ORDER BY COALESCE(t.typrelid,-1) ASC, a.attnum ASC"))
+           (result (query* conn (sprintf q (in-list (length oids)))
+                           (map number->string oids) raw: #t))
+           (count (row-count result)))
+      (let dissect-types ((unknown-oids (list))
+                          (pos 0)
+                          (domains (list))
+                          (arrays (list))
+                          (classes (list))
+                          (last-class 0))
+        (cond
+         ((>= pos count)     ; Done scanning rows?
+          ;; Keep going until all oids are resolved
+          (resolve-unknown-types! conn unknown-oids)
+          ;; Postprocessing step: resolve all nested types
+          (for-each (lambda (d)
+                      (and-let* ((p (hash-table-ref/default parsers (cdr d) #f)))
+                        (hash-table-set! parsers (car d) p)))
+                    domains)
+          (for-each (lambda (a)
+                      (and-let* ((p (hash-table-ref/default parsers (cddr a) #f)))
+                        (hash-table-set! parsers (car a)
+                                         (make-array-parser p (cadr a)))))
+                    arrays)
+          (for-each
+           (lambda (c)
+             (and-let* ((p-list
+                         (fold
+                          (lambda (att l)
+                            (and-let* ((l)
+                                       (p (hash-table-ref/default parsers att #f)))
+                              (cons p l)))
+                          '()
+                          (cdr c))))
+               (hash-table-set! parsers (car c)
+                                (make-composite-parser p-list))))
+           classes))
+         ((not (string=? (value-at* result 4 pos #f) "0")) ; Domain type?
+          (let* ((basetype-oid (string->number (value-at* result 4 pos #f)))
+                 (parser (hash-table-ref/default parsers basetype-oid #f))
+                 (oid (string->number (value-at* result 0 pos #f))))
+            (dissect-types (if parser
+                               unknown-oids
+                               (cons basetype-oid unknown-oids))
+                           (add1 pos) (cons (cons oid basetype-oid) domains)
+                           arrays classes last-class)))
+         ((string=? (value-at* result 5 pos #f) "0") ; Array value?
+          (let* ((elem (string->number (value-at* result 2 pos #f)))
+                 (delim (string-ref (value-at* result 3 pos #f) 0))
+                 (parser (hash-table-ref/default parsers elem #f))
+                 (oid (string->number (value-at* result 0 pos #f))))
+            (dissect-types (if parser
+                               unknown-oids
+                               (cons elem unknown-oids))
+                           (add1 pos) domains
+                           (cons (cons oid (cons delim elem)) arrays)
+                           classes last-class)))
+         ((string=? (value-at* result 1 pos #f) "c") ; Class? (i.e., table or type)
+          (let* ((classid (string->number (value-at* result 6 pos #f)))
+                 (attrid (string->number (value-at* result 7 pos #f)))
+                 (parser (hash-table-ref/default parsers attrid #f)))
+            (dissect-types (if parser
+                               unknown-oids
+                               (cons attrid unknown-oids))
+                           (add1 pos) domains arrays
+                           ;; Keep oid at the front of the list, insert this
+                           ;; attr after it, before the other attrs, if any.
+                           (if (= last-class classid)
+                               (cons (cons (caar classes)
+                                           (cons attrid (cdar classes)))
+                                     (cdr classes))
+                               (cons (cons (string->number
+                                            (value-at* result 0 pos #f))
+                                           (list attrid)) classes))
+                           classid)))
+         (else
+          (dissect-types unknown-oids (add1 pos)
+                         domains arrays classes last-class)))))))
+
+(define (make-value-parsers conn pqresult #!key raw)
+  (let* ((nfields (PQnfields pqresult))
+         (parsers (make-vector nfields))
+         (ht (pg-connection-oid-parsers conn)))
+    (let loop ((col 0)
+               (unknowns (list)))
+      (if (= col nfields)
+          (begin
+            (resolve-unknown-types! conn (map cdr unknowns))
+            (for-each (lambda (unknown)
+                        (let* ((col (car unknown))
+                               (oid (cdr unknown))
+                               (parser (hash-table-ref/default ht oid identity)))
+                          (vector-set! parsers col parser)))
+                      unknowns)
+            parsers)
+          (let* ((oid (PQftype pqresult col))
+                 (parser (if raw identity (hash-table-ref/default ht oid #f))))
+            (vector-set! parsers col parser)
+            (loop (add1 col) (if parser
+                                 unknowns
+                                 (cons (cons col oid) unknowns))))))))
+
+;; Collect the result pointers from the last query.
+;;
+;; A pgresult represents an entire resultset and is always read into memory
+;; all at once.
+(define (get-last-result conn #!key raw)
+  (buffer-available-input! conn)
+  (let* ((conn-ptr (pg-connection-ptr conn))
+         ;; Read out all remaining results (including the current one).
+         ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
+         ;; but ostensibly only to concatenate the error messages for
+         ;; each query.  OTOH, maybe we want to do that, too.
+         (clean-results! (lambda (result)
+                           (let loop ((result result))
+                             (when result
+                               (PQclear result)
+                               (loop (PQgetResult conn-ptr))))))
+         (result (PQgetResult conn-ptr))
+         (status (PQresultStatus result)))
+    (cond
+     ((not result) (postgresql-error
+                    'internal 'get-last-result
+                    "Internal error! No result object available from server"
+                    conn))
+     ((member status (list PGRES_BAD_RESPONSE PGRES_FATAL_ERROR
+                           PGRES_NONFATAL_ERROR))
+      (let* ((error-field (lambda (f) (and f (PQresultErrorField result f))))
+             (error-field/int (lambda (f)
+                                (and-let* ((value (error-field f)))
+                                  (string->number value))))
+             (sqlstate (error-field PG_DIAG_SQLSTATE))
+             (maybe-severity (error-field PG_DIAG_SEVERITY))
+             (condition
+              (make-pg-condition
+               (make-property-condition
+                'query
+                'severity (and maybe-severity
+                               (string->symbol
+                                (string-downcase maybe-severity)))
+                'error-class        (and sqlstate (string-take sqlstate 2))
+                'error-code         sqlstate
+                'message-primary    (error-field PG_DIAG_MESSAGE_PRIMARY)
+                'message-detail     (error-field PG_DIAG_MESSAGE_DETAIL)
+                'message-hint       (error-field PG_DIAG_MESSAGE_HINT)
+                'statement-position (error-field/int PG_DIAG_STATEMENT_POSITION)
+                'context            (error-field PG_DIAG_CONTEXT)
+                'source-file        (error-field PG_DIAG_SOURCE_FILE)
+                'source-line        (error-field/int PG_DIAG_SOURCE_LINE)
+                'source-function    (error-field PG_DIAG_SOURCE_FUNCTION)
+                'internal-query     (error-field PG_DIAG_INTERNAL_QUERY)
+                'internal-position  (error-field/int PG_DIAG_INTERNAL_POSITION)
+                'schema-name        (error-field PG_DIAG_SCHEMA_NAME)
+                'table-name         (error-field PG_DIAG_TABLE_NAME)
+                'column-name        (error-field PG_DIAG_COLUMN_NAME)
+                'datatype-name      (error-field PG_DIAG_DATATYPE_NAME)
+                'constraint-name    (error-field PG_DIAG_CONSTRAINT_NAME))
+               'get-last-result
+               (PQresultErrorMessage result))))
+        (clean-results! result)
+        (signal condition)))
+     ((member status (list PGRES_COPY_OUT PGRES_COPY_IN))
+      ;; These are weird; A COPY puts the connection in "copy mode".
+      ;; As long as it's in "copy mode", pqgetresult will return the
+      ;; same result every time you call it, so don't try to call
+      ;; clean-results!
+      (let ((result-obj (make-pg-result result #f)))
+        (set-finalizer! result-obj clear-result!)
+        result-obj))
+     ((member status (list PGRES_EMPTY_QUERY PGRES_COMMAND_OK PGRES_TUPLES_OK))
+      (let ((result-obj (make-pg-result result #f)))
+        (set-finalizer! result-obj clear-result!)
+        (let ((trailing-result (PQgetResult conn-ptr)))
+          (when trailing-result
+            (clean-results! trailing-result)
+            (postgresql-error 'internal 'get-last-result
+                              (conc "Internal error! Unexpected extra "
+                                    "results after first query result")
+                              conn)))
+        (pg-result-value-parsers-set!
+         result-obj (make-value-parsers conn result raw: raw))
+        result-obj))
+     (else
+      (postgresql-error 'internal 'get-last-result
+                        (conc "Internal error! Unknown status code: " status)
+                        conn)))))
+
+(define (query conn query . params)
+  (query* conn query params))
+
+(define (query* conn query #!optional (params '()) #!key (format 'text) raw)
+  (let* ((params ;; Check all params and ensure they are proper pairs
+          (map (lambda (p)
+                 (let ((obj (if raw p (scheme-value->db-value conn p))))
+                   (cond ((string? obj) ; Convert to ASCIIZ
+                          (let* ((len (##sys#size obj))
+                                 (res (string-append obj "\x00")))
+                            (vector 0 len res)))
+                         ((blob? obj)
+                          (vector 1 (##sys#size obj) obj))
+                         ((sql-null? obj) #f)
+                         (else (postgresql-error
+                                'type 'query*
+                                (sprintf "Param value is not string, sql-null or blob: ~S" p)
+                                conn query params format)))))
+               params))
+         ;; It's a shame we need to traverse params twice (and again in C)...
+         (len (length params))
+         (send-query
+          (foreign-lambda*
+              bool ((pgconn* conn) (nonnull-c-string query)
+                    (bool is_prepped) (int num) (scheme-object params)
+                    (scheme-pointer valsbuf) (scheme-pointer lensbuf)
+                    (scheme-pointer fmtsbuf) (int rfmt))
+            "int i = 0, *lens = (int *)lensbuf, *fmts = (int *)fmtsbuf;"
+            "const char **vals = (const char **)valsbuf;"
+            "C_word obj, cons;"
+            "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
+            "    obj = C_u_i_car(cons);"
+            "    if (obj == C_SCHEME_FALSE) {"
+            "        fmts[i] = lens[i] = 0;"
+            "        vals[i] = NULL;"
+            "    } else {"
+            "        fmts[i] = C_unfix(C_block_item(obj, 0));"
+            "        lens[i] = C_unfix(C_block_item(obj, 1));"
+            "        vals[i] = C_c_string(C_block_item(obj, 2));"
+            "    }"
+            "}"
+            "if (is_prepped)"
+            "  C_return(PQsendQueryPrepared((PGconn *)conn, query, num,"
+            "                               vals, lens, fmts, rfmt));"
+            "else"
+            "  C_return(PQsendQueryParams((PGconn *)conn, query, num, NULL,"
+            "                             vals, lens, fmts, rfmt));"))
+         (query-as-string (if (symbol? query) (symbol->string query) query)))
+    ;; XXX: What if we're using a newer protocol version?  Then this error is
+    ;; well-meaning but completely wrong...  Unfortunately the error message
+    ;; returned by the server if we exceed this limit is even more confusing.
+    (cond ((> len 65535)
+           (postgresql-error
+            'domain 'query*
+            (sprintf "Too many bind parameters (PG protocol supports up to 65535, but got ~A).  Try using the COPY support, or escaping the data and sending it as a big string." len)
+            conn query params format))
+          ((send-query (pg-connection-ptr conn) query-as-string (symbol? query)
+                       len params
+                       ;; We allocate here instead of in C to keep things simple
+                       (make-blob (* len (foreign-value "sizeof(char *)" int)))
+                       (make-blob (* len (foreign-value "sizeof(int)" int)))
+                       (make-blob (* len (foreign-value "sizeof(int)" int)))
+                       (symbol->format format))
+           (get-last-result conn raw: raw))
+          (else (postgresql-error 'i/o 'query*
+                                  (conc "Unable to send query to server: "
+                                        (PQerrorMessage (pg-connection-ptr conn)))
+                                  conn query params format)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Transaction management
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (with-transaction conn thunk #!key isolation access)
+  (let* ((old-depth (pg-connection-transaction-depth conn))
+         (isolation (and isolation
+                         (case isolation
+                           ((read-committed) "ISOLATION LEVEL READ COMMITTED")
+                           ((serializable) "ISOLATION LEVEL SERIALIZABLE")
+                           (else (postgresql-error
+                                  'type 'with-transaction
+                                  "Unknown isolation level" isolation)))))
+         (access (and access
+                      (case access
+                        ((read/write) "READ WRITE")
+                        ((read-only) "READ ONLY")
+                        (else (postgresql-error
+                               'type 'with-transaction
+                               "Unknown access mode" access)))))
+         (characteristics (conc (or isolation "") " " (or access "")))
+         (rollback!
+          (lambda ()
+            (if (zero? old-depth)
+                (query conn "ROLLBACK")
+                ;; We do not *need* to give savepoints unique names,
+                ;; but it aids debugging and we know the depth anyway.
+                (query conn (conc "ROLLBACK TO SAVEPOINT s_" old-depth)))))
+         (commit!
+          (lambda ()
+            (if (zero? old-depth)
+                (query conn "COMMIT")
+                (query conn (conc "RELEASE SAVEPOINT s_" old-depth))))))
+    (when (and isolation (not (zero? old-depth)))
+      (postgresql-error
+       'domain 'with-transaction
+       "Can't set isolation level in nested transactions" isolation))
+    (if (zero? old-depth)
+        (query conn (conc "BEGIN " characteristics))
+        (begin (query conn (conc "SAVEPOINT s_" old-depth))
+               ;; XXX: This should probably be SET LOCAL instead of SET
+               ;; (which is implicitly the same as SET SESSION), but I
+               ;; can't come up with a testcase that fails with this and
+               ;; succeeds with SET LOCAL, so keep it around for now.
+               (when access
+                 (query conn (conc "SET TRANSACTION " characteristics)))))
+    (pg-connection-transaction-depth-set! conn (add1 old-depth))
+    ;; TODO: Add a warning mechanism (using dynamic-wind) for when the
+    ;; user tries to jump into/out of transactions with continuations?
+    (handle-exceptions exn
+        (begin
+          (pg-connection-transaction-depth-set! conn old-depth)
+          (rollback!)
+          (raise exn))
+      (let ((res (thunk)))
+        (pg-connection-transaction-depth-set! conn old-depth)
+        (if res (commit!) (rollback!))
+        res))))
+
+(define (in-transaction? conn)
+  (> (pg-connection-transaction-depth conn) 0))
+
+;;;;;;;;;;;;;;;;;;;;
+;;;; COPY support
+;;;;;;;;;;;;;;;;;;;;
+
+(define (put-copy-data conn data)
+  (let* ((data (cond
+                ((or (string? data) (blob? data)) data)
+                ((srfi-4-vector? data) (##sys#slot data 1))
+                (else (postgresql-error
+                       'type 'put-copy-data
+                       "Expected a blob, string or srfi-4 vector" conn data))))
+         (len (##sys#size data))
+         (conn-ptr (pg-connection-ptr conn))
+         (conn-fd (pgsql-connection->fd conn)))
+    (let loop ((res (PQputCopyData conn-ptr data len)))
+      (cond
+       ((= res 0)
+        (thread-wait-for-i/o! conn-fd #:output)
+        (loop (PQputCopyData conn-ptr data len)))
+       ((= res 1) (void))
+       ((= res -1)
+        (postgresql-error
+         'i/o 'put-copy-data
+         (conc "Error putting COPY data: " (PQerrorMessage conn-ptr)) conn))
+       (else (postgresql-error
+              'internal 'put-copy-data
+              (conc "Internal error! Unexpected return value: " res) conn))))))
+
+(define (put-copy-end conn #!optional error-message)
+  (let ((conn-ptr (pg-connection-ptr conn))
+        (conn-fd (pgsql-connection->fd conn)))
+    (let loop ((res (PQputCopyEnd conn-ptr error-message)))
+      (cond
+       ((= res 0)
+        (thread-wait-for-i/o! conn-fd #:output)
+        (loop (PQputCopyEnd conn-ptr error-message)))
+       ((= res 1) (get-last-result conn))
+       ((= res -1)
+        (postgresql-error
+         'i/o 'put-copy-end
+         (conc "Error ending put COPY data: " (PQerrorMessage conn-ptr))
+         conn error-message))
+       (else
+        (postgresql-error
+         'internal 'put-copy-end
+         (conc "Internal error! Unexpected return value: " res) conn))))))
+
+(define (get-copy-data conn #!key (format 'text))
+  (let ((conn-ptr (pg-connection-ptr conn)))
+    (let loop ()
+      (let-location ((buf c-pointer))
+        (let ((res (PQgetCopyData conn-ptr (location buf) #t)))
+          (cond
+           ((> res 0)
+            (let ((value (case format
+                           ((text) (make-string res))
+                           ((binary) (make-blob res))
+                           (else (postgresql-error
+                                  'internal 'get-copy-data
+                                  (conc "Unknown column format type: " format)
+                                  conn)))))
+              (memcpy value buf res)
+              (free buf)
+              value))
+           ((= res 0)
+            (buffer-available-input! conn)
+            (loop))
+           ((= res -1)
+            (get-last-result conn))
+           ((= res -2)
+            (postgresql-error
+             'i/o 'get-copy-data
+             (conc "Error getting COPY data: " (PQerrorMessage conn-ptr)) conn))
+           (else (postgresql-error
+                  'internal 'get-copy-data
+                  (conc "Internal error! Unexpected return value: " res)
+                  conn))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Value escaping and quotation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (escape-string conn str)
+  (define %escape-string-conn
+    (foreign-lambda size_t PQescapeStringConn
+      pgconn* scheme-pointer scheme-pointer size_t (c-pointer bool)))
+  (let-location ((err bool))
+    (let* ((strlen (string-length str))
+           (buflen (add1 (* strlen 2)))
+           (buffer (make-string buflen))
+           (conn-ptr (pg-connection-ptr conn))
+           (size (%escape-string-conn conn-ptr buffer str strlen (location err))))
+      (cond (err (postgresql-error 'internal 'escape-string
+                                   (conc "String escaping failed. "
+                                         (PQerrorMessage conn-ptr)) conn str))
+            ((= size buflen) buffer)
+            (else (##sys#substring buffer 0 size))))))
+
+(define (quote-identifier conn str)
+  (cond-expand
+    (has-escape-identifier
+     (define %escape-ident
+       (foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t))
+     (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
+         (postgresql-error 'internal 'quote-identifier
+                           (conc "Identifier escaping failed: "
+                                 (PQerrorMessage (pg-connection-ptr conn)))
+                           conn str)))
+    (else (postgresql-error 'unsupported-version 'quote-identifier
+                            (conc "Please upgrade your PostgreSQL to 9.0 or later "
+                                  "in order to be able to use quote-identifier!")
+                            conn str))))
+
+(define (escape-bytea conn obj)
+  (define %escape-bytea-conn
+    (foreign-lambda (c-pointer unsigned-char) PQescapeByteaConn
+      pgconn* scheme-pointer size_t (c-pointer size_t)))
+  (let-location ((allocated size_t))
+    (let* ((data (cond ((or (string? obj) (blob? obj)) obj)
+                       ((srfi-4-vector? obj) (##sys#slot obj 1))
+                       (else (postgresql-error
+                              'type 'escape-bytea
+                              "Expected string, blob or srfi-4 vector" obj))))
+           (conn-ptr (pg-connection-ptr conn))
+           (buf (%escape-bytea-conn
+                 conn-ptr data (##sys#size data) (location allocated))))
+      (if buf
+          (let* ((string-length (sub1 allocated))
+                 (result-string (make-string string-length)))
+            (memcpy result-string buf string-length)
+            (free buf)
+            result-string)
+          (postgresql-error
+           'internal 'escape-bytea
+           (conc "Byte array escaping failed: " (PQerrorMessage conn-ptr))
+           conn obj)))))
+
+(define (unescape-bytea str)
+  (define %unescape-bytea
+    (foreign-lambda (c-pointer unsigned-char) PQunescapeBytea c-string (c-pointer size_t)))
+  (let-location ((blob-length size_t))
+    (let ((buf (%unescape-bytea str (location blob-length))))
+      (if buf 
+          (let ((result-blob (make-blob blob-length)))
+            (memcpy result-blob buf blob-length)
+            (free buf)
+            (blob->u8vector/shared result-blob))
+          (postgresql-error 'internal 'unescape-bytea
+                            "Byte array unescaping failed (out of memory?)" str)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; High-level interface
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (make-result-fold item-count sub-item-count extract-item)
+  (lambda (kons knil result)
+    (let ((items (item-count result))
+          (sub-items (sub-item-count result)))
+      (let loop ((seed knil)
+                 (item 0))
+        (if (= item items)
+            seed
+            (loop (kons (extract-item result item sub-items #f) seed) (add1 item)))))))
+
+(define row-fold (make-result-fold row-count column-count row-values*))
+(define (row-fold* kons knil result)
+  (row-fold (lambda (values seed)
+              (apply kons (append values (list seed)))) knil result))
+
+(define column-fold (make-result-fold column-count row-count column-values*))
+(define (column-fold* kons knil result)
+  (column-fold (lambda (values seed)
+                 (apply kons (append values (list seed)))) knil result))
+
+
+(define (make-result-fold-right item-count sub-item-count extract-item)
+  (lambda (kons knil result)
+    (let ((sub-items (sub-item-count result)))
+      (let loop ((seed knil)
+                 (item (item-count result)))
+        (if (= item 0)
+            seed
+            (loop (kons (extract-item result (sub1 item) sub-items #f) seed) (sub1 item)))))))
+
+(define row-fold-right (make-result-fold-right row-count column-count row-values*))
+(define (row-fold-right* kons knil result)
+  (row-fold-right (lambda (values seed)
+                    (apply kons (append values (list seed)))) knil result))
+
+(define column-fold-right (make-result-fold-right column-count row-count column-values*))
+(define (column-fold-right* kons knil result)
+  (column-fold-right (lambda (values seed)
+                       (apply kons (append values (list seed)))) knil result))
+
+
+(define (row-for-each proc result)
+  (row-fold (lambda (values seed) (proc values)) #f result)
+  (void))
+(define (row-for-each* proc result)
+  (row-fold (lambda (values seed) (apply proc values)) #f result)
+  (void))
+
+(define (column-for-each proc result)
+  (column-fold (lambda (values seed) (proc values)) #f result)
+  (void))
+(define (column-for-each* proc result)
+  (column-fold (lambda (values seed) (apply proc values)) #f result)
+  (void))
+
+;; Like regular Scheme map, the order in which the procedure is applied is
+;; undefined.  We make good use of that by traversing the resultset from
+;; the end back to the beginning, thereby avoiding a reverse! on the result.
+(define (row-map proc res)
+  (row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res))
+(define (row-map* proc res)
+  (row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res))
+(define (column-map proc res)
+  (column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res))
+(define (column-map* proc res)
+  (column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res))
+
+(define (result-format result)
+  (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
+                   (pg-result-ptr result)))
+      'binary 'text))
+
+(define (copy-query*-fold kons knil conn query
+                          #!optional (params '()) #!key (format 'text) raw)
+  (let* ((result (query* conn query params format: format raw: raw))
+         (data-format (result-format result)))
+    (handle-exceptions exn
+        (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
+      (let loop ((data (get-copy-data conn format: data-format))
+                 (seed knil))
+        (if (result? data)
+            seed
+            ;; Explicit ordering; data could be _very_ big, allow one to be GCed
+            (let ((next (kons data seed)))
+              (loop (get-copy-data conn format: data-format) next)))))))
+
+(define (copy-query-fold kons knil conn query . params)
+  (copy-query*-fold kons knil conn query params))
+
+
+;; This is slow and memory-intensive if data is big. Provided for completeness
+(define (copy-query*-fold-right kons knil conn query
+                                #!optional (params '()) #!key (format 'text) raw)
+  (let* ((result (query* conn query params format: format raw: raw))
+         (data-format (result-format result)))
+    (handle-exceptions exn
+        (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
+      (let loop ((data (get-copy-data conn format: data-format)))
+        (if (result? data)
+            knil
+            (kons data (loop (get-copy-data conn format: data-format))))))))
+
+(define (copy-query-fold-right kons knil conn query . params)
+  (copy-query*-fold-right kons knil conn query params))
+
+
+(define (copy-query*-map proc conn query
+                         #!optional (params '()) #!key (format 'text) raw)
+  (reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed))
+                              '() conn query params format: format raw: raw)))
+
+(define (copy-query-map proc conn query . params)
+  (copy-query*-map proc conn query params))
+
+
+(define (copy-query*-for-each proc conn query
+                              #!optional (params '()) #!key (format 'text) raw)
+  (copy-query*-fold (lambda (data seed) (proc data))
+                    #f conn query params format: format raw: raw)
+  (void))
+
+(define (copy-query-for-each proc conn query . params)
+  (copy-query*-for-each proc conn query params))
+
+;; A bit of a weird name but consistent
+(define (call-with-output-copy-query*
+         proc conn query #!optional (params '()) #!key (format 'text) raw)
+  (query* conn query params format: format raw: raw)
+  (let* ((closed? #f)
+         (output-port (make-output-port
+                       (lambda (data) (put-copy-data conn data))
+                       (lambda () (put-copy-end conn) (set! closed? #t)))))
+    (handle-exceptions exn
+        (if closed?
+            (raise exn)
+            (handle-exceptions _
+                (raise exn)
+              ;; Previously written data will be discarded to guarantee atomicity
+              (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
+      (call-with-values (lambda () (proc output-port))
+        (lambda args
+          (unless closed? (put-copy-end conn))
+          (apply values args))))))
+
+(define (call-with-output-copy-query proc conn query . params)
+  (call-with-output-copy-query* proc conn query params))
+
+(define (with-output-to-copy-query*
+         thunk conn query #!optional (params '()) #!key (format 'text) raw)
+  (call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk))
+                                conn query params format: format raw: raw))
+
+(define (with-output-to-copy-query thunk conn query . params)
+  (with-output-to-copy-query* thunk conn query params))
+
+)
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..0469929
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,949 @@
+(import (chicken blob)
+        (chicken condition)
+        (chicken string)
+        test
+        postgresql
+        sql-null
+        srfi-4)
+
+(define-syntax test-error*
+  (syntax-rules ()
+    ((_ ?msg (?error-type ...) ?expr)
+     (let-syntax ((expression:
+                   (syntax-rules ()
+                     ((_ ?expr)
+                      (condition-case (begin ?expr "<no error thrown>")
+                                      ((?error-type ...) '(?error-type ...))
+                                      (exn () (##sys#slot exn 1)))))))
+       (test ?msg '(?error-type ...) (expression: ?expr))))
+    ((_ ?msg ?error-type ?expr)
+     (test-error* ?msg (?error-type) ?expr))
+    ((_ ?error-type ?expr)
+     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
+
+;; Perform a quick sanity check before running the actual tests
+(condition-case (disconnect (connect '((dbname . test))))
+  (exn (exn postgresql connect)
+       (print "Could not connect to server.  Please ensure that the UNIX "
+              "user running these tests is allowed to connect to a database "
+              "with the name \"test\".  Error from Postgres:")
+       (print ((condition-property-accessor 'exn 'message) exn))
+       (test-exit)))
+
+(test-begin "postgresql")
+
+(test-group "connection management"
+  (test "connect returns a connected connection"
+        '(#t #t)
+        (let* ((conn (connect '((dbname . test))))
+               (isconn (connection? conn))
+               (connected (connected? conn)))
+          (disconnect conn)
+          (list isconn connected)))
+  (test "disconnect causes connection to be disconnected"
+        '(#t #f)
+        (let ((conn (connect '((dbname . test)))))
+          (disconnect conn)
+          (list (connection? conn) (connected? conn))))
+  (test-error "cannot connect with invalid credentials"
+              (connect '((dbname . does-not-exist)
+                         (username . nobody))))
+  (test-error "disconnect invalidates the connection"
+              (let ((conn (connect '((dbname . test)))))
+                (disconnect conn)
+                (reset-connection conn)))
+  ;; It would be nice if we could test some more error cases here but
+  ;; that's hard to do
+  )
+
+;; From now on, just keep using the same connection
+(define conn (connect '((dbname . test))))
+
+;; In the tests, we assume that the client lib is at least equal to
+;; the server's version.
+(define-values (major-version minor-version micro-version)
+  (apply values
+         (map string->number
+              (string-split
+               (value-at (query conn "SHOW server_version")) "."))))
+
+(test-group "low-level interface"
+  (test-assert "query returns result"
+               (result? (query conn "SELECT 1")))
+  (test "Correct row count"
+        2
+        (row-count (query conn "SELECT 1 UNION SELECT 2")))
+  (test "Correct column count"
+        4
+        (column-count (query conn "SELECT 1, 2, 3, 4")))
+  (test "Correct column name"
+        'one
+        (column-name
+         (query conn "SELECT 1 AS one, 2 AS two") 0))
+  (test "Correct column names"
+        '(one two)
+        (column-names
+         (query conn "SELECT 1 AS one, 2 AS two")))
+  (test-error* "Condition for nonexistant column index"
+               (exn postgresql bounds)
+               (column-name
+                (query conn "SELECT 1 AS one, 2 AS two") 3))
+  (test "Not false for nameless column"
+        #f ;; Could check for ?column?, but that's a bit too specific
+        (not (column-name
+              (query conn "SELECT 1, 2") 0)))
+  ;; Maybe add a few tests here for case folding/noncase folding variants?
+  ;; Perhaps column-index-ci vs column-index?  That would be
+  ;; misleading though, since column-index-ci isn't really ci,
+  ;; it will not match columns that are explicitly uppercased in the query.
+  (test "Correct column index"
+        0
+        (column-index
+         (query conn "SELECT 1 AS one, 2 AS two") 'one))
+  (test "False column index for nonexistant column name"
+        #f
+        (column-index
+         (query conn "SELECT 1 AS one, 2 AS two") 'foo))
+  (test "False oid for virtual table"
+        #f
+        (table-oid
+         (query conn "SELECT 1 AS one, 2 AS two") 0))
+  (test-assert "Number for nonvirtual table"
+               (number?
+                (table-oid
+                 (query conn "SELECT typlen FROM pg_type") 0)))
+  
+  (test-error* "Condition for column index out of bounds"
+               (exn postgresql bounds)
+               (table-oid
+                (query conn "SELECT typname FROM pg_type") 1))
+  (test "Table column number for real table"
+        0
+        (table-column-index
+         (query conn "SELECT typname FROM pg_type") 0))
+  (test "Column format is text for normal data"
+        'text
+        (column-format
+         (query conn "SELECT 'hello'") 0))
+  
+  (test "Column format is binary for forced binary data"
+        'binary
+        (column-format
+         (query* conn "SELECT 1" '() format: 'binary) 0))
+  
+  (test "Column type OID ok"
+        23 ;; from catalog/pg_type.h
+        (column-type
+         (query conn "SELECT 1::int4") 0))
+  (test "Column modifier false"
+        #f
+        (column-type-modifier
+         (query conn "SELECT 1") 0))
+  (test "Column modifier for bit ok"
+        2
+        (column-type-modifier
+         (query conn "SELECT '10'::bit(2)") 0))
+  (test "Result value string for strings"
+        "test"
+        (value-at (query conn "SELECT 'test'")))
+  (test "Result value string for 'name' type (with no custom parser)"
+        "test"
+        (value-at (query conn "SELECT 'test'::name")))
+  (test "Result row values"
+        '("one" "two")
+        (row-values
+         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
+  (test "Result row values for second row"
+        '("three" "four")
+        (row-values
+         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1))
+  (test "Result row alist"
+        '((a . "one") (b . "two"))
+        (row-alist
+         (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 0))
+  (test "Result row alist for second row"
+        '((a . "three") (b . "four"))
+        (row-alist
+         (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 1))
+  (test "Result column values"
+        '("one" "three")
+        (column-values
+         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
+  (test "Result column values for second column"
+        '("two" "four")
+        (column-values
+         (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1))
+  (test "Result value number for numbers"
+        1
+        (value-at (query conn "SELECT 1")))
+  (test "Result value string for raw numbers"
+        "1"
+        (value-at (query conn "SELECT 1") 0 0 raw: #t))
+  ;; We are using two levels of escaping here because the ::bytea cast
+  ;; performs another string interpretation. Yes, this is kinda confusing...
+  (test "Result value for null-terminated byte array"
+        (blob->u8vector (string->blob "h\x00ello"))
+        (value-at (query conn "SELECT E'h\\\\000ello'::bytea")))
+  
+  (test "Result value for raw null-terminated byte array"
+        (if (>= major-version 9)
+            "\\x6800656c6c6f"
+            "h\\000ello")
+        (value-at (query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
+
+  (test "Result value blob for binary string"
+        (string->blob "hello")
+        (value-at (query* conn "SELECT 'hello'" '() format: 'binary)))
+  
+  (test "Result value blob for binary integer"
+        (u8vector->blob (u8vector 0 0 0 1))
+        (value-at (query* conn "SELECT 1::int4" '() format: 'binary)))
+
+  (test "Result value for binary string with NUL bytes"
+        (string->blob "h\x00ello")
+        (value-at (query* conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary)))
+
+  (test "Result value for array of integers"
+        `#(1 ,(sql-null) 3) ;; Not sure if comparing sql-null is kosher
+        (value-at (query conn "SELECT array[1, null, 3]")))
+
+  (test "Result value for nested array of ints"
+        `#(#(1 ,(sql-null) 3)
+           #(4 5 ,(sql-null))) ;; Not sure if comparing sql-null is kosher
+        (value-at
+         (query conn "SELECT array[array[1, null, 3], array[4, 5, NULL]]")))
+  
+  (test "Result value for array of strings"
+        `#("a" ,(sql-null) "c") ;; Not sure if comparing sql-null is kosher
+        (value-at (query conn "SELECT array['a', null, 'c']")))
+
+  (test "Result value for nested array of strings"
+        `#(#("a" ,(sql-null) "c")
+           #("NULL" "e" ,(sql-null))) ;; Not sure if comparing sql-null is kosher
+        (value-at (query conn "SELECT array[array['a', null, 'c'], array['NULL', 'e', NULL]]")))
+  
+  (test "Result value at row 0, column 1"
+        2
+        (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 1 0))
+  (test "Result value at row 1, column 0"
+        3
+        (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 0 1))
+  (test-assert "Result value sql-null for NULL"
+               (sql-null? (value-at (query conn "SELECT NULL"))))
+  (test-error* "Result value error for out of bounds row"
+               (exn postgresql bounds)
+               (value-at (query conn "SELECT NULL") 0 1))
+  (test-error* "Result value error for out of bounds column"
+               (exn postgresql bounds)
+               (value-at (query conn "SELECT NULL") 1 0))
+
+  (query conn "PREPARE foo (int) AS (SELECT 1, 2, $1)")
+  (test-assert "query with prepared statement name returns result"
+               (result? (query conn 'foo 3)))
+  (test "result value ok for query with prepared statement name"
+        '(1 2 3)
+        (row-values (query conn 'foo 3)))
+  (test-error* "condition for missing parameter names"
+               (exn postgresql query)
+               (query conn 'foo))
+
+  (query conn "BEGIN")
+  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+  (test "Number of affected rows 1 with INSERT"
+        1
+        (affected-rows
+         (query conn "INSERT INTO foo (bar) VALUES (1);")))
+  (query conn "COMMIT")
+
+  (query conn "BEGIN")
+  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+  (query conn "INSERT INTO foo (bar) VALUES (100);")
+  (query conn "INSERT INTO foo (bar) VALUES (101);")
+  (test "Number of affected rows 2 with UPDATE of two rows"
+        2
+        (affected-rows
+         (query conn "UPDATE foo SET bar=102;")))
+  (query conn "COMMIT")
+  
+  (test "Inserted OID false on SELECT"
+        #f
+        (inserted-oid
+         (query conn "SELECT 1")))
+
+  (query conn "BEGIN")
+  (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+  (test "Inserted OID false on OID-less table"
+        #f
+        (inserted-oid
+         (query conn  "INSERT INTO foo (bar) VALUES (1);")))
+  (query conn "COMMIT")
+  
+  (query conn "BEGIN")
+  (query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP")
+  (test-assert "Inserted OID number on table with OID"
+               (number?
+                (inserted-oid
+                 (query conn "INSERT INTO foo (bar) VALUES (1)"))))
+  (query conn "COMMIT")
+
+  (test "regular parameters"
+        "hi"
+        (value-at (query conn "SELECT $1::text" "hi") 0 0))
+  (test-assert "NULL parameters"
+               (sql-null? (value-at
+                           (query conn "SELECT $1::text" (sql-null)) 0 0)))
+  (test "blob parameters"
+        "hi"
+        (value-at (query conn "SELECT $1::text" (string->blob "hi")) 0 0))
+  (test "boolean parameters"
+        '(#t #f)
+        (row-values (query conn "SELECT $1::bool, $2::bool" #t #f)))
+  (test "integer array parameters"
+        `(#(1 2) #(,(sql-null) 4))
+        (row-values (query conn "SELECT $1::int[], $2::int[]"
+                           `#(1 2) `#(,(sql-null) 4))))
+  (test "nested integer array parameters"
+        `(#(#(1 2) #(,(sql-null) 4)))
+        (row-values (query conn "SELECT $1::int[][]"
+                           `#(#(1 2) #(,(sql-null) 4)))))
+  (test "string array parameters (including 'null')"
+        `(#("a" "b") #(,(sql-null) "null"))
+        (row-values (query conn "SELECT $1::text[], $2::text[]"
+                           `#("a" "b") `#(,(sql-null) "null"))))
+  (test "string array parameters with meta-characters"
+        `(#("a\\b" "c\"d") #("{" "}"))
+        (row-values (query conn "SELECT $1::text[], $2::text[]"
+                           '#("a\\b" "c\"d") '#("{" "}"))))
+  (test "nested string array parameters"
+        `(#(#("a" "b") #(,(sql-null) "null")))
+        (row-values (query conn "SELECT $1::text[][]"
+                           `#(#("a" "b") #(,(sql-null) "null")))))
+  (test "array bounds are ignored"
+        `#(#(#(1 2 3) #(4 5 6)))
+        (value-at
+         (query conn
+                "SELECT '[1:1][-2:-1][3:5]={{{1,2,3},{4,5,6}}}'::int[] AS f1")))
+
+  ;; Basic domains seem to return just their base type
+  (query conn "BEGIN")
+  (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 2)")
+  (test "basic domains"
+        3
+        (value-at (query conn "SELECT $1::mydom" 3)))
+  (query conn "ROLLBACK")
+  
+  (query conn "BEGIN")
+  (query conn "CREATE TYPE foo AS ( a integer, b text )")
+  (test "basic composite type"
+        `(1 "one")
+        (value-at (query conn "SELECT $1::foo" `(1 "one"))))
+  (test "composite type with meta-characters"
+        `(123 "\\backslash\"quote")
+        (value-at (query conn "SELECT $1::foo" `(123 "\\backslash\"quote"))))
+  (query conn "CREATE TYPE bar AS ( x foo, y integer )")
+  (test "Nested composite type"
+        `((2 "two") 3)
+        (value-at (query conn "SELECT $1::bar" `((2 "two") 3))))
+  (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 1)")
+  (query conn "CREATE TYPE qux AS ( i integer, d mydom )")
+  (test "Composite type containing domain value"
+        `(1 2)
+        (value-at (query conn "SELECT $1::qux" `(1 2))))
+  (query conn "ROLLBACK")
+
+  (test "anonymous composite type ('record')"
+        '("one" "two")
+        (value-at (query conn "SELECT ROW('one', 'two')")))
+
+  (test "anonymous composite type ('record') with NULL"
+        `("one" ,(sql-null))
+        (value-at (query conn "SELECT ROW('one', NULL)")))
+
+  ;; ROW() is indistinguishable from ROW(NULL).  The latter is more likely
+  ;; to occur than the former, so let's ensure that's how it's interpreted
+  ;; See also http://archives.postgresql.org/pgsql-hackers/2004-06/msg00159.php
+  (test "anonymous composite type ('record') with just one NULL"
+        `(,(sql-null))
+        (value-at (query conn "SELECT ROW(NULL)"))))
+
+(test-group "escaping and quotation"
+  (test-group "with standards conforming strings off"
+    (query conn "SET standard_conforming_strings='off'")
+    (test "String is escaped correctly"
+          "it''s \"this\" \\\\ safe!"
+          (escape-string conn "it's \"this\" \\ safe!"))
+    (test "Small string is escaped correctly"
+          "foo"
+          (escape-string conn "foo"))
+    (test "Bytea is escaped correctly (u8vector)"
+          (if (>= major-version 9)
+              "\\\\x576800617427730a75703f"
+              "Wh\\\\000at''s\\\\012up?")
+          (escape-bytea conn (blob->u8vector (string->blob "Wh\x00at's\nup?"))))
+    (test "Bytea is unescaped correctly (blob)"
+          (blob->u8vector (string->blob "What's\nup? "))
+          ;; The extra quote is dropped here because it wouldn't be returned
+          ;; by pgsql either.
+          (unescape-bytea "What's\\012up?\\ "))
+    (test "Identifier is escaped and quoted correctly"
+          ;; Backslashes have no special meaning in identifiers,
+          ;; standards conforming strings or no
+          "\"it's \"\"this\"\" \\ safe!\""
+          (quote-identifier conn "it's \"this\" \\ safe!")))
+  (test-group "with standards conforming strings on"
+    (query conn "SET standard_conforming_strings='on'")
+    (test "String is escaped correctly"
+          "it''s \"this\" \\ safe!"
+          (escape-string conn "it's \"this\" \\ safe!"))
+    (test "Bytea is escaped correctly"
+          (if (>= major-version 9)
+              "\\x576800617427730a75703f"
+              "Wh\\000at''s\\012up?")
+          (escape-bytea conn "Wh\x00at's\nup?"))
+    (test "Bytea is unescaped correctly"
+          (blob->u8vector (string->blob "What's\nup? "))
+          ;; The extra quote is dropped here because it wouldn't be returned
+          ;; by pgsql either.
+          (unescape-bytea "What's\\012up?\\ "))
+    (test "Identifier is escaped and quoted correctly"
+          ;; Backslashes have no special meaning in identifiers,
+          ;; standards conforming strings or no
+          "\"it's \"\"this\"\" \\ safe!\""
+          (quote-identifier conn "it's \"this\" \\ safe!"))))
+
+(test-group "query error handling"
+  (test-group "basic info: position and code"
+    (handle-exceptions exn
+        (begin (test "Class of real query error is available and set to expected value"
+                     "42"
+                     ((condition-property-accessor 'query 'error-class) exn))
+               (test "Code of real query error is available and set to expected value"
+                     "42P01"            ; undefined_table
+                     ((condition-property-accessor 'query 'error-code) exn))
+               ;; We can't set locale w/o superuser rights, so we'll
+               ;; have to make do with an incomplete severity check.
+               (test-assert "Severity of real query error is a symbol"
+                            (symbol? ((condition-property-accessor
+                                       'query 'severity) exn)))
+               (test "Statement position in real query error is correct"
+                     15
+                     ((condition-property-accessor
+                       'query 'statement-position) exn)))
+      (query conn "SELECT 1 FROM nonexistant_table")
+      (error "query call didn't fail")))
+  (test-group "message and code"
+    (handle-exceptions exn
+        (begin (test "Error class is available and set to expected value"
+                     "42"
+                     ((condition-property-accessor 'query 'error-class) exn))
+               (test "Error code is available and set to expected value"
+                     "42P16"
+                     ((condition-property-accessor 'query 'error-code) exn))
+               ;; We can't set locale w/o superuser rights, so we'll
+               ;; have to make do with some neutered checks.
+               (test-assert "Severity is a symbol"
+                            (symbol? ((condition-property-accessor
+                                       'query 'severity) exn)))
+               (test "Message primary is set to the expected value"
+                     "testing, 1, 2, 3."
+                     ((condition-property-accessor 'query 'message-primary) exn))
+               (test "Detail is set to the expected value"
+                     "this is a test"
+                     ((condition-property-accessor 'query 'message-detail) exn))
+               (test "Hint is set to the expected value"
+                     "try again"
+                     ((condition-property-accessor 'query 'message-hint) exn))
+               ;; XXX These two may be too version-specific
+               (test "source function is set to the correct value"
+                     "exec_stmt_raise"
+                     ((condition-property-accessor 'query 'source-function) exn))
+               (test "source file is set to the the correct value"
+                     "pl_exec.c"
+                     ((condition-property-accessor 'query 'source-file) exn))
+               (test-assert "source line is available and a number"
+                            (number? ((condition-property-accessor
+                                       'query 'source-line) exn))))
+      (query conn (conc "CREATE OR REPLACE FUNCTION cause_error() "
+                        "RETURNS void AS $$\n"
+                        "  BEGIN\n"
+                        "    RAISE invalid_table_definition \n"
+                        "    USING MESSAGE = 'testing, 1, 2, 3.', \n"
+                        "          DETAIL = 'this is a test', \n"
+                        "          HINT = 'try again';\n"
+                        "  END;\n"
+                        "$$ LANGUAGE plpgsql"))
+      (value-at (query conn "SELECT cause_error()"))
+      (error "query call didn't fail")))
+  (when (or (> major-version 9) (and (= major-version 9) (>= minor-version 3)))
+    (test-group "schema information"
+      (query conn "BEGIN")
+      (query conn (conc "CREATE DOMAIN posint AS int"
+                        " CONSTRAINT must_be_positive CHECK (VALUE > 0)"))
+      (query conn (conc "CREATE TEMP TABLE foo (bar posint) ON COMMIT DROP"))
+      (handle-exceptions exn
+          (begin (test-assert "Schema name is set" ; It is pg_temp_2
+                              ((condition-property-accessor
+                                'query 'schema-name) exn))
+                 (test "Data type name is correct"
+                       "posint"
+                       ((condition-property-accessor 'query 'datatype-name) exn))
+                 (test "Constraint name is correct"
+                       "must_be_positive"
+                       ((condition-property-accessor 'query 'constraint-name) exn)))
+        (query conn "INSERT INTO foo (bar) VALUES (-1)")
+        (error "query call didn't fail"))
+      (query conn "ROLLBACK")
+      (query conn "BEGIN")
+      (query conn (conc "CREATE TEMP TABLE foo (bar int NOT NULL) "
+                        "ON COMMIT DROP"))
+      (handle-exceptions exn
+          (begin (test-assert "Schema name is set" ; It is pg_temp_2
+                              ((condition-property-accessor
+                                'query 'schema-name) exn))
+                 (test "Table name is correct"
+                       "foo"
+                       ((condition-property-accessor 'query 'table-name) exn))
+                 (test "Column name is correct"
+                       "bar"
+                       ((condition-property-accessor 'query 'column-name) exn)))
+        (query conn "INSERT INTO foo (bar) VALUES (NULL)")
+        (error "query call didn't fail"))
+      (query conn "ROLLBACK"))))
+
+(test-group "COPY support"
+  (query conn "CREATE TEMP TABLE copy_table ( nr integer, s text )")
+  (test-group "low-level interface"
+    (test-error* "Cannot put copy data while no COPY in progress"
+                 (exn postgresql i/o)
+                 (put-copy-data conn "whatever"))
+    (query conn "COPY copy_table (s, nr) FROM STDIN")
+    (test-error* "Cannot initiate new query while waiting for COPY input"
+                 (exn postgresql i/o)
+                 (query conn "SELECT 1"))
+    (put-copy-data conn "one\t1\n")
+    (test-error* "Cannot initiate new query while COPY data in progress"
+                 (exn postgresql i/o)
+                 (query conn "SELECT 1"))
+    (put-copy-data conn "two\t2")
+    (put-copy-end conn)
+    (let ((res (query conn "SELECT * FROM copy_table")))
+      (test "Simple copy from STDIN works"
+            '((1 "one")
+              (2 "two"))
+            (list (row-values res 0) (row-values res 1))))
+    (test-error* "Cannot get copy data while no COPY in progress"
+                 (exn postgresql i/o)
+                 (get-copy-data conn))
+    (query conn "COPY copy_table (s, nr) TO STDOUT")
+    (test-error* "Cannot initiate new query while waiting for COPY output"
+                 (exn postgresql i/o)
+                 (query conn "SELECT 1"))
+    (test "Simple copy to STDOUT works, first record"
+          "one\t1\n"
+          (get-copy-data conn))
+    (test-error* "Cannot initiate new query while reading COPY data"
+                 (exn postgresql i/o)
+                 (query conn "SELECT 1"))
+    (test "Simple copy to STDOUT works, second record"
+          "two\t2\n"
+          (get-copy-data conn))
+    (test-assert "EOF is marked by a result object"
+                 (result? (get-copy-data conn))))
+  (test-group "high-level interface"
+    (test "Mapping"
+          '(("one" "1")
+            ("two" "2"))
+          (copy-query-map string-split conn "COPY copy_table (s, nr) TO STDOUT"))
+    (test "Error while mapping gets connection out of COPY state"
+          "okay"
+          (handle-exceptions exn
+            (value-at (query conn "SELECT 'okay'"))
+            (copy-query-map (lambda _ (error "blah"))
+                            conn "COPY copy_table (s, nr) TO STDOUT")))
+    (test "Fold"
+          '(("one" "1")
+            ("two" "2"))
+          (reverse
+           (copy-query-fold
+            (lambda (data result)
+              (cons (string-split data) result))
+            '() conn "COPY copy_table (s, nr) TO STDOUT")))
+    (test "Error while folding gets connection out of COPY state"
+          "okay"
+          (handle-exceptions exn
+            (value-at (query conn "SELECT 'okay'"))
+            (copy-query-fold (lambda _ (error "blah"))
+                             '() conn "COPY copy_table (s, nr) TO STDOUT")))
+    (test "Fold-right"
+          '(("one" "1")
+            ("two" "2"))
+          (copy-query-fold-right
+           (lambda (data result)
+             (cons (string-split data) result))
+           '() conn "COPY copy_table (s, nr) TO STDOUT"))
+    (test "Error while folding right gets connection out of COPY state"
+          "okay"
+          (handle-exceptions exn
+            (value-at (query conn "SELECT 'okay'"))
+            (copy-query-fold-right (lambda _ (error "blah"))
+                                   '() conn "COPY copy_table (s, nr) TO STDOUT")))
+    (test "For-each"
+          '(("one" "1")
+            ("two" "2"))
+          (let ((res '()))
+            (copy-query-for-each (lambda (x)
+                                   (set! res (cons (string-split x) res)))
+                                 conn "COPY copy_table (s, nr) TO STDOUT")
+            (reverse res)))
+    (test "Error during for-each gets connection out of COPY state"
+          "okay"
+          (handle-exceptions exn
+            (value-at (query conn "SELECT 'okay'"))
+            (copy-query-for-each (lambda (x) (error "blah"))
+                                 conn "COPY copy_table (s, nr) TO STDOUT")))
+    (query conn "TRUNCATE copy_table")
+    (with-output-to-copy-query (lambda ()
+                                 (print "first\t1")
+                                 (print "second\t2"))
+                               conn "COPY copy_table (s, nr) FROM STDIN")
+    (test "Port interface inserted data correctly"
+          '(("first" 1)
+            ("second" 2))
+          (let ((res (query conn "SELECT s, nr FROM copy_table")))
+            (list (row-values res 0) (row-values res 1))))
+    (query conn "TRUNCATE copy_table")
+    (handle-exceptions _
+      (void)
+      (with-output-to-copy-query (lambda ()
+                                   (print "first\t1")
+                                   (print "second\t2")
+                                   (error "blah"))
+                                 conn "COPY copy_table (s, nr) FROM STDIN"))
+    (test "Error inside with-output-to-copy caused abort of insert"
+          0 (value-at (query conn "SELECT COUNT(*) FROM copy_table")))))
+
+(test-group "type parsers"
+  (test "Integer parsed correctly"
+        1234
+        (numeric-parser "1234"))
+  (test "Float parsed correctly"
+        123.456
+        (numeric-parser "123.456"))
+  (test-error* "Non-integer is an error"
+               (exn postgresql parse)
+               (numeric-parser "not an integer"))
+  (test "Boolean true parsed correctly"
+        #t
+        (bool-parser "t"))
+  (test "Boolean false parsed correctly"
+        #f
+        (bool-parser "f"))
+  (test "Byte array parsed correctly"
+        (blob->u8vector/shared (string->blob "abc\x01\x02\xffdef"))
+        (bytea-parser "abc\\001\\002\\377def"))
+  (test "Char parser"
+        #\x
+        (char-parser "x")))
+
+(test-group "type unparsers"
+  (test "Boolean true unparsed correctly"
+        "TRUE"
+        (bool-unparser conn #t))
+  (test "Boolean false unparsed correctly"
+        "FALSE"
+        (bool-unparser conn #f)))
+
+(test-group "high-level interface"
+  (test "row-fold"
+        '(("one" 2)
+          ("three" 4))
+        (reverse
+         (row-fold
+          cons '()
+          (query conn
+                 "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+                 "one" 2))))
+  (test "column-fold"
+        '(("one" "three")
+          (2 4))
+        (reverse
+         (column-fold
+          cons '()
+          (query conn
+                 "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+                 "one" 2))))
+  (test "row-fold-right"
+        '(("one" 2)
+          ("three" 4))
+        (row-fold-right
+         cons '()
+         (query conn
+                "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+                "one" 2)))
+  (test "column-fold-right"
+        '(("one" "three")
+          (2 4))
+        (column-fold-right
+         cons '()
+         (query conn
+                "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+                "one" 2)))
+  (test "row-for-each"
+        '(("one" 2)
+          ("three" 4))
+        (let ((res '()))
+          (row-for-each
+           (lambda (row) (set! res (cons row res)))
+           (query
+            conn
+            "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))
+          (reverse res)))
+  (test "column-for-each"
+        '(("one" "three")
+          (2 4))
+        (let ((res '()))
+          (column-for-each
+           (lambda (col) (set! res (cons col res)))
+           (query
+            conn
+            "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))
+          (reverse res)))
+  (test "row-map"
+        '(("one" 2)
+          ("three" 4))
+        (row-map
+         identity
+         (query conn
+                "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)))
+  (test "column-map"
+        '(("one" "three")
+          (2 4))
+        (column-map
+         identity
+         (query conn
+                "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))))
+
+(test-group "transactions"
+  (query conn "CREATE TEMP TABLE foo ( bar integer )")
+
+  (test-group "simple transactions"
+    (test "Transaction inactive"
+          #f
+          (in-transaction? conn))
+    (test "Transaction active"
+          #t
+          (with-transaction conn
+                            (lambda () (in-transaction? conn))))
+    (test "Successful transaction"
+          '(1)
+          (and
+           (with-transaction
+            conn (lambda ()
+                   (query conn "INSERT INTO foo (bar) VALUES (1)")))
+           (column-values (query conn "SELECT * FROM foo"))))
+  
+    (query conn "TRUNCATE foo")
+  
+    (test "Unsuccessful transaction"
+          #f
+          (with-transaction
+           conn (lambda ()
+                  (query conn "INSERT INTO foo (bar) VALUES (1)")
+                  #f)))
+
+    (test "Empty table after unsuccessful transaction"
+          '()
+          (column-values (query conn "SELECT * FROM foo")))
+
+    (handle-exceptions exn
+      (void)
+      (with-transaction
+       conn (lambda ()
+              (query conn "INSERT INTO foo (bar) VALUES (1)")
+              (error "oops!"))))
+  
+    (test "Exception during transaction causes reset"
+          '()
+          (column-values (query conn "SELECT * FROM foo"))))
+
+  (test-group "nested transactions"
+    (test "Successful transaction"
+          '(1 2)
+          (and
+           (with-transaction
+            conn (lambda ()
+                   (query conn "INSERT INTO foo (bar) VALUES (1)")
+                   (with-transaction
+                    conn (lambda ()
+                           (query conn "INSERT INTO foo (bar) VALUES (2)")))))
+           (column-values (query conn "SELECT * FROM foo"))))
+    
+    (query conn "TRUNCATE foo")
+
+    (test "Unsuccessful main transaction"
+          '()
+          (and
+           (not
+            (with-transaction
+             conn (lambda ()
+                    (query conn "INSERT INTO foo (bar) VALUES (1)")
+                    (with-transaction
+                     conn (lambda ()
+                            (query conn "INSERT INTO foo (bar) VALUES (2)")))
+                    #f)))
+           (column-values (query conn "SELECT * FROM foo"))))
+    
+    (test "Unsuccessful subtransaction"
+          '(1)
+          (and
+           (with-transaction
+            conn (lambda ()
+                   (query conn "INSERT INTO foo (bar) VALUES (1)")
+                   (with-transaction
+                    conn (lambda ()
+                           (query conn "INSERT INTO foo (bar) VALUES (2)")
+                           #f))
+                   #t))
+           (column-values (query conn "SELECT * FROM foo"))))
+
+    (query conn "TRUNCATE foo")
+
+    ;; Test that errors do not kill the transaction.  Apparently
+    ;; aborting transactions on errors is a psql(1) "feature", not a
+    ;; libpq one.
+    (test "Unsuccessful subtransaction with bad query"
+          '(1 2)
+          (and
+           (with-transaction
+            conn (lambda ()
+                   (query conn "INSERT INTO foo (bar) VALUES (1)")
+                   (handle-exceptions exn
+                     #t
+                     (with-transaction
+                      conn (lambda ()
+                             (query conn "INVALID QUERY"))))
+                   (query conn "INSERT INTO foo (bar) VALUES (2)")))
+           (column-values (query conn "SELECT * FROM foo"))))
+
+    (query conn "TRUNCATE foo")
+
+    (test "Multiple subtransactions"
+          '(1 3)
+          (and
+           (with-transaction
+            conn (lambda ()
+                   (query conn "INSERT INTO foo (bar) VALUES (1)")
+                   (with-transaction
+                    conn (lambda ()
+                           (query conn "INSERT INTO foo (bar) VALUES (2)")
+                           #f))
+                   (with-transaction
+                    conn (lambda ()
+                           (query conn "INSERT INTO foo (bar) VALUES (3)")))))
+           (column-values (query conn "SELECT * FROM foo")))))
+
+  ;; Very annoying; read-only transactions can write to temporary tables,
+  ;; so we have to create a REAL table here.
+  (query conn "CREATE TABLE chicken_pgsql_test (bar int)")
+  ;; We'd better make damn sure it gets dropped again.
+  (on-exit (lambda () (query conn "DROP TABLE chicken_pgsql_test")))
+  
+  (test-group "transaction access mode"
+    (test "Writes with explicit read/write access mode work"
+          '(1)
+          (with-transaction
+           conn (lambda ()
+                  (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (1)")
+                  (column-values
+                   (query conn "SELECT * FROM chicken_pgsql_test")))
+           access: 'read/write))
+    
+    (test "Reads with read-only access mode work"
+          '(1)
+          (with-transaction
+           conn (lambda ()
+                  (column-values
+                   (query conn "SELECT * FROM chicken_pgsql_test")))
+           access: 'read-only))
+    
+    (test-error* "Writes with read-only access cause errors"
+                 (exn postgresql query)
+                 (with-transaction
+                  conn (lambda ()
+                        (query conn (conc "INSERT INTO chicken_pgsql_test (bar)"
+                                          "VALUES (1)")))
+                  access: 'read-only))
+
+    (test "Switching read-write to read-only works"
+          '(1 2)
+          (with-transaction
+           conn (lambda ()
+                  (with-transaction
+                   conn (lambda ()
+                          (query conn "SELECT * FROM chicken_pgsql_test"))
+                   access: 'read-only)
+                  (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (2)")
+                  (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+           access: 'read/write))
+
+    (test "Switching read-write to read-only works with rollback"
+          '(1 2 3)
+          (with-transaction
+           conn (lambda ()
+                  (handle-exceptions exn
+                    (void)
+                    (with-transaction
+                     conn (lambda ()
+                            (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)"))
+                     access: 'read-only))
+                  (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)")
+                  (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+           access: 'read/write))
+
+    (test-error* "Switching read-only to read-write causes error"
+                 (exn postgresql query)
+                 (with-transaction
+                  conn (lambda ()
+                         (query conn "SELECT * FROM chicken_pgsql_test")
+                         (with-transaction
+                          conn (lambda ()
+                                 (query conn
+                                        (conc "INSERT INTO chicken_pgsql_test (bar)"
+                                              "VALUES (2)")))
+                          access: 'read/write)
+                         (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+                  access: 'read-only))
+
+    ;; Run these "concurrent" tests with a second connection
+    (let ((conn2 (connect '((dbname . test)))))
+      (test "Read committed transaction does see concurrent changes"
+            '(1 2 3 4)
+            (with-transaction
+             conn (lambda ()
+                    ;; MUST perform a query, since only after the first
+                    ;; query will the isolation take effect.
+                    (query conn "SELECT * FROM chicken_pgsql_test")
+                    (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) "
+                                       "VALUES (4)"))
+                    (column-values
+                     (query conn "SELECT * FROM chicken_pgsql_test")))
+             isolation: 'read-committed))
+
+      (test "Serializable transaction doesn't see concurrent changes"
+            '(1 2 3 4)
+            (with-transaction
+             conn (lambda ()
+                    ;; MUST perform a query, since only after the first
+                    ;; query will the isolation take effect.
+                    (query conn "SELECT * FROM chicken_pgsql_test")
+                    (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) "
+                                       "VALUES (5)"))
+                    (column-values
+                     (query conn "SELECT * FROM chicken_pgsql_test")))
+             isolation: 'serializable))
+      (disconnect conn2)))
+  )
+
+(test-end)
+
+(test-exit)