steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

define-persistent checks that slots exist

db4
Doug Coleman 2008-09-23 16:55:32 -05:00
parent 46262a6554
commit 8eea1d13c2
2 changed files with 23 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/db/tuples/tuples-tests.factor
View File

@ -236,6 +236,17 @@ TUPLE: exam id name score ;
exam boa ; exam boa ;
: test-intervals ( -- ) : 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" exam "EXAM"
{ {
{ "id" "ID" +db-assigned-id+ } { "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 "Kenny" 60 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[ ] [ 10 [ random-exam insert-tuple ] times ] unit-test [ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
[ ] [ ] unit-test ! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test
! [ ] [ query ] unit-test ! [ ] [ query ] unit-test
; ;
: test-db ( -- ) : test-db ( -- )

13
basis/db/tuples/tuples.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs classes db kernel namespaces USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations math.parser io prettyprint db.types continuations
destructors mirrors ; destructors mirrors sets ;
IN: db.tuples IN: db.tuples
TUPLE: query tuple group order offset limit ; 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 -- ) 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 -- ) : 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 [ relation? ] partition swapd
dupd [ spec>tuple ] with map dupd [ spec>tuple ] with map
"db-columns" set-word-prop "db-columns" set-word-prop