From d6ede4dda5c35c8c27819928958e09e4936f27ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 Feb 2008 16:52:00 -0600 Subject: [PATCH] intermediate work on db, everything is broken --- extra/db/postgresql/postgresql-tests.factor | 50 ++++++- extra/db/postgresql/postgresql.factor | 151 ++++++++++---------- extra/db/tuples/tuples-tests.factor | 41 +++++- extra/db/tuples/tuples.factor | 62 +++++--- extra/db/types/types.factor | 51 +++++-- 5 files changed, 243 insertions(+), 112 deletions(-) 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 ; +: ( 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 ; +: ( 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 + 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 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" [ + ! 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-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 ;