From 511ecaff59cb689302cb423a21bb9f4fa4a3df90 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Sep 2008 14:07:39 -0500 Subject: [PATCH] add composite primary keys to db --- basis/db/postgresql/postgresql.factor | 32 +++++++++-------- basis/db/queries/queries.factor | 28 ++++++++------- basis/db/sqlite/sqlite.factor | 19 ++++++---- basis/db/tuples/tuples-tests.factor | 38 +++++++++++++++----- basis/db/tuples/tuples.factor | 20 ++--------- basis/db/types/types.factor | 52 ++++++++++++++++++--------- 6 files changed, 114 insertions(+), 75 deletions(-) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 17bb97320d..60cc584bbf 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -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 ( 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 ( 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 } } diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 2beb3a9ecb..f7809de578 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -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 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 ( 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 ( tuple table -- sql ) [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index a4d16ae4d1..e520ad302b 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -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" } } diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 4b1e49c76e..85a3b73264 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -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 ] [ 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 ] [ + + 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 ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 4ecff74c10..7f567697d2 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -19,23 +19,7 @@ HOOK: db ( tuple class -- tuple ) HOOK: 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>> [ ] cache - [ bind-tuple ] 2keep insert-tuple* ; + [ bind-tuple ] 2keep insert-tuple-set-key ; : insert-user-assigned-statement ( tuple -- ) dup class diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 24876336c7..5ead216174 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -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 ;