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 db.tuples.private ;
   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     [
 240         exam "EXAM"
 241         {
 242             { "idd" "ID" +db-assigned-id+ }
 243             { "named" "NAME" TEXT }
 244             { "score" "SCORE" INTEGER }
 245         } define-persistent
 246     ] [
 247         seq>> { "idd" "named" } =
 248     ] must-fail-with
 249
 250     exam "EXAM"
 251     {
 252         { "id" "ID" +db-assigned-id+ }
 253         { "name" "NAME" TEXT }
 254         { "score" "SCORE" INTEGER }
 255     } define-persistent
 256     [ exam drop-table ] [ drop ] recover
 257     [ ] [ exam create-table ] unit-test
 258
 259     [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
 260     [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
 261     [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
 262     [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
 263
 264     [
 265         {
 266             T{ exam f 3 "Kenny" 60 }
 267             T{ exam f 4 "Cartman" 41 }
 268         }
 269     ] [
 270         T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
 271     ] unit-test
 272
 273     [
 274         { }
 275     ] [
 276         T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
 277     ] unit-test
 278     [
 279         {
 280             T{ exam f 4 "Cartman" 41 }
 281         }
 282     ] [
 283         T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
 284     ] unit-test
 285     [
 286         {
 287             T{ exam f 3 "Kenny" 60 }
 288         }
 289     ] [
 290         T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
 291     ] unit-test
 292     [
 293         {
 294             T{ exam f 3 "Kenny" 60 }
 295             T{ exam f 4 "Cartman" 41 }
 296         }
 297     ] [
 298         T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
 299     ] unit-test
 300
 301     [
 302         {
 303             T{ exam f 1 "Kyle" 100 }
 304             T{ exam f 2 "Stan" 80 }
 305         }
 306     ] [
 307         T{ exam f f { "Stan" "Kyle" } } select-tuples
 308     ] unit-test
 309
 310     [
 311         {
 312             T{ exam f 1 "Kyle" 100 }
 313             T{ exam f 2 "Stan" 80 }
 314             T{ exam f 3 "Kenny" 60 }
 315         }
 316     ] [
 317         T{ exam f T{ range f 1 3 1 } } select-tuples
 318     ] unit-test
 319
 320     [
 321         {
 322             T{ exam f 2 "Stan" 80 }
 323             T{ exam f 3 "Kenny" 60 }
 324             T{ exam f 4 "Cartman" 41 }
 325         }
 326     ] [
 327         T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
 328     ] unit-test
 329
 330     [
 331         {
 332             T{ exam f 1 "Kyle" 100 }
 333         }
 334     ] [
 335         T{ exam f T{ interval f { -1.0/0.0 t } { 2 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 f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
 347     ] unit-test
 348
 349     [
 350         {
 351             T{ exam f 1 "Kyle" 100 }
 352             T{ exam f 2 "Stan" 80 }
 353             T{ exam f 3 "Kenny" 60 }
 354             T{ exam f 4 "Cartman" 41 }
 355         }
 356     ] [
 357         T{ exam } select-tuples
 358     ] unit-test
 359
 360     [ 4 ] [ T{ exam } count-tuples ] unit-test ;
 361
 362 TUPLE: bignum-test id m n o ;
 363 : <bignum-test> ( m n o -- obj )
 364     bignum-test new
 365         swap >>o
 366         swap >>n
 367         swap >>m ;
 368
 369 : test-bignum
 370     bignum-test "BIGNUM_TEST"
 371     {
 372         { "id" "ID" +db-assigned-id+ }
 373         { "m" "M" BIG-INTEGER }
 374         { "n" "N" UNSIGNED-BIG-INTEGER }
 375         { "o" "O" SIGNED-BIG-INTEGER }
 376     } define-persistent
 377     [ bignum-test drop-table ] ignore-errors
 378     [ ] [ bignum-test ensure-table ] unit-test
 379     [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
 380
 381     ! sqlite only
 382     ! [ T{ bignum-test f 1
 383         ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
 384     ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
 385
 386 TUPLE: secret n message ;
 387 C: <secret> secret
 388
 389 : test-random-id
 390     secret "SECRET"
 391     {
 392         { "n" "ID" +random-id+ system-random-generator }
 393         { "message" "MESSAGE" TEXT }
 394     } define-persistent
 395
 396     [ ] [ secret recreate-table ] unit-test
 397
 398     [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 399
 400     [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
 401
 402     [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
 403
 404     [ t ] [
 405         T{ secret } select-tuples
 406         first message>> "kilroy was here" head?
 407     ] unit-test
 408
 409     [ t ] [
 410         T{ secret } select-tuples length 3 =
 411     ] unit-test ;
 412
 413 [ db-assigned-person-schema test-tuples ] test-sqlite
 414 [ user-assigned-person-schema test-tuples ] test-sqlite
 415 [ user-assigned-person-schema test-repeated-insert ] test-sqlite
 416 [ test-bignum ] test-sqlite
 417 [ test-serialize ] test-sqlite
 418 [ test-intervals ] test-sqlite
 419 [ test-random-id ] test-sqlite
 420
 421 [ db-assigned-person-schema test-tuples ] test-postgresql
 422 [ user-assigned-person-schema test-tuples ] test-postgresql
 423 [ user-assigned-person-schema test-repeated-insert ] test-postgresql
 424 [ test-bignum ] test-postgresql
 425 [ test-serialize ] test-postgresql
 426 [ test-intervals ] test-postgresql
 427 [ test-random-id ] test-postgresql
 428
 429 TUPLE: does-not-persist ;
 430
 431 [
 432     [ does-not-persist create-sql-statement ]
 433     [ class \ not-persistent = ] must-fail-with
 434 ] test-sqlite
 435
 436 [
 437     [ does-not-persist create-sql-statement ]
 438     [ class \ not-persistent = ] must-fail-with
 439 ] test-postgresql
 440
 441
 442 TUPLE: suparclass id a ;
 443
 444 suparclass f {
 445     { "id" "ID" +db-assigned-id+ }
 446     { "a" "A" INTEGER }
 447 } define-persistent
 448
 449 TUPLE: subbclass < suparclass b ;
 450
 451 subbclass "SUBCLASS" {
 452     { "b" "B" TEXT }
 453 } define-persistent
 454
 455 TUPLE: fubbclass < subbclass ;
 456
 457 fubbclass "FUBCLASS" { } define-persistent
 458
 459 : test-db-inheritance ( -- )
 460     [ ] [ subbclass ensure-table ] unit-test
 461     [ ] [ fubbclass ensure-table ] unit-test
 462
 463     [ ] [
 464         subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
 465     ] unit-test
 466
 467     [ t "hi" 5 ] [
 468         subbclass new "id" get >>id select-tuple
 469         [ subbclass? ] [ b>> ] [ a>> ] tri
 470     ] unit-test
 471
 472     [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
 473
 474     [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
 475
 476 [ test-db-inheritance ] test-sqlite
 477 [ test-db-inheritance ] test-postgresql
 478
 479
 480 TUPLE: string-encoding-test id string ;
 481
 482 string-encoding-test "STRING_ENCODING_TEST" {
 483     { "id" "ID" +db-assigned-id+ }
 484     { "string" "STRING" TEXT }
 485 } define-persistent
 486
 487 : test-string-encoding ( -- )
 488     [ ] [ string-encoding-test ensure-table ] unit-test
 489
 490     [ ] [
 491         string-encoding-test new
 492             "\u{copyright-sign}\u{bengali-letter-cha}" >>string
 493         [ insert-tuple ] [ id>> "id" set ] bi
 494     ] unit-test
 495
 496     [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
 497         string-encoding-test new "id" get >>id select-tuple string>>
 498     ] unit-test ;
 499
 500 [ test-string-encoding ] test-sqlite
 501 [ test-string-encoding ] test-postgresql
 502
 503 ! Don't comment these out. These words must infer
 504 \ bind-tuple must-infer
 505 \ insert-tuple must-infer
 506 \ update-tuple must-infer
 507 \ delete-tuples must-infer
 508 \ select-tuple must-infer
 509 \ define-persistent must-infer
 510 \ ensure-table must-infer
 511 \ create-table must-infer
 512 \ drop-table must-infer
 513
 514 : test-queries ( -- )
 515     [ ] [ exam ensure-table ] unit-test
 516     ! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
 517     ! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
 518     ! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
 519     ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
 520     [ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
 521     ! [ ] [ T{ exam { name "Kenny" } } >query  ] unit-test
 522     ! [ ] [ query ] unit-test
 523     ;
 524
 525 : test-db ( -- )
 526     "tuples-test.db" temp-file sqlite-db make-db db-open db set ;