define-persistent checks that slots exist

diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 466d086fbef4a68d0abc05404e0d70ba489f8e2e..45a51719f98550930327fe044ef18b28ab0aa477 100755 (executable)
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -236,6 +236,17 @@ TUPLE: exam id name score ;
     exam boa ;
 
 : test-intervals ( -- )
+    [
+        exam "EXAM"
+        {
+            { "idd" "ID" +db-assigned-id+ }
+            { "named" "NAME" TEXT }
+            { "score" "SCORE" INTEGER }
+        } define-persistent
+    ] [
+        seq>> { "idd" "named" } =
+    ] must-fail-with
+
     exam "EXAM"
     {
         { "id" "ID" +db-assigned-id+ }
@@ -507,9 +518,8 @@ string-encoding-test "STRING_ENCODING_TEST" {
     ! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
     ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
     [ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
-    [ ] [ ] unit-test
+    ! [ ] [ T{ exam { name "Kenny" } } >query  ] unit-test
     ! [ ] [ query ] unit-test
-
     ;
 
 : test-db ( -- )

diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 534b91b8fcebd803bbce6461f4856bfea0c0947f..bff83b5b49aca391759dfb7759d7ef4e397c7ec4 100755 (executable)
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -3,7 +3,7 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors ;
+destructors mirrors sets ;
 IN: db.tuples
 
 TUPLE: query tuple group order offset limit ;
@@ -30,8 +30,17 @@ HOOK: make-query db ( tuple class query -- statement )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
+ERROR: no-slots-named class seq ;
+: check-columns ( class columns -- )
+    tuck
+    [ [ first ] map ]
+    [ "slots" word-prop [ name>> ] map ] bi* diff
+    [ drop ] [ no-slots-named ] if-empty ;
+
 : define-persistent ( class table columns -- )
-    >r dupd "db-table" set-word-prop dup r>
+    pick dupd
+    check-columns
+    [ dupd "db-table" set-word-prop dup ] dip
     [ relation? ] partition swapd
     dupd [ spec>tuple ] with map
     "db-columns" set-word-prop