1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: io.files kernel tools.test db db.tuples classes
4 db.types continuations namespaces math math.ranges
5 prettyprint calendar sequences db.sqlite math.intervals
6 db.postgresql accessors random math.bitwise
7 math.ranges strings urls fry db.tuples.private ;
10 : test-sqlite ( quot -- )
12 "tuples-test.db" temp-file sqlite-db _ with-db
15 : test-postgresql ( quot -- )
17 { "localhost" "postgres" "foob" "factor-test" }
18 postgresql-db _ with-db
21 TUPLE: person the-id the-name the-number the-real
22 ts date time blob factor-blob url ;
24 : <person> ( name age real ts date time blob factor-blob url -- person )
36 : <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
46 [ ] [ person recreate-table ] unit-test
47 [ ] [ person ensure-table ] unit-test
48 [ ] [ person drop-table ] unit-test
49 [ ] [ person create-table ] unit-test
50 [ person create-table ] must-fail
51 [ ] [ person ensure-table ] unit-test
53 [ ] [ person1 get insert-tuple ] unit-test
55 [ 1 ] [ person1 get the-id>> ] unit-test
57 [ ] [ person1 get 200 >>the-number drop ] unit-test
59 [ ] [ person1 get update-tuple ] unit-test
61 [ T{ person f 1 "billy" 200 3.14 } ]
62 [ T{ person f 1 } select-tuple ] unit-test
63 [ ] [ person2 get insert-tuple ] unit-test
66 T{ person f 1 "billy" 200 3.14 }
67 T{ person f 2 "johnny" 10 3.14 }
69 ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
72 T{ person f 1 "billy" 200 3.14 }
73 T{ person f 2 "johnny" 10 3.14 }
75 ] [ T{ person f } select-tuples ] unit-test
79 T{ person f 2 "johnny" 10 3.14 }
81 ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
84 [ ] [ person1 get delete-tuples ] unit-test
85 [ f ] [ T{ person f 1 } select-tuple ] unit-test
87 [ ] [ person3 get insert-tuple ] unit-test
97 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
98 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
99 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
100 B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
102 ] [ T{ person f 3 } select-tuple ] unit-test
104 [ ] [ person4 get insert-tuple ] unit-test
113 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
114 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
115 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
117 H{ { 1 2 } { 3 4 } { 5 "lol" } }
118 URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
120 ] [ T{ person f 4 } select-tuple ] unit-test
122 [ ] [ person drop-table ] unit-test ;
124 : db-assigned-person-schema ( -- )
127 { "the-id" "ID" +db-assigned-id+ }
128 { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
129 { "the-number" "AGE" INTEGER { +default+ 0 } }
130 { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
131 { "ts" "TS" TIMESTAMP }
135 { "factor-blob" "FB" FACTOR-BLOB }
138 "billy" 10 3.14 f f f f f f <person> person1 set
139 "johnny" 10 3.14 f f f f f f <person> person2 set
141 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
142 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
143 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
144 B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
146 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
147 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
148 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
149 f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
151 : user-assigned-person-schema ( -- )
154 { "the-id" "ID" INTEGER +user-assigned-id+ }
155 { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
156 { "the-number" "AGE" INTEGER { +default+ 0 } }
157 { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
158 { "ts" "TS" TIMESTAMP }
162 { "factor-blob" "FB" FACTOR-BLOB }
165 1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
166 2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
168 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
169 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
170 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
171 B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
172 f f <user-assigned-person> person3 set
174 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
175 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
176 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
177 f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
180 TUPLE: paste n summary author channel mode contents timestamp annotations ;
181 TUPLE: annotation n paste-id summary author mode contents ;
185 { "n" "ID" +db-assigned-id+ }
186 { "summary" "SUMMARY" TEXT }
187 { "author" "AUTHOR" TEXT }
188 { "channel" "CHANNEL" TEXT }
189 { "mode" "MODE" TEXT }
190 { "contents" "CONTENTS" TEXT }
191 { "timestamp" "DATE" TIMESTAMP }
192 { "annotations" { +has-many+ annotation } }
195 : annotation-schema-foreign-key ( -- )
196 annotation "ANNOTATION"
198 { "n" "ID" +db-assigned-id+ }
199 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
200 { "summary" "SUMMARY" TEXT }
201 { "author" "AUTHOR" TEXT }
202 { "mode" "MODE" TEXT }
203 { "contents" "CONTENTS" TEXT }
204 } define-persistent ;
206 : annotation-schema-foreign-key-not-null ( -- )
207 annotation "ANNOTATION"
209 { "n" "ID" +db-assigned-id+ }
210 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
211 { "summary" "SUMMARY" TEXT }
212 { "author" "AUTHOR" TEXT }
213 { "mode" "MODE" TEXT }
214 { "contents" "CONTENTS" TEXT }
215 } define-persistent ;
217 : annotation-schema-cascade ( -- )
218 annotation "ANNOTATION"
220 { "n" "ID" +db-assigned-id+ }
221 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
222 +on-delete+ +cascade+ }
223 { "summary" "SUMMARY" TEXT }
224 { "author" "AUTHOR" TEXT }
225 { "mode" "MODE" TEXT }
226 { "contents" "CONTENTS" TEXT }
227 } define-persistent ;
229 : annotation-schema-restrict ( -- )
230 annotation "ANNOTATION"
232 { "n" "ID" +db-assigned-id+ }
233 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
234 { "summary" "SUMMARY" TEXT }
235 { "author" "AUTHOR" TEXT }
236 { "mode" "MODE" TEXT }
237 { "contents" "CONTENTS" TEXT }
238 } define-persistent ;
240 : test-paste-schema ( -- )
241 [ ] [ paste ensure-table ] unit-test
242 [ ] [ annotation ensure-table ] unit-test
243 [ ] [ annotation drop-table ] unit-test
244 [ ] [ paste drop-table ] unit-test
245 [ ] [ paste create-table ] unit-test
246 [ ] [ annotation create-table ] unit-test
253 "contents1" >>contents
261 "annotation1" >>summary
263 "annotation contents" >>contents
267 : test-foreign-key ( -- )
268 [ ] [ annotation-schema-foreign-key ] unit-test
270 [ paste new 1 >>n delete-tuples ] must-fail ;
272 : test-foreign-key-not-null ( -- )
273 [ ] [ annotation-schema-foreign-key-not-null ] unit-test
275 [ paste new 1 >>n delete-tuples ] must-fail ;
277 : test-cascade ( -- )
278 [ ] [ annotation-schema-cascade ] unit-test
280 [ ] [ paste new 1 >>n delete-tuples ] unit-test
281 [ 0 ] [ paste new select-tuples length ] unit-test ;
283 : test-restrict ( -- )
284 [ ] [ annotation-schema-restrict ] unit-test
286 [ paste new 1 >>n delete-tuples ] must-fail ;
288 [ test-foreign-key ] test-sqlite
289 [ test-foreign-key-not-null ] test-sqlite
290 [ test-cascade ] test-sqlite
291 [ test-restrict ] test-sqlite
293 [ test-foreign-key ] test-postgresql
294 [ test-foreign-key-not-null ] test-postgresql
295 [ test-cascade ] test-postgresql
296 [ test-restrict ] test-postgresql
298 : test-repeated-insert
299 [ ] [ person ensure-table ] unit-test
300 [ ] [ person1 get insert-tuple ] unit-test
301 [ person1 get insert-tuple ] must-fail ;
303 TUPLE: serialize-me id data ;
305 : test-serialize ( -- )
306 serialize-me "SERIALIZED"
308 { "id" "ID" +db-assigned-id+ }
309 { "data" "DATA" FACTOR-BLOB }
311 [ serialize-me drop-table ] [ drop ] recover
312 [ ] [ serialize-me create-table ] unit-test
314 [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
316 { T{ serialize-me f 1 H{ { 1 2 } } } }
317 ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
319 TUPLE: exam id name score ;
321 : random-exam ( -- exam )
323 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
327 : test-intervals ( -- )
331 { "idd" "ID" +db-assigned-id+ }
332 { "named" "NAME" TEXT }
333 { "score" "SCORE" INTEGER }
336 seq>> { "idd" "named" } =
341 { "id" "ID" +db-assigned-id+ }
342 { "name" "NAME" TEXT }
343 { "score" "SCORE" INTEGER }
345 [ exam drop-table ] [ drop ] recover
346 [ ] [ exam create-table ] unit-test
348 [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
349 [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
350 [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
351 [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
354 [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
357 [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
359 [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
363 T{ exam f 3 "Kenny" 60 }
364 T{ exam f 4 "Cartman" 41 }
367 T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
373 T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
377 T{ exam f 4 "Cartman" 41 }
380 T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
384 T{ exam f 3 "Kenny" 60 }
387 T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
391 T{ exam f 3 "Kenny" 60 }
392 T{ exam f 4 "Cartman" 41 }
395 T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
400 T{ exam f 1 "Kyle" 100 }
401 T{ exam f 2 "Stan" 80 }
404 T{ exam f f { "Stan" "Kyle" } } select-tuples
409 T{ exam f 1 "Kyle" 100 }
410 T{ exam f 2 "Stan" 80 }
411 T{ exam f 3 "Kenny" 60 }
414 T{ exam f T{ range f 1 3 1 } } select-tuples
419 T{ exam f 2 "Stan" 80 }
420 T{ exam f 3 "Kenny" 60 }
421 T{ exam f 4 "Cartman" 41 }
424 T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
429 T{ exam f 1 "Kyle" 100 }
432 T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
437 T{ exam f 1 "Kyle" 100 }
438 T{ exam f 2 "Stan" 80 }
439 T{ exam f 3 "Kenny" 60 }
440 T{ exam f 4 "Cartman" 41 }
443 T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
448 T{ exam f 1 "Kyle" 100 }
449 T{ exam f 2 "Stan" 80 }
450 T{ exam f 3 "Kenny" 60 }
451 T{ exam f 4 "Cartman" 41 }
454 T{ exam } select-tuples
457 [ 4 ] [ T{ exam } count-tuples ] unit-test ;
459 TUPLE: bignum-test id m n o ;
460 : <bignum-test> ( m n o -- obj )
467 bignum-test "BIGNUM_TEST"
469 { "id" "ID" +db-assigned-id+ }
470 { "m" "M" BIG-INTEGER }
471 { "n" "N" UNSIGNED-BIG-INTEGER }
472 { "o" "O" SIGNED-BIG-INTEGER }
474 [ bignum-test drop-table ] ignore-errors
475 [ ] [ bignum-test ensure-table ] unit-test
476 [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
479 ! [ T{ bignum-test f 1
480 ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
481 ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
483 TUPLE: secret n message ;
489 { "n" "ID" +random-id+ system-random-generator }
490 { "message" "MESSAGE" TEXT }
493 [ ] [ secret recreate-table ] unit-test
495 [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
497 [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
499 [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
502 T{ secret } select-tuples
503 first message>> "kilroy was here" head?
507 T{ secret } select-tuples length 3 =
510 [ db-assigned-person-schema test-tuples ] test-sqlite
511 [ user-assigned-person-schema test-tuples ] test-sqlite
512 [ user-assigned-person-schema test-repeated-insert ] test-sqlite
513 [ test-bignum ] test-sqlite
514 [ test-serialize ] test-sqlite
515 [ test-intervals ] test-sqlite
516 [ test-random-id ] test-sqlite
518 [ db-assigned-person-schema test-tuples ] test-postgresql
519 [ user-assigned-person-schema test-tuples ] test-postgresql
520 [ user-assigned-person-schema test-repeated-insert ] test-postgresql
521 [ test-bignum ] test-postgresql
522 [ test-serialize ] test-postgresql
523 [ test-intervals ] test-postgresql
524 [ test-random-id ] test-postgresql
526 TUPLE: does-not-persist ;
529 [ does-not-persist create-sql-statement ]
530 [ class \ not-persistent = ] must-fail-with
534 [ does-not-persist create-sql-statement ]
535 [ class \ not-persistent = ] must-fail-with
539 TUPLE: suparclass id a ;
542 { "id" "ID" +db-assigned-id+ }
546 TUPLE: subbclass < suparclass b ;
548 subbclass "SUBCLASS" {
552 TUPLE: fubbclass < subbclass ;
554 fubbclass "FUBCLASS" { } define-persistent
556 : test-db-inheritance ( -- )
557 [ ] [ subbclass ensure-table ] unit-test
558 [ ] [ fubbclass ensure-table ] unit-test
561 subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
565 subbclass new "id" get >>id select-tuple
566 [ subbclass? ] [ b>> ] [ a>> ] tri
569 [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
571 [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
573 [ test-db-inheritance ] test-sqlite
574 [ test-db-inheritance ] test-postgresql
577 TUPLE: string-encoding-test id string ;
579 string-encoding-test "STRING_ENCODING_TEST" {
580 { "id" "ID" +db-assigned-id+ }
581 { "string" "STRING" TEXT }
584 : test-string-encoding ( -- )
585 [ ] [ string-encoding-test ensure-table ] unit-test
588 string-encoding-test new
589 "\u{copyright-sign}\u{bengali-letter-cha}" >>string
590 [ insert-tuple ] [ id>> "id" set ] bi
593 [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
594 string-encoding-test new "id" get >>id select-tuple string>>
597 [ test-string-encoding ] test-sqlite
598 [ test-string-encoding ] test-postgresql
600 ! Don't comment these out. These words must infer
601 \ bind-tuple must-infer
602 \ insert-tuple must-infer
603 \ update-tuple must-infer
604 \ delete-tuples must-infer
605 \ select-tuple must-infer
606 \ define-persistent must-infer
607 \ ensure-table must-infer
608 \ create-table must-infer
609 \ drop-table must-infer
611 : test-queries ( -- )
612 [ ] [ exam ensure-table ] unit-test
613 [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
616 T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
618 5 >>limit select-tuples length
621 TUPLE: compound-foo a b c ;
623 compound-foo "COMPOUND_FOO"
625 { "a" "A" INTEGER +user-assigned-id+ }
626 { "b" "B" INTEGER +user-assigned-id+ }
630 : test-compound-primary-key ( -- )
631 [ ] [ compound-foo ensure-table ] unit-test
632 [ ] [ compound-foo drop-table ] unit-test
633 [ ] [ compound-foo create-table ] unit-test
634 [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
635 [ 1 2 3 compound-foo boa insert-tuple ] must-fail
636 [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
637 [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
638 [ compound-foo new 4 >>c select-tuple ] unit-test ;
640 [ test-compound-primary-key ] test-sqlite
641 [ test-compound-primary-key ] test-postgresql
643 : sqlite-test-db ( -- )
644 "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
646 : postgresql-test-db ( -- )
647 { "localhost" "postgres" "foob" "factor-test" } postgresql-db
648 make-db db-open db set ;