basis/db/tuples/tuples-tests.factor

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