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 ;
   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: make-db* ( object db -- db )
  21
  22 : make-db ( object class -- db ) new-db make-db* ;
  23
  24 GENERIC: db-open ( db -- db )
  25 HOOK: db-close db ( handle -- )
  26
  27 : dispose-statements ( assoc -- ) values dispose-each ;
  28
  29 : db-dispose ( db -- )
  30     dup db [
  31         {
  32             [ insert-statements>> dispose-statements ]
  33             [ update-statements>> dispose-statements ]
  34             [ delete-statements>> dispose-statements ]
  35             [ handle>> db-close ]
  36         } cleave
  37     ] with-variable ;
  38
  39 TUPLE: result-set sql in-params out-params handle n max ;
  40
  41 GENERIC: query-results ( query -- result-set )
  42 GENERIC: #rows ( result-set -- n )
  43 GENERIC: #columns ( result-set -- n )
  44 GENERIC# row-column 1 ( result-set column -- obj )
  45 GENERIC# row-column-typed 1 ( result-set column -- sql )
  46 GENERIC: advance-row ( result-set -- )
  47 GENERIC: more-rows? ( result-set -- ? )
  48
  49 : init-result-set ( result-set -- )
  50     dup #rows >>max
  51     0 >>n drop ;
  52
  53 : new-result-set ( query handle class -- result-set )
  54     new
  55         swap >>handle
  56         >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
  57         swap >>out-params
  58         swap >>in-params
  59         swap >>sql ;
  60
  61 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
  62 TUPLE: simple-statement < statement ;
  63 TUPLE: prepared-statement < statement ;
  64
  65 : new-statement ( sql in out class -- statement )
  66     new
  67         swap >>out-params
  68         swap >>in-params
  69         swap >>sql ;
  70
  71 HOOK: <simple-statement> db ( string in out -- statement )
  72 HOOK: <prepared-statement> db ( string in out -- statement )
  73 GENERIC: prepare-statement ( statement -- )
  74 GENERIC: bind-statement* ( statement -- )
  75 GENERIC: low-level-bind ( statement -- )
  76 GENERIC: bind-tuple ( tuple statement -- )
  77
  78 GENERIC: execute-statement* ( statement type -- )
  79
  80 M: object execute-statement* ( statement type -- )
  81     drop query-results dispose ;
  82
  83 : execute-one-statement ( statement -- )
  84     dup type>> execute-statement* ;
  85
  86 : execute-statement ( statement -- )
  87     dup sequence? [
  88         [ execute-one-statement ] each
  89     ] [
  90         execute-one-statement
  91     ] if ;
  92
  93 : bind-statement ( obj statement -- )
  94     swap >>bind-params
  95     [ bind-statement* ] keep
  96     t >>bound? drop ;
  97
  98 : sql-row ( result-set -- seq )
  99     dup #columns [ row-column ] with map ;
 100
 101 : sql-row-typed ( result-set -- seq )
 102     dup #columns [ row-column-typed ] with map ;
 103
 104 : query-each ( statement quot: ( statement -- ) -- )
 105     over more-rows? [
 106         [ call ] 2keep over advance-row query-each
 107     ] [
 108         2drop
 109     ] if ; inline recursive
 110
 111 : query-map ( statement quot -- seq )
 112     accumulator [ query-each ] dip { } like ; inline
 113
 114 : with-db ( seq class quot -- )
 115     [ make-db db-open db ] dip
 116     [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
 117     inline
 118
 119 : default-query ( query -- result-set )
 120     query-results [ [ sql-row ] query-map ] with-disposal ;
 121
 122 : sql-query ( sql -- rows )
 123     f f <simple-statement> [ default-query ] with-disposal ;
 124
 125 : sql-command ( sql -- )
 126     dup string? [
 127         f f <simple-statement> [ execute-statement ] with-disposal
 128     ] [
 129         ! [
 130             [ sql-command ] each
 131         ! ] with-transaction
 132     ] if ;
 133
 134 SYMBOL: in-transaction
 135 HOOK: begin-transaction db ( -- )
 136 HOOK: commit-transaction db ( -- )
 137 HOOK: rollback-transaction db ( -- )
 138
 139 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
 140 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
 141 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
 142
 143 : in-transaction? ( -- ? ) in-transaction get ;
 144
 145 : with-transaction ( quot -- )
 146     t in-transaction [
 147         begin-transaction
 148         [ ] [ rollback-transaction ] cleanup commit-transaction
 149     ] with-variable ;