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 db.errors ;
   6 IN: db
   7
   8 TUPLE: db-connection
   9     handle
  10     insert-statements
  11     update-statements
  12     delete-statements ;
  13
  14 <PRIVATE
  15
  16 : new-db-connection ( class -- obj )
  17     new
  18         H{ } clone >>insert-statements
  19         H{ } clone >>update-statements
  20         H{ } clone >>delete-statements ; inline
  21
  22 PRIVATE>
  23
  24 GENERIC: db-open ( db -- db-connection )
  25 HOOK: db-close db-connection ( handle -- )
  26 HOOK: parse-db-error db-connection ( error -- error' )
  27
  28 : dispose-statements ( assoc -- ) values dispose-each ;
  29
  30 M: db-connection dispose ( db-connection -- )
  31     dup db-connection [
  32         [ dispose-statements H{ } clone ] change-insert-statements
  33         [ dispose-statements H{ } clone ] change-update-statements
  34         [ dispose-statements H{ } clone ] change-delete-statements
  35         [ db-close f ] change-handle
  36         drop
  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         [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
  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-connection ( string in out -- statement )
  72 HOOK: <prepared-statement> db-connection ( 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     '[
  82         _ _ drop query-results dispose
  83     ] [
  84         parse-db-error rethrow
  85     ] recover ;
  86
  87 : execute-one-statement ( statement -- )
  88     dup type>> execute-statement* ;
  89
  90 : execute-statement ( statement -- )
  91     dup sequence? [
  92         [ execute-one-statement ] each
  93     ] [
  94         execute-one-statement
  95     ] if ;
  96
  97 : bind-statement ( obj statement -- )
  98     swap >>bind-params
  99     [ bind-statement* ] keep
 100     t >>bound? drop ;
 101
 102 : sql-row ( result-set -- seq )
 103     dup #columns [ row-column ] with { } map-integers ;
 104
 105 : sql-row-typed ( result-set -- seq )
 106     dup #columns [ row-column-typed ] with { } map-integers ;
 107
 108 : query-each ( statement quot: ( statement -- ) -- )
 109     over more-rows? [
 110         [ call ] 2keep over advance-row query-each
 111     ] [
 112         2drop
 113     ] if ; inline recursive
 114
 115 : query-map ( statement quot -- seq )
 116     collector [ query-each ] dip { } like ; inline
 117
 118 : with-db ( db quot -- )
 119     [ db-open db-connection ] dip
 120     '[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
 121
 122 ! Words for working with raw SQL statements
 123 : default-query ( query -- result-set )
 124     query-results [ [ sql-row ] query-map ] with-disposal ;
 125
 126 : sql-query ( sql -- rows )
 127     f f <simple-statement> [ default-query ] with-disposal ;
 128
 129 : (sql-command) ( string -- )
 130     f f <simple-statement> [ execute-statement ] with-disposal ;
 131
 132 : sql-command ( sql -- )
 133     dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
 134
 135 ! Transactions
 136 SYMBOL: in-transaction
 137
 138 HOOK: begin-transaction db-connection ( -- )
 139 HOOK: commit-transaction db-connection ( -- )
 140 HOOK: rollback-transaction db-connection ( -- )
 141
 142 M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
 143 M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
 144 M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
 145
 146 : in-transaction? ( -- ? ) in-transaction get ;
 147
 148 : with-transaction ( quot -- )
 149     in-transaction? [
 150         call
 151     ] [
 152         t in-transaction [
 153             begin-transaction
 154             [ ] [ rollback-transaction ] cleanup commit-transaction
 155         ] with-variable
 156     ] if ; inline