Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 252 lines (240 sloc) 10.985 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 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 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 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 245 246 247 248 249 250 251 252
(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))
Something went wrong with that request. Please try again.