basis/db/tester/tester.factor

   1 ! Copyright (C) 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: concurrency.combinators db.pools db.sqlite db.tuples
   4 db.types kernel math random threads tools.test db sequences
   5 io prettyprint db.postgresql db.sqlite accessors io.files.temp
   6 namespaces fry system math.parser ;
   7 IN: db.tester
   8
   9 : postgresql-test-db ( -- postgresql-db )
  10     <postgresql-db>
  11         "localhost" >>host
  12         "postgres" >>username
  13         "thepasswordistrust" >>password
  14         "factor-test" >>database ;
  15
  16 : sqlite-test-db ( -- sqlite-db )
  17     "tuples-test.db" temp-file <sqlite-db> ;
  18
  19
  20 ! These words leak resources, but are useful for interactivel testing
  21 : set-sqlite-db ( -- )
  22     sqlite-db db-open db-connection set ;
  23
  24 : set-postgresql-db ( -- )
  25     postgresql-db db-open db-connection set ;
  26
  27
  28 : test-sqlite ( quot -- )
  29     '[
  30         [ ] [ sqlite-test-db _ with-db ] unit-test
  31     ] call ; inline
  32
  33 : test-postgresql ( quot -- )
  34     '[
  35         os windows? cpu x86.64? and [
  36             [ ] [ postgresql-test-db _ with-db ] unit-test
  37         ] unless
  38     ] call ; inline
  39
  40
  41 TUPLE: test-1 id a b c ;
  42
  43 test-1 "TEST1" {
  44    { "id" "ID" INTEGER +db-assigned-id+ }
  45    { "a" "A" { VARCHAR 256 } +not-null+ }
  46    { "b" "B" { VARCHAR 256 } +not-null+ }
  47    { "c" "C" { VARCHAR 256 } +not-null+ }
  48 } define-persistent
  49
  50 TUPLE: test-2 id x y z ;
  51
  52 test-2 "TEST2" {
  53    { "id" "ID" INTEGER +db-assigned-id+ }
  54    { "x" "X" { VARCHAR 256 } +not-null+ }
  55    { "y" "Y" { VARCHAR 256 } +not-null+ }
  56    { "z" "Z" { VARCHAR 256 } +not-null+ }
  57 } define-persistent
  58
  59 : test-1-tuple ( -- tuple )
  60     f 100 random 100 random 100 random [ number>string ] tri@
  61     test-1 boa ;
  62
  63 : db-tester ( test-db -- )
  64     [
  65         [
  66             test-1 ensure-table
  67             test-2 ensure-table
  68         ] with-db
  69     ] [
  70         10 [
  71             drop
  72             10 [
  73                 dup [
  74                     test-1-tuple insert-tuple yield
  75                 ] with-db
  76             ] times
  77         ] with parallel-each
  78     ] bi ;
  79
  80 : db-tester2 ( test-db -- )
  81     [
  82         [
  83             test-1 ensure-table
  84             test-2 ensure-table
  85         ] with-db
  86     ] [
  87         <db-pool> [
  88             10 [
  89                 10 [
  90                     test-1-tuple insert-tuple yield
  91                 ] times
  92             ] parallel-each
  93         ] with-pooled-db
  94     ] bi ;