add composite primary keys to db

diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
index 17bb97320d53067287094bc4823823e518aca3e5..60cc584bbf8c73f38a1104902702abbb181d649c 100755 (executable)
--- 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 <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 } }

diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 2beb3a9ecbcc3c5b1c8dc639d1588fcc5044a5f1..f7809de578180097928ae73c859464d767addbd4 100644 (file)
--- 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
     <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 )
     [

diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor
index a4d16ae4d1a3d1adb2300147e40b4525079967a4..e520ad302bd6dc5305b52ae55237cd3a9d8772da 100755 (executable)
--- 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 4b1e49c76ebf8f0c53198ba542121c93707b31ca..85a3b73264b9b00a36616224e3f631d7a41067df 100755 (executable)
--- 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 ] [ <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 ;

diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 4ecff74c10c64d503f4f2b4581d902eb83bd7aa5..7f567697d2ce0bf667faafb02f3a88fcb2217bd6 100755 (executable)
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -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

diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
index 24876336c75766e56550c8584b5f753001f0c989..5ead216174b69c672563995f7e420df3d6ecf8c4 100755 (executable)
--- 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 ;