! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes continuations destructors kernel math
-namespaces sequences classes.tuple words strings
-tools.walker accessors combinators fry ;
+USING: accessors assocs continuations destructors kernel
+namespaces sequences strings ;
IN: db
-<PRIVATE
-
TUPLE: db-connection
handle
insert-statements
update-statements
delete-statements ;
+<PRIVATE
+
: new-db-connection ( class -- obj )
new
H{ } clone >>insert-statements
GENERIC: db-open ( db -- db-connection )
HOOK: db-close db-connection ( handle -- )
+HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ;
-M: db-connection dispose ( db-connection -- )
+M: db-connection dispose
dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set column -- obj )
-GENERIC# row-column-typed 1 ( result-set column -- sql )
+GENERIC#: row-column 1 ( result-set column -- obj )
+GENERIC#: row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
GENERIC: execute-statement* ( statement type -- )
-M: object execute-statement* ( statement type -- )
- drop query-results dispose ;
+M: object execute-statement*
+ '[
+ _ _ drop query-results dispose
+ ] [
+ parse-db-error rethrow
+ ] recover ;
: execute-one-statement ( statement -- )
dup type>> execute-statement* ;
t >>bound? drop ;
: sql-row ( result-set -- seq )
- dup #columns [ row-column ] with map ;
+ dup #columns [ row-column ] with { } map-integers ;
: sql-row-typed ( result-set -- seq )
- dup #columns [ row-column-typed ] with map ;
+ dup #columns [ row-column-typed ] with { } map-integers ;
-: query-each ( statement quot: ( statement -- ) -- )
+: query-each ( result-set quot: ( row -- ) -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
2drop
] if ; inline recursive
-: query-map ( statement quot -- seq )
- accumulator [ query-each ] dip { } like ; inline
+: query-map ( result-set quot: ( row -- row' ) -- seq )
+ collector [ query-each ] dip { } like ; inline
: with-db ( db quot -- )
[ db-open db-connection ] dip
HOOK: commit-transaction db-connection ( -- )
HOOK: rollback-transaction db-connection ( -- )
-M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+M: db-connection begin-transaction "BEGIN" sql-command ;
+M: db-connection commit-transaction "COMMIT" sql-command ;
+M: db-connection rollback-transaction "ROLLBACK" sql-command ;
: in-transaction? ( -- ? ) in-transaction get ;
: with-transaction ( quot -- )
- t in-transaction [
- begin-transaction
- [ ] [ rollback-transaction ] cleanup commit-transaction
- ] with-variable ;
+ in-transaction? [
+ call
+ ] [
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable
+ ] if ; inline