Find file
Fetching contributors…
Cannot retrieve contributors at this time
257 lines (243 sloc) 10.8 KB
;;; TODO: We need to find a mechanism for actually running these
;;; tests; for now, disable them.
(exit 0)
(use test freetds sql-null srfi-19)
;; TODO: (use numbers) and add some tests with bignums
;; or even ratnums (if those are used anywhere...?)
(include "test-freetds-secret.scm")
(test-begin "FreeTDS")
(test-group "connection management"
(test-assert "connect returns an open connection"
(let* ((conn (make-connection server username password))
(is-conn (connection? conn))
(conn-open (connection-open? conn)))
(connection-close conn)
(and is-conn conn-open)))
(test-error "cannot connect with invalid credentials"
(make-connection server "non-existing-user" "invalid-password"))
(test-assert "connection-close closes the connection"
(let ((conn (make-connection server username password)))
(connection-close conn)
(not (connection-open? conn)))))
;; From now on, just keep using the same connection
(define connection (make-connection server username password database))
(test-group "low-level query & results interface"
(let ((res (send-query connection
(conc "SELECT 1 AS one, 2 AS two, 3 AS three"
" UNION "
"SELECT 4, 5, 6"))))
(test-assert "send-query returns result object"
(result? res))
(test "Column name can be obtained"
'one
(column-name res 0))
(test "All column names can be obtained"
'(one two three)
(column-names res))
(test "Result-row with no args returns first row"
'(1 2 3)
(result-row res))
(test "Result-row with arg returns that row"
'(4 5 6)
(result-row res 1))
(test "Result-column with no args returns first column"
'(1 4)
(result-column res))
(test "Result-column with arg returns that column"
'(3 6)
(result-column res 2))
(test "Result-row/alist with arg returns that row"
'((one . 4) (two . 5) (three . 6))
(result-row/alist res 1))
(test "Result-value with no args returns first col&row"
1 (result-value res 0))
(test "Result-value with column arg returns col in first row"
3 (result-value res 2))
(test "Result-value with column and row arg returns proper value"
6 (result-value res 2 1))
(test-assert "Cleaning up the result gives no problems"
(result-cleanup! res)))
(test "result-values returns empty list on empty result set"
'()
(result-values (send-query connection "SELECT 1 WHERE 1 = 0")))
(test "result-values returns all rows when result contains multiple rows"
'((1 2 3) (4 5 6))
(result-values
(send-query connection (conc "SELECT 1 AS one, 2 AS two, 3 AS three"
" UNION "
"SELECT 4, 5, 6"))))
(test "result-values/alist retrieves all values as alist"
'(((one . 1) (two . 2) (three . 3))
((one . 4) (two . 5) (three . 6)))
(result-values/alist
(send-query connection (conc "SELECT 1 AS one, 2 AS two, 3 AS three"
" UNION "
"SELECT 4, 5, 6"))))
;; This is ok because we read in the entire result at once
(test "Querying before reading out the previous result works"
'((4 5 6))
(begin (send-query connection "SELECT 1, 2, 3")
(result-values (send-query connection "SELECT 4, 5, 6"))))
(test "After resetting the connection, we can send queries again"
'((7 8 9))
(begin (connection-reset! connection)
(result-values (send-query connection "SELECT 7, 8, 9"))))
(test "Cleaning up one result allows us to send another"
'((13 14 15))
(begin (result-cleanup! (send-query connection "SELECT 10, 11, 12"))
(result-values (send-query connection "SELECT 13, 14, 15")))))
(test-group "type parsing"
(test "Variable-length string values are retrieved correctly"
'(("one" "testing" ""))
(result-values (send-query connection "SELECT 'one', 'testing', ''")))
(test "Fixed-length string values are retrieved correctly"
'(("one" "testing" " "))
(result-values (send-query connection
(conc "SELECT CAST('one' AS CHAR(3)),"
" CAST('testing' AS CHAR(7)),"
;; CHAR(0) is not allowed...
" CAST(' ' AS CHAR(1))"))))
(test "Integer values are retrieved correctly"
'((0 -1 110))
(result-values (send-query connection "SELECT 0, -1, 110")))
(test "Numeric values are retrieved correctly"
'((0.0 -1.5 256.0 257.0 0.256 110.12345))
(result-values
(send-query connection
"SELECT 0.0, -1.5, 256.0, 257.0, 0.256, 110.12345")))
(test "Float values are retrieved correctly"
'((0.0 -1.5 256.0 257.0 0.125 110.0625))
(result-values
(send-query connection
(conc "SELECT CAST(0.0 AS FLOAT), CAST(-1.5 AS FLOAT), "
" CAST(256.0 AS FLOAT), CAST(257.0 AS FLOAT), "
" CAST(0.125 AS FLOAT), CAST(110.0625 AS FLOAT)"))))
(test "Real values are retrieved correctly"
'((0.0 -1.5 256.0 257.0 0.125 110.0625))
(result-values
(send-query connection
(conc "SELECT CAST(0.0 AS REAL), CAST(-1.5 AS REAL), "
" CAST(256.0 AS REAL), CAST(257.0 AS REAL), "
" CAST(0.125 AS REAL), CAST(110.0625 AS REAL)"))))
;; The following two have no reverse (Scheme->SQL) mapping
(test "Money values are retrieved correctly (as floats)"
'((0.0 -1.5 256.0 257.0 0.125 110.0625))
(result-values
(send-query connection
(conc "SELECT $0.0, $-1.5, $256.0, $257.0, $0.125, "
" $110.0625"))))
(test "Small money values are retrieved correctly (as floats)"
'((0.0 -1.5 256.0 257.0 0.125 110.0625))
(result-values
(send-query connection
(conc "SELECT CAST($0.0 AS SMALLMONEY), "
" CAST($-1.5 AS SMALLMONEY),"
" CAST($256.0 AS SMALLMONEY), "
" CAST($257.0 AS SMALLMONEY), "
" CAST($0.125 AS SMALLMONEY), "
" CAST($110.0625 AS SMALLMONEY)"))))
(test "Datetime values are retrieved correctly"
;; TODO: Figure out how to make this thing use timezones
`((,(make-date 0 0 0 0 1 1 2000 0)
,(make-date 0 56 1 17 9 5 2011 0)
,(make-date 0 58 14 17 9 5 2011 0)))
(result-values
(send-query connection
(conc "SELECT CAST('2000-01-01T00:00:00Z' AS DATETIME),"
" CAST('2011-05-09T17:01:56Z' AS DATETIME),"
" CAST('May 9 2011 17:14:58PM' AS DATETIME)"))))
(test "NULL values are retrieved correctly"
(list (list (sql-null) (sql-null)))
(result-values (send-query connection "SELECT NULL, NULL"))))
(test-group "type unparsing"
;; See http://lists.ibiblio.org/pipermail/freetds/2009q2/024682.html
(test "String values are written correctly (broken in FreeTDS <= 0.82)"
'(("one" "testing" ""))
(result-values
(send-query connection "SELECT ?, ?, ?" "one" "testing" "")))
(test "Integer values are written correctly"
'((0 -1 110))
(result-values (send-query connection "SELECT ?, ?, ?" 0 -1 110)))
(test "Float values are written correctly"
'((0.0 -1.5 110.12345))
(result-values
(send-query connection "SELECT ?, ?, ?" 0.0 -1.5 110.12345)))
(test "Datetime values are written correctly"
;; TODO: Figure out how to make this thing use timezones
`((,(make-date 0 0 0 0 1 1 2000 0)
,(make-date 0 56 1 17 9 5 2011 0)
,(make-date 0 58 14 17 9 5 2011 0)))
(result-values (send-query connection
"SELECT ?, ?, ?"
(make-date 0 0 0 0 1 1 2000 0)
(make-date 0 56 1 17 9 5 2011 0)
(make-date 0 58 14 17 9 5 2011 0))))
(test "NULL values are written correctly"
(list (list (sql-null) (sql-null)))
(result-values
(send-query connection "SELECT ?, ?" (sql-null) (sql-null)))))
(test-group "misc"
(test "Call-with-result-set works the way it should"
'((1 2 3) (4 5 6))
(call-with-result-set connection
"SELECT 1, 2, 3 UNION SELECT 4, 5, 6"
result-values))
(test-error "Error for invalid SQL"
(send-query connection "INVALID")))
(test-group "high-level interface"
(test "row-fold"
'(("one" 2)
("three" 4))
(reverse
(row-fold
cons '()
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2))))
(test "column-fold"
'(("one" "three")
(2 4))
(reverse
(column-fold
cons '()
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2))))
(test "row-fold-right"
'(("one" 2)
("three" 4))
(row-fold-right
cons '()
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2)))
(test "column-fold-right"
'(("one" "three")
(2 4))
(column-fold-right
cons '()
(send-query connection "SELECT ?, ? 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)))
(send-query connection "SELECT ?, ? 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)))
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2))
(reverse res)))
(test "row-map"
'(("one" 2)
("three" 4))
(row-map
identity
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2)))
(test "column-map"
'(("one" "three")
(2 4))
(column-map
identity
(send-query connection "SELECT ?, ? UNION SELECT 'three', 4" "one" 2))))
(test-end)
(unless (zero? (test-failure-count)) (exit 1))