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