factor: trim using lists

[factor.git] / basis / db / db.factor

diff --git a/basis/db/db.factor b/basis/db/db.factor
old mode 100755 (executable)
new mode 100644 (file)
index 5b159d0..6f9c448
--- a/basis/db/db.factor
+++ b/basis/db/db.factor
@@ -1,35 +1,38 @@
 ! 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
 
-TUPLE: db
+TUPLE: db-connection
     handle
     insert-statements
     update-statements
     delete-statements ;
 
-: new-db ( class -- obj )
+<PRIVATE
+
+: new-db-connection ( class -- obj )
     new
         H{ } clone >>insert-statements
         H{ } clone >>update-statements
         H{ } clone >>delete-statements ; inline
 
-GENERIC: db-open ( db -- db )
-HOOK: db-close db ( handle -- )
+PRIVATE>
+
+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 ;
 
-: db-dispose ( db -- ) 
-    dup db [
-        {
-            [ insert-statements>> dispose-statements ]
-            [ update-statements>> dispose-statements ]
-            [ delete-statements>> dispose-statements ]
-            [ handle>> db-close ]
-        } cleave
+M: db-connection dispose
+    dup db-connection [
+        [ dispose-statements H{ } clone ] change-insert-statements
+        [ dispose-statements H{ } clone ] change-update-statements
+        [ dispose-statements H{ } clone ] change-delete-statements
+        [ db-close f ] change-handle
+        drop
     ] with-variable ;
 
 TUPLE: result-set sql in-params out-params handle n max ;
@@ -37,8 +40,8 @@ TUPLE: result-set sql in-params out-params handle n max ;
 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 -- ? )
 
@@ -49,7 +52,7 @@ GENERIC: more-rows? ( result-set -- ? )
 : new-result-set ( query handle class -- result-set )
     new
         swap >>handle
-        >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+        [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
         swap >>out-params
         swap >>in-params
         swap >>sql ;
@@ -64,8 +67,8 @@ TUPLE: prepared-statement < statement ;
         swap >>in-params
         swap >>sql ;
 
-HOOK: <simple-statement> db ( string in out -- statement )
-HOOK: <prepared-statement> db ( string in out -- statement )
+HOOK: <simple-statement> db-connection ( string in out -- statement )
+HOOK: <prepared-statement> db-connection ( string in out -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( statement -- )
 GENERIC: low-level-bind ( statement -- )
@@ -73,8 +76,12 @@ GENERIC: bind-tuple ( tuple statement -- )
 
 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* ;
@@ -92,53 +99,57 @@ M: object execute-statement* ( statement type -- )
     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 ] dip
-    '[ db get [ drop @ ] with-disposal ] with-variable ; inline
+    [ db-open db-connection ] dip
+    '[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
 
+! Words for working with raw SQL statements
 : default-query ( query -- result-set )
     query-results [ [ sql-row ] query-map ] with-disposal ;
 
 : sql-query ( sql -- rows )
     f f <simple-statement> [ default-query ] with-disposal ;
 
+: (sql-command) ( string -- )
+    f f <simple-statement> [ execute-statement ] with-disposal ;
+
 : sql-command ( sql -- )
-    dup string? [
-        f f <simple-statement> [ execute-statement ] with-disposal
-    ] [
-        ! [
-            [ sql-command ] each
-        ! ] with-transaction
-    ] if ;
+    dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
 
+! Transactions
 SYMBOL: in-transaction
-HOOK: begin-transaction db ( -- )
-HOOK: commit-transaction db ( -- )
-HOOK: rollback-transaction db ( -- )
 
-M: db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+HOOK: begin-transaction db-connection ( -- )
+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 ;
 
 : 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