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