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

add composite primary keys to db

db4
Doug Coleman 2008-09-27 14:07:39 -05:00
parent 876e3d0e04
commit 511ecaff59
6 changed files with 114 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
basis/db/postgresql/postgresql.factor
View File

@ -37,8 +37,7 @@ M: postgresql-db db-open ( db -- db )
M: postgresql-db dispose ( db -- )
handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
@ -67,11 +66,11 @@ M: postgresql-result-set #columns ( result-set -- n )
[ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column ( result-set column -- object )
>r result-handle-n r> pq-get-string ;
[ result-handle-n ] dip pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- object )
dup pick out-params>> nth type>>
>r >r result-handle-n r> r> postgresql-column-typed ;
[ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [
@ -126,13 +125,20 @@ M: postgresql-db bind# ( spec object -- )
: create-table-sql ( class -- statement )
[
dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] interleave
", " 0%
find-primary-key
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
"));" 0%
] query-make ;
: create-function-sql ( class -- statement )
@ -160,8 +166,7 @@ M: postgresql-db bind# ( spec object -- )
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key db-assigned-id-spec?
[ create-function-sql , ] [ drop ] if
dup db-assigned? [ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
@ -181,15 +186,14 @@ M: postgresql-db create-sql-statement ( class -- seq )
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key db-assigned-id-spec?
[ drop-function-sql , ] [ drop ] if
dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
dup find-primary-key 2,
dup find-primary-key first 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
@ -218,14 +222,14 @@ M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
");" 0%
] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
M: postgresql-db insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db persistent-table ( -- hashtable )
H{
{ +db-assigned-id+ { "integer" "serial primary key" f } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "bigint" "bigint primary key" f } }
{ +db-assigned-id+ { "integer" "serial" f } }
{ +user-assigned-id+ { f f f } }
{ +random-id+ { "bigint" "bigint" f } }
{ TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }
{ INTEGER { "integer" "integer" f } }

28
basis/db/queries/queries.factor
View File

@ -46,13 +46,18 @@ M: retryable execute-statement* ( statement type -- )
[ db-columns ] [ db-table ] bi ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
{ "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
find-primary-key [
" and " 0%
] [
dup column-name>> 0% " = " 0% bind%
] interleave ;
M: db <update-tuple-statement> ( class -- statement )
[
@ -121,16 +126,15 @@ M: string where ( spec obj -- ) object-where ;
dup double-infinite-interval? [ drop f ] when
] with filter ;
: where-clause ( tuple specs -- )
dupd filter-slots [
drop
: many-where ( tuple seq -- )
" where " 0% [
" and " 0%
] [
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop
] if-empty ;
2dup slot-name>> swap get-slot-named where
] interleave drop ;
: where-clause ( tuple specs -- )
dupd filter-slots [ drop ] [ many-where ] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql )
[

19
basis/db/sqlite/sqlite.factor
View File

@ -88,7 +88,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
db get handle>> sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )
M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
@ -114,13 +114,20 @@ M: sqlite-statement query-results ( query -- result-set )
M: sqlite-db create-sql-statement ( class -- statement )
[
dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] interleave
", " 0%
find-primary-key
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
"));" 0%
] query-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
@ -161,10 +168,10 @@ M: sqlite-db bind% ( spec -- )
M: sqlite-db persistent-table ( -- assoc )
H{
{ +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "integer primary key" "integer primary key" "primary key" } }
{ INTEGER { "integer" "integer" "primary key" } }
{ +db-assigned-id+ { "integer" "integer" f } }
{ +user-assigned-id+ { f f f } }
{ +random-id+ { "integer" "integer" f } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }

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

@ -513,15 +513,35 @@ string-encoding-test "STRING_ENCODING_TEST" {
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-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
[ 5 ] [ <query> T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } } >>tuple 5 >>limit select-tuples length ] unit-test
! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test
! [ ] [ query ] unit-test
;
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
[ 5 ] [
<query>
T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
>>tuple
5 >>limit select-tuples length
] unit-test ;
TUPLE: compound-foo a b c ;
compound-foo "COMPOUND_FOO"
{
{ "a" "A" INTEGER +user-assigned-id+ }
{ "b" "B" INTEGER +user-assigned-id+ }
{ "c" "C" INTEGER }
} define-persistent
: test-compound-primary-key ( -- )
[ ] [ compound-foo ensure-table ] unit-test
[ ] [ compound-foo drop-table ] unit-test
[ ] [ compound-foo create-table ] unit-test
[ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
[ 1 2 3 compound-foo boa insert-tuple ] must-fail
[ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
[ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
[ compound-foo new 4 >>c select-tuple ] unit-test ;
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
: test-db ( -- )
"tuples-test.db" temp-file sqlite-db make-db db-open db set ;

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

@ -19,23 +19,7 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: <count-statement> db ( query -- statement )
HOOK: query>statement db ( query -- statement )
HOOK: insert-tuple* db ( tuple statement -- )
ERROR: not-persistent class ;
: db-table ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- object )
"db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key slot-name>>
] keep set-slot-named ;
HOOK: insert-tuple-set-key db ( tuple statement -- )
SYMBOL: sql-counter
: next-sql-counter ( -- str )
@ -69,7 +53,7 @@ GENERIC: eval-generator ( singleton -- object )
: insert-db-assigned-statement ( tuple -- )
dup class
db get insert-statements>> [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
[ bind-tuple ] 2keep insert-tuple-set-key ;
: insert-user-assigned-statement ( tuple -- )
dup class

52
basis/db/types/types.factor
View File

@ -30,14 +30,44 @@ UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat
slot-named offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
ERROR: not-persistent class ;
: db-table ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- object )
"db-relations" word-prop ;
: find-primary-key ( specs -- seq )
[ primary-key>> ] filter ;
: set-primary-key ( value tuple -- )
[
class db-columns
find-primary-key first slot-name>>
] keep set-slot-named ;
: primary-key? ( spec -- ? )
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( spec -- ? )
primary-key>> +db-assigned-id+? ;
: db-assigned-id-spec? ( specs -- ? )
[ primary-key>> +db-assigned-id+? ] contains? ;
: assigned-id-spec? ( spec -- ? )
primary-key>> +user-assigned-id+? ;
: assigned-id-spec? ( specs -- ? )
[ primary-key>> +user-assigned-id+? ] contains? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
@ -49,8 +79,8 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
[ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ primary-key>> ] find nip ;
: db-assigned? ( class -- ? )
db-columns find-primary-key db-assigned-id-spec? ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
@ -125,13 +155,3 @@ ERROR: no-sql-type ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat
slot-named offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;