pg-tests.lisp 32 KB
Newer Older
1 2
;;; pg-tests.lisp -- incomplete test suite
;;;
3
;;; Author: Eric Marsden <eric.marsden@free.fr>
Eric Marsden's avatar
Eric Marsden committed
4 5 6 7
;;
;;
;; These tests assume that a table named "test" is defined in the
;; system catalog, and that the user identified in
Peter Van Eynde's avatar
Peter Van Eynde committed
8
;; CALL-WITH-TEST-CONNECTION has the rights to access that table.
Eric Marsden's avatar
Eric Marsden committed
9 10 11 12

(defpackage :pg-tests
  (:use :cl
        :pg
13 14
        #+cmu :fwrappers)
  (:export #:test))
Eric Marsden's avatar
Eric Marsden committed
15 16
(in-package :pg-tests)

17 18 19 20 21 22
(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)))))

Eric Marsden's avatar
Eric Marsden committed
23
;; !!! CHANGE THE VALUES HERE !!!
24 25 26 27 28 29 30 31 32 33
(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))
Eric Marsden's avatar
Eric Marsden committed
34 35


36 37 38 39 40
(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))))))


Eric Marsden's avatar
Eric Marsden committed
41 42 43
(defun test-insert ()
  (format *debug-io* "Testing INSERT & SELECT on integers ...~%")
  (with-test-connection (conn)
44
    (let ((count 0)
Eric Marsden's avatar
Eric Marsden committed
45 46 47 48 49 50 51 52 53
          (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)
54 55 56
             (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)
Eric Marsden's avatar
Eric Marsden committed
57 58 59 60 61 62 63 64 65 66 67
             ;; 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)
68
    (let ((sum 0.0)
Eric Marsden's avatar
Eric Marsden committed
69 70 71 72 73 74 75 76 77 78 79
          (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))
80 81
               (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)
Eric Marsden's avatar
Eric Marsden committed
82 83 84 85 86 87 88 89
               ;; 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")))))))

90 91 92
(defun test-insert/numeric ()
  (format *debug-io* "Testing INSERT & SELECT on NUMERIC ...~%")
  (with-test-connection (conn)
93
    (let ((sum 0)
94 95 96 97 98 99 100 101 102
          (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))
103 104 105 106
             (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)
107 108 109 110 111
             ;; 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)))
112
        ;; (check-single-return conn "SELECT 'infinity'::float4 + 'NaN'::float4" 'NAN)
113
        (check-single-return conn "SELECT 1 / (!! 2)" 1/2)
114 115 116
        (when created
          (pg-exec conn "DROP TABLE count_test_numeric"))))))

Eric Marsden's avatar
Eric Marsden committed
117 118 119 120 121 122 123 124
(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)
125 126
             (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')")
Eric Marsden's avatar
Eric Marsden committed
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
             (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)))))
153 154 155 156 157 158 159
               (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))))
Eric Marsden's avatar
Eric Marsden committed
160 161 162
        (when created
          (pg-exec conn "DROP TABLE pgbooltest"))))))

163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178

(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)
179 180 181 182 183 184
                 (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))))
185 186 187 188 189 190 191 192 193 194 195
        (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)"
196 197
                         "d174ab98d277d9f5a5611c2c9f419d9f" :test #'string-equal)
    (check-single-return conn "SELECT /* embedded comment */ CASE 'a' WHEN 'a' THEN 42 ELSE 2 END" 42)))
198 199


Eric Marsden's avatar
Eric Marsden committed
200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
(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"))))))

218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244

(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)))
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
    (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)))
260 261 262 263 264
    (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)))
265 266 267 268 269
    (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)))
270 271 272 273 274
    (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)))
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291
    (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)))
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
    (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")
314
                 (pg-exec conn "SELECT sqrt(-2)")))
315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
             (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
330 331 332
             (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)
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
             (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
358 359
             (check-single-return conn "SELECT POSITION(B'1010' IN B'000001010')" 6)
             (check-single-return conn "SELECT POSITION(B'1011011011011' IN B'00001011011011011')" 5)
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
             (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"))))))

Eric Marsden's avatar
Eric Marsden committed
376 377 378 379 380 381
(defun test-introspection ()
  (format *debug-io* "Testing support for introspection ...~%")
  (with-test-connection (conn)
    (dotimes (i 500)
      (pg-tables conn))))

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

Eric Marsden's avatar
Eric Marsden committed
385

386 387 388 389 390 391 392 393 394 395 396 397 398 399
(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"))))))



Eric Marsden's avatar
Eric Marsden committed
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430
;; 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)
431
             #+cmu (funwrap 'fib)
Eric Marsden's avatar
Eric Marsden committed
432 433
             (time (setq non-memoized (fib 40)))
             #+cmu (fwrap 'fib #'memoize-fib :user-data conn)
434
             #+cmu (update-fwrappers 'fib)    ; remove stale conn user-data object
Eric Marsden's avatar
Eric Marsden committed
435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
             (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)))))

