fix sqlite foreign triggers create/delete bug

ignore-errors only if there is a sql spec defined for the class until database-specific errors are implemented

basis/db/sqlite/lib/lib.factor

@@ -5,8 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
 io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors shuffle io prettyprint
+io.encodings.string accessors shuffle io db.private ;
-db.private ;
 IN: db.sqlite.lib
 
 ERROR: sqlite-error < db-error n string ;
@@ -125,8 +124,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
     ] if* (sqlite-bind-type) ;
 
 : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- )
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
-"resetting: " write dup . sqlite3_reset sqlite-check-result ;
 : sqlite-clear-bindings ( handle -- )
     sqlite3_clear_bindings sqlite-check-result ;
 : sqlite-#columns ( query -- int ) sqlite3_column_count ;

basis/db/sqlite/sqlite-tests.factor

@@ -1,6 +1,7 @@
 USING: io io.files io.files.temp io.directories io.launcher
 kernel namespaces prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case ;
+continuations db.types db.tuples unicode.case accessors arrays
+sorting ;
 IN: db.sqlite.tests
 
 : db-path ( -- path ) "test.db" temp-file ;
@@ -74,8 +75,9 @@ IN: db.sqlite.tests
     ] with-db
 ] unit-test
 
+[ \ swap ensure-table ] must-fail
+
 ! You don't need a primary key
-USING: accessors arrays sorting ;
 TUPLE: things one two ;
 
 things "THINGS" {
@@ -163,5 +165,3 @@ watch "WATCH" {
         user>> f user boa select-tuple
     ] with-db
 ] unit-test
-
-[ \ swap ensure-table ] must-fail

basis/db/sqlite/sqlite.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
+io.files kernel math math.parser namespaces prettyprint fry
 sequences strings classes.tuple alien.c-types continuations
 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
 math.intervals io nmake accessors vectors math.ranges random
 math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+io.streams.string multiline make db.private sequences.deep ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -126,30 +126,6 @@ M: sqlite-statement query-results ( query -- result-set )
     dup handle>> sqlite-result-set new-result-set
     dup advance-row ;
 
