cl-pg 1:20061216-5 / usr / share / common-lisp / source / pg / pg-tests.lisp

;;; pg-tests.lisp -- incomplete test suite
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>
;;
;;
;; These tests assume that a table named "test" is defined in the
;; system catalog, and that the user identified in
;; CALL-WITH-TEST-CONNECTION has the rights to access that table.

(defpackage :pg-tests
  (:use :cl
        :pg
        #+cmu :fwrappers)
  (:export #:test))
(in-package :pg-tests)

(defmacro with-pg-connection/2 ((con &rest open-args) &body body)
  `(let ((,con (pg::pg-connect/v2 ,@open-args)))
     (unwind-protect
         (progn ,@body)
       (when ,con (pg-disconnect ,con)))))

;; !!! CHANGE THE VALUES HERE !!!
(defmacro with-test-connection ((conn &key (database "test")
                                      (user-name "pgdotlisp")
                                      (password "secret")
                                      (host "localhost") ;; or "/var/run/postgresql/"
                                      (port 5432)
                                      (encoding *pg-client-encoding*))
                                &body body)
  `(with-pg-connection (,conn ,database ,user-name :password ,password
                        :host ,host :port ,port :encoding ,encoding)
    ,@body))


(defun check-single-return (conn sql expected &key (test #'eql))
  (let ((res (pg-exec conn sql)))
    (assert (funcall test expected (first (pg-result res :tuple 0))))))


(defun test-insert ()
  (format *debug-io* "Testing INSERT & SELECT on integers ...~%")
  (with-test-connection (conn)
    (let ((count 0)
          (created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE count_test(key int, val int)")
             (loop :for i :from 1 :to 100
                   :for sql = (format nil "INSERT INTO count_test VALUES(~s, ~s)"
                                      i (* i i))
                   :do (pg-exec conn sql))
             (setq created t)
             (pg-exec conn "VACUUM count_test")
             (check-single-return conn "SELECT count(val) FROM count_test" 100)
             (check-single-return conn "SELECT sum(key) FROM count_test" 5050)
             ;; this iterator does the equivalent of the sum(key) SQL statement
             ;; above, but on the client side.
             (pg-for-each conn "SELECT key FROM count_test"
                          (lambda (tuple) (incf count (first tuple))))
             (assert (= 5050 count)))
        (when created
          (pg-exec conn "DROP TABLE count_test"))))))

(defun test-insert/float ()
  (format *debug-io* "Testing INSERT & SELECT on floats ...~%")
  (with-test-connection (conn)
    (let ((sum 0.0)
          (created nil))
      (flet ((float-eql (a b)
               (< (/ (abs (- a b)) b) 1e-5)))
        (unwind-protect
             (progn
               (pg-exec conn "CREATE TABLE count_test_float(key int, val float)")
               (setq created t)
               (loop :for i :from 1 :to 1000
                     :for sql = (format nil "INSERT INTO count_test_float VALUES(~d, ~f)"
                                        i i)
                     :do (pg-exec conn sql))
               (check-single-return conn "SELECT count(val) FROM count_test_float" 1000)
               (check-single-return conn "SELECT sum(key) FROM count_test_float" 500500.0 :test #'float-eql)
               ;; this iterator does the equivalent of the sum(key) SQL statement
               ;; above, but on the client side.
               (pg-for-each conn "SELECT val FROM count_test_float"
                            (lambda (tuple) (incf sum (first tuple))))
               (assert (float-eql 500500 sum)))
          (when created
            (pg-exec conn "DROP TABLE count_test_float")))))))

(defun test-insert/numeric ()
  (format *debug-io* "Testing INSERT & SELECT on NUMERIC ...~%")
  (with-test-connection (conn)
    (let ((sum 0)
          (created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE count_test_numeric(key int, val numeric(10,2))")
             (setq created t)
             (loop :for i :from 1 :to 1000
                   :for sql = (format nil "INSERT INTO count_test_numeric VALUES(~d, ~f)"
                                      i i)
                   :do (pg-exec conn sql))
             (check-single-return conn "SELECT count(val) FROM count_test_numeric" 1000)
             (let ((res (pg-exec conn "EXPLAIN SELECT count(val) FROM count_test_numeric")))
               (assert (string= "EXPLAIN" (pg-result res :status))))
             (check-single-return conn "SELECT sum(key) FROM count_test_numeric" 500500)
             ;; this iterator does the equivalent of the sum(key) SQL statement
             ;; above, but on the client side.
             (pg-for-each conn "SELECT val FROM count_test_numeric"
                          (lambda (tuple) (incf sum (first tuple))))
             (assert (eql 500500 sum)))
        ;; (check-single-return conn "SELECT 'infinity'::float4 + 'NaN'::float4" 'NAN)
        (check-single-return conn "SELECT 1 / (!! 2)" 1/2)
        (when created
          (pg-exec conn "DROP TABLE count_test_numeric"))))))

(defun test-date ()
  (format *debug-io* "Testing DATE and TIMESTAMP parsing ...~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE pgltest (a timestamp, b abstime, c time, d date)")
             (setq created t)
             (pg-exec conn "COMMENT ON TABLE pgltest is 'pg-dot-lisp testing DATE and TIMESTAMP parsing'")
             (pg-exec conn "INSERT INTO pgltest VALUES (current_timestamp, 'now', 'now', 'now')")
             (let* ((res (pg-exec conn "SELECT * FROM pgltest"))
                    (parsed (first (pg-result res :tuples))))
               (format t "attributes ~a~%" (pg-result res :attributes))
               (format t "Timestamp = ~s~%abstime = ~s~%time = ~s (CL universal-time = ~d)~%date = ~s~%"
                       (first parsed)
                       (second parsed)
                       (third parsed)
                       (get-universal-time)
                       (fourth parsed))))
        (when created
          (pg-exec conn "DROP TABLE pgltest"))))))

(defun test-booleans ()
  (format *debug-io* "Testing support for BOOLEAN type ...~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE pgbooltest (a BOOLEAN, b INT4)")
             (setq created t)
             (pg-exec conn "INSERT INTO pgbooltest VALUES ('t', 42)")
             (dotimes (i 100)
               (pg-exec conn (format nil "INSERT INTO pgbooltest VALUES ('f', ~D)" i)))
             (let ((sum 0))
               (pg-for-each conn "SELECT * FROM pgbooltest"
                            (lambda (tuple) (when (first tuple) (incf sum (second tuple)))))
               (assert (eql 42 sum)))
             (pg-exec conn "ALTER TABLE pgbooltest ADD COLUMN foo int2")
             (pg-exec conn "INSERT INTO pgbooltest VALUES ('t', -1, 1)")
             (let ((sum 0))
               (pg-for-each conn "SELECT * FROM pgbooltest"
                            (lambda (tuple) (when (first tuple) (incf sum (second tuple)))))
               (assert (eql 41 sum))))
        (when created
          (pg-exec conn "DROP TABLE pgbooltest"))))))


