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 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
   8 db.tester ;
   9 FROM: math.ranges => [a,b] ;
  10 IN: db.tuples.tests
  11
  12 TUPLE: person the-id the-name the-number the-real
  13 ts date time blob factor-blob url ;
  14
  15 : <person> ( name age real ts date time blob factor-blob url -- person )
  16     person new
  17         swap >>url
  18         swap >>factor-blob
  19         swap >>blob
  20         swap >>time
  21         swap >>date
  22         swap >>ts
  23         swap >>the-real
  24         swap >>the-number
  25         swap >>the-name ;
  26
  27 : <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
  28     <person>
  29         swap >>the-id ;
  30
  31 SYMBOL: person1
  32 SYMBOL: person2
  33 SYMBOL: person3
  34 SYMBOL: person4
  35
  36 : test-tuples ( -- )
  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
  43
  44     [ ] [ person1 get insert-tuple ] unit-test
  45
  46     [ 1 ] [ person1 get the-id>> ] unit-test
  47
  48     [ ] [ person1 get 200 >>the-number drop ] unit-test
  49
  50     [ ] [ person1 get update-tuple ] unit-test
  51
  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
  55     [
  56         {
  57             T{ person f 1 "billy" 200 3.14 }
  58             T{ person f 2 "johnny" 10 3.14 }
  59         }
  60     ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
  61     [
  62         {
  63             T{ person f 1 "billy" 200 3.14 }
  64             T{ person f 2 "johnny" 10 3.14 }
  65         }
  66     ] [ T{ person f } select-tuples ] unit-test
  67
  68     [
  69         {
  70             T{ person f 2 "johnny" 10 3.14 }
  71         }
  72     ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
  73
  74
  75     [ ] [ person1 get delete-tuples ] unit-test
  76     [ f ] [ T{ person f 1 } select-tuple ] unit-test
  77
  78     [ ] [ person3 get insert-tuple ] unit-test
  79
  80     [
  81         T{
  82             person
  83             f
  84             3
  85             "teddy"
  86             10
  87             3.14
  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 }
  92         }
  93     ] [ T{ person f 3 } select-tuple ] unit-test
  94
  95     [ ] [ person4 get insert-tuple ] unit-test
  96     [
  97         T{
  98             person
  99             f
 100             4
 101             "eddie"
 102             10
 103             3.14
 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 } }
 107             f
 108             H{ { 1 2 } { 3 4 } { 5 "lol" } }
 109             URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
 110         }
 111     ] [ T{ person f 4 } select-tuple ] unit-test
 112
 113     [ ] [ person drop-table ] unit-test ;
 114
 115 : db-assigned-person-schema ( -- )
 116     person "PERSON"
 117     {
 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 }
 123         { "date" "D" DATE }
 124         { "time" "T" TIME }
 125         { "blob" "B" BLOB }
 126         { "factor-blob" "FB" FACTOR-BLOB }
 127         { "url" "U" URL }
 128     } define-persistent
 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
 131     "teddy" 10 3.14
 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
 136     "eddie" 10 3.14
 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 ;
 141
 142 : user-assigned-person-schema ( -- )
 143     person "PERSON"
 144     {
 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 }
 150         { "date" "D" DATE }
 151         { "time" "T" TIME }
 152         { "blob" "B" BLOB }
 153         { "factor-blob" "FB" FACTOR-BLOB }
 154         { "url" "U" URL }
 155     } define-persistent
 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
 158     3 "teddy" 10 3.14
 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
 164     4 "eddie" 10 3.14
 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 ;
 169
 170
 171 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 172 TUPLE: annotation n paste-id summary author mode contents ;
 173
 174 paste "PASTE"
 175 {
 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 } }
 184 } define-persistent
 185
 186 : annotation-schema-foreign-key ( -- )
 187     annotation "ANNOTATION"
 188     {
 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 ;
 196
 197 : annotation-schema-foreign-key-not-null ( -- )
 198     annotation "ANNOTATION"
 199     {
 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 ;
 207
 208 : annotation-schema-cascade ( -- )
 209     annotation "ANNOTATION"
 210     {
 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 ;
 219
 220 : annotation-schema-restrict ( -- )
 221     annotation "ANNOTATION"
 222     {
 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 ;
 230
 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
 238
 239     [ ] [
 240         paste new
 241             "summary1" >>summary
 242             "erg" >>author
 243             "#lol" >>channel
 244             "contents1" >>contents
 245             now >>timestamp
 246         insert-tuple
 247     ] unit-test
 248
 249     [ ] [
 250         annotation new
 251             1 >>paste-id
 252             "annotation1" >>summary
 253             "erg" >>author
 254             "annotation contents" >>contents
 255         insert-tuple
 256     ] unit-test ;
 257
 258 : test-foreign-key ( -- )
 259     [ ] [ annotation-schema-foreign-key ] unit-test
 260     test-paste-schema
 261     [ paste new 1 >>n delete-tuples ] must-fail ;
 262
 263 : test-foreign-key-not-null ( -- )
 264     [ ] [ annotation-schema-foreign-key-not-null ] unit-test
 265     test-paste-schema
 266     [ paste new 1 >>n delete-tuples ] must-fail ;
 267
 268 : test-cascade ( -- )
 269     [ ] [ annotation-schema-cascade ] unit-test
 270     test-paste-schema
 271     [ ] [ paste new 1 >>n delete-tuples ] unit-test
 272     [ 0 ] [ paste new select-tuples length ] unit-test ;
 273
 274 : test-restrict ( -- )
 275     [ ] [ annotation-schema-restrict ] unit-test
 276     test-paste-schema
 277     [ paste new 1 >>n delete-tuples ] must-fail ;
 278
 279 [ test-foreign-key ] test-sqlite
 280 [ test-foreign-key-not-null ] test-sqlite
 281 [ test-cascade ] test-sqlite
 282 [ test-restrict ] test-sqlite
 283
 284 [ test-foreign-key ] test-postgresql
 285 [ test-foreign-key-not-null ] test-postgresql
 286 [ test-cascade ] test-postgresql
 287 [ test-restrict ] test-postgresql
 288
 289 : test-repeated-insert ( -- )
 290     [ ] [ person ensure-table ] unit-test
 291     [ ] [ person1 get insert-tuple ] unit-test
 292     [ person1 get insert-tuple ] must-fail ;
 293
 294 TUPLE: serialize-me id data ;
 295
 296 : test-serialize ( -- )
 297     serialize-me "SERIALIZED"
 298     {
 299         { "id" "ID" +db-assigned-id+ }
 300         { "data" "DATA" FACTOR-BLOB }
 301     } define-persistent
 302     [ serialize-me drop-table ] [ drop ] recover
 303     [ ] [ serialize-me create-table ] unit-test
 304
 305     [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
 306     [
 307         { T{ serialize-me f 1 H{ { 1 2 } } } }
 308     ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
 309
 310 TUPLE: exam id name score ;
 311
 312 : random-exam ( -- exam )
 313         f
 314         6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
 315         100 random
 316     exam boa ;
 317
 318 : test-intervals ( -- )
 319     [
 320         exam "EXAM"
 321         {
 322             { "idd" "ID" +db-assigned-id+ }
 323             { "named" "NAME" TEXT }
 324             { "score" "SCORE" INTEGER }
 325         } define-persistent
 326     ] [
 327         seq>> { "idd" "named" } =
 328     ] must-fail-with
 329
 330     exam "EXAM"
 331     {
 332         { "id" "ID" +db-assigned-id+ }
 333         { "name" "NAME" TEXT }
 334         { "score" "SCORE" INTEGER }
 335     } define-persistent
 336     [ exam drop-table ] [ drop ] recover
 337     [ ] [ exam create-table ] unit-test
 338
 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
 343
 344     [ 4 ]
 345     [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
 346
 347     [ f ]
 348     [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
 349
 350     [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
 351
 352     [
 353         {
 354             T{ exam f 3 "Kenny" 60 }
 355             T{ exam f 4 "Cartman" 41 }
 356         }
 357     ] [
 358         T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
 359     ] unit-test
 360
 361     [
 362         { }
 363     ] [
 364         T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
 365     ] unit-test
 366     [
 367         {
 368             T{ exam f 4 "Cartman" 41 }
 369         }
 370     ] [
 371         T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
 372     ] unit-test
 373     [
 374         {
 375             T{ exam f 3 "Kenny" 60 }
 376         }
 377     ] [
 378         T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
 379     ] unit-test
 380     [
 381         {
 382             T{ exam f 3 "Kenny" 60 }
 383             T{ exam f 4 "Cartman" 41 }
 384         }
 385     ] [
 386         T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
 387     ] unit-test
 388
 389     [
 390         {
 391             T{ exam f 1 "Kyle" 100 }
 392             T{ exam f 2 "Stan" 80 }
 393         }
 394     ] [
 395         T{ exam f f { "Stan" "Kyle" } } select-tuples
 396     ] unit-test
 397
 398     [
 399         {
 400             T{ exam f 1 "Kyle" 100 }
 401             T{ exam f 2 "Stan" 80 }
 402             T{ exam f 3 "Kenny" 60 }
 403         }
 404     ] [
 405         T{ exam f T{ range f 1 3 1 } } select-tuples
 406     ] unit-test
 407
 408     [
 409         {
 410             T{ exam f 2 "Stan" 80 }
 411             T{ exam f 3 "Kenny" 60 }
 412             T{ exam f 4 "Cartman" 41 }
 413         }
 414     ] [
 415         T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
 416     ] unit-test
 417
 418     [
 419         {
 420             T{ exam f 1 "Kyle" 100 }
 421         }
 422     ] [
 423         T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
 424     ] unit-test
 425
 426     [
 427         {
 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 }
 432         }
 433     ] [
 434         T{ exam f T{ interval f { -1/0. t } { 1/0. 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 } select-tuples
 446     ] unit-test
 447
 448     [ 4 ] [ T{ exam } count-tuples ] unit-test
 449
 450     [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
 451
 452     [ 10 ]
 453     [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
 454
 455 TUPLE: bignum-test id m n o ;
 456 : <bignum-test> ( m n o -- obj )
 457     bignum-test new
 458         swap >>o
 459         swap >>n
 460         swap >>m ;
 461
 462 : test-bignum ( -- )
 463     bignum-test "BIGNUM_TEST"
 464     {
 465         { "id" "ID" +db-assigned-id+ }
 466         { "m" "M" BIG-INTEGER }
 467         { "n" "N" UNSIGNED-BIG-INTEGER }
 468         { "o" "O" SIGNED-BIG-INTEGER }
 469     } define-persistent
 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 ;
 473
 474     ! sqlite only
 475     ! [ T{ bignum-test f 1
 476         ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
 477     ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
 478
 479 TUPLE: secret n message ;
 480 C: <secret> secret
 481
 482 : test-random-id ( -- )
 483     secret "SECRET"
 484     {
 485         { "n" "ID" +random-id+ system-random-generator }
 486         { "message" "MESSAGE" TEXT }
 487     } define-persistent
 488
 489     [ ] [ secret recreate-table ] unit-test
 490
 491     [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 492
 493     [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
 494
 495     [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
 496
 497     [ t ] [
 498         T{ secret } select-tuples
 499         first message>> "kilroy was here" head?
 500     ] unit-test
 501
 502     [ t ] [
 503         T{ secret } select-tuples length 3 =
 504     ] unit-test ;
 505
 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
 513
 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
 521
 522 TUPLE: does-not-persist ;
 523
 524 [
 525     [ does-not-persist create-sql-statement ]
 526     [ class \ not-persistent = ] must-fail-with
 527 ] test-sqlite
 528
 529 [
 530     [ does-not-persist create-sql-statement ]
 531     [ class \ not-persistent = ] must-fail-with
 532 ] test-postgresql
 533
 534
 535 TUPLE: suparclass id a ;
 536
 537 suparclass f {
 538     { "id" "ID" +db-assigned-id+ }
 539     { "a" "A" INTEGER }
 540 } define-persistent
 541
 542 TUPLE: subbclass < suparclass b ;
 543
 544 subbclass "SUBCLASS" {
 545     { "b" "B" TEXT }
 546 } define-persistent
 547
 548 TUPLE: fubbclass < subbclass ;
 549
 550 fubbclass "FUBCLASS" { } define-persistent
 551
 552 : test-db-inheritance ( -- )
 553     [ ] [ subbclass ensure-table ] unit-test
 554     [ ] [ fubbclass ensure-table ] unit-test
 555
 556     [ ] [
 557         subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
 558     ] unit-test
 559
 560     [ t "hi" 5 ] [
 561         subbclass new "id" get >>id select-tuple
 562         [ subbclass? ] [ b>> ] [ a>> ] tri
 563     ] unit-test
 564
 565     [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
 566
 567     [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
 568
 569 [ test-db-inheritance ] test-sqlite
 570 [ test-db-inheritance ] test-postgresql
 571
 572
 573 TUPLE: string-encoding-test id string ;
 574
 575 string-encoding-test "STRING_ENCODING_TEST" {
 576     { "id" "ID" +db-assigned-id+ }
 577     { "string" "STRING" TEXT }
 578 } define-persistent
 579
 580 : test-string-encoding ( -- )
 581     [ ] [ string-encoding-test ensure-table ] unit-test
 582
 583     [ ] [
 584         string-encoding-test new
 585             "\u{copyright-sign}\u{bengali-letter-cha}" >>string
 586         [ insert-tuple ] [ id>> "id" set ] bi
 587     ] unit-test
 588
 589     [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
 590         string-encoding-test new "id" get >>id select-tuple string>>
 591     ] unit-test ;
 592
 593 [ test-string-encoding ] test-sqlite
 594 [ test-string-encoding ] test-postgresql
 595
 596 : test-queries ( -- )
 597     [ ] [ exam ensure-table ] unit-test
 598     [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
 599     [ 5 ] [
 600         <query>
 601         T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
 602             >>tuple
 603         5 >>limit select-tuples length
 604     ] unit-test ;
 605
 606 TUPLE: compound-foo a b c ;
 607
 608 compound-foo "COMPOUND_FOO"
 609 {
 610     { "a" "A" INTEGER +user-assigned-id+ }
 611     { "b" "B" INTEGER +user-assigned-id+ }
 612     { "c" "C" INTEGER }
 613 } define-persistent
 614
 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 ;
 624
 625 [ test-compound-primary-key ] test-sqlite
 626 [ test-compound-primary-key ] test-postgresql
 627
 628
 629 TUPLE: example id data ;
 630
 631 example "EXAMPLE"
 632 {
 633     { "id" "ID" +db-assigned-id+ }
 634     { "data" "DATA" BLOB }
 635 } define-persistent
 636
 637 : test-blob-select ( -- )
 638     example ensure-table
 639     [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
 640     [
 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 ;
 643
 644 [ test-blob-select ] test-sqlite
 645 [ test-blob-select ] test-postgresql