basis/db/db.factor

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