(defun test-integer-overflow ()
  (format *debug-io* "Testing integer overflow signaling ...~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE pg_int_overflow (a INTEGER, b INTEGER)")
             (setq created t)
             (handler-case
                 (loop :for i :from 10 :by 100
                       :do (pg-exec conn (format nil "INSERT INTO pg_int_overflow VALUES (~D, ~D)" i (* i i)))
                       (check-single-return conn (format nil "SELECT b FROM pg_int_overflow WHERE a = ~D" i) (* i i)))
               (pg:backend-error (exc)
                 (format *debug-io* "OK: integer overflow handled: ~A~%" exc))
               (error (exc)
                 (format *debug-io* "FAIL: integer overflow not handled: ~A~%" exc)))
             (handler-case (pg-exec conn "SELECT (10000 * 10000.0 / 45)::int2")
               (pg:backend-error (exc)
                 (format *debug-io* "OK: int2 overflow handled: ~A~%" exc))
               (error (exc)
                 (format *debug-io* "FAIL: int2 overflow not handled: ~A~%" exc))))
        (when created
          (pg-exec conn "DROP TABLE pg_int_overflow"))))))

(defun test-strings ()
  (format *debug-io* "Testing strings ...~%")
  (with-test-connection (conn)
    (check-single-return conn "SELECT POSITION('4' IN '1234567890')" 4)
    (check-single-return conn "SELECT SUBSTRING('1234567890' FROM 4 FOR 3)" "456" :test #'string-equal)
    (check-single-return conn "SELECT 'indio' LIKE 'in__o'" t)
    (check-single-return conn "SELECT replace('yabadabadoo', 'ba', '123')" "ya123da123doo" :test #'string-equal)
    (check-single-return conn "select md5('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'::bytea)"
                         "d174ab98d277d9f5a5611c2c9f419d9f" :test #'string-equal)
    (check-single-return conn "SELECT /* embedded comment */ CASE 'a' WHEN 'a' THEN 42 ELSE 2 END" 42)))


(defun test-integrity ()
  (format *debug-io* "Testing integrity constaint signaling ...~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE pgintegritycheck (a INTEGER UNIQUE)")
             (setq created t)
             (dotimes (i 100)
               (pg-exec conn (format nil "INSERT INTO pgintegritycheck VALUES (~D)" i)))
             (handler-case (pg-exec conn "INSERT INTO pgintegritycheck VALUES (1)")
               (pg:backend-error (exc)
                 (format *debug-io* "OK: integrity constraint handled: ~A~%" exc))
               (error (exc)
                 (format *debug-io* "FAIL: unhandled integrity constraint: ~A~%" exc))))
        (when created
          (pg-exec conn "DROP TABLE pgintegritycheck"))))))


