basis/db/db.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes continuations destructors kernel math
   4 namespaces sequences classes.tuple words strings
   5 tools.walker accessors combinators fry ;
   6 IN: db
   7
   8 TUPLE: db
   9     handle
  10     insert-statements
  11     update-statements
  12     delete-statements ;
  13
  14 : new-db ( class -- obj )
  15     new
  16         H{ } clone >>insert-statements
  17         H{ } clone >>update-statements
  18         H{ } clone >>delete-statements ; inline
  19
  20 GENERIC: db-open ( db -- db )
  21 HOOK: db-close db ( handle -- )
  22
  23 : dispose-statements ( assoc -- ) values dispose-each ;
  24
  25 M: db dispose ( db -- )
  26     dup db [
  27         [ dispose-statements H{ } clone ] change-insert-statements
  28         [ dispose-statements H{ } clone ] change-update-statements
  29         [ dispose-statements H{ } clone ] change-delete-statements
  30         [ db-close f ] change-handle
  31         drop
  32     ] with-variable ;
  33
  34 TUPLE: result-set sql in-params out-params handle n max ;
  35
  36 GENERIC: query-results ( query -- result-set )
  37 GENERIC: #rows ( result-set -- n )
  38 GENERIC: #columns ( result-set -- n )
  39 GENERIC# row-column 1 ( result-set column -- obj )
  40 GENERIC# row-column-typed 1 ( result-set column -- sql )
  41 GENERIC: advance-row ( result-set -- )
  42 GENERIC: more-rows? ( result-set -- ? )
  43
  44 : init-result-set ( result-set -- )
  45     dup #rows >>max
  46     0 >>n drop ;
  47
  48 : new-result-set ( query handle class -- result-set )
  49     new
  50         swap >>handle
  51         [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
  52         swap >>out-params
  53         swap >>in-params
  54         swap >>sql ;
  55
  56 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
  57 TUPLE: simple-statement < statement ;
  58 TUPLE: prepared-statement < statement ;
  59
  60 : new-statement ( sql in out class -- statement )
  61     new
  62         swap >>out-params
  63         swap >>in-params
  64         swap >>sql ;
  65
  66 HOOK: <simple-statement> db ( string in out -- statement )
  67 HOOK: <prepared-statement> db ( string in out -- statement )
  68 GENERIC: prepare-statement ( statement -- )
  69 GENERIC: bind-statement* ( statement -- )
  70 GENERIC: low-level-bind ( statement -- )
  71 GENERIC: bind-tuple ( tuple statement -- )
  72
  73 GENERIC: execute-statement* ( statement type -- )
  74
  75 M: object execute-statement* ( statement type -- )
  76     drop query-results dispose ;
  77
  78 : execute-one-statement ( statement -- )
  79     dup type>> execute-statement* ;
  80
  81 : execute-statement ( statement -- )
  82     dup sequence? [
  83         [ execute-one-statement ] each
  84     ] [
  85         execute-one-statement
  86     ] if ;
  87
  88 : bind-statement ( obj statement -- )
  89     swap >>bind-params
  90     [ bind-statement* ] keep
  91     t >>bound? drop ;
  92
  93 : sql-row ( result-set -- seq )
  94     dup #columns [ row-column ] with map ;
  95
  96 : sql-row-typed ( result-set -- seq )
  97     dup #columns [ row-column-typed ] with map ;
  98
  99 : query-each ( statement quot: ( statement -- ) -- )
 100     over more-rows? [
 101         [ call ] 2keep over advance-row query-each
 102     ] [
 103         2drop
 104     ] if ; inline recursive
 105
 106 : query-map ( statement quot -- seq )
 107     accumulator [ query-each ] dip { } like ; inline
 108
 109 : with-db ( db quot -- )
 110     [ db-open db ] dip
 111     '[ db get [ drop @ ] with-disposal ] with-variable ; inline
 112
 113 ! Words for working with raw SQL statements
 114 : default-query ( query -- result-set )
 115     query-results [ [ sql-row ] query-map ] with-disposal ;
 116
 117 : sql-query ( sql -- rows )
 118     f f <simple-statement> [ default-query ] with-disposal ;
 119
 120 : (sql-command) ( string -- )
 121     f f <simple-statement> [ execute-statement ] with-disposal ;
 122
 123 : sql-command ( sql -- )
 124     dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
 125
 126 ! Transactions
 127 SYMBOL: in-transaction
 128
 129 HOOK: begin-transaction db ( -- )
 130 HOOK: commit-transaction db ( -- )
 131 HOOK: rollback-transaction db ( -- )
 132
 133 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
 134 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
 135 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
 136
 137 : in-transaction? ( -- ? ) in-transaction get ;
 138
 139 : with-transaction ( quot -- )
 140     t in-transaction [
 141         begin-transaction
 142         [ ] [ rollback-transaction ] cleanup commit-transaction
 143     ] with-variable ;