-M: sqlite-db-connection create-sql-statement ( class -- statement )
-    [
-        dupd
-        "create table " 0% 0%
-        "(" 0% [ ", " 0% ] [
-            dup "sql-spec" set
-            dup column-name>> [ "table-id" set ] [ 0% ] bi
-            " " 0%
-            dup type>> lookup-create-type 0%
-            modifiers 0%
-        ] interleave
-
-        find-primary-key [
-            ", " 0%
-            "primary key(" 0%
-            [ "," 0% ] [ column-name>> 0% ] interleave
-            ")" 0%
-        ] unless-empty
-        ");" 0%
-    ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
-    [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
     [
         "insert into " 0% 0%
@@ -225,7 +201,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -237,7 +213,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -247,10 +223,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-insert-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : update-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -262,7 +245,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : update-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -272,10 +255,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-update-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-restrict ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -284,10 +274,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-restrict ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-cascade ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
@@ -295,6 +292,13 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-cascade ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : can-be-null? ( -- ? )
     "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
 
@@ -318,14 +322,69 @@ M: sqlite-db-connection persistent-table ( -- assoc )
         delete-trigger-restrict sqlite-trigger,
     ] if ;
 
+: drop-sqlite-triggers ( -- )
+    drop-insert-trigger sqlite-trigger,
+    drop-update-trigger sqlite-trigger,
+    delete-cascade? [
+        drop-delete-trigger-cascade sqlite-trigger,
+    ] [
+        drop-delete-trigger-restrict sqlite-trigger,
+    ] if ;
+
+: db-triggers ( sql-specs word -- )
+    '[
+        [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+        [
+            [ class>> db-table-name "db-table" set ]
+            [ column-name>> "table-id" set ]
+            [
+                modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+                [
+                    [ second db-table-name "foreign-table-name" set ]
+                    [ third "foreign-table-id" set ] bi
+                    _ execute
+                ] each
+            ] tri
+        ] each
+    ] call ;
+
+: sqlite-create-table ( sql-specs class-name -- )
+    [
+        "create table " 0% 0%
+        "(" 0% [ ", " 0% ] [
+            dup "sql-spec" set
+            dup column-name>> [ "table-id" set ] [ 0% ] bi
+            " " 0%
+            dup type>> lookup-create-type 0%
+            modifiers 0%
+        ] interleave
+    ] [
+        drop
+        find-primary-key [
+            ", " 0%
+            "primary key(" 0%
+            [ "," 0% ] [ column-name>> 0% ] interleave
+            ")" 0%
+        ] unless-empty
+        ");" 0%
+    ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement ( class -- statement )
+    [
+        ! specs name
+        [ sqlite-create-table ]
+        [ drop \ create-sqlite-triggers db-triggers ] 2bi
+    ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement ( class -- statements )
+    [
+        [ nip "drop table " 0% 0% ";" 0% ]
+        [ drop \ drop-sqlite-triggers db-triggers ] 2bi
+    ] query-make ;
+
 M: sqlite-db-connection compound ( string seq -- new-string )
     over {
         { "default" [ first number>string " " glue ] }
-        { "references" [
+        { "references" [ >reference-string ] }
-            [ >reference-string ] keep
-            first2 [ db-table-name "foreign-table-name" set ]
-            [ "foreign-table-id" set ] bi*
-            create-sqlite-triggers
-        ] }
         [ 2drop ]
     } case ;

basis/db/tuples/tuples.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private ;
+destructors mirrors sets db.types db.private fry
+combinators.short-circuit ;
 IN: db.tuples
 
 HOOK: create-sql-statement db-connection ( class -- object )
@@ -29,7 +30,7 @@ GENERIC: eval-generator ( singleton -- object )
 
 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
     rot class new [
-        [ [ slot-name>> ] dip set-slot-named ] curry 2each
+        '[ slot-name>> _ set-slot-named ] 2each
     ] keep ;
 
 : query-tuples ( exemplar-tuple statement -- seq )
@@ -98,33 +99,49 @@ M: query >query clone ;
 
 M: tuple >query <query> swap >>tuple ;
 
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+    dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+        no-defined-persistent
+    ] unless ;
+
 : create-table ( class -- )
+    ensure-defined-persistent
     create-sql-statement [ execute-statement ] with-disposals ;
 
 : drop-table ( class -- )
+    ensure-defined-persistent
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : recreate-table ( class -- )
+    ensure-defined-persistent
     [
-        [ drop-sql-statement [ execute-statement ] with-disposals
+        '[
-        ] curry ignore-errors
+            _ drop-sql-statement [ execute-statement ] with-disposals
+        ] ignore-errors
     ] [ create-table ] bi ;
 
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+    ensure-defined-persistent
+    '[ _ create-table ] ignore-errors ;
 
 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key db-assigned-id-spec?
+    dup class ensure-defined-persistent
+    db-columns find-primary-key db-assigned-id-spec?
     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 
 : update-tuple ( tuple -- )
-    dup class
+    dup class ensure-defined-persistent
     db-connection get update-statements>> [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : delete-tuples ( tuple -- )
-    dup dup class <delete-tuples-statement> [
+    dup
+    dup class ensure-defined-persistent
+    <delete-tuples-statement> [
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
@@ -132,8 +149,8 @@ M: tuple >query <query> swap >>tuple ;
     >query [ tuple>> ] [ query>statement ] bi do-select ;
 
 : select-tuple ( query/tuple -- tuple/f )
-    >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
+    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
-    [ f ] [ first ] if-empty ;
+    do-select [ f ] [ first ] if-empty ;
 
 : count-tuples ( query/tuple -- n )
     >query [ tuple>> ] [ <count-statement> ] bi do-count