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 ;
   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{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
  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{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
 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 : db-assigned-person-schema ( -- )
 114     person "PERSON"
 115     {
 116         { "the-id" "ID" +db-assigned-id+ }
 117         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
 118         { "the-number" "AGE" INTEGER { +default+ 0 } }
 119         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
 120         { "ts" "TS" TIMESTAMP }
 121         { "date" "D" DATE }
 122         { "time" "T" TIME }
 123         { "blob" "B" BLOB }
 124         { "factor-blob" "FB" FACTOR-BLOB }
 125         { "url" "U" URL }
 126     } define-persistent
 127     "billy" 10 3.14 f f f f f f <person> person1 set
 128     "johnny" 10 3.14 f f f f f f <person> person2 set
 129     "teddy" 10 3.14
 130         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
 131         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
 132         T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
 133         B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
 134     "eddie" 10 3.14
 135         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
 136         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
 137         T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
 138         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 ;
 139
 140 : user-assigned-person-schema ( -- )
 141     person "PERSON"
 142     {
 143         { "the-id" "ID" INTEGER +user-assigned-id+ }
 144         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
 145         { "the-number" "AGE" INTEGER { +default+ 0 } }
 146         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
 147         { "ts" "TS" TIMESTAMP }
 148         { "date" "D" DATE }
 149         { "time" "T" TIME }
 150         { "blob" "B" BLOB }
 151         { "factor-blob" "FB" FACTOR-BLOB }
 152         { "url" "U" URL }
 153     } define-persistent
 154     1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
 155     2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
 156     3 "teddy" 10 3.14
 157         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
 158         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
 159         T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
 160         B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
 161         f f <user-assigned-person> person3 set
 162     4 "eddie" 10 3.14
 163         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
 164         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
 165         T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
 166         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 ;
 167
 168 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 169 TUPLE: annotation n paste-id summary author mode contents ;
 170
 171 : db-assigned-paste-schema ( -- )
 172     paste "PASTE"
 173     {
 174         { "n" "ID" +db-assigned-id+ }
 175         { "summary" "SUMMARY" TEXT }
 176         { "author" "AUTHOR" TEXT }
 177         { "channel" "CHANNEL" TEXT }
 178         { "mode" "MODE" TEXT }
 179         { "contents" "CONTENTS" TEXT }
 180         { "date" "DATE" TIMESTAMP }
 181         { "annotations" { +has-many+ annotation } }
 182     } define-persistent
 183
 184     annotation "ANNOTATION"
 185     {
 186         { "n" "ID" +db-assigned-id+ }
 187         { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
 188         { "summary" "SUMMARY" TEXT }
 189         { "author" "AUTHOR" TEXT }
 190         { "mode" "MODE" TEXT }
 191         { "contents" "CONTENTS" TEXT }
 192     } define-persistent ;
 193
 194 ! { "localhost" "postgres" "" "factor-test" } postgresql-db [
 195     ! [ paste drop-table ] [ drop ] recover
 196     ! [ annotation drop-table ] [ drop ] recover
 197     ! [ paste drop-table ] [ drop ] recover
 198     ! [ annotation drop-table ] [ drop ] recover
 199     ! [ ] [ paste create-table ] unit-test
 200     ! [ ] [ annotation create-table ] unit-test
 201 ! ] with-db
 202
 203 : test-sqlite ( quot -- )
 204     [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
 205
 206 : test-postgresql ( quot -- )
 207     [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
 208
 209 : test-repeated-insert
 210     [ ] [ person ensure-table ] unit-test
 211     [ ] [ person1 get insert-tuple ] unit-test
 212     [ person1 get insert-tuple ] must-fail ;
 213
 214 TUPLE: serialize-me id data ;
 215
 216 : test-serialize ( -- )
 217     serialize-me "SERIALIZED"
 218     {
 219         { "id" "ID" +db-assigned-id+ }
 220         { "data" "DATA" FACTOR-BLOB }
 221     } define-persistent
 222     [ serialize-me drop-table ] [ drop ] recover
 223     [ ] [ serialize-me create-table ] unit-test
 224
 225     [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
 226     [
 227         { T{ serialize-me f 1 H{ { 1 2 } } } }
 228     ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
 229
 230 TUPLE: exam id name score ;
 231
 232 : random-exam ( -- exam )
 233         f
 234         6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
 235         100 random
 236     exam boa ;
 237
 238 : test-intervals ( -- )
 239     exam "EXAM"
 240     {
 241         { "id" "ID" +db-assigned-id+ }
 242         { "name" "NAME" TEXT }
 243         { "score" "SCORE" INTEGER }
 244     } define-persistent
 245     [ exam drop-table ] [ drop ] recover
 246     [ ] [ exam create-table ] unit-test
 247
 248     [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
 249     [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
 250     [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
 251     [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
 252
 253     [
 254         {
 255             T{ exam f 3 "Kenny" 60 }
 256             T{ exam f 4 "Cartman" 41 }
 257         }
 258     ] [
 259         T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
 260     ] unit-test
 261
 262     [
 263         { }
 264     ] [
 265         T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
 266     ] unit-test
 267     [
 268         {
 269             T{ exam f 4 "Cartman" 41 }
 270         }
 271     ] [
 272         T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
 273     ] unit-test
 274     [
 275         {
 276             T{ exam f 3 "Kenny" 60 }
 277         }
 278     ] [
 279         T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
 280     ] unit-test
 281     [
 282         {
 283             T{ exam f 3 "Kenny" 60 }
 284             T{ exam f 4 "Cartman" 41 }
 285         }
 286     ] [
 287         T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
 288     ] unit-test
 289
 290     [
 291         {
 292             T{ exam f 1 "Kyle" 100 }
 293             T{ exam f 2 "Stan" 80 }
 294         }
 295     ] [
 296         T{ exam f f { "Stan" "Kyle" } } select-tuples
 297     ] unit-test
 298
 299     [
 300         {
 301             T{ exam f 1 "Kyle" 100 }
 302             T{ exam f 2 "Stan" 80 }
 303             T{ exam f 3 "Kenny" 60 }
 304         }
 305     ] [
 306         T{ exam f T{ range f 1 3 1 } } select-tuples
 307     ] unit-test
 308
 309     [
 310         {
 311             T{ exam f 2 "Stan" 80 }
 312             T{ exam f 3 "Kenny" 60 }
 313             T{ exam f 4 "Cartman" 41 }
 314         }
 315     ] [
 316         T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
 317     ] unit-test
 318
 319     [
 320         {
 321             T{ exam f 1 "Kyle" 100 }
 322         }
 323     ] [
 324         T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
 325     ] unit-test
 326
 327     [
 328         {
 329             T{ exam f 1 "Kyle" 100 }
 330             T{ exam f 2 "Stan" 80 }
 331             T{ exam f 3 "Kenny" 60 }
 332             T{ exam f 4 "Cartman" 41 }
 333         }
 334     ] [
 335         T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
 336     ] unit-test
 337
 338     [
 339         {
 340             T{ exam f 1 "Kyle" 100 }
 341             T{ exam f 2 "Stan" 80 }
 342             T{ exam f 3 "Kenny" 60 }
 343             T{ exam f 4 "Cartman" 41 }
 344         }
 345     ] [
 346         T{ exam } select-tuples
 347     ] unit-test
 348
 349     [ 4 ] [ T{ exam } f count-tuples ] unit-test ;
 350
 351 TUPLE: bignum-test id m n o ;
 352 : <bignum-test> ( m n o -- obj )
 353     bignum-test new
 354         swap >>o
 355         swap >>n
 356         swap >>m ;
 357
 358 : test-bignum
 359     bignum-test "BIGNUM_TEST"
 360     {
 361         { "id" "ID" +db-assigned-id+ }
 362         { "m" "M" BIG-INTEGER }
 363         { "n" "N" UNSIGNED-BIG-INTEGER }
 364         { "o" "O" SIGNED-BIG-INTEGER }
 365     } define-persistent
 366     [ bignum-test drop-table ] ignore-errors
 367     [ ] [ bignum-test ensure-table ] unit-test
 368     [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
 369
 370     ! sqlite only
 371     ! [ T{ bignum-test f 1
 372         ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
 373     ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
 374
 375 TUPLE: secret n message ;
 376 C: <secret> secret
 377
 378 : test-random-id
 379     secret "SECRET"
 380     {
 381         { "n" "ID" +random-id+ system-random-generator }
 382         { "message" "MESSAGE" TEXT }
 383     } define-persistent
 384
 385     [ ] [ secret recreate-table ] unit-test
 386
 387     [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 388
 389     [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
 390
 391     [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
 392
 393     [ t ] [
 394         T{ secret } select-tuples
 395         first message>> "kilroy was here" head?
 396     ] unit-test
 397
 398     [ t ] [
 399         T{ secret } select-tuples length 3 =
 400     ] unit-test ;
 401
 402 [ db-assigned-person-schema test-tuples ] test-sqlite
 403 [ user-assigned-person-schema test-tuples ] test-sqlite
 404 [ user-assigned-person-schema test-repeated-insert ] test-sqlite
 405 [ test-bignum ] test-sqlite
 406 [ test-serialize ] test-sqlite
 407 [ test-intervals ] test-sqlite
 408 [ test-random-id ] test-sqlite
 409
 410 [ db-assigned-person-schema test-tuples ] test-postgresql
 411 [ user-assigned-person-schema test-tuples ] test-postgresql
 412 [ user-assigned-person-schema test-repeated-insert ] test-postgresql
 413 [ test-bignum ] test-postgresql
 414 [ test-serialize ] test-postgresql
 415 [ test-intervals ] test-postgresql
 416 [ test-random-id ] test-postgresql
 417
 418 TUPLE: does-not-persist ;
 419
 420 [
 421     [ does-not-persist create-sql-statement ]
 422     [ class \ not-persistent = ] must-fail-with
 423 ] test-sqlite
 424
 425 [
 426     [ does-not-persist create-sql-statement ]
 427     [ class \ not-persistent = ] must-fail-with
 428 ] test-postgresql
 429
 430
 431 TUPLE: suparclass id a ;
 432
 433 suparclass f {
 434     { "id" "ID" +db-assigned-id+ }
 435     { "a" "A" INTEGER }
 436 } define-persistent
 437
 438 TUPLE: subbclass < suparclass b ;
 439
 440 subbclass "SUBCLASS" {
 441     { "b" "B" TEXT }
 442 } define-persistent
 443
 444 TUPLE: fubbclass < subbclass ;
 445
 446 fubbclass "FUBCLASS" { } define-persistent
 447
 448 : test-db-inheritance ( -- )
 449     [ ] [ subbclass ensure-table ] unit-test
 450     [ ] [ fubbclass ensure-table ] unit-test
 451
 452     [ ] [
 453         subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
 454     ] unit-test
 455
 456     [ t "hi" 5 ] [
 457         subbclass new "id" get >>id select-tuple
 458         [ subbclass? ] [ b>> ] [ a>> ] tri
 459     ] unit-test
 460
 461     [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
 462
 463     [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
 464
 465 [ test-db-inheritance ] test-sqlite
 466 [ test-db-inheritance ] test-postgresql
 467
 468
 469 TUPLE: string-encoding-test id string ;
 470
 471 string-encoding-test "STRING_ENCODING_TEST" {
 472     { "id" "ID" +db-assigned-id+ }
 473     { "string" "STRING" TEXT }
 474 } define-persistent
 475
 476 : test-string-encoding ( -- )
 477     [ ] [ string-encoding-test ensure-table ] unit-test
 478
 479     [ ] [
 480         string-encoding-test new
 481             "\u{copyright-sign}\u{bengali-letter-cha}" >>string
 482         [ insert-tuple ] [ id>> "id" set ] bi
 483     ] unit-test
 484
 485     [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
 486         string-encoding-test new "id" get >>id select-tuple string>>
 487     ] unit-test ;
 488
 489 [ test-string-encoding ] test-sqlite
 490 [ test-string-encoding ] test-postgresql
 491
 492 ! Don't comment these out. These words must infer
 493 \ bind-tuple must-infer
 494 \ insert-tuple must-infer
 495 \ update-tuple must-infer
 496 \ delete-tuples must-infer
 497 \ select-tuple must-infer
 498 \ define-persistent must-infer
 499 \ ensure-table must-infer
 500 \ create-table must-infer
 501 \ drop-table must-infer