source: project/release/4/pandora/trunk/tests/run.scm @ 22763

Last change on this file since 22763 was 22763, checked in by Thomas Chust, 9 years ago

[pandora] Replaced uses of deprecated procedures for CHICKEN 4.6.5 compatibility

File size: 9.4 KB
Line 
1;;;; tests/run.scm
2;;;; :tabSize=2:indentSize=2:noTabs=true:
3;;;; Tests for pandora
4
5(use test miscmacros pandora pandora-sqlite3)
6
7;;; Utility syntax
8
9(define-syntax with-datastore
10  (syntax-rules ()
11    [(with-datastore [ds uri]
12       body ...)
13      (let ([ds (*sql-datastore* 'connect uri)])
14        (dynamic-wind
15          void
16          (lambda ()
17            body ...)
18          (lambda ()
19            (and-let* ([s ds])
20              (set! ds #f)
21              (s 'disconnect!)))))]))
22
23(define-syntax with-tables
24  (syntax-rules ()
25    [(with-tables ds
26       ([(name column ...) (data ...) ...] ...)
27       body ...)
28      (let ([s ds])
29        (let ([name
30                (let ([columns (append (s 'name->column-clause 'column) ...)])
31                  (s 'execute
32                    `("CREATE TABLE " ,@(s 'name->table-clause 'name)
33                      " (" ,@(intersperse columns ", ") ")")
34                    '())
35                  (let ([t (s 'table 'name)])
36                    (apply t 'insert! (join (zip columns (list data ...))))
37                    ...
38                    t))]
39              ...)
40          body ...))]))
41
42(define (collapse sql params)
43  (cons (string-join (map ->string sql) "") params))
44
45;;; Unit tests
46(test-group "Pandora ORM"
47
48  (test-assert "SQLite3 driver connection"
49    (with-datastore [ds "sqlite3::memory:"]
50      (string-prefix?
51        "3."
52        (ds 'fold
53          (lambda (acc version)
54            version)
55          #f
56          '("SELECT sqlite_version()")
57          '()))))
58
59  (test-group "SQL formatting"
60
61    (test "identifier escaping"
62      '("alpha" "beta_2" "\"gamma-3\"" "\"Funny \"\"Name\"\"\"")
63      (map
64        (cut *sqlite3-datastore* 'escape-sql-identifier <>)
65        '("alpha" "beta_2" "gamma-3" "Funny \"Name\"")))
66
67    (test "automatic table naming"
68      '("HelloWorld")
69      (*sql-datastore* 'name->table-clause 'hello-world))
70
71    (test "automatic column naming"
72      '("hello_world")
73      (*sql-datastore* 'name->column-clause 'hello-world))
74
75    (test "table expressions"
76      '(("FooBar") ("just what I said"))
77      (map
78        (lambda (dataset)
79          (call-with-values (cut dataset 'table-expression) collapse))
80        (list
81          (*sql-datastore* 'table 'foo-bar)
82          (*sql-datastore* 'table "just what I said"))))
83
84    (test "filter expressions"
85      '(("(id = ?)" 42) ("(name IN (?, ?))" "foo" "bar") ("(a = ?) AND (b = ?)" 1 2))
86      (map
87        (lambda (dataset)
88          (call-with-values (cut dataset 'filter-expression) collapse))
89        (list
90          (*sql-dataset* 'filter id: 42)
91          (*sql-dataset* 'filter name: '("foo" "bar"))
92          (*sql-dataset* 'filter a: 1 b: 2))))
93
94    (test "joined table expressions"
95      '(("(SELECT x AS id FROM Y) NATURAL INNER JOIN X")
96        ("(SELECT a AS id FROM B WHERE (name = ?)) NATURAL INNER JOIN A" "foo")
97        ("(SELECT (foo + ?) AS bar FROM B) NATURAL INNER JOIN A" 42))
98      (map
99        (lambda (dataset)
100          (call-with-values (cut dataset 'table-expression) collapse))
101        (list
102          ((*sql-datastore* 'table 'x) 'match
103            (*sql-datastore* 'table 'y) '[id x])
104          ((*sql-datastore* 'table 'a) 'match
105            ((*sql-datastore* 'table 'b) 'filter name: "foo") '[id a])
106          ((*sql-datastore* 'table 'a) 'match
107            (*sql-datastore* 'table 'b) '[bar ("foo + " ?) 42]))))
108
109    (test "order expressions"
110      '(("(name) ASC") ("(name) ASC, (date) DESC"))
111      (map
112        (lambda (dataset)
113          (call-with-values (cut dataset 'order-expression) collapse))
114        (list
115          (*sql-dataset* 'order name: 'ascending)
116          (*sql-dataset* 'order name: 'asc date: 'desc))))
117
118    )
119
120  (test-group "simple data handling"
121
122    (test "data invariance"
123      '("foo" "bar" "baz")
124      (with-datastore [ds "memory:"]
125        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
126          ((a 'order id: 'asc) 'name #f))))
127
128    (test-assert "empty dataset detection"
129      (let/cc esc
130        (with-datastore [ds "memory:"]
131          (with-tables ds ([(a id name) (1 "foo")])
132            ((a 'filter id: 42) 'name (cut esc #t))
133            #f))))
134
135    (test "update"
136      '("foo" "bar")
137      (with-datastore [ds "memory:"]
138        (with-tables ds ([(a id name) (1 "foo")])
139          (let ([before (a 'name)])
140            (a 'set-name! "bar")
141            (let ([after (a 'name)])
142              (list before after))))))
143
144    (test "insert"
145      '(("foo" "baz") ("foo" "bar" "baz"))
146      (with-datastore [ds "memory:"]
147        (with-tables ds ([(a id name) (1 "foo") (3 "baz")])
148          (let ([before ((a 'order id: 'asc) 'name #f)])
149            (a 'insert! id: 2 name: "bar")
150            (let ([after ((a 'order id: 'asc) 'name #f)])
151              (list before after))))))
152
153    (test "transfer"
154      '(("foo" "baz") ("foo" "bar" "baz"))
155      (with-datastore [ds "memory:"]
156        (with-tables ds ([(a id name) (1 "foo") (3 "baz")]
157                         [(b id name) (2 "bar")])
158          (let ([before ((a 'order id: 'asc) 'name #f)])
159            (a 'transfer! b '(id id) '(name name))
160            (let ([after ((a 'order id: 'asc) 'name #f)])
161              (list before after))))))
162
163    (test "delete"
164      '(("foo" "bar" "baz") ("foo" "baz"))
165      (with-datastore [ds "memory:"]
166        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
167          (let ([before ((a 'order id: 'asc) 'name #f)])
168            ((a 'filter name: "bar") 'delete!)
169            (let ([after ((a 'order id: 'asc) 'name #f)])
170              (list before after))))))
171
172    (test "match"
173      '((2 "foo"))
174      (with-datastore [ds "memory:"]
175        (with-tables ds ([(a id name) (1 "x") (2 "foo") (3 "y")]
176                         [(b id name) (1 "blubb") (2 "foo") (3 "boing")])
177          ((a 'match b '(name name)) 'select 'id 'name))))
178
179    )
180
181  (test-group "dataset iteration"
182
183    (test "first"
184      "baz"
185      (with-datastore [ds "memory:"]
186        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
187          (((a 'order id: 'desc) 'first) 'name))))
188
189    (test "all"
190      '(3 2 1)
191      (with-datastore [ds "memory:"]
192        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
193          (map (cut <> 'id) ((a 'order id: 'desc) 'all)))))
194
195    (test "map"
196      '("bar" "baz" "foo")
197      (with-datastore [ds "memory:"]
198        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
199          ((a 'order name: 'asc) 'map (cut <> 'name)))))
200
201    (test "fold"
202      "barbazfoo"
203      (with-datastore [ds "memory:"]
204        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
205          ((a 'order name: 'asc) 'fold
206            (lambda (row acc)
207              (string-append acc (row 'name)))
208            ""))))
209
210    (test "fold"
211      "barbazfoo"
212      (with-datastore [ds "memory:"]
213        (with-tables ds ([(a id name) (1 "foo") (2 "bar") (3 "baz")])
214          (let ([acc ""])
215            ((a 'order name: 'asc) 'for-each
216              (lambda (row)
217                (set! acc (string-append acc (row 'name)))))
218            acc))))
219
220    )
221
222  (test-group "linked datasets"
223
224    (test "read simple link"
225      "blurb"
226      (with-datastore [ds "memory:"]
227        (with-tables ds ([(a id name)
228                           (1 "blurb") (2 "schwall")]
229                         [(b type data)
230                           (1 "Hallo Welt!") (1 "Wie geht's?") (2 "Test")])
231          (b 'add-link-slots! 'type* '((type id)) a)
232          (((b 'filter data: "Hallo Welt!") 'type*) 'name))))
233
234    (test "write simple link"
235      '("blurb" "schwall")
236      (with-datastore [ds "memory:"]
237        (with-tables ds ([(a id name)
238                           (1 "blurb") (2 "schwall")]
239                         [(b type data)
240                           (1 "Hallo Welt!") (1 "Wie geht's?") (2 "Test")])
241          (b 'add-link-slots! 'type* 'set-type*! '((type id)) a)
242          (let ([before (((b 'filter data: "Hallo Welt!") 'type*) 'name)])
243            (b 'set-type*! (a 'filter name: "schwall"))
244            (let ([after (((b 'filter data: "Hallo Welt!") 'type*) 'name)])
245              (list before after))))))
246
247    (test "read complex link"
248      '("large" "red")
249      (with-datastore [ds "memory:"]
250        (with-tables ds ([(items id name)
251                           (1 "button") (2 "lever")]
252                         [(tags id name)
253                           (1 "large") (2 "green") (3 "red") (4 "small")]
254                         [(item-tags item tag)
255                           (1 1) (1 3) (2 4)])
256          (items 'add-link-slots! 'tags* '((id item)) item-tags '((tag id)) tags)
257          ((((items 'filter name: "button") 'tags*) 'order id: 'asc) 'name #f))))
258
259    (test "write complex link"
260      '(("large" "red") ("small" "green"))
261      (with-datastore [ds "memory:"]
262        (with-tables ds ([(items id name)
263                           (1 "button") (2 "lever")]
264                         [(tags id name)
265                           (1 "large") (2 "green") (3 "red") (4 "small")]
266                         [(item-tags item tag)
267                           (1 1) (1 3) (2 4)])
268          (items 'add-link-slots! 'tags* 'set-tags*! '((id item)) item-tags '((tag id)) tags)
269          (let ([before ((((items 'filter name: "button") 'tags*) 'order id: 'asc) 'name #f)])
270            ((items 'filter name: "button") 'set-tags*!
271              (tags 'filter name: '("small" "green")))
272            (let ([after ((((items 'filter name: "button") 'tags*) 'order id: 'desc) 'name #f)])
273              (list before after))))))
274
275    )
276
277  )
Note: See TracBrowser for help on using the repository browser.