(defun test-error-handling ()
  (format *debug-io* "Testing error handling ...~%")
  (with-test-connection (conn)
    ;; error handling for non-existant table
    (handler-case (pg-exec conn "SELECT * FROM inexistant_table")
      (pg:backend-error (exc)
        (format *debug-io* "OK: non-existant table error handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    ;; test for an ABORT when not in a transaction
    (handler-case (pg-exec conn "ABORT")
      (pg:backend-error (exc)
        (format *debug-io* "OK: ABORT outside transaction handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    ;; test division by zero
    (handler-case (pg-exec conn "SELECT 1/0::int8")
      (pg:backend-error (exc)
        (format *debug-io* "OK: integer division by zero handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT 1/0::float4")
      (pg:backend-error (exc)
        (format *debug-io* "OK: floating point division by zero handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT (4 / 4e40)::float4")
      (pg:backend-error (exc)
        (format *debug-io* "OK: floating point underflow handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled floating point underflow: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT (4 / 4e400)::float8")
      (pg:backend-error (exc)
        (format *debug-io* "OK: double precision floating point underflow handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled double precision floating point underflow: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT (log(-1))::float8")
      (pg:backend-error (exc)
        (format *debug-io* "OK: negative log handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: undetected negative log: ~A~%" exc)))
    (handler-case (pg-exec conn "DROP OPERATOR = (int4, nonesuch)")
      (pg:backend-error (exc)
        (format *debug-io* "OK: drop non-existant operator handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT CONVERT('éfooù' USING utf8_to_big5)")
      (pg:backend-error (exc)
        (format *debug-io* "OK: encoding error handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled encoding error: ~A~%" exc)))
    (handler-case (pg-exec conn "EXPLAIN WHY MYSQL SUCKS")
      (pg:backend-error (exc)
        (format *debug-io* "OK: syntax error handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT '{ }}'::text[]")
      (pg:backend-error (exc)
        (format *debug-io* "OK: array syntax error handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))
    (handler-case (pg-exec conn "SET SESSION AUTHORIZATION postgres")
      (pg:backend-error (exc)
        (format *debug-io* "OK: authorization error: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled authorization error: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT " (let ((sql "array[42]"))
                                            (dotimes (i 2000)
                                              (setq sql (format nil "array_prepend(~d, ~a)" i sql))) sql))
      (pg:backend-error (exc)
        (format *debug-io* "OK: stack overflow detected: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: undetected stack overflow: ~A~%" exc)))
    (handler-case (pg-exec conn "SELECT DISTINCT on (foobar) * from pg_database")
      (pg:backend-error (exc)
        (format *debug-io* "OK: selected attribute not in table handled: ~A~%" exc))
      (error (exc)
        (format *debug-io* "FAIL: unhandled error: ~A~%" exc)))))

(defun test-transactions ()
  (format *debug-io* "Testing transactions ...~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE truncating (a INTEGER PRIMARY KEY)")
             (setq created t)
             (pg-exec conn" INSERT INTO truncating VALUES (1)")
             (pg-exec conn "INSERT INTO truncating VALUES (2)")
             (let ((res (pg-exec conn "SELECT * FROM truncating")))
               (assert (eql 2 (length (pg-result res :tuples)))))
             ;; emit a TRUNCATE but then abort the transaction
             (ignore-errors
               (with-pg-transaction conn
                 (pg-exec conn "TRUNCATE truncating")
                 (pg-exec conn "SELECT sqrt(-2)")))
             (let ((res (pg-exec conn "SELECT * FROM truncating")))
               (assert (eql 2 (length (pg-result res :tuples)))))
             (with-pg-transaction conn
               (pg-exec conn "TRUNCATE truncating"))
             (let ((res (pg-exec conn "SELECT * FROM truncating")))
               (assert (zerop (length (pg-result res :tuples))))))
        (when created
          (pg-exec conn "DROP TABLE truncating"))))))

(defun test-arrays ()
  (format *debug-io* "Testing array support ... ~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (check-single-return conn "SELECT 33.4 > ALL(ARRAY[1,2,3])" t)
             (check-single-return conn "SELECT 33.4 = ANY(ARRAY[1,2,3])" nil)
             (check-single-return conn "SELECT 'foo' LIKE ANY (ARRAY['%a', '%o'])" t)
             (pg-exec conn "CREATE TABLE arrtest (
                                a                       int2[],
                                b                       int4[][][],
                                c                       name[],
                                d                       text[][], 
                                e                       float8[],
                                f                       char(5)[],
                                g                       varchar(5)[])")
             (setq created t)
             (pg-exec conn "INSERT INTO arrtest (a[1:5], b[1:1][1:2][1:2], c, d, f, g)
                            VALUES ('{1,2,3,4,5}', '{{{0,0},{1,2}}}', '{}', '{}', '{}', '{}')")
             (pg-exec conn "UPDATE arrtest SET e[0] = '1.1'")
             (pg-exec conn "UPDATE arrtest SET e[1] = '2.2'")
             (pg-for-each conn "SELECT * FROM arrtest"
                           (lambda (tuple) (princ tuple) (terpri)))
             (pg-exec conn "SELECT a[1], b[1][1][1], c[1], d[1][1], e[0] FROM arrtest"))
        (when created
          (pg-exec conn "DROP TABLE arrtest"))))))

(defun test-bit-tables ()
  (format *debug-io* "Testing bit-tables ... ~%")
  (with-test-connection (conn)
    (let ((created nil))
      (unwind-protect
           (progn
             (check-single-return conn "SELECT POSITION(B'1010' IN B'000001010')" 6)
             (check-single-return conn "SELECT POSITION(B'1011011011011' IN B'00001011011011011')" 5)
             (pg-exec conn "CREATE TABLE BIT_TABLE(b BIT(11))")
             (setq created t)
             (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'00000000000')")
             (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'11011000000')")
             (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'01010101010')")
             (handler-case (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'101011111010')")
               (pg:backend-error (exc)
                 (format *debug-io* "OK: bittable overflow handled: ~A~%" exc))
               (error (exc)
                 (format *debug-io* "FAIL: undetected bittable overflow (type ~A): ~A~%"
                         (type-of exc) exc)))
             (pg-for-each conn "SELECT * FROM bit_table"
                          (lambda (tuple) (format t "bits: ~A~%" tuple))))
        (when created
          (pg-exec conn "DROP TABLE bit_table"))))))

(defun test-introspection ()
  (format *debug-io* "Testing support for introspection ...~%")
  (with-test-connection (conn)
    (dotimes (i 500)
      (pg-tables conn))))

;;     (let ((res (pg-exec conn "SELECT pg_stat_file('/tmp')")))
;;       (format t "stat(\"/tmp\"): ~S~%" (pg-result res :tuples)))))


(defun test-encoding ()
  (let ((octets (coerce '(105 97 122 115 124) '(vector (unsigned-byte 8)))))
    (dolist (encoding '("UTF8" "LATIN1" "LATIN2"))
      (let ((encoded (pg::convert-string-from-bytes octets encoding)))
        (with-test-connection (conn :encoding encoding)
          (ignore-errors
            (pg-exec conn "DROP TABLE encoding_test"))
          (pg-exec conn "CREATE TABLE encoding_test (a VARCHAR(40))")
          (pg-exec conn "INSERT INTO encoding_test VALUES ('" encoded "')")
          (check-single-return conn "SELECT * FROM encoding_test" encoded :test #'string=)
          (pg-exec conn "DROP TABLE encoding_test"))))))



;; Fibonnaci numbers with memoization via a database table
(defun fib (n)
  (declare (type integer n))
  (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))

;; (compile 'fib)

#+cmu
(define-fwrapper memoize-fib (n)
  (let* ((conn (fwrapper-user-data fwrapper))
         (res (pg-exec conn (format nil "SELECT fibn FROM fib WHERE n = ~d" n)))
         (tuples (pg-result res :tuples)))
    (cond ((zerop (length tuples))
           (let ((fibn (call-next-function)))
             (pg-exec conn (format nil "INSERT INTO fib VALUES (~D, ~D)" n fibn))
             fibn))
          ((eql 1 (length tuples))
           (caar tuples))
          (t
           (error "integrity error in fibn table")))))

(defun test-fib ()
  (format *debug-io* "Testing fibonnaci number generation ...~%3")
  (with-test-connection (conn)
    (let ((created nil)
          (non-memoized 0)
          (memoized 0))
      (unwind-protect
           (progn
             (pg-exec conn "CREATE TABLE fib (n INTEGER, fibn INT8)")
             (setq created t)
             #+cmu (funwrap 'fib)
             (time (setq non-memoized (fib 40)))
             #+cmu (fwrap 'fib #'memoize-fib :user-data conn)
             #+cmu (update-fwrappers 'fib)    ; remove stale conn user-data object
             (time (setq memoized (fib 40)))
             (format t "~S" (pg-exec conn "SELECT COUNT(n) FROM fib"))
             (assert (eql non-memoized memoized)))
        (when created
          (pg-exec conn "DROP TABLE fib"))))))


(defun test-lo ()
  (format *debug-io* "Testing large object support ...~%")
  (with-test-connection (conn)
   (with-pg-transaction conn
    (let* ((oid (pglo-create conn))
           (fd (pglo-open conn oid)))
      (sleep 1)
      (pglo-tell conn fd)
      (sleep 1)
      (pglo-unlink conn oid)))))

;; test of large-object interface. We are careful to use vectors of
;; bytes instead of strings, because with the v3 protocol strings
;; undergo \\xxx encoding (for instance #\newline is transformed to \\012). 
(defun test-lo-read ()
  (format *debug-io* "Testing read of large object ...~%")
  (with-test-connection (conn)
   (with-pg-transaction conn
    (let* ((oid (pglo-create conn "rw"))
           (fd (pglo-open conn oid "rw")))
      (pglo-write conn fd (map '(vector (unsigned-byte 8)) #'char-code (format nil "Hi there mate~%What's up?~%")))
      (pglo-lseek conn fd 3 0)           ; SEEK_SET = 0
      (assert (eql 3 (pglo-tell conn fd)))
      ;; this should print "there mate"
      (format *debug-io* "Read ~s from lo~%" (map 'string #'code-char (pglo-read conn fd 10)))
      (format *debug-io* "Rest is ~s~%" (map 'string #'code-char (pglo-read conn fd 1024)))
      (pglo-close conn fd)
      #+nil (pglo-unlink conn oid)))))

#+cmu
(defun test-lo-import ()
  (format *debug-io* "Testing import of large object ...~%")
  (with-test-connection (conn)
   (with-pg-transaction conn
    (let ((oid (pglo-import conn "/etc/group")))
      (pglo-export conn oid "/tmp/group")
      (cond ((zerop
              (ext:process-exit-code
               (ext:run-program "diff" (list "/tmp/group" "/etc/group"))))
             (format *debug-io* "pglo-import test succeeded~%")
             (unix:unix-unlink "/tmp/group"))
            (t
             (format *debug-io* "pglo-import test failed: check differences
between files /etc/group and /tmp/group")))
      (pglo-unlink conn oid)))))

(defun test-simple ()
  (let ((*pg-disable-type-coercion* t))
    (with-test-connection (conn)
     (format t "backend ~a~%" (pg-backend-version conn)))))

(defun test-notifications ()
  (with-test-connection (conn)
    (let (res)
      (setq res (pg-exec conn "LISTEN pg_test_listen"))
      (format t "LISTEN -> ~S~%" (pg-result res :status))
      (assert (null (pg::pgcon-notices conn)))
      (pg-exec conn "SELECT * FROM pg_type")
      (assert (null (pg::pgcon-notices conn)))
      (setq res (pg-exec conn "NOTIFY pg_test_listen"))
      (format t "NOTIFY -> ~S~%" (pg-result res :status))
      (format t "In TEST-NOTIFICATIONS notices are ~S~%"
              (pg::pgcon-notices conn)))))


;; FIXME could add interaction between producer and consumers via NOTIFY

#+(and cmu mp)
(defun test-multiprocess ()
  (format *debug-io* "Testing multiprocess database access~%")
  (when (eq mp::*current-process* mp::*initial-process*)
    (mp::startup-idle-and-top-level-loops))
  (with-test-connection (conn)
    (pg-exec conn "CREATE TABLE pgmt (a TEXT, b INTEGER, C FLOAT)"))
  (flet ((producer ()
           (with-test-connection (conn)
             (dotimes (i 5000)
               (pg-exec conn (format nil "INSERT INTO pgmt VALUES (~S, ~D, ~F)" i i i))
               (when (zerop (mod i 100))
                 (pg-exec conn "COMMIT WORK")))))
         (consumer ()
           (with-test-connection (conn)
             (dotimes (i 10)
               (sleep 1)
               (let ((res (pg-exec conn "SELECT count(*) FROM pgmt")))
                 (format *debug-io* "  Consumer sees ~D rows~%"
                         (first (pg-result res :tuple 0))))))))
    (let ((p1 (mp:make-process #'producer :name "PG data producer"))
          (p2 (mp:make-process #'producer :name "PG data producer"))
          (p3 (mp:make-process #'producer :name "PG data producer"))
          (co (mp:make-process #'consumer :name "PG data consumer")))
      (loop :while (some 'mp:process-alive-p (list p1 p2 p3 co))
            :do (sleep 5) (mp:show-processes t))))
  (with-test-connection (conn)
    (pg-exec conn "DROP TABLE pgmt")))

#+(and sbcl sb-thread)
(defun test-multiprocess ()
  (format *debug-io* "Testing multiprocess database access~%")
  (with-test-connection (conn)
    (pg-exec conn "CREATE TABLE pgmt (a TEXT, b INTEGER, C FLOAT)"))
  (let ((dio *debug-io*))
    (flet ((producer ()
             (with-test-connection (con)
               (dotimes (i 5000)
                 (if (= (mod i 1000) 0) (format dio "~s connected over ~S producing ~a~%"
                                                sb-thread:*current-thread* con i))
                 (pg-exec con (format nil "INSERT INTO pgmt VALUES (~S, ~D, ~F)" i i i))
                 (when (zerop (mod i 100))
                   (pg-exec con "COMMIT WORK")))))
           (consumer ()
             (with-test-connection (con)
               (dotimes (i 10)
                 (sleep 1)
                 (format dio "~&consumer on ~a" i)
                 (let ((res (pg-exec con "SELECT count(*) FROM pgmt")))
                   (format *debug-io* "  Consumer sees ~D rows~%"
                           (first (pg-result res :tuple 0))))))))
      (let ((prs (loop :for x :from 0 :below 3
                       :collect (sb-thread:make-thread #'producer :name "PG data producer")))
            (co (sb-thread:make-thread #'consumer :name "PG data consumer")))
        (loop :while (some 'sb-thread:thread-alive-p (append prs (list co)))
              :do (sleep 5))))
    (with-test-connection (conn)
      (pg-exec conn "DROP TABLE pgmt"))))

(defun test-pbe ()
  (with-test-connection (conn)
    (when (pg-supports-pbe conn)
      (format *debug-io* "~&Testing PBE/int4 ...")
      (let ((count 0)
            (created nil))
        (unwind-protect
             (progn
               (pg-exec conn "CREATE TABLE count_test(key int, val int)")
               (setq created t)
               (pg-prepare conn "ct_insert"
                           "INSERT INTO count_test VALUES ($1, $2)"
                           '("int4" "int4"))
               (loop :for i :from 1 :to 100
                     :do
                     (pg-bind conn
                              "ct_portal" "ct_insert"
                              `((:int32 ,i)
                                (:int32 ,(* i i))))
                     (pg-execute conn "ct_portal")
                     (pg-close-portal conn "ct_portal"))
               (check-single-return conn "SELECT count(val) FROM count_test" 100)
               (check-single-return conn "SELECT sum(key) FROM count_test" 5050)
               ;; this iterator does the equivalent of the sum(key) SQL statement
               ;; above, but on the client side.
               (pg-for-each conn "SELECT key FROM count_test"
                            (lambda (tuple) (incf count (first tuple))))
               (assert (= 5050 count)))
          (when created
            (pg-exec conn "DROP TABLE count_test")))))))

(defun test-pbe-text ()
  (with-test-connection (conn)
    (when (pg-supports-pbe conn)
      (format *debug-io* "~&Testing PBE/text...")
      (let ((count 0)
            (created nil))
        (unwind-protect
             (progn
               (pg-exec conn "CREATE TABLE pbe_text_test(key int, val text)")
               (setq created t)
               (pg-prepare conn "ct_insert/text"
                           "INSERT INTO pbe_text_test VALUES ($1, $2)"
                           '("int4" "text"))
               (loop :for i :from 1 :to 100
                     :do
                     (pg-bind conn
                              "ct_portal/text" "ct_insert/text"
                              `((:int32 ,i)
                                (:string ,(format nil "~a" (* i i)))))
                     (pg-execute conn "ct_portal/text")
                     (pg-close-portal conn "ct_portal/text"))
               (check-single-return conn "SELECT count(val) FROM pbe_text_test" 100)
               (check-single-return conn "SELECT sum(key) FROM pbe_text_test" 5050)
               ;; this iterator does the equivalent of the sum(key) SQL statement
               ;; above, but on the client side.
               (pg-for-each conn "SELECT key FROM pbe_text_test"
                            (lambda (tuple) (incf count (first tuple))))
               (assert (= 5050 count)))
          (when created
            (pg-exec conn "DROP TABLE pbe_text_test")))))))

(defun test-copy-in-out ()
  (with-test-connection (conn)
    (ignore-errors
      (pg-exec conn "DROP TABLE foo"))
    (pg-exec conn "CREATE TABLE foo (a int, b int, c text)")
    (pg-exec conn "INSERT INTO foo VALUES (1, 2, 'two')")
    (pg-exec conn "INSERT INTO foo VALUES (2, 4, 'four')")
    (with-open-file (stream "/tmp/foo-out"
			    :direction :output
			    :element-type '(unsigned-byte 8)
			    :if-does-not-exist :create
			    :if-exists :overwrite)
      (setf (pgcon-sql-stream conn) stream)
      (pg-exec conn "COPY foo TO stdout"))
    (pg-exec conn "DELETE FROM foo")
    (with-open-file (stream "/tmp/foo-out"
			    :direction :input
			    :element-type '(unsigned-byte 8)
			    :if-does-not-exist :error)
      (setf (pgcon-sql-stream conn) stream)
      (pg-exec conn "COPY foo FROM stdout"))
    (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 1")))
      (assert (eql 2 (first (pg-result res :tuple 0)))))
    (let ((res (pg-exec conn "SELECT c FROM foo WHERE a = 1")))
      (assert (string-equal "two" (first (pg-result res :tuple 0)))))
    (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 2")))
      (assert (eql 4 (first (pg-result res :tuple 0)))))
    (pg-exec conn "DROP TABLE foo")))


(defun test-triggers ()
  (with-test-connection (conn)
    (ignore-errors
      (pg-exec conn "DROP TABLE pg_trigger_table"))
    (pg-exec conn "CREATE TABLE pg_trigger_table (a int, b int)")
    (pg-exec conn "CREATE FUNCTION trigger_func() RETURNS trigger LANGUAGE plpgsql AS '"
             "BEGIN "
             "RAISE NOTICE ''trigger_func() called: action = %, when = %, level = %'', TG_OP, TG_WHEN, TG_LEVEL; "
             "RETURN NULL; "
             "END;'")
    (pg-exec conn "CREATE TRIGGER before_ins_stmt_trig BEFORE INSERT ON pg_trigger_table "
             "FOR EACH STATEMENT EXECUTE PROCEDURE trigger_func()")
    (pg-exec conn "CREATE TRIGGER after_ins_stmt_trig AFTER INSERT ON pg_trigger_table "
             "FOR EACH STATEMENT EXECUTE PROCEDURE trigger_func()")
    (pg-exec conn "INSERT INTO pg_trigger_table VALUES (1, 2)")
    (pg-exec conn "INSERT INTO pg_trigger_table VALUES (3, 4)")
    (pg-exec conn "DROP TABLE pg_trigger_table")))


(defun test ()
  (let (#+nil(*pg-client-encoding* "UTF8"))
    (with-test-connection (conn)
      (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn))
      ;; client encoding supported since PostgreSQL v7.1
      (format t "Client encoding is ~A~%" (pg-client-encoding conn))
      (format t "Date style is ~A~%" (pg-date-style conn))
      (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c numeric)"))
            (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, 123.45)"))
            (r4 (pg-exec conn "DROP TABLE pgltest")))
        (format t "~%==============================================~%")
        (format t "status of CREATE is ~s~%" (pg-result r2 :status))
        (format t "status of INSERT is ~s~%" (pg-result r3 :status))
        (format t "oid of INSERT is ~s~%" (pg-result r3 :oid))
        (format t "status of DROP is ~s~%" (pg-result r4 :status))
        (format t "==============================================~%")))
    (test-simple)
    (test-insert)
    (test-insert/float)
    (test-insert/numeric)
    (test-date)
    (test-booleans)
    (test-integer-overflow)
    (test-strings)
    (test-integrity)
    (test-error-handling)
    (test-transactions)
    (test-arrays)
    (test-bit-tables)
    (test-notifications)
    (test-lo)
    (test-lo-read)
    #+cmu (test-lo-import)
    (test-pbe)
    (test-pbe-text)
    #+unix
    (test-copy-in-out)
    (values)))


;; EOF