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 ;
15 : new-db-connection ( class -- obj )
17 H{ } clone >>insert-statements
18 H{ } clone >>update-statements
19 H{ } clone >>delete-statements ; inline
23 GENERIC: db-open ( db -- db-connection )
24 HOOK: db-close db-connection ( handle -- )
25 HOOK: parse-db-error db-connection ( error -- error' )
27 : dispose-statements ( assoc -- ) values dispose-each ;
29 M: db-connection dispose
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
38 TUPLE: result-set sql in-params out-params handle n max ;
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 -- ? )
48 : init-result-set ( result-set -- )
52 : new-result-set ( query handle class -- result-set )
55 [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
60 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
61 TUPLE: simple-statement < statement ;
62 TUPLE: prepared-statement < statement ;
64 : new-statement ( sql in out class -- statement )
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 -- )
77 GENERIC: execute-statement* ( statement type -- )
79 M: object execute-statement*
81 _ _ drop query-results dispose
83 parse-db-error rethrow
86 : execute-one-statement ( statement -- )
87 dup type>> execute-statement* ;
89 : execute-statement ( statement -- )
91 [ execute-one-statement ] each
96 : bind-statement ( obj statement -- )
98 [ bind-statement* ] keep
101 : sql-row ( result-set -- seq )
102 dup #columns [ row-column ] with map-integers ;
104 : sql-row-typed ( result-set -- seq )
105 dup #columns [ row-column-typed ] with map-integers ;
107 : query-each ( result-set quot: ( row -- ) -- )
109 [ call ] 2keep over advance-row query-each
112 ] if ; inline recursive
114 : query-map ( result-set quot: ( row -- row' ) -- seq )
115 collector [ query-each ] dip { } like ; inline
117 : with-db ( db quot -- )
118 [ db-open db-connection ] dip
119 '[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
121 ! Words for working with raw SQL statements
122 : default-query ( query -- result-set )
123 query-results [ [ sql-row ] query-map ] with-disposal ;
125 : sql-query ( sql -- rows )
126 f f <simple-statement> [ default-query ] with-disposal ;
128 : (sql-command) ( string -- )
129 f f <simple-statement> [ execute-statement ] with-disposal ;
131 : sql-command ( sql -- )
132 dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
135 SYMBOL: in-transaction
137 HOOK: begin-transaction db-connection ( -- )
138 HOOK: commit-transaction db-connection ( -- )
139 HOOK: rollback-transaction db-connection ( -- )
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 ;
145 : in-transaction? ( -- ? ) in-transaction get ;
147 : with-transaction ( quot -- )
153 [ ] [ rollback-transaction ] cleanup commit-transaction