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