(import (chicken blob) (chicken condition) (chicken string) test postgresql sql-null srfi-4 srfi-18) (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))) ) ;; This testing code is pretty hairy (test-group "LISTEN/NOTIFY" (let ((received-channel #f) (received-pid #f) (received-message #f) (pid1 (value-at (query conn "SELECT pg_backend_pid()")))) (define (reset-received-values!) (set! received-channel #f) (set! received-pid #f) (set! received-message #f)) (query conn "LISTEN \"testing channel\"") (query conn "LISTEN \"unused channel\"") (set-notify-handler! conn (lambda (channel pid message) (set! received-channel channel) (set! received-pid pid) (set! received-message message))) (query conn "NOTIFY \"testing channel\", 'this is a test'") (test "Notification handler is immediately invoked for own connection" `("testing channel" ,pid1 "this is a test") (list received-channel pid1 received-message)) (reset-received-values!) (let* ((conn2 (connect '((dbname . test)))) (pid2 (value-at (query conn2 "SELECT pg_backend_pid()")))) (query conn2 "NOTIFY \"testing channel\", 'another test'") (test "Notification handler for connection 1 is not invoked when notifying from connection 2" `(#f #f #f) (list received-channel received-pid received-message)) (query conn "SELECT 1") (test "Notification handler is invoked after performing next query" `("testing channel" ,pid2 "another test") (list received-channel received-pid received-message)) (reset-received-values!) ;; This sucks, we have to do this from another thread (thread-start! (lambda () (thread-sleep! 0.1) (query conn2 "NOTIFY \"testing channel\", 'hi'"))) (test "Waiting manually for a short while does nothing yet" `(#f #f #f) (begin (wait-for-notifications! conn 1) (list received-channel received-pid received-message))) (test "Waiting long enough returns the notification" `("testing channel" ,pid2 "hi") (begin (wait-for-notifications! conn 5000) (list received-channel received-pid received-message))) (reset-received-values!) ;; And once more (thread-start! (lambda () (thread-sleep! 0.01) (query conn2 "NOTIFY \"testing channel\", 'also hi'"))) (test "Waiting without timeout returns the notification" `("testing channel" ,pid2 "also hi") (begin (wait-for-notifications! conn #f) (list received-channel received-pid received-message)))))) (test-end) (test-exit)