diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 466d086fbe..45a51719f9 100755 --- 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 534b91b8fc..bff83b5b49 100755 --- 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