summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/run.scm949
1 files changed, 949 insertions, 0 deletions
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..0469929
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,949 @@
+(import (chicken blob)
+ (chicken condition)
+ (chicken string)
+ test
+ postgresql
+ sql-null
+ srfi-4)
+
+(define-syntax test-error*
+ (syntax-rules ()
+ ((_ ?msg (?error-type ...) ?expr)
+ (let-syntax ((expression:
+ (syntax-rules ()
+ ((_ ?expr)
+ (condition-case (begin ?expr "<no error thrown>")
+ ((?error-type ...) '(?error-type ...))
+ (exn () (##sys#slot exn 1)))))))
+ (test ?msg '(?error-type ...) (expression: ?expr))))
+ ((_ ?msg ?error-type ?expr)
+ (test-error* ?msg (?error-type) ?expr))
+ ((_ ?error-type ?expr)
+ (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
+
+;; Perform a quick sanity check before running the actual tests
+(condition-case (disconnect (connect '((dbname . test))))
+ (exn (exn postgresql connect)
+ (print "Could not connect to server. Please ensure that the UNIX "
+ "user running these tests is allowed to connect to a database "
+ "with the name \"test\". Error from Postgres:")
+ (print ((condition-property-accessor 'exn 'message) exn))
+ (test-exit)))
+
+(test-begin "postgresql")
+
+(test-group "connection management"
+ (test "connect returns a connected connection"
+ '(#t #t)
+ (let* ((conn (connect '((dbname . test))))
+ (isconn (connection? conn))
+ (connected (connected? conn)))
+ (disconnect conn)
+ (list isconn connected)))
+ (test "disconnect causes connection to be disconnected"
+ '(#t #f)
+ (let ((conn (connect '((dbname . test)))))
+ (disconnect conn)
+ (list (connection? conn) (connected? conn))))
+ (test-error "cannot connect with invalid credentials"
+ (connect '((dbname . does-not-exist)
+ (username . nobody))))
+ (test-error "disconnect invalidates the connection"
+ (let ((conn (connect '((dbname . test)))))
+ (disconnect conn)
+ (reset-connection conn)))
+ ;; It would be nice if we could test some more error cases here but
+ ;; that's hard to do
+ )
+
+;; From now on, just keep using the same connection
+(define conn (connect '((dbname . test))))
+
+;; In the tests, we assume that the client lib is at least equal to
+;; the server's version.
+(define-values (major-version minor-version micro-version)
+ (apply values
+ (map string->number
+ (string-split
+ (value-at (query conn "SHOW server_version")) "."))))
+
+(test-group "low-level interface"
+ (test-assert "query returns result"
+ (result? (query conn "SELECT 1")))
+ (test "Correct row count"
+ 2
+ (row-count (query conn "SELECT 1 UNION SELECT 2")))
+ (test "Correct column count"
+ 4
+ (column-count (query conn "SELECT 1, 2, 3, 4")))
+ (test "Correct column name"
+ 'one
+ (column-name
+ (query conn "SELECT 1 AS one, 2 AS two") 0))
+ (test "Correct column names"
+ '(one two)
+ (column-names
+ (query conn "SELECT 1 AS one, 2 AS two")))
+ (test-error* "Condition for nonexistant column index"
+ (exn postgresql bounds)
+ (column-name
+ (query conn "SELECT 1 AS one, 2 AS two") 3))
+ (test "Not false for nameless column"
+ #f ;; Could check for ?column?, but that's a bit too specific
+ (not (column-name
+ (query conn "SELECT 1, 2") 0)))
+ ;; Maybe add a few tests here for case folding/noncase folding variants?
+ ;; Perhaps column-index-ci vs column-index? That would be
+ ;; misleading though, since column-index-ci isn't really ci,
+ ;; it will not match columns that are explicitly uppercased in the query.
+ (test "Correct column index"
+ 0
+ (column-index
+ (query conn "SELECT 1 AS one, 2 AS two") 'one))
+ (test "False column index for nonexistant column name"
+ #f
+ (column-index
+ (query conn "SELECT 1 AS one, 2 AS two") 'foo))
+ (test "False oid for virtual table"
+ #f
+ (table-oid
+ (query conn "SELECT 1 AS one, 2 AS two") 0))
+ (test-assert "Number for nonvirtual table"
+ (number?
+ (table-oid
+ (query conn "SELECT typlen FROM pg_type") 0)))
+
+ (test-error* "Condition for column index out of bounds"
+ (exn postgresql bounds)
+ (table-oid
+ (query conn "SELECT typname FROM pg_type") 1))
+ (test "Table column number for real table"
+ 0
+ (table-column-index
+ (query conn "SELECT typname FROM pg_type") 0))
+ (test "Column format is text for normal data"
+ 'text
+ (column-format
+ (query conn "SELECT 'hello'") 0))
+
+ (test "Column format is binary for forced binary data"
+ 'binary
+ (column-format
+ (query* conn "SELECT 1" '() format: 'binary) 0))
+
+ (test "Column type OID ok"
+ 23 ;; from catalog/pg_type.h
+ (column-type
+ (query conn "SELECT 1::int4") 0))
+ (test "Column modifier false"
+ #f
+ (column-type-modifier
+ (query conn "SELECT 1") 0))
+ (test "Column modifier for bit ok"
+ 2
+ (column-type-modifier
+ (query conn "SELECT '10'::bit(2)") 0))
+ (test "Result value string for strings"
+ "test"
+ (value-at (query conn "SELECT 'test'")))
+ (test "Result value string for 'name' type (with no custom parser)"
+ "test"
+ (value-at (query conn "SELECT 'test'::name")))
+ (test "Result row values"
+ '("one" "two")
+ (row-values
+ (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
+ (test "Result row values for second row"
+ '("three" "four")
+ (row-values
+ (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1))
+ (test "Result row alist"
+ '((a . "one") (b . "two"))
+ (row-alist
+ (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 0))
+ (test "Result row alist for second row"
+ '((a . "three") (b . "four"))
+ (row-alist
+ (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 1))
+ (test "Result column values"
+ '("one" "three")
+ (column-values
+ (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0))
+ (test "Result column values for second column"
+ '("two" "four")
+ (column-values
+ (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1))
+ (test "Result value number for numbers"
+ 1
+ (value-at (query conn "SELECT 1")))
+ (test "Result value string for raw numbers"
+ "1"
+ (value-at (query conn "SELECT 1") 0 0 raw: #t))
+ ;; We are using two levels of escaping here because the ::bytea cast
+ ;; performs another string interpretation. Yes, this is kinda confusing...
+ (test "Result value for null-terminated byte array"
+ (blob->u8vector (string->blob "h\x00ello"))
+ (value-at (query conn "SELECT E'h\\\\000ello'::bytea")))
+
+ (test "Result value for raw null-terminated byte array"
+ (if (>= major-version 9)
+ "\\x6800656c6c6f"
+ "h\\000ello")
+ (value-at (query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
+
+ (test "Result value blob for binary string"
+ (string->blob "hello")
+ (value-at (query* conn "SELECT 'hello'" '() format: 'binary)))
+
+ (test "Result value blob for binary integer"
+ (u8vector->blob (u8vector 0 0 0 1))
+ (value-at (query* conn "SELECT 1::int4" '() format: 'binary)))
+
+ (test "Result value for binary string with NUL bytes"
+ (string->blob "h\x00ello")
+ (value-at (query* conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary)))
+
+ (test "Result value for array of integers"
+ `#(1 ,(sql-null) 3) ;; Not sure if comparing sql-null is kosher
+ (value-at (query conn "SELECT array[1, null, 3]")))
+
+ (test "Result value for nested array of ints"
+ `#(#(1 ,(sql-null) 3)
+ #(4 5 ,(sql-null))) ;; Not sure if comparing sql-null is kosher
+ (value-at
+ (query conn "SELECT array[array[1, null, 3], array[4, 5, NULL]]")))
+
+ (test "Result value for array of strings"
+ `#("a" ,(sql-null) "c") ;; Not sure if comparing sql-null is kosher
+ (value-at (query conn "SELECT array['a', null, 'c']")))
+
+ (test "Result value for nested array of strings"
+ `#(#("a" ,(sql-null) "c")
+ #("NULL" "e" ,(sql-null))) ;; Not sure if comparing sql-null is kosher
+ (value-at (query conn "SELECT array[array['a', null, 'c'], array['NULL', 'e', NULL]]")))
+
+ (test "Result value at row 0, column 1"
+ 2
+ (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 1 0))
+ (test "Result value at row 1, column 0"
+ 3
+ (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 0 1))
+ (test-assert "Result value sql-null for NULL"
+ (sql-null? (value-at (query conn "SELECT NULL"))))
+ (test-error* "Result value error for out of bounds row"
+ (exn postgresql bounds)
+ (value-at (query conn "SELECT NULL") 0 1))
+ (test-error* "Result value error for out of bounds column"
+ (exn postgresql bounds)
+ (value-at (query conn "SELECT NULL") 1 0))
+
+ (query conn "PREPARE foo (int) AS (SELECT 1, 2, $1)")
+ (test-assert "query with prepared statement name returns result"
+ (result? (query conn 'foo 3)))
+ (test "result value ok for query with prepared statement name"
+ '(1 2 3)
+ (row-values (query conn 'foo 3)))
+ (test-error* "condition for missing parameter names"
+ (exn postgresql query)
+ (query conn 'foo))
+
+ (query conn "BEGIN")
+ (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+ (test "Number of affected rows 1 with INSERT"
+ 1
+ (affected-rows
+ (query conn "INSERT INTO foo (bar) VALUES (1);")))
+ (query conn "COMMIT")
+
+ (query conn "BEGIN")
+ (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+ (query conn "INSERT INTO foo (bar) VALUES (100);")
+ (query conn "INSERT INTO foo (bar) VALUES (101);")
+ (test "Number of affected rows 2 with UPDATE of two rows"
+ 2
+ (affected-rows
+ (query conn "UPDATE foo SET bar=102;")))
+ (query conn "COMMIT")
+
+ (test "Inserted OID false on SELECT"
+ #f
+ (inserted-oid
+ (query conn "SELECT 1")))
+
+ (query conn "BEGIN")
+ (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
+ (test "Inserted OID false on OID-less table"
+ #f
+ (inserted-oid
+ (query conn "INSERT INTO foo (bar) VALUES (1);")))
+ (query conn "COMMIT")
+
+ (query conn "BEGIN")
+ (query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP")
+ (test-assert "Inserted OID number on table with OID"
+ (number?
+ (inserted-oid
+ (query conn "INSERT INTO foo (bar) VALUES (1)"))))
+ (query conn "COMMIT")
+
+ (test "regular parameters"
+ "hi"
+ (value-at (query conn "SELECT $1::text" "hi") 0 0))
+ (test-assert "NULL parameters"
+ (sql-null? (value-at
+ (query conn "SELECT $1::text" (sql-null)) 0 0)))
+ (test "blob parameters"
+ "hi"
+ (value-at (query conn "SELECT $1::text" (string->blob "hi")) 0 0))
+ (test "boolean parameters"
+ '(#t #f)
+ (row-values (query conn "SELECT $1::bool, $2::bool" #t #f)))
+ (test "integer array parameters"
+ `(#(1 2) #(,(sql-null) 4))
+ (row-values (query conn "SELECT $1::int[], $2::int[]"
+ `#(1 2) `#(,(sql-null) 4))))
+ (test "nested integer array parameters"
+ `(#(#(1 2) #(,(sql-null) 4)))
+ (row-values (query conn "SELECT $1::int[][]"
+ `#(#(1 2) #(,(sql-null) 4)))))
+ (test "string array parameters (including 'null')"
+ `(#("a" "b") #(,(sql-null) "null"))
+ (row-values (query conn "SELECT $1::text[], $2::text[]"
+ `#("a" "b") `#(,(sql-null) "null"))))
+ (test "string array parameters with meta-characters"
+ `(#("a\\b" "c\"d") #("{" "}"))
+ (row-values (query conn "SELECT $1::text[], $2::text[]"
+ '#("a\\b" "c\"d") '#("{" "}"))))
+ (test "nested string array parameters"
+ `(#(#("a" "b") #(,(sql-null) "null")))
+ (row-values (query conn "SELECT $1::text[][]"
+ `#(#("a" "b") #(,(sql-null) "null")))))
+ (test "array bounds are ignored"
+ `#(#(#(1 2 3) #(4 5 6)))
+ (value-at
+ (query conn
+ "SELECT '[1:1][-2:-1][3:5]={{{1,2,3},{4,5,6}}}'::int[] AS f1")))
+
+ ;; Basic domains seem to return just their base type
+ (query conn "BEGIN")
+ (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 2)")
+ (test "basic domains"
+ 3
+ (value-at (query conn "SELECT $1::mydom" 3)))
+ (query conn "ROLLBACK")
+
+ (query conn "BEGIN")
+ (query conn "CREATE TYPE foo AS ( a integer, b text )")
+ (test "basic composite type"
+ `(1 "one")
+ (value-at (query conn "SELECT $1::foo" `(1 "one"))))
+ (test "composite type with meta-characters"
+ `(123 "\\backslash\"quote")
+ (value-at (query conn "SELECT $1::foo" `(123 "\\backslash\"quote"))))
+ (query conn "CREATE TYPE bar AS ( x foo, y integer )")
+ (test "Nested composite type"
+ `((2 "two") 3)
+ (value-at (query conn "SELECT $1::bar" `((2 "two") 3))))
+ (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 1)")
+ (query conn "CREATE TYPE qux AS ( i integer, d mydom )")
+ (test "Composite type containing domain value"
+ `(1 2)
+ (value-at (query conn "SELECT $1::qux" `(1 2))))
+ (query conn "ROLLBACK")
+
+ (test "anonymous composite type ('record')"
+ '("one" "two")
+ (value-at (query conn "SELECT ROW('one', 'two')")))
+
+ (test "anonymous composite type ('record') with NULL"
+ `("one" ,(sql-null))
+ (value-at (query conn "SELECT ROW('one', NULL)")))
+
+ ;; ROW() is indistinguishable from ROW(NULL). The latter is more likely
+ ;; to occur than the former, so let's ensure that's how it's interpreted
+ ;; See also http://archives.postgresql.org/pgsql-hackers/2004-06/msg00159.php
+ (test "anonymous composite type ('record') with just one NULL"
+ `(,(sql-null))
+ (value-at (query conn "SELECT ROW(NULL)"))))
+
+(test-group "escaping and quotation"
+ (test-group "with standards conforming strings off"
+ (query conn "SET standard_conforming_strings='off'")
+ (test "String is escaped correctly"
+ "it''s \"this\" \\\\ safe!"
+ (escape-string conn "it's \"this\" \\ safe!"))
+ (test "Small string is escaped correctly"
+ "foo"
+ (escape-string conn "foo"))
+ (test "Bytea is escaped correctly (u8vector)"
+ (if (>= major-version 9)
+ "\\\\x576800617427730a75703f"
+ "Wh\\\\000at''s\\\\012up?")
+ (escape-bytea conn (blob->u8vector (string->blob "Wh\x00at's\nup?"))))
+ (test "Bytea is unescaped correctly (blob)"
+ (blob->u8vector (string->blob "What's\nup? "))
+ ;; The extra quote is dropped here because it wouldn't be returned
+ ;; by pgsql either.
+ (unescape-bytea "What's\\012up?\\ "))
+ (test "Identifier is escaped and quoted correctly"
+ ;; Backslashes have no special meaning in identifiers,
+ ;; standards conforming strings or no
+ "\"it's \"\"this\"\" \\ safe!\""
+ (quote-identifier conn "it's \"this\" \\ safe!")))
+ (test-group "with standards conforming strings on"
+ (query conn "SET standard_conforming_strings='on'")
+ (test "String is escaped correctly"
+ "it''s \"this\" \\ safe!"
+ (escape-string conn "it's \"this\" \\ safe!"))
+ (test "Bytea is escaped correctly"
+ (if (>= major-version 9)
+ "\\x576800617427730a75703f"
+ "Wh\\000at''s\\012up?")
+ (escape-bytea conn "Wh\x00at's\nup?"))
+ (test "Bytea is unescaped correctly"
+ (blob->u8vector (string->blob "What's\nup? "))
+ ;; The extra quote is dropped here because it wouldn't be returned
+ ;; by pgsql either.
+ (unescape-bytea "What's\\012up?\\ "))
+ (test "Identifier is escaped and quoted correctly"
+ ;; Backslashes have no special meaning in identifiers,
+ ;; standards conforming strings or no
+ "\"it's \"\"this\"\" \\ safe!\""
+ (quote-identifier conn "it's \"this\" \\ safe!"))))
+
+(test-group "query error handling"
+ (test-group "basic info: position and code"
+ (handle-exceptions exn
+ (begin (test "Class of real query error is available and set to expected value"
+ "42"
+ ((condition-property-accessor 'query 'error-class) exn))
+ (test "Code of real query error is available and set to expected value"
+ "42P01" ; undefined_table
+ ((condition-property-accessor 'query 'error-code) exn))
+ ;; We can't set locale w/o superuser rights, so we'll
+ ;; have to make do with an incomplete severity check.
+ (test-assert "Severity of real query error is a symbol"
+ (symbol? ((condition-property-accessor
+ 'query 'severity) exn)))
+ (test "Statement position in real query error is correct"
+ 15
+ ((condition-property-accessor
+ 'query 'statement-position) exn)))
+ (query conn "SELECT 1 FROM nonexistant_table")
+ (error "query call didn't fail")))
+ (test-group "message and code"
+ (handle-exceptions exn
+ (begin (test "Error class is available and set to expected value"
+ "42"
+ ((condition-property-accessor 'query 'error-class) exn))
+ (test "Error code is available and set to expected value"
+ "42P16"
+ ((condition-property-accessor 'query 'error-code) exn))
+ ;; We can't set locale w/o superuser rights, so we'll
+ ;; have to make do with some neutered checks.
+ (test-assert "Severity is a symbol"
+ (symbol? ((condition-property-accessor
+ 'query 'severity) exn)))
+ (test "Message primary is set to the expected value"
+ "testing, 1, 2, 3."
+ ((condition-property-accessor 'query 'message-primary) exn))
+ (test "Detail is set to the expected value"
+ "this is a test"
+ ((condition-property-accessor 'query 'message-detail) exn))
+ (test "Hint is set to the expected value"
+ "try again"
+ ((condition-property-accessor 'query 'message-hint) exn))
+ ;; XXX These two may be too version-specific
+ (test "source function is set to the correct value"
+ "exec_stmt_raise"
+ ((condition-property-accessor 'query 'source-function) exn))
+ (test "source file is set to the the correct value"
+ "pl_exec.c"
+ ((condition-property-accessor 'query 'source-file) exn))
+ (test-assert "source line is available and a number"
+ (number? ((condition-property-accessor
+ 'query 'source-line) exn))))
+ (query conn (conc "CREATE OR REPLACE FUNCTION cause_error() "
+ "RETURNS void AS $$\n"
+ " BEGIN\n"
+ " RAISE invalid_table_definition \n"
+ " USING MESSAGE = 'testing, 1, 2, 3.', \n"
+ " DETAIL = 'this is a test', \n"
+ " HINT = 'try again';\n"
+ " END;\n"
+ "$$ LANGUAGE plpgsql"))
+ (value-at (query conn "SELECT cause_error()"))
+ (error "query call didn't fail")))
+ (when (or (> major-version 9) (and (= major-version 9) (>= minor-version 3)))
+ (test-group "schema information"
+ (query conn "BEGIN")
+ (query conn (conc "CREATE DOMAIN posint AS int"
+ " CONSTRAINT must_be_positive CHECK (VALUE > 0)"))
+ (query conn (conc "CREATE TEMP TABLE foo (bar posint) ON COMMIT DROP"))
+ (handle-exceptions exn
+ (begin (test-assert "Schema name is set" ; It is pg_temp_2
+ ((condition-property-accessor
+ 'query 'schema-name) exn))
+ (test "Data type name is correct"
+ "posint"
+ ((condition-property-accessor 'query 'datatype-name) exn))
+ (test "Constraint name is correct"
+ "must_be_positive"
+ ((condition-property-accessor 'query 'constraint-name) exn)))
+ (query conn "INSERT INTO foo (bar) VALUES (-1)")
+ (error "query call didn't fail"))
+ (query conn "ROLLBACK")
+ (query conn "BEGIN")
+ (query conn (conc "CREATE TEMP TABLE foo (bar int NOT NULL) "
+ "ON COMMIT DROP"))
+ (handle-exceptions exn
+ (begin (test-assert "Schema name is set" ; It is pg_temp_2
+ ((condition-property-accessor
+ 'query 'schema-name) exn))
+ (test "Table name is correct"
+ "foo"
+ ((condition-property-accessor 'query 'table-name) exn))
+ (test "Column name is correct"
+ "bar"
+ ((condition-property-accessor 'query 'column-name) exn)))
+ (query conn "INSERT INTO foo (bar) VALUES (NULL)")
+ (error "query call didn't fail"))
+ (query conn "ROLLBACK"))))
+
+(test-group "COPY support"
+ (query conn "CREATE TEMP TABLE copy_table ( nr integer, s text )")
+ (test-group "low-level interface"
+ (test-error* "Cannot put copy data while no COPY in progress"
+ (exn postgresql i/o)
+ (put-copy-data conn "whatever"))
+ (query conn "COPY copy_table (s, nr) FROM STDIN")
+ (test-error* "Cannot initiate new query while waiting for COPY input"
+ (exn postgresql i/o)
+ (query conn "SELECT 1"))
+ (put-copy-data conn "one\t1\n")
+ (test-error* "Cannot initiate new query while COPY data in progress"
+ (exn postgresql i/o)
+ (query conn "SELECT 1"))
+ (put-copy-data conn "two\t2")
+ (put-copy-end conn)
+ (let ((res (query conn "SELECT * FROM copy_table")))
+ (test "Simple copy from STDIN works"
+ '((1 "one")
+ (2 "two"))
+ (list (row-values res 0) (row-values res 1))))
+ (test-error* "Cannot get copy data while no COPY in progress"
+ (exn postgresql i/o)
+ (get-copy-data conn))
+ (query conn "COPY copy_table (s, nr) TO STDOUT")
+ (test-error* "Cannot initiate new query while waiting for COPY output"
+ (exn postgresql i/o)
+ (query conn "SELECT 1"))
+ (test "Simple copy to STDOUT works, first record"
+ "one\t1\n"
+ (get-copy-data conn))
+ (test-error* "Cannot initiate new query while reading COPY data"
+ (exn postgresql i/o)
+ (query conn "SELECT 1"))
+ (test "Simple copy to STDOUT works, second record"
+ "two\t2\n"
+ (get-copy-data conn))
+ (test-assert "EOF is marked by a result object"
+ (result? (get-copy-data conn))))
+ (test-group "high-level interface"
+ (test "Mapping"
+ '(("one" "1")
+ ("two" "2"))
+ (copy-query-map string-split conn "COPY copy_table (s, nr) TO STDOUT"))
+ (test "Error while mapping gets connection out of COPY state"
+ "okay"
+ (handle-exceptions exn
+ (value-at (query conn "SELECT 'okay'"))
+ (copy-query-map (lambda _ (error "blah"))
+ conn "COPY copy_table (s, nr) TO STDOUT")))
+ (test "Fold"
+ '(("one" "1")
+ ("two" "2"))
+ (reverse
+ (copy-query-fold
+ (lambda (data result)
+ (cons (string-split data) result))
+ '() conn "COPY copy_table (s, nr) TO STDOUT")))
+ (test "Error while folding gets connection out of COPY state"
+ "okay"
+ (handle-exceptions exn
+ (value-at (query conn "SELECT 'okay'"))
+ (copy-query-fold (lambda _ (error "blah"))
+ '() conn "COPY copy_table (s, nr) TO STDOUT")))
+ (test "Fold-right"
+ '(("one" "1")
+ ("two" "2"))
+ (copy-query-fold-right
+ (lambda (data result)
+ (cons (string-split data) result))
+ '() conn "COPY copy_table (s, nr) TO STDOUT"))
+ (test "Error while folding right gets connection out of COPY state"
+ "okay"
+ (handle-exceptions exn
+ (value-at (query conn "SELECT 'okay'"))
+ (copy-query-fold-right (lambda _ (error "blah"))
+ '() conn "COPY copy_table (s, nr) TO STDOUT")))
+ (test "For-each"
+ '(("one" "1")
+ ("two" "2"))
+ (let ((res '()))
+ (copy-query-for-each (lambda (x)
+ (set! res (cons (string-split x) res)))
+ conn "COPY copy_table (s, nr) TO STDOUT")
+ (reverse res)))
+ (test "Error during for-each gets connection out of COPY state"
+ "okay"
+ (handle-exceptions exn
+ (value-at (query conn "SELECT 'okay'"))
+ (copy-query-for-each (lambda (x) (error "blah"))
+ conn "COPY copy_table (s, nr) TO STDOUT")))
+ (query conn "TRUNCATE copy_table")
+ (with-output-to-copy-query (lambda ()
+ (print "first\t1")
+ (print "second\t2"))
+ conn "COPY copy_table (s, nr) FROM STDIN")
+ (test "Port interface inserted data correctly"
+ '(("first" 1)
+ ("second" 2))
+ (let ((res (query conn "SELECT s, nr FROM copy_table")))
+ (list (row-values res 0) (row-values res 1))))
+ (query conn "TRUNCATE copy_table")
+ (handle-exceptions _
+ (void)
+ (with-output-to-copy-query (lambda ()
+ (print "first\t1")
+ (print "second\t2")
+ (error "blah"))
+ conn "COPY copy_table (s, nr) FROM STDIN"))
+ (test "Error inside with-output-to-copy caused abort of insert"
+ 0 (value-at (query conn "SELECT COUNT(*) FROM copy_table")))))
+
+(test-group "type parsers"
+ (test "Integer parsed correctly"
+ 1234
+ (numeric-parser "1234"))
+ (test "Float parsed correctly"
+ 123.456
+ (numeric-parser "123.456"))
+ (test-error* "Non-integer is an error"
+ (exn postgresql parse)
+ (numeric-parser "not an integer"))
+ (test "Boolean true parsed correctly"
+ #t
+ (bool-parser "t"))
+ (test "Boolean false parsed correctly"
+ #f
+ (bool-parser "f"))
+ (test "Byte array parsed correctly"
+ (blob->u8vector/shared (string->blob "abc\x01\x02\xffdef"))
+ (bytea-parser "abc\\001\\002\\377def"))
+ (test "Char parser"
+ #\x
+ (char-parser "x")))
+
+(test-group "type unparsers"
+ (test "Boolean true unparsed correctly"
+ "TRUE"
+ (bool-unparser conn #t))
+ (test "Boolean false unparsed correctly"
+ "FALSE"
+ (bool-unparser conn #f)))
+
+(test-group "high-level interface"
+ (test "row-fold"
+ '(("one" 2)
+ ("three" 4))
+ (reverse
+ (row-fold
+ cons '()
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+ "one" 2))))
+ (test "column-fold"
+ '(("one" "three")
+ (2 4))
+ (reverse
+ (column-fold
+ cons '()
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+ "one" 2))))
+ (test "row-fold-right"
+ '(("one" 2)
+ ("three" 4))
+ (row-fold-right
+ cons '()
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+ "one" 2)))
+ (test "column-fold-right"
+ '(("one" "three")
+ (2 4))
+ (column-fold-right
+ cons '()
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4"
+ "one" 2)))
+ (test "row-for-each"
+ '(("one" 2)
+ ("three" 4))
+ (let ((res '()))
+ (row-for-each
+ (lambda (row) (set! res (cons row res)))
+ (query
+ conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))
+ (reverse res)))
+ (test "column-for-each"
+ '(("one" "three")
+ (2 4))
+ (let ((res '()))
+ (column-for-each
+ (lambda (col) (set! res (cons col res)))
+ (query
+ conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))
+ (reverse res)))
+ (test "row-map"
+ '(("one" 2)
+ ("three" 4))
+ (row-map
+ identity
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)))
+ (test "column-map"
+ '(("one" "three")
+ (2 4))
+ (column-map
+ identity
+ (query conn
+ "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))))
+
+(test-group "transactions"
+ (query conn "CREATE TEMP TABLE foo ( bar integer )")
+
+ (test-group "simple transactions"
+ (test "Transaction inactive"
+ #f
+ (in-transaction? conn))
+ (test "Transaction active"
+ #t
+ (with-transaction conn
+ (lambda () (in-transaction? conn))))
+ (test "Successful transaction"
+ '(1)
+ (and
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")))
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (query conn "TRUNCATE foo")
+
+ (test "Unsuccessful transaction"
+ #f
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ #f)))
+
+ (test "Empty table after unsuccessful transaction"
+ '()
+ (column-values (query conn "SELECT * FROM foo")))
+
+ (handle-exceptions exn
+ (void)
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (error "oops!"))))
+
+ (test "Exception during transaction causes reset"
+ '()
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (test-group "nested transactions"
+ (test "Successful transaction"
+ '(1 2)
+ (and
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (2)")))))
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (query conn "TRUNCATE foo")
+
+ (test "Unsuccessful main transaction"
+ '()
+ (and
+ (not
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (2)")))
+ #f)))
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (test "Unsuccessful subtransaction"
+ '(1)
+ (and
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (2)")
+ #f))
+ #t))
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (query conn "TRUNCATE foo")
+
+ ;; Test that errors do not kill the transaction. Apparently
+ ;; aborting transactions on errors is a psql(1) "feature", not a
+ ;; libpq one.
+ (test "Unsuccessful subtransaction with bad query"
+ '(1 2)
+ (and
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (handle-exceptions exn
+ #t
+ (with-transaction
+ conn (lambda ()
+ (query conn "INVALID QUERY"))))
+ (query conn "INSERT INTO foo (bar) VALUES (2)")))
+ (column-values (query conn "SELECT * FROM foo"))))
+
+ (query conn "TRUNCATE foo")
+
+ (test "Multiple subtransactions"
+ '(1 3)
+ (and
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (1)")
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (2)")
+ #f))
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO foo (bar) VALUES (3)")))))
+ (column-values (query conn "SELECT * FROM foo")))))
+
+ ;; Very annoying; read-only transactions can write to temporary tables,
+ ;; so we have to create a REAL table here.
+ (query conn "CREATE TABLE chicken_pgsql_test (bar int)")
+ ;; We'd better make damn sure it gets dropped again.
+ (on-exit (lambda () (query conn "DROP TABLE chicken_pgsql_test")))
+
+ (test-group "transaction access mode"
+ (test "Writes with explicit read/write access mode work"
+ '(1)
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (1)")
+ (column-values
+ (query conn "SELECT * FROM chicken_pgsql_test")))
+ access: 'read/write))
+
+ (test "Reads with read-only access mode work"
+ '(1)
+ (with-transaction
+ conn (lambda ()
+ (column-values
+ (query conn "SELECT * FROM chicken_pgsql_test")))
+ access: 'read-only))
+
+ (test-error* "Writes with read-only access cause errors"
+ (exn postgresql query)
+ (with-transaction
+ conn (lambda ()
+ (query conn (conc "INSERT INTO chicken_pgsql_test (bar)"
+ "VALUES (1)")))
+ access: 'read-only))
+
+ (test "Switching read-write to read-only works"
+ '(1 2)
+ (with-transaction
+ conn (lambda ()
+ (with-transaction
+ conn (lambda ()
+ (query conn "SELECT * FROM chicken_pgsql_test"))
+ access: 'read-only)
+ (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (2)")
+ (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+ access: 'read/write))
+
+ (test "Switching read-write to read-only works with rollback"
+ '(1 2 3)
+ (with-transaction
+ conn (lambda ()
+ (handle-exceptions exn
+ (void)
+ (with-transaction
+ conn (lambda ()
+ (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)"))
+ access: 'read-only))
+ (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)")
+ (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+ access: 'read/write))
+
+ (test-error* "Switching read-only to read-write causes error"
+ (exn postgresql query)
+ (with-transaction
+ conn (lambda ()
+ (query conn "SELECT * FROM chicken_pgsql_test")
+ (with-transaction
+ conn (lambda ()
+ (query conn
+ (conc "INSERT INTO chicken_pgsql_test (bar)"
+ "VALUES (2)")))
+ access: 'read/write)
+ (column-values (query conn "SELECT * FROM chicken_pgsql_test")))
+ access: 'read-only))
+
+ ;; Run these "concurrent" tests with a second connection
+ (let ((conn2 (connect '((dbname . test)))))
+ (test "Read committed transaction does see concurrent changes"
+ '(1 2 3 4)
+ (with-transaction
+ conn (lambda ()
+ ;; MUST perform a query, since only after the first
+ ;; query will the isolation take effect.
+ (query conn "SELECT * FROM chicken_pgsql_test")
+ (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) "
+ "VALUES (4)"))
+ (column-values
+ (query conn "SELECT * FROM chicken_pgsql_test")))
+ isolation: 'read-committed))
+
+ (test "Serializable transaction doesn't see concurrent changes"
+ '(1 2 3 4)
+ (with-transaction
+ conn (lambda ()
+ ;; MUST perform a query, since only after the first
+ ;; query will the isolation take effect.
+ (query conn "SELECT * FROM chicken_pgsql_test")
+ (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) "
+ "VALUES (5)"))
+ (column-values
+ (query conn "SELECT * FROM chicken_pgsql_test")))
+ isolation: 'serializable))
+ (disconnect conn2)))
+ )
+
+(test-end)
+
+(test-exit)