From 779bd8c8d9ea5118a6403d20afabfefbfe1cc660 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Feb 2008 11:30:48 -0600 Subject: [PATCH] sql is correctly generated for sqlite and postgresql up to basic selects --- extra/db/db.factor | 6 +- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/postgresql/postgresql.factor | 27 +++-- extra/db/sqlite/lib/lib.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 157 +++++++++++++++++++++++++- extra/db/sqlite/sqlite.factor | 107 +++++++++--------- extra/db/tuples/tuples-tests.factor | 26 ++--- extra/db/tuples/tuples.factor | 1 - extra/db/types/types.factor | 33 ++++-- 9 files changed, 269 insertions(+), 96 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index fe8459031e..d269d4654c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -23,7 +23,7 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement handle sql slot-names bind-params bound? ; +TUPLE: statement handle sql slot-names bound? in-params out-params ; TUPLE: simple-statement ; TUPLE: prepared-statement ; @@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? ) : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when [ bind-statement* ] 2keep - [ set-statement-bind-params ] keep + [ set-statement-in-params ] keep t swap set-statement-bound? ; : init-result-set ( result-set -- ) @@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? ) 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-bind-params } get-slots r> + >r >r { statement-sql statement-in-params } get-slots r> { set-result-set-sql set-result-set-params diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8a0e24e4cb..5f24dd9ea0 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -37,8 +37,8 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-bind-params length f ] keep - statement-bind-params + [ statement-in-params length f ] keep + statement-in-params [ first number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e949c3900..8cf7e79f53 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- ) >r r> with-disposal ; M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-bind-params ; + set-statement-in-params ; M: postgresql-statement reset-statement ( statement -- ) drop ; @@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id ) query-results [ 0 row-column ] with-disposal string>number ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-bind-params [ + dup statement-in-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> - dup statement-sql swap statement-bind-params + dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -118,12 +118,6 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: modifiers% ( spec -- ) - sql-spec-modifiers - [ lookup-modifier ] map - " " join - dup empty? [ drop ] [ " " % % ] if ; - SYMBOL: postgresql-counter : bind% ( spec -- ) 1, @@ -274,6 +268,7 @@ M: postgresql-db type-table ( -- hash ) { TEXT "text" } { VARCHAR "varchar" } { INTEGER "integer" } + { TIMESTAMP "timestamp" } } ; M: postgresql-db create-type-table ( -- hash ) @@ -282,16 +277,24 @@ M: postgresql-db create-type-table ( -- hash ) } ; : postgresql-compound ( str n -- newstr ) - dup number? [ "compound -- not a number" throw ] unless - number>string " " swap 3append ; + over { + { "varchar" [ first number>string join-space ] } + { "references" + [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ sql-spec-slot-name = ] with find nip sql-spec-column-name paren append + ] } + [ "no compound found" 3array throw ] + } case ; -M: postgresql-db compound-modifier ( str n -- newstr ) +M: postgresql-db compound-modifier ( str seq -- newstr ) postgresql-compound ; M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 85aa671d4d..6a3d7d03ae 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -78,7 +78,7 @@ IN: db.sqlite.lib { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { SERIAL [ sqlite-bind-int-by-name ] } + { TIMESTAMP [ sqlite-bind-double-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -102,6 +102,8 @@ IN: db.sqlite.lib { BIG_INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } + { TIMESTAMP [ sqlite3_column_double ] } + [ no-sql-type ] } case ; ! TODO diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index d3388b4648..3f5372ac26 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types ; +continuations db.types db.tuples unicode.case ; IN: temporary : test.db "extra/db/sqlite/test.db" resource-path ; @@ -89,3 +89,158 @@ IN: temporary "select * from person" sql-query length ] with-sqlite ] 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+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "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" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id integer primary key not null, name varchar 256, age integer);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id integer primary key not null, location text);" +] [ + T{ sqlite-db } db [ + basket dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +! Drop table +[ + "drop table puppy;" +] [ + T{ sqlite-db } db [ + puppy db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ sqlite-db } db [ + kitty db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ sqlite-db } db [ + basket db-table drop-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "insert into puppy(name, age) values(:name, :age);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values(:id, :name, :age);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +[ + "update kitty set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +[ + "delete from kitty where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +! Select +[ + "select from puppy id, name, age where name = :name;" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ sqlite-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-sql >r >lower r> + ] with-variable +] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..dcb581a76c 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types ; +words combinators.lib db.types combinators ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -86,54 +86,53 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -M: sqlite-db create-sql ( columns table -- sql ) +M: sqlite-db create-sql ( specs table -- sql ) [ "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type % " " % - sql-modifiers " " join % - ] interleave ")" % + "(" % [ ", " % ] [ + dup sql-spec-column-name % + " " % + dup sql-spec-type t lookup-type % + modifiers% + ] interleave ");" % ] "" make ; -M: sqlite-db drop-sql ( columns table -- sql ) +M: sqlite-db drop-sql ( specs table -- sql ) [ - "drop table " % % - drop + "drop table " % % ";" % ] "" make ; -M: sqlite-db insert-sql* ( columns table -- sql ) +M: sqlite-db insert-sql* ( specs table -- sql ) [ - "insert into " % - % + "insert into " % % "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - [ ", " % ] [ ":" % second % ] interleave - ")" % + maybe-remove-id + dup [ ", " % ] [ sql-spec-column-name % ] interleave + ") values(" % + [ ", " % ] [ ":" % sql-spec-column-name % ] interleave + ");" % ] "" make ; -: where-primary-key% ( columns -- ) +: where-primary-key% ( specs -- ) " where " % - [ primary-key? ] find nip second dup % " = :" % % ; + find-primary-key sql-spec-column-name dup % " = :" % % ; -M: sqlite-db update-sql* ( columns table -- sql ) +M: sqlite-db update-sql* ( specs table -- sql ) [ "update " % % " set " % dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + [ ", " % ] [ sql-spec-column-name dup % " = :" % % ] interleave where-primary-key% ] "" make ; -M: sqlite-db delete-sql* ( columns table -- sql ) +M: sqlite-db delete-sql* ( specs table -- sql ) [ - "delete from " % - % + "delete from " % % " where " % - first second dup % " = :" % % + find-primary-key + sql-spec-column-name dup % " = :" % % ] "" make ; : select-interval ( interval name -- ) @@ -142,22 +141,32 @@ M: sqlite-db delete-sql* ( columns table -- sql ) : select-sequence ( seq name -- ) ; -M: sqlite-db select-sql ( columns table -- sql ) +: select-by-slots-sql ( tuple -- sql out-specs ) [ - "select ROWID, " % - over [ ", " % ] [ second % ] interleave - " from " % % - " where " % - ] "" make ; + "select from " 0% dup class db-table 0% + " " 0% + dup class db-columns [ ", " 0% ] + [ dup sql-spec-column-name 0% 1, ] interleave -M: sqlite-db tuple>params ( columns tuple -- obj ) + dup class db-columns + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ sql-spec-column-name dup 0% " = :" 0% 0% ] interleave + ";" 0% + ] { "" { } } nmake ; + +M: sqlite-db select-sql ( tuple -- sql ) + select-by-slots-sql ; + +M: sqlite-db tuple>params ( specs tuple -- obj ) [ >r [ second ":" swap append ] keep r> dupd >r first r> get-slot-named swap third 3array ] curry map ; -: sqlite-db-modifiers ( -- hashtable ) +M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } @@ -168,32 +177,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: sqlite-db sql-modifiers* ( modifiers -- str ) - sqlite-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: sqlite-db compound-type ( str seq -- ) + over { + { "varchar" [ first number>string join-space ] } + [ 2drop "" ] ! "no sqlite compound data type" 3array throw ] + } case ; -: sqlite-type-hash ( -- assoc ) +M: sqlite-db type-table ( -- assoc ) H{ + { +native-id+ "integer primary key" } { INTEGER "integer" } - { SERIAL "integer" } { TEXT "text" } - { VARCHAR "text" } + { VARCHAR "varchar" } + { TIMESTAMP "timestamp" } { DOUBLE "real" } } ; -M: sqlite-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - sqlite-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; +M: sqlite-db create-type-table + type-table ; ! HOOK: get-column-value ( n result-set type -- ) ! M: sqlite get-column-value { { "TEXT" get-text-column } { diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7df0b430de..742702cebf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.sqlite db.tuples -db.types continuations namespaces db.postgresql math ; +db.types continuations namespaces db.postgresql math +prettyprint ; ! tools.time ; IN: temporary @@ -45,7 +46,7 @@ SYMBOL: the-person person "PERSON" { - { "the-id" "ID" SERIAL +native-id+ } + { "the-id" "ID" +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -53,7 +54,7 @@ person "PERSON" "billy" 10 3.14 the-person set -! test-sqlite +test-sqlite ! test-postgresql ! person "PERSON" @@ -74,7 +75,7 @@ TUPLE: annotation n paste-id summary author mode contents ; paste "PASTE" { - { "n" "ID" SERIAL +native-id+ } + { "n" "ID" +native-id+ } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "channel" "CHANNEL" TEXT } @@ -84,17 +85,10 @@ paste "PASTE" { "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" } } + { "n" "ID" +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "mode" "MODE" TEXT } @@ -102,8 +96,10 @@ annotation "ANNOTATION" } define-persistent "localhost" "postgres" "" "factor-test" [ - ! paste drop-table - ! annotation drop-table + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover paste create-table annotation create-table ] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 9c22ba2a65..11926b832d 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -65,7 +65,6 @@ HOOK: tuple>params db ( columns tuple -- obj ) : tuple-statement ( columns tuple quot -- statement ) >r [ tuple>params ] 2keep class r> call - 2dup . . [ bind-statement ] keep ; : make-tuple-statement ( tuple columns-quot statement-quot -- statement ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9354f4fe37..ad19c45e6a 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib -words ; +words namespaces ; IN: db.types TUPLE: sql-spec slot-name column-name type modifiers primary-key ; @@ -34,7 +34,7 @@ SYMBOL: +assigned-id+ : assigned-id? ( spec -- ? ) sql-spec-primary-key +assigned-id+ = ; -SYMBOL: +foreign-key+ +SYMBOL: +foreign-id+ ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ @@ -107,23 +107,27 @@ TUPLE: no-sql-modifier ; HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str n -- hash ) +HOOK: compound-modifier db ( str seq -- hash ) : lookup-modifier ( obj -- str ) - dup pair? [ - first2 >r lookup-modifier r> compound-modifier + dup array? [ + unclip lookup-modifier swap compound-modifier ] [ modifier-table at* [ "unknown modifier" throw ] unless ] if ; +: modifiers% ( spec -- ) + sql-spec-modifiers + [ lookup-modifier ] map " " join + dup empty? [ drop ] [ " " % % ] if ; HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) : lookup-type* ( obj -- str ) - dup pair? [ + dup array? [ first lookup-type* ] [ type-table at* @@ -131,12 +135,25 @@ HOOK: compound-type db ( str n -- hash ) ] if ; : lookup-create-type ( obj -- str ) - dup pair? [ - first2 >r lookup-create-type r> compound-type + dup array? [ + unclip lookup-create-type swap compound-type ] [ dup create-type-table at* [ nip ] [ drop lookup-type* ] if ] if ; +USE: prettyprint : lookup-type ( obj create? -- str ) [ lookup-create-type ] [ lookup-type* ] if ; + +: single-quote ( str -- newstr ) + "'" swap "'" 3append ; + +: double-quote ( str -- newstr ) + "\"" swap "\"" 3append ; + +: paren ( str -- newstr ) + "(" swap ")" 3append ; + +: join-space ( str1 str2 -- newstr ) + " " swap 3append ;