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 ;
14 : new-db ( class -- obj )
16 H{ } clone >>insert-statements
17 H{ } clone >>update-statements
18 H{ } clone >>delete-statements ; inline
20 GENERIC: db-open ( db -- db )
21 HOOK: db-close db ( handle -- )
23 : dispose-statements ( assoc -- ) values dispose-each ;
25 : db-dispose ( db -- )
28 [ insert-statements>> dispose-statements ]
29 [ update-statements>> dispose-statements ]
30 [ delete-statements>> dispose-statements ]
35 TUPLE: result-set sql in-params out-params handle n max ;
37 GENERIC: query-results ( query -- result-set )
38 GENERIC: #rows ( result-set -- n )
39 GENERIC: #columns ( result-set -- n )
40 GENERIC# row-column 1 ( result-set column -- obj )
41 GENERIC# row-column-typed 1 ( result-set column -- sql )
42 GENERIC: advance-row ( result-set -- )
43 GENERIC: more-rows? ( result-set -- ? )
45 : init-result-set ( result-set -- )
49 : new-result-set ( query handle class -- result-set )
52 >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
57 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
58 TUPLE: simple-statement < statement ;
59 TUPLE: prepared-statement < statement ;
61 : new-statement ( sql in out class -- statement )
67 HOOK: <simple-statement> db ( string in out -- statement )
68 HOOK: <prepared-statement> db ( string in out -- statement )
69 GENERIC: prepare-statement ( statement -- )
70 GENERIC: bind-statement* ( statement -- )
71 GENERIC: low-level-bind ( statement -- )
72 GENERIC: bind-tuple ( tuple statement -- )
74 GENERIC: execute-statement* ( statement type -- )
76 M: object execute-statement* ( statement type -- )
77 drop query-results dispose ;
79 : execute-one-statement ( statement -- )
80 dup type>> execute-statement* ;
82 : execute-statement ( statement -- )
84 [ execute-one-statement ] each
89 : bind-statement ( obj statement -- )
91 [ bind-statement* ] keep
94 : sql-row ( result-set -- seq )
95 dup #columns [ row-column ] with map ;
97 : sql-row-typed ( result-set -- seq )
98 dup #columns [ row-column-typed ] with map ;
100 : query-each ( statement quot: ( statement -- ) -- )
102 [ call ] 2keep over advance-row query-each
105 ] if ; inline recursive
107 : query-map ( statement quot -- seq )
108 accumulator [ query-each ] dip { } like ; inline
110 : with-db ( db quot -- )
112 '[ db get [ drop @ ] with-disposal ] with-variable ; inline
114 : default-query ( query -- result-set )
115 query-results [ [ sql-row ] query-map ] with-disposal ;
117 : sql-query ( sql -- rows )
118 f f <simple-statement> [ default-query ] with-disposal ;
120 : sql-command ( sql -- )
122 f f <simple-statement> [ execute-statement ] with-disposal
129 SYMBOL: in-transaction
130 HOOK: begin-transaction db ( -- )
131 HOOK: commit-transaction db ( -- )
132 HOOK: rollback-transaction db ( -- )
134 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
135 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
136 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
138 : in-transaction? ( -- ? ) in-transaction get ;
140 : with-transaction ( quot -- )
143 [ ] [ rollback-transaction ] cleanup commit-transaction