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 ;
14 : new-db ( class -- obj )
16 H{ } clone >>insert-statements
17 H{ } clone >>update-statements
18 H{ } clone >>delete-statements ; inline
20 GENERIC: make-db* ( seq db -- db )
22 : make-db ( seq class -- db ) new-db make-db* ;
24 GENERIC: db-open ( db -- db )
25 HOOK: db-close db ( handle -- )
27 : dispose-statements ( assoc -- ) values dispose-each ;
29 : db-dispose ( db -- )
32 [ insert-statements>> dispose-statements ]
33 [ update-statements>> dispose-statements ]
34 [ delete-statements>> dispose-statements ]
39 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
40 TUPLE: simple-statement < statement ;
41 TUPLE: prepared-statement < statement ;
43 TUPLE: result-set sql in-params out-params handle n max ;
45 : construct-statement ( sql in out class -- statement )
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 -- ? )
65 GENERIC: execute-statement* ( statement type -- )
67 M: object execute-statement* ( statement type -- )
68 drop query-results dispose ;
70 : execute-statement ( statement -- )
72 [ execute-statement ] each
74 dup type>> execute-statement*
77 : bind-statement ( obj statement -- )
79 [ bind-statement* ] keep
82 : init-result-set ( result-set -- )
86 : construct-result-set ( query handle class -- result-set )
89 >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
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 ( seq class quot -- )
111 [ make-db db-open db ] dip
112 [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
115 : default-query ( query -- result-set )
116 query-results [ [ sql-row ] query-map ] with-disposal ;
118 : do-bound-query ( obj query -- rows )
119 [ bind-statement ] keep default-query ;
121 : do-bound-command ( obj query -- )
122 [ bind-statement ] keep execute-statement ;
124 SYMBOL: in-transaction
125 HOOK: begin-transaction db ( -- )
126 HOOK: commit-transaction db ( -- )
127 HOOK: rollback-transaction db ( -- )
129 : in-transaction? ( -- ? ) in-transaction get ;
131 : with-transaction ( quot -- )
134 [ ] [ rollback-transaction ] cleanup commit-transaction
137 : sql-query ( sql -- rows )
138 f f <simple-statement> [ default-query ] with-disposal ;
140 : sql-command ( sql -- )
142 f f <simple-statement> [ execute-statement ] with-disposal