basis/db/tuples/tuples-tests.factor

   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 ;
   8 IN: db.tuples.tests
   9
  10 : test-sqlite ( quot -- )
  11     [ ] swap '[
  12         "tuples-test.db" temp-file sqlite-db _ with-db
  13     ] unit-test ;
  14
  15 : test-postgresql ( quot -- )
  16     [ ] swap '[
  17         { "localhost" "postgres" "foob" "factor-test" }
  18         postgresql-db _ with-db
  19     ] unit-test ;
  20
  21 TUPLE: person the-id the-name the-number the-real
  22 ts date time blob factor-blob url ;
  23
  24 : <person> ( name age real ts date time blob factor-blob url -- person )
  25     person new
  26         swap >>url
  27         swap >>factor-blob
  28         swap >>blob
  29         swap >>time
  30         swap >>date
  31         swap >>ts
  32         swap >>the-real
  33         swap >>the-number
  34         swap >>the-name ;
  35
  36 : <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
  37     <person>
  38         swap >>the-id ;
  39
  40 SYMBOL: person1
  41 SYMBOL: person2
  42 SYMBOL: person3
  43 SYMBOL: person4
  44
  45 : test-tuples ( -- )
  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
  52
  53     [ ] [ person1 get insert-tuple ] unit-test
  54
  55     [ 1 ] [ person1 get the-id>> ] unit-test
  56
  57     [ ] [ person1 get 200 >>the-number drop ] unit-test
  58
  59     [ ] [ person1 get update-tuple ] unit-test
  60
  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
  64     [
  65         {
  66             T{ person f 1 "billy" 200 3.14 }
  67             T{ person f 2 "johnny" 10 3.14 }
  68         }
  69     ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
  70     [
  71         {
  72             T{ person f 1 "billy" 200 3.14 }
  73             T{ person f 2 "johnny" 10 3.14 }
  74         }
  75     ] [ T{ person f } select-tuples ] unit-test
  76
  77     [
  78         {
  79             T{ person f 2 "johnny" 10 3.14 }
  80         }
  81     ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
  82
  83
  84     [ ] [ person1 get delete-tuples ] unit-test
  85     [ f ] [ T{ person f 1 } select-tuple ] unit-test
  86
  87     [ ] [ person3 get insert-tuple ] unit-test
  88
  89     [
  90         T{
  91             person
  92             f
  93             3
  94             "teddy"
  95             10
  96             3.14
  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 }
 101         }
 102     ] [ T{ person f 3 } select-tuple ] unit-test
 103
 104     [ ] [ person4 get insert-tuple ] unit-test
 105     [
 106         T{
 107             person
 108             f
 109             4
 110             "eddie"
 111             10
 112             3.14
 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 } }
 116             f
 117             H{ { 1 2 } { 3 4 } { 5 "lol" } }
 118             URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
 119         }
 120     ] [ T{ person f 4 } select-tuple ] unit-test
 121
 122     [ ] [ person drop-table ] unit-test ;
 123
 124 : db-assigned-person-schema ( -- )
 125     person "PERSON"
 126     {
 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 }
 132         { "date" "D" DATE }
 133         { "time" "T" TIME }
 134         { "blob" "B" BLOB }
 135         { "factor-blob" "FB" FACTOR-BLOB }
 136         { "url" "U" URL }
 137     } define-persistent
 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
 140     "teddy" 10 3.14
 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
 145     "eddie" 10 3.14
 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 ;
 150
 151 : user-assigned-person-schema ( -- )
 152     person "PERSON"
 153     {
 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 }
 159         { "date" "D" DATE }
 160         { "time" "T" TIME }
 161         { "blob" "B" BLOB }
 162         { "factor-blob" "FB" FACTOR-BLOB }
 163         { "url" "U" URL }
 164     } define-persistent
 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
 167     3 "teddy" 10 3.14
 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
 173     4 "eddie" 10 3.14
 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 ;
 178
 179
 180 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 181 TUPLE: annotation n paste-id summary author mode contents ;
 182
 183 paste "PASTE"
 184 {
 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 } }
 193 } define-persistent
 194
 195 : annotation-schema-foreign-key ( -- )
 196     annotation "ANNOTATION"
 197     {
 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 ;
 205
 206 : annotation-schema-foreign-key-not-null ( -- )
 207     annotation "ANNOTATION"
 208     {
 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 ;
 216
 217 : annotation-schema-cascade ( -- )
 218     annotation "ANNOTATION"
 219     {
 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 ;
 228
 229 : annotation-schema-restrict ( -- )
 230     annotation "ANNOTATION"
 231     {
 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 ;
 239
 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
 247
 248     [ ] [
 249         paste new
 250             "summary1" >>summary
 251             "erg" >>author
 252             "#lol" >>channel
 253             "contents1" >>contents
 254             now >>timestamp
 255         insert-tuple
 256     ] unit-test
 257
 258     [ ] [
 259         annotation new
 260             1 >>paste-id
 261             "annotation1" >>summary
 262             "erg" >>author
 263             "annotation contents" >>contents
 264         insert-tuple
 265     ] unit-test ;
 266
 267 : test-foreign-key ( -- )
 268     [ ] [ annotation-schema-foreign-key ] unit-test
 269     test-paste-schema
 270     [ paste new 1 >>n delete-tuples ] must-fail ;
 271
 272 : test-foreign-key-not-null ( -- )
 273     [ ] [ annotation-schema-foreign-key-not-null ] unit-test
 274     test-paste-schema
 275     [ paste new 1 >>n delete-tuples ] must-fail ;
 276
 277 : test-cascade ( -- )
 278     [ ] [ annotation-schema-cascade ] unit-test
 279     test-paste-schema
 280     [ ] [ paste new 1 >>n delete-tuples ] unit-test
 281     [ 0 ] [ paste new select-tuples length ] unit-test ;
 282
 283 : test-restrict ( -- )
 284     [ ] [ annotation-schema-restrict ] unit-test
 285     test-paste-schema
 286     [ paste new 1 >>n delete-tuples ] must-fail ;
 287
 288 [ test-foreign-key ] test-sqlite
 289 [ test-foreign-key-not-null ] test-sqlite
 290 [ test-cascade ] test-sqlite
 291 [ test-restrict ] test-sqlite
 292
 293 [ test-foreign-key ] test-postgresql
 294 [ test-foreign-key-not-null ] test-postgresql
 295 [ test-cascade ] test-postgresql
 296 [ test-restrict ] test-postgresql
 297
 298 : test-repeated-insert
 299     [ ] [ person ensure-table ] unit-test
 300     [ ] [ person1 get insert-tuple ] unit-test
 301     [ person1 get insert-tuple ] must-fail ;
 302
 303 TUPLE: serialize-me id data ;
 304
 305 : test-serialize ( -- )
 306     serialize-me "SERIALIZED"
 307     {
 308         { "id" "ID" +db-assigned-id+ }
 309         { "data" "DATA" FACTOR-BLOB }
 310     } define-persistent
 311     [ serialize-me drop-table ] [ drop ] recover
 312     [ ] [ serialize-me create-table ] unit-test
 313
 314     [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
 315     [
 316         { T{ serialize-me f 1 H{ { 1 2 } } } }
 317     ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
 318
 319 TUPLE: exam id name score ;
 320
 321 : random-exam ( -- exam )
 322         f
 323         6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
 324         100 random
 325     exam boa ;
 326
 327 : test-intervals ( -- )
 328     [
 329         exam "EXAM"
 330         {
 331             { "idd" "ID" +db-assigned-id+ }
 332             { "named" "NAME" TEXT }
 333             { "score" "SCORE" INTEGER }
 334         } define-persistent
 335     ] [
 336         seq>> { "idd" "named" } =
 337     ] must-fail-with
 338
 339     exam "EXAM"
 340     {
 341         { "id" "ID" +db-assigned-id+ }
 342         { "name" "NAME" TEXT }
 343         { "score" "SCORE" INTEGER }
 344     } define-persistent
 345     [ exam drop-table ] [ drop ] recover
 346     [ ] [ exam create-table ] unit-test
 347
 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
 352
 353     [ 4 ]
 354     [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
 355
 356     [ f ]
 357     [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
 358
 359     ! FIXME
 360     ! [ f ]
 361     ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test
 362
 363     [
 364         {
 365             T{ exam f 3 "Kenny" 60 }
 366             T{ exam f 4 "Cartman" 41 }
 367         }
 368     ] [
 369         T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
 370     ] unit-test
 371
 372     [
 373         { }
 374     ] [
 375         T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
 376     ] unit-test
 377     [
 378         {
 379             T{ exam f 4 "Cartman" 41 }
 380         }
 381     ] [
 382         T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
 383     ] unit-test
 384     [
 385         {
 386             T{ exam f 3 "Kenny" 60 }
 387         }
 388     ] [
 389         T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
 390     ] unit-test
 391     [
 392         {
 393             T{ exam f 3 "Kenny" 60 }
 394             T{ exam f 4 "Cartman" 41 }
 395         }
 396     ] [
 397         T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
 398     ] unit-test
 399
 400     [
 401         {
 402             T{ exam f 1 "Kyle" 100 }
 403             T{ exam f 2 "Stan" 80 }
 404         }
 405     ] [
 406         T{ exam f f { "Stan" "Kyle" } } select-tuples
 407     ] unit-test
 408
 409     [
 410         {
 411             T{ exam f 1 "Kyle" 100 }
 412             T{ exam f 2 "Stan" 80 }
 413             T{ exam f 3 "Kenny" 60 }
 414         }
 415     ] [
 416         T{ exam f T{ range f 1 3 1 } } select-tuples
 417     ] unit-test
 418
 419     [
 420         {
 421             T{ exam f 2 "Stan" 80 }
 422             T{ exam f 3 "Kenny" 60 }
 423             T{ exam f 4 "Cartman" 41 }
 424         }
 425     ] [
 426         T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
 427     ] unit-test
 428
 429     [
 430         {
 431             T{ exam f 1 "Kyle" 100 }
 432         }
 433     ] [
 434         T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
 435     ] unit-test
 436
 437     [
 438         {
 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 }
 443         }
 444     ] [
 445         T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
 446     ] unit-test
 447
 448     [
 449         {
 450             T{ exam f 1 "Kyle" 100 }
 451             T{ exam f 2 "Stan" 80 }
 452             T{ exam f 3 "Kenny" 60 }
 453             T{ exam f 4 "Cartman" 41 }
 454         }
 455     ] [
 456         T{ exam } select-tuples
 457     ] unit-test
 458
 459     [ 4 ] [ T{ exam } count-tuples ] unit-test ;
 460
 461 TUPLE: bignum-test id m n o ;
 462 : <bignum-test> ( m n o -- obj )
 463     bignum-test new
 464         swap >>o
 465         swap >>n
 466         swap >>m ;
 467
 468 : test-bignum
 469     bignum-test "BIGNUM_TEST"
 470     {
 471         { "id" "ID" +db-assigned-id+ }
 472         { "m" "M" BIG-INTEGER }
 473         { "n" "N" UNSIGNED-BIG-INTEGER }
 474         { "o" "O" SIGNED-BIG-INTEGER }
 475     } define-persistent
 476     [ bignum-test drop-table ] ignore-errors
 477     [ ] [ bignum-test ensure-table ] unit-test
 478     [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
 479
 480     ! sqlite only
 481     ! [ T{ bignum-test f 1
 482         ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
 483     ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
 484
 485 TUPLE: secret n message ;
 486 C: <secret> secret
 487
 488 : test-random-id
 489     secret "SECRET"
 490     {
 491         { "n" "ID" +random-id+ system-random-generator }
 492         { "message" "MESSAGE" TEXT }
 493     } define-persistent
 494
 495     [ ] [ secret recreate-table ] unit-test
 496
 497     [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 498
 499     [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
 500
 501     [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
 502
 503     [ t ] [
 504         T{ secret } select-tuples
 505         first message>> "kilroy was here" head?
 506     ] unit-test
 507
 508     [ t ] [
 509         T{ secret } select-tuples length 3 =
 510     ] unit-test ;
 511
 512 [ db-assigned-person-schema test-tuples ] test-sqlite
 513 [ user-assigned-person-schema test-tuples ] test-sqlite
 514 [ user-assigned-person-schema test-repeated-insert ] test-sqlite
 515 [ test-bignum ] test-sqlite
 516 [ test-serialize ] test-sqlite
 517 [ test-intervals ] test-sqlite
 518 [ test-random-id ] test-sqlite
 519
 520 [ db-assigned-person-schema test-tuples ] test-postgresql
 521 [ user-assigned-person-schema test-tuples ] test-postgresql
 522 [ user-assigned-person-schema test-repeated-insert ] test-postgresql
 523 [ test-bignum ] test-postgresql
 524 [ test-serialize ] test-postgresql
 525 [ test-intervals ] test-postgresql
 526 [ test-random-id ] test-postgresql
 527
 528 TUPLE: does-not-persist ;
 529
 530 [
 531     [ does-not-persist create-sql-statement ]
 532     [ class \ not-persistent = ] must-fail-with
 533 ] test-sqlite
 534
 535 [
 536     [ does-not-persist create-sql-statement ]
 537     [ class \ not-persistent = ] must-fail-with
 538 ] test-postgresql
 539
 540
 541 TUPLE: suparclass id a ;
 542
 543 suparclass f {
 544     { "id" "ID" +db-assigned-id+ }
 545     { "a" "A" INTEGER }
 546 } define-persistent
 547
 548 TUPLE: subbclass < suparclass b ;
 549
 550 subbclass "SUBCLASS" {
 551     { "b" "B" TEXT }
 552 } define-persistent
 553
 554 TUPLE: fubbclass < subbclass ;
 555
 556 fubbclass "FUBCLASS" { } define-persistent
 557
 558 : test-db-inheritance ( -- )
 559     [ ] [ subbclass ensure-table ] unit-test
 560     [ ] [ fubbclass ensure-table ] unit-test
 561
 562     [ ] [
 563         subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
 564     ] unit-test
 565
 566     [ t "hi" 5 ] [
 567         subbclass new "id" get >>id select-tuple
 568         [ subbclass? ] [ b>> ] [ a>> ] tri
 569     ] unit-test
 570
 571     [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
 572
 573     [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
 574
 575 [ test-db-inheritance ] test-sqlite
 576 [ test-db-inheritance ] test-postgresql
 577
 578
 579 TUPLE: string-encoding-test id string ;
 580
 581 string-encoding-test "STRING_ENCODING_TEST" {
 582     { "id" "ID" +db-assigned-id+ }
 583     { "string" "STRING" TEXT }
 584 } define-persistent
 585
 586 : test-string-encoding ( -- )
 587     [ ] [ string-encoding-test ensure-table ] unit-test
 588
 589     [ ] [
 590         string-encoding-test new
 591             "\u{copyright-sign}\u{bengali-letter-cha}" >>string
 592         [ insert-tuple ] [ id>> "id" set ] bi
 593     ] unit-test
 594
 595     [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
 596         string-encoding-test new "id" get >>id select-tuple string>>
 597     ] unit-test ;
 598
 599 [ test-string-encoding ] test-sqlite
 600 [ test-string-encoding ] test-postgresql
 601
 602 ! Don't comment these out. These words must infer
 603 \ bind-tuple must-infer
 604 \ insert-tuple must-infer
 605 \ update-tuple must-infer
 606 \ delete-tuples must-infer
 607 \ select-tuple must-infer
 608 \ define-persistent must-infer
 609 \ ensure-table must-infer
 610 \ create-table must-infer
 611 \ drop-table must-infer
 612
 613 : test-queries ( -- )
 614     [ ] [ exam ensure-table ] unit-test
 615     [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
 616     [ 5 ] [
 617         <query>
 618         T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
 619             >>tuple
 620         5 >>limit select-tuples length
 621     ] unit-test ;
 622
 623 TUPLE: compound-foo a b c ;
 624
 625 compound-foo "COMPOUND_FOO"
 626 {
 627     { "a" "A" INTEGER +user-assigned-id+ }
 628     { "b" "B" INTEGER +user-assigned-id+ }
 629     { "c" "C" INTEGER }
 630 } define-persistent
 631
 632 : test-compound-primary-key ( -- )
 633     [ ] [ compound-foo ensure-table ] unit-test
 634     [ ] [ compound-foo drop-table ] unit-test
 635     [ ] [ compound-foo create-table ] unit-test
 636     [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
 637     [ 1 2 3 compound-foo boa insert-tuple ] must-fail
 638     [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
 639     [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
 640     [ compound-foo new 4 >>c select-tuple ] unit-test ;
 641
 642 [ test-compound-primary-key ] test-sqlite
 643 [ test-compound-primary-key ] test-postgresql
 644
 645 : sqlite-test-db ( -- )
 646     "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
 647
 648 : postgresql-test-db ( -- )
 649     { "localhost" "postgres" "foob" "factor-test" } postgresql-db
 650     make-db db-open db set ;