diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
index 36b6fc829b..9c98b53626 100644
--- a/extra/db/postgresql/postgresql-tests.factor
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -1,8 +1,9 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
-USING: kernel db.postgresql alien continuations io prettyprint
-sequences namespaces tools.test db db.types ;
+USING: kernel db.postgresql alien continuations io classes
+prettyprint sequences namespaces tools.test db
+db.tuples db.types unicode.case ;
IN: temporary
IN: scratchpad
@@ -108,3 +109,48 @@ IN: temporary
"select * from person" sql-query length
] with-db
] unit-test
+
+
+
+! TEST TUPLE DB
+
+TUPLE: puppy id name age ;
+: <puppy> ( name age -- puppy )
+ { set-puppy-name set-puppy-age } puppy construct ;
+
+puppy "PUPPY" {
+ { "id" "ID" +native-id+ }
+ { "name" "NAME" TEXT }
+ { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: kitty id name age ;
+: <kitty> ( name age -- kitty )
+ { set-kitty-name set-kitty-age } kitty construct ;
+
+kitty "KITTY" {
+ { "id" "ID" +native-id+ }
+ { "name" "NAME" TEXT }
+ { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: basket id puppies kitties ;
+basket "BASKET"
+{
+ { "id" "ID" +native-id+ }
+ { "location" "LOCATION" TEXT }
+ { "puppies" { +has-many+ puppy } }
+ { "kitties" { +has-many+ kitty } }
+} define-persistent
+
+[
+ { "name" "age" }
+ ! "insert into table puppy(name, age) values($1, $2);"
+ "select add_puppy($1, $2, $3);"
+] [
+ T{ postgresql-db } db [
+ "Mr Clunkers" 3 <puppy>
+ class dup db-columns swap db-table insert-sql* >lower
+ ] with-variable
+] unit-test
+
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 03746bcaa0..b877d72060 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
-combinators ;
+combinators sequences.lib classes ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -117,52 +117,13 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
-: postgresql-type-hash* ( -- assoc )
- H{
- { SERIAL "serial" }
- } ;
-
-: postgresql-type-hash ( -- assoc )
- H{
- { INTEGER "integer" }
- { SERIAL "integer" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { DOUBLE "real" }
- } ;
-
-: enquote ( str -- newstr ) "(" swap ")" 3append ;
-
-: postgresql-type ( str n/str -- newstr )
- " " swap number>string* enquote 3append ;
-
-: >sql-type* ( obj -- str )
- dup pair? [
- first2 >r >sql-type* r> postgresql-type
- ] [
- dup postgresql-type-hash* at* [
- nip
- ] [
- drop >sql-type
- ] if
- ] if ;
-
-M: postgresql-db >sql-type ( hash obj -- str )
- dup pair? [
- first2 >r >sql-type r> postgresql-type
- ] [
- postgresql-type-hash at* [
- no-sql-type
- ] unless
- ] if ;
-
-: insert-function ( columns table -- sql )
+: insert-function ( columns table -- sql types )
[
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
- [ third dup array? [ first ] when >sql-type % ] interleave
+ [ third dup array? [ first ] when >sql-type-string % ] interleave
")" %
" returns bigint as '" %
@@ -177,31 +138,31 @@ M: postgresql-db >sql-type ( hash obj -- str )
"select currval(''" % % "_id_seq'');' language sql;" %
drop
- ] "" make ;
+ ] "" make f ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
- [ "," % ] [ third >sql-type % ] interleave
+ [ "," % ] [ third >sql-type-string % ] interleave
")" %
- ] "" make ;
+ ] "" nmake ;
-M: postgresql-db create-sql ( columns table -- seq )
- [
- [
- 2dup
- "create table " % %
- " (" % [ ", " % ] [
- dup second % " " %
- dup third >sql-type* % " " %
- sql-modifiers " " join %
- ] interleave "); " %
- ] "" make ,
-
- over native-id? [ insert-function , ] [ 2drop ] if
- ] { } make ;
+! M: postgresql-db create-sql ( columns table -- seq )
+ ! [
+ ! [
+ ! 2dup
+ ! "create table " % %
+ ! " (" % [ ", " % ] [
+ ! dup second % " " %
+ ! dup third >sql-type-string % " " %
+ ! sql-modifiers " " join %
+ ! ] interleave "); " %
+ ! ] "" make ,
+!
+ ! over native-id? [ insert-function , ] [ 2drop ] if
+ ! ] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
@@ -211,15 +172,15 @@ M: postgresql-db drop-sql ( columns table -- seq )
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
-M: postgresql-db insert-sql* ( columns table -- slot-names sql )
+M: postgresql-db insert-sql* ( columns table -- sql slots )
[
"select add_" % %
"(" %
- length [1,b] [ ", " % ] [ "$" % # ] interleave
- ")" %
+ dup length [1,b] [ ", " % ] [ "$" % # ] interleave
+ ");" %
] "" make ;
-M: postgresql-db update-sql* ( columns table -- slot-names sql )
+M: postgresql-db update-sql* ( columns table -- sql slots )
[
"update " %
%
@@ -239,8 +200,42 @@ M: postgresql-db delete-sql* ( columns table -- slot-names sql )
first second % " = $1" %
] "" make ;
-M: postgresql-db select-sql ( columns table -- slot-names sql )
- drop ;
+: column-name% ( spec -- )
+ dup sql-spec-column-name 0%
+ sql-spec-type >sql-type-string 1, ;
+
+: column-names% ( class -- )
+ db-columns [ "," 0, ] [ column-name% ] interleave ;
+
+M: postgresql-db column-bind% ( spec -- )
+
+
+ ;
+
+
+! : select-foreign-table-sql ( tuple relation -- )
+! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id
+ ! "select " 0%
+ ! ;
+! TODO
+: select-relations-sql ( tuple -- seq )
+ ! seq -- { sql types }
+ dup class db-relations [
+ [
+ ! select-foreign-table-sql
+ ] { "" { } } 2 nmake
+ ] with { } map>assoc ;
+
+! TODO
+: select-by-slots-sql ( tuple -- sql )
+ dup tuple>filled-slots
+ ;
+
+
+M: postgresql-db select-sql ( tuple -- sql slot-names )
+ [
+
+ ] { } 2 nmake ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
@@ -248,7 +243,8 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
: postgresql-db-modifiers ( -- hashtable )
H{
- { +native-id+ "not null primary key" }
+ { +native-id+ "primary key" }
+ { +foreign-key+ "" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
@@ -257,13 +253,16 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
-M: postgresql-db sql-modifiers* ( modifiers -- str )
- postgresql-db-modifiers swap [
- dup array? [
- first2
- >r swap at r> number>string*
- " " swap 3append
- ] [
- swap at
- ] if
- ] with map [ ] subset ;
+! M: postgresql-db sql-modifier>string ( modifier -- str )
+ ! dup array? [
+ ! first2
+ ! >r swap at r> number>string*
+ ! " " swap 3append
+ ! ] [
+ ! swap at
+ ! ] if ;
+!
+! M: postgresql-db sql-modifiers* ( modifiers -- str )
+ ! postgresql-db-modifiers swap [
+ ! sql-modifier>string
+ ! ] with map [ ] subset ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index ea57193750..7df0b430de 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -54,7 +54,7 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set
! test-sqlite
- test-postgresql
+! test-postgresql
! person "PERSON"
! {
@@ -68,3 +68,42 @@ person "PERSON"
! test-sqlite
! test-postgresql
+
+TUPLE: paste n summary author channel mode contents timestamp annotations ;
+TUPLE: annotation n paste-id summary author mode contents ;
+
+paste "PASTE"
+{
+ { "n" "ID" SERIAL +native-id+ }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "channel" "CHANNEL" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ { "date" "DATE" TIMESTAMP }
+ { "annotations" { +has-many+ annotation } }
+} define-persistent
+
+! n
+ ! NO: drop insert
+ ! YES: create update delete select
+! annotations
+ ! NO: create drop insert update delete
+ ! YES: select
+
+annotation "ANNOTATION"
+{
+ { "n" "ID" SERIAL +native-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-key+ paste "n" } }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+} define-persistent
+
+"localhost" "postgres" "" "factor-test" <postgresql-db> [
+ ! paste drop-table
+ ! annotation drop-table
+ paste create-table
+ annotation create-table
+] with-db
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 20cdd8a386..30ca260b93 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -2,11 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots slots.private math
-math.parser io prettyprint db.types continuations ;
+math.parser io prettyprint db.types continuations
+mirrors sequences.lib ;
IN: db.tuples
-: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ;
+: db-columns ( class -- obj ) "db-columns" word-prop ;
+: db-relations ( class -- obj ) "db-relations" word-prop ;
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
@@ -41,26 +43,15 @@ TUPLE: no-slot-named ;
HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( columns table -- seq )
-HOOK: insert-sql* db ( columns table -- slot-names sql )
-HOOK: update-sql* db ( columns table -- slot-names sql )
-HOOK: delete-sql* db ( columns table -- slot-names sql )
-HOOK: select-sql db ( tuple -- statement )
+HOOK: insert-sql* db ( columns table -- sql slot-names )
+HOOK: update-sql* db ( columns table -- sql slot-names )
+HOOK: delete-sql* db ( columns table -- sql slot-names )
+HOOK: select-sql db ( tuple -- seq/statement )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
HOOK: tuple>params db ( columns tuple -- obj )
-
-HOOK: make-slot-names* db ( quot -- seq )
-HOOK: column-slot-name% db ( spec -- )
-HOOK: column-bind-name% db ( spec -- )
-
-: make-slots-names ( quot -- seq str )
- [ make-slot-names* ] "" make ; inline
-: slot-name% ( seq -- ) first % ;
-: column-name% ( seq -- ) second % ;
-: column-type% ( seq -- ) third % ;
-
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
@@ -108,8 +99,37 @@ HOOK: column-bind-name% db ( spec -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
: define-persistent ( class table columns -- )
- >r dupd "db-table" set-word-prop r>
- "db-columns" set-word-prop ;
+ >r dupd "db-table" set-word-prop dup r>
+ [ relation? ] partition swapd
+ [ spec>tuple ] map "db-columns" set-word-prop
+ "db-relations" set-word-prop ;
-: define-relation ( spec -- )
- drop ;
+: tuple>filled-slots ( tuple -- alist )
+ dup <mirror> mirror-slots [ slot-spec-name ] map
+ swap tuple-slots 2array flip [ nip ] assoc-subset ;
+
+! [ tuple>filled-slots ] keep
+! [ >r first r> get-slot-named ] curry each
+
+SYMBOL: building-seq
+: get-building-seq ( n -- seq )
+ building-seq get nth ;
+
+: n, get-building-seq push ;
+: n% get-building-seq push-all ;
+
+: 0, 0 n, ;
+: 0% 0 n% ;
+: 1, 1 n, ;
+: 1% 1 n% ;
+: 2, 2 n, ;
+: 2% 2 n% ;
+
+: nmake ( quot exemplars -- seqs )
+ dup length dup zero? [ 1+ ] when
+ [
+ [
+ [ drop 1024 swap new-resizable ] 2map
+ [ building-seq set call ] keep
+ ] 2keep >r [ like ] 2map r> firstn
+ ] with-scope ;
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 7cacbcf861..b75d3616f1 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
-sequences continuations ;
+sequences continuations sequences.deep sequences.lib ;
IN: db.types
! ID is the Primary key
@@ -17,6 +17,8 @@ SYMBOL: +assigned-id+
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+SYMBOL: +foreign-key+
+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
SYMBOL: +serial+
@@ -28,9 +30,13 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
-SYMBOL: SERIAL
+: relation? ( spec -- ? )
+ [ +has-many+ = ] deep-find* nip ;
+
SYMBOL: INTEGER
+SYMBOL: BIG_INTEGER
SYMBOL: DOUBLE
+
SYMBOL: BOOLEAN
SYMBOL: TEXT
@@ -39,29 +45,50 @@ SYMBOL: VARCHAR
SYMBOL: TIMESTAMP
SYMBOL: DATE
-SYMBOL: BIG_INTEGER
-
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-HOOK: sql-modifiers* db ( modifiers -- str )
-HOOK: >sql-type db ( obj -- str )
-
-! HOOK: >factor-type db ( obj -- obj )
-
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( columns -- obj )
[ +native-id+ swap member? not ] subset ;
+: remove-relations ( columns -- newcolumns )
+ [ relation? not ] subset ;
+
: remove-id ( columns -- obj )
[ primary-key? not ] subset ;
-: sql-modifiers ( spec -- seq )
- 3 tail sql-modifiers* ;
-
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+TUPLE: sql-spec slot-name column-name type modifiers ;
+
+: spec>tuple ( spec -- tuple )
+ [ ?first3 ] keep 3 ?tail* sql-spec construct-boa ;
+
+: sql-type-hash ( -- assoc )
+ H{
+ { INTEGER "integer" }
+ { TEXT "text" }
+ { VARCHAR "varchar" }
+ { DOUBLE "real" }
+ { TIMESTAMP "timestamp" }
+ } ;
+
+! HOOK: sql-type-hash db ( -- obj )
+! HOOK: >sql-type-string db ( obj -- str )
+
+: >sql-type-string ( obj -- str/f )
+ dup pair? [
+ first >sql-type-string
+ ] [
+ sql-type-hash at* [ drop "" ] unless
+ ] if ;
+
+: full-sql-type-string ( obj -- str )
+ [ >sql-type-string ] keep second
+ number>string " " swap 3append ;