453 454 455
;; 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). 
Eric Marsden's avatar
Eric Marsden committed
456 457 458 459 460 461
(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")))
462
      (pglo-write conn fd (map '(vector (unsigned-byte 8)) #'char-code (format nil "Hi there mate~%What's up?~%")))
Eric Marsden's avatar
Eric Marsden committed
463
      (pglo-lseek conn fd 3 0)           ; SEEK_SET = 0
464
      (assert (eql 3 (pglo-tell conn fd)))
Eric Marsden's avatar
Eric Marsden committed
465
      ;; this should print "there mate"
466 467
      (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)))
Eric Marsden's avatar
Eric Marsden committed
468
      (pglo-close conn fd)
469
      #+nil (pglo-unlink conn oid)))))
Eric Marsden's avatar
Eric Marsden committed
470 471 472

#+cmu
(defun test-lo-import ()
473
  (format *debug-io* "Testing import of large object ...~%")
Eric Marsden's avatar
Eric Marsden committed
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
  (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")))

538 539 540 541 542 543 544 545 546 547
#+(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~%"
548
                                                sb-thread:*current-thread* con i))
549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
                 (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"))))
Eric Marsden's avatar
Eric Marsden committed
567

Peter Van Eynde's avatar
Peter Van Eynde committed
568 569 570
(defun test-pbe ()
  (with-test-connection (conn)
    (when (pg-supports-pbe conn)
571
      (format *debug-io* "~&Testing PBE/int4 ...")
572
      (let ((count 0)
Peter Van Eynde's avatar
Peter Van Eynde committed
573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
            (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"))
589 590
               (check-single-return conn "SELECT count(val) FROM count_test" 100)
               (check-single-return conn "SELECT sum(key) FROM count_test" 5050)
Peter Van Eynde's avatar
Peter Van Eynde committed
591 592 593 594 595 596 597 598
               ;; 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")))))))

599 600 601 602
(defun test-pbe-text ()
  (with-test-connection (conn)
    (when (pg-supports-pbe conn)
      (format *debug-io* "~&Testing PBE/text...")
603
      (let ((count 0)
604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619
            (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"))
620 621
               (check-single-return conn "SELECT count(val) FROM pbe_text_test" 100)
               (check-single-return conn "SELECT sum(key) FROM pbe_text_test" 5050)
622 623 624 625 626 627 628 629
               ;; 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")))))))

630 631 632 633
(defun test-copy-in-out ()
  (with-test-connection (conn)
    (ignore-errors
      (pg-exec conn "DROP TABLE foo"))
634 635 636
    (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')")
637 638 639 640 641 642 643 644 645 646 647
    (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)
648
			    :if-does-not-exist :error)
649 650 651 652
      (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)))))
653 654
    (let ((res (pg-exec conn "SELECT c FROM foo WHERE a = 1")))
      (assert (string-equal "two" (first (pg-result res :tuple 0)))))
655 656 657
    (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")))
Eric Marsden's avatar
Eric Marsden committed
658

659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678

(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")))


Eric Marsden's avatar
Eric Marsden committed
679
(defun test ()
680
  (let (#+nil(*pg-client-encoding* "UTF8"))
681 682 683 684 685
    (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))
686 687
      (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)"))
688 689 690 691 692 693 694 695 696 697
            (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)
698
    (test-insert/numeric)
699 700
    (test-date)
    (test-booleans)
701 702
    (test-integer-overflow)
    (test-strings)
703
    (test-integrity)
704 705 706 707
    (test-error-handling)
    (test-transactions)
    (test-arrays)
    (test-bit-tables)
708 709 710 711
    (test-notifications)
    (test-lo)
    (test-lo-read)
    #+cmu (test-lo-import)
712 713 714 715 716
    (test-pbe)
    (test-pbe-text)
    #+unix
    (test-copy-in-out)
    (values)))
Eric Marsden's avatar
Eric Marsden committed
717

718

Eric Marsden's avatar
Eric Marsden committed
719
;; EOF