1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: io.files io.files.temp kernel tools.test db db.tuples classes
4 db.types continuations namespaces math
5 prettyprint calendar sequences db.sqlite math.intervals
6 db.postgresql accessors random math.bitwise system
7 math.ranges strings urls fry db.tuples.private db.private
9 FROM: math.ranges => [a,b] ;
12 TUPLE: person the-id the-name the-number the-real
13 ts date time blob factor-blob url ;
15 : <person> ( name age real ts date time blob factor-blob url -- person )
27 : <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
37 [ ] [ person recreate-table ] unit-test
38 [ ] [ person ensure-table ] unit-test
39 [ ] [ person drop-table ] unit-test
40 [ ] [ person create-table ] unit-test
41 [ person create-table ] must-fail
42 [ ] [ person ensure-table ] unit-test
44 [ ] [ person1 get insert-tuple ] unit-test
46 [ 1 ] [ person1 get the-id>> ] unit-test
48 [ ] [ person1 get 200 >>the-number drop ] unit-test
50 [ ] [ person1 get update-tuple ] unit-test
52 [ T{ person f 1 "billy" 200 3.14 } ]
53 [ T{ person f 1 } select-tuple ] unit-test
54 [ ] [ person2 get insert-tuple ] unit-test
57 T{ person f 1 "billy" 200 3.14 }
58 T{ person f 2 "johnny" 10 3.14 }
60 ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
63 T{ person f 1 "billy" 200 3.14 }
64 T{ person f 2 "johnny" 10 3.14 }
66 ] [ T{ person f } select-tuples ] unit-test
70 T{ person f 2 "johnny" 10 3.14 }
72 ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
75 [ ] [ person1 get delete-tuples ] unit-test
76 [ f ] [ T{ person f 1 } select-tuple ] unit-test
78 [ ] [ person3 get insert-tuple ] unit-test
88 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
89 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
90 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
91 B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
93 ] [ T{ person f 3 } select-tuple ] unit-test
95 [ ] [ person4 get insert-tuple ] unit-test
104 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
105 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
106 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
108 H{ { 1 2 } { 3 4 } { 5 "lol" } }
109 URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
111 ] [ T{ person f 4 } select-tuple ] unit-test
113 [ ] [ person drop-table ] unit-test ;
115 : db-assigned-person-schema ( -- )
118 { "the-id" "ID" +db-assigned-id+ }
119 { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
120 { "the-number" "AGE" INTEGER { +default+ 0 } }
121 { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
122 { "ts" "TS" TIMESTAMP }
126 { "factor-blob" "FB" FACTOR-BLOB }
129 "billy" 10 3.14 f f f f f f <person> person1 set
130 "johnny" 10 3.14 f f f f f f <person> person2 set
132 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
133 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
134 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
135 B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
137 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
138 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
139 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
140 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 ;
142 : user-assigned-person-schema ( -- )
145 { "the-id" "ID" INTEGER +user-assigned-id+ }
146 { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
147 { "the-number" "AGE" INTEGER { +default+ 0 } }
148 { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
149 { "ts" "TS" TIMESTAMP }
153 { "factor-blob" "FB" FACTOR-BLOB }
156 1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
157 2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
159 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
160 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
161 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
162 B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
163 f f <user-assigned-person> person3 set
165 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
166 T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
167 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
168 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 ;
171 TUPLE: paste n summary author channel mode contents timestamp annotations ;
172 TUPLE: annotation n paste-id summary author mode contents ;
176 { "n" "ID" +db-assigned-id+ }
177 { "summary" "SUMMARY" TEXT }
178 { "author" "AUTHOR" TEXT }
179 { "channel" "CHANNEL" TEXT }
180 { "mode" "MODE" TEXT }
181 { "contents" "CONTENTS" TEXT }
182 { "timestamp" "DATE" TIMESTAMP }
183 { "annotations" { +has-many+ annotation } }
186 : annotation-schema-foreign-key ( -- )
187 annotation "ANNOTATION"
189 { "n" "ID" +db-assigned-id+ }
190 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
191 { "summary" "SUMMARY" TEXT }
192 { "author" "AUTHOR" TEXT }
193 { "mode" "MODE" TEXT }
194 { "contents" "CONTENTS" TEXT }
195 } define-persistent ;
197 : annotation-schema-foreign-key-not-null ( -- )
198 annotation "ANNOTATION"
200 { "n" "ID" +db-assigned-id+ }
201 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
202 { "summary" "SUMMARY" TEXT }
203 { "author" "AUTHOR" TEXT }
204 { "mode" "MODE" TEXT }
205 { "contents" "CONTENTS" TEXT }
206 } define-persistent ;
208 : annotation-schema-cascade ( -- )
209 annotation "ANNOTATION"
211 { "n" "ID" +db-assigned-id+ }
212 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
213 +on-delete+ +cascade+ }
214 { "summary" "SUMMARY" TEXT }
215 { "author" "AUTHOR" TEXT }
216 { "mode" "MODE" TEXT }
217 { "contents" "CONTENTS" TEXT }
218 } define-persistent ;
220 : annotation-schema-restrict ( -- )
221 annotation "ANNOTATION"
223 { "n" "ID" +db-assigned-id+ }
224 { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
225 { "summary" "SUMMARY" TEXT }
226 { "author" "AUTHOR" TEXT }
227 { "mode" "MODE" TEXT }
228 { "contents" "CONTENTS" TEXT }
229 } define-persistent ;
231 : test-paste-schema ( -- )
232 [ ] [ paste ensure-table ] unit-test
233 [ ] [ annotation ensure-table ] unit-test
234 [ ] [ annotation drop-table ] unit-test
235 [ ] [ paste drop-table ] unit-test
236 [ ] [ paste create-table ] unit-test
237 [ ] [ annotation create-table ] unit-test
244 "contents1" >>contents
252 "annotation1" >>summary
254 "annotation contents" >>contents
258 : test-foreign-key ( -- )
259 [ ] [ annotation-schema-foreign-key ] unit-test
261 [ paste new 1 >>n delete-tuples ] must-fail ;
263 : test-foreign-key-not-null ( -- )
264 [ ] [ annotation-schema-foreign-key-not-null ] unit-test
266 [ paste new 1 >>n delete-tuples ] must-fail ;
268 : test-cascade ( -- )
269 [ ] [ annotation-schema-cascade ] unit-test
271 [ ] [ paste new 1 >>n delete-tuples ] unit-test
272 [ 0 ] [ paste new select-tuples length ] unit-test ;
274 : test-restrict ( -- )
275 [ ] [ annotation-schema-restrict ] unit-test
277 [ paste new 1 >>n delete-tuples ] must-fail ;
279 [ test-foreign-key ] test-sqlite
280 [ test-foreign-key-not-null ] test-sqlite
281 [ test-cascade ] test-sqlite
282 [ test-restrict ] test-sqlite
284 [ test-foreign-key ] test-postgresql
285 [ test-foreign-key-not-null ] test-postgresql
286 [ test-cascade ] test-postgresql
287 [ test-restrict ] test-postgresql
289 : test-repeated-insert ( -- )
290 [ ] [ person ensure-table ] unit-test
291 [ ] [ person1 get insert-tuple ] unit-test
292 [ person1 get insert-tuple ] must-fail ;
294 TUPLE: serialize-me id data ;
296 : test-serialize ( -- )
297 serialize-me "SERIALIZED"
299 { "id" "ID" +db-assigned-id+ }
300 { "data" "DATA" FACTOR-BLOB }
302 [ serialize-me drop-table ] [ drop ] recover
303 [ ] [ serialize-me create-table ] unit-test
305 [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
307 { T{ serialize-me f 1 H{ { 1 2 } } } }
308 ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
310 TUPLE: exam id name score ;
312 : random-exam ( -- exam )
314 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
318 : test-intervals ( -- )
322 { "idd" "ID" +db-assigned-id+ }
323 { "named" "NAME" TEXT }
324 { "score" "SCORE" INTEGER }
327 seq>> { "idd" "named" } =
332 { "id" "ID" +db-assigned-id+ }
333 { "name" "NAME" TEXT }
334 { "score" "SCORE" INTEGER }
336 [ exam drop-table ] [ drop ] recover
337 [ ] [ exam create-table ] unit-test
339 [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
340 [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
341 [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
342 [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
345 [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
348 [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
350 [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
354 T{ exam f 3 "Kenny" 60 }
355 T{ exam f 4 "Cartman" 41 }
358 T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
364 T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
368 T{ exam f 4 "Cartman" 41 }
371 T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
375 T{ exam f 3 "Kenny" 60 }
378 T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
382 T{ exam f 3 "Kenny" 60 }
383 T{ exam f 4 "Cartman" 41 }
386 T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
391 T{ exam f 1 "Kyle" 100 }
392 T{ exam f 2 "Stan" 80 }
395 T{ exam f f { "Stan" "Kyle" } } select-tuples
400 T{ exam f 1 "Kyle" 100 }
401 T{ exam f 2 "Stan" 80 }
402 T{ exam f 3 "Kenny" 60 }
405 T{ exam f T{ range f 1 3 1 } } select-tuples
410 T{ exam f 2 "Stan" 80 }
411 T{ exam f 3 "Kenny" 60 }
412 T{ exam f 4 "Cartman" 41 }
415 T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
420 T{ exam f 1 "Kyle" 100 }
423 T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
428 T{ exam f 1 "Kyle" 100 }
429 T{ exam f 2 "Stan" 80 }
430 T{ exam f 3 "Kenny" 60 }
431 T{ exam f 4 "Cartman" 41 }
434 T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
439 T{ exam f 1 "Kyle" 100 }
440 T{ exam f 2 "Stan" 80 }
441 T{ exam f 3 "Kenny" 60 }
442 T{ exam f 4 "Cartman" 41 }
445 T{ exam } select-tuples
448 [ 4 ] [ T{ exam } count-tuples ] unit-test
450 [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
453 [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
455 TUPLE: bignum-test id m n o ;
456 : <bignum-test> ( m n o -- obj )
463 bignum-test "BIGNUM_TEST"
465 { "id" "ID" +db-assigned-id+ }
466 { "m" "M" BIG-INTEGER }
467 { "n" "N" UNSIGNED-BIG-INTEGER }
468 { "o" "O" SIGNED-BIG-INTEGER }
470 [ bignum-test drop-table ] ignore-errors
471 [ ] [ bignum-test ensure-table ] unit-test
472 [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
475 ! [ T{ bignum-test f 1
476 ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
477 ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
479 TUPLE: secret n message ;
482 : test-random-id ( -- )
485 { "n" "ID" +random-id+ system-random-generator }
486 { "message" "MESSAGE" TEXT }
489 [ ] [ secret recreate-table ] unit-test
491 [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
493 [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
495 [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
498 T{ secret } select-tuples
499 first message>> "kilroy was here" head?
503 T{ secret } select-tuples length 3 =
506 [ db-assigned-person-schema test-tuples ] test-sqlite
507 [ user-assigned-person-schema test-tuples ] test-sqlite
508 [ user-assigned-person-schema test-repeated-insert ] test-sqlite
509 [ test-bignum ] test-sqlite
510 [ test-serialize ] test-sqlite
511 [ test-intervals ] test-sqlite
512 [ test-random-id ] test-sqlite
514 [ db-assigned-person-schema test-tuples ] test-postgresql
515 [ user-assigned-person-schema test-tuples ] test-postgresql
516 [ user-assigned-person-schema test-repeated-insert ] test-postgresql
517 [ test-bignum ] test-postgresql
518 [ test-serialize ] test-postgresql
519 [ test-intervals ] test-postgresql
520 [ test-random-id ] test-postgresql
522 TUPLE: does-not-persist ;
525 [ does-not-persist create-sql-statement ]
526 [ class \ not-persistent = ] must-fail-with
530 [ does-not-persist create-sql-statement ]
531 [ class \ not-persistent = ] must-fail-with
535 TUPLE: suparclass id a ;
538 { "id" "ID" +db-assigned-id+ }
542 TUPLE: subbclass < suparclass b ;
544 subbclass "SUBCLASS" {
548 TUPLE: fubbclass < subbclass ;
550 fubbclass "FUBCLASS" { } define-persistent
552 : test-db-inheritance ( -- )
553 [ ] [ subbclass ensure-table ] unit-test
554 [ ] [ fubbclass ensure-table ] unit-test
557 subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
561 subbclass new "id" get >>id select-tuple
562 [ subbclass? ] [ b>> ] [ a>> ] tri
565 [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
567 [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
569 [ test-db-inheritance ] test-sqlite
570 [ test-db-inheritance ] test-postgresql
573 TUPLE: string-encoding-test id string ;
575 string-encoding-test "STRING_ENCODING_TEST" {
576 { "id" "ID" +db-assigned-id+ }
577 { "string" "STRING" TEXT }
580 : test-string-encoding ( -- )
581 [ ] [ string-encoding-test ensure-table ] unit-test
584 string-encoding-test new
585 "\u{copyright-sign}\u{bengali-letter-cha}" >>string
586 [ insert-tuple ] [ id>> "id" set ] bi
589 [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
590 string-encoding-test new "id" get >>id select-tuple string>>
593 [ test-string-encoding ] test-sqlite
594 [ test-string-encoding ] test-postgresql
596 : test-queries ( -- )
597 [ ] [ exam ensure-table ] unit-test
598 [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
601 T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
603 5 >>limit select-tuples length
606 TUPLE: compound-foo a b c ;
608 compound-foo "COMPOUND_FOO"
610 { "a" "A" INTEGER +user-assigned-id+ }
611 { "b" "B" INTEGER +user-assigned-id+ }
615 : test-compound-primary-key ( -- )
616 [ ] [ compound-foo ensure-table ] unit-test
617 [ ] [ compound-foo drop-table ] unit-test
618 [ ] [ compound-foo create-table ] unit-test
619 [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
620 [ 1 2 3 compound-foo boa insert-tuple ] must-fail
621 [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
622 [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
623 [ compound-foo new 4 >>c select-tuple ] unit-test ;
625 [ test-compound-primary-key ] test-sqlite
626 [ test-compound-primary-key ] test-postgresql
629 TUPLE: example id data ;
633 { "id" "ID" +db-assigned-id+ }
634 { "data" "DATA" BLOB }
637 : test-blob-select ( -- )
639 [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
641 T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
642 ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
644 [ test-blob-select ] test-sqlite
645 [ test-blob-select ] test-postgresql