From c12600815f6833da3238db473c46797ba37cffe6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 Feb 2008 16:00:50 -0600 Subject: [PATCH] add lots of unit tests to postgresql select queries are generated now --- extra/db/db.factor | 8 +- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/postgresql/postgresql-tests.factor | 226 ++++++++++++++- extra/db/postgresql/postgresql.factor | 289 +++++++++++--------- extra/db/tuples/tuples.factor | 8 +- extra/db/types/types.factor | 128 ++++++--- 6 files changed, 480 insertions(+), 183 deletions(-) mode change 100644 => 100755 extra/db/postgresql/lib/lib.factor mode change 100644 => 100755 extra/db/postgresql/postgresql-tests.factor diff --git a/extra/db/db.factor b/extra/db/db.factor index d88bbaee03..fe8459031e 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -23,12 +23,12 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement sql params handle bound? slot-names ; +TUPLE: statement handle sql slot-names bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) +HOOK: db ( str slot-names -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( 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-params ] keep + [ set-statement-bind-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-params } get-slots r> + >r >r { statement-sql statement-bind-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 old mode 100644 new mode 100755 index c48eff964a..8a0e24e4cb --- 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-params length f ] keep - statement-params + [ statement-bind-params length f ] keep + statement-bind-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-tests.factor b/extra/db/postgresql/postgresql-tests.factor old mode 100644 new mode 100755 index 9c98b53626..bdb434cfdd --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -111,6 +111,8 @@ IN: temporary ] unit-test +: with-dummy-db ( quot -- ) + >r T{ postgresql-db } db r> with-variable ; ! TEST TUPLE DB @@ -119,8 +121,8 @@ TUPLE: puppy id name age ; { set-puppy-name set-puppy-age } puppy construct ; puppy "PUPPY" { - { "id" "ID" +native-id+ } - { "name" "NAME" TEXT } + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } { "age" "AGE" INTEGER } } define-persistent @@ -129,7 +131,7 @@ TUPLE: kitty id name age ; { set-kitty-name set-kitty-age } kitty construct ; kitty "KITTY" { - { "id" "ID" +native-id+ } + { "id" "ID" INTEGER +assigned-id+ } { "name" "NAME" TEXT } { "age" "AGE" INTEGER } } define-persistent @@ -137,20 +139,226 @@ kitty "KITTY" { TUPLE: basket id puppies kitties ; basket "BASKET" { - { "id" "ID" +native-id+ } + { "id" "ID" +native-id+ +not-null+ } { "location" "LOCATION" TEXT } { "puppies" { +has-many+ puppy } } { "kitties" { +has-many+ kitty } } } define-persistent +! Create table [ - { "name" "age" } - ! "insert into table puppy(name, age) values($1, $2);" - "select add_puppy($1, $2, $3);" + "create table puppy(id serial primary key not null, name varchar 256, age integer);" ] [ T{ postgresql-db } db [ - "Mr Clunkers" 3 - class dup db-columns swap db-table insert-sql* >lower + puppy dup db-columns swap db-table create-table-sql >lower ] with-variable ] unit-test +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id serial primary key not null, location text);" +] [ + T{ postgresql-db } db [ + basket dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +! Create function +[ + "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-function-sql >lower + ] with-variable +] unit-test + +! Drop table + +[ + "drop table puppy;" +] [ + T{ postgresql-db } db [ + puppy db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ postgresql-db } db [ + kitty db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ postgresql-db } db [ + basket db-table drop-table-sql >lower + ] with-variable +] unit-test + + +! Drop function +[ + "drop function add_puppy(varchar, integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table drop-function-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "select add_puppy($1, $2);" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } } + T{ sql-spec f "age" "AGE" INTEGER { } } + } + { + T{ sql-spec f "id" "ID" +native-id+ { +not-null+ } +native-id+ } + } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values($1, $2, $3);" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table update-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "update kitty set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table update-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = $1" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table delete-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "delete from KITTY where ID = $1" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table delete-sql* + ] with-variable +] unit-test + +! Select +[ + "select from PUPPY ID, NAME, AGE where NAME = $1;" + { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } + { + 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{ postgresql-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-by-slots-sql + ] with-variable +] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index b877d72060..3e949c3900 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 sequences.lib classes ; +combinators sequences.lib classes locals words ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- ) >r r> with-disposal ; M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-params ; + set-statement-bind-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-params [ + dup statement-bind-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-params + dup statement-sql swap statement-bind-params length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -104,9 +104,10 @@ M: postgresql-db ( sql -- statement ) { set-statement-sql } statement construct ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct - ; +M: postgresql-db ( pair -- statement ) + ?first2 + { set-statement-sql set-statement-slot-names } + statement construct ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -117,134 +118,179 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: insert-function ( columns table -- sql types ) +: modifiers% ( spec -- ) + sql-spec-modifiers + [ lookup-modifier ] map + " " join + dup empty? [ drop ] [ " " % % ] if ; + +SYMBOL: postgresql-counter +: bind% ( spec -- ) + 1, + CHAR: $ 0, + postgresql-counter [ inc ] keep get 0# ; + +: postgresql-make ( quot -- ) + [ postgresql-counter off ] swap compose + { "" { } { } } nmake ; + +:: create-table-sql | specs table | [ - >r remove-id r> - "create function add_" % dup % + "create table " % table % "(" % - over [ "," % ] - [ third dup array? [ first ] when >sql-type-string % ] interleave - ")" % - " returns bigint as '" % + specs [ ", " % ] [ + dup sql-spec-column-name % + " " % + dup sql-spec-type t lookup-type % + modifiers% + ] interleave ");" % + ] "" make ; - 2dup "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - "); " % - - "select currval(''" % % "_id_seq'');' language sql;" % - drop - ] "" make f ; - -: drop-function ( columns table -- sql ) +:: create-function-sql | specs table | + [ + [let | specs [ specs remove-id ] | + "create function add_" 0% table 0% + "(" 0% + specs [ "," 0% ] + [ + sql-spec-type f lookup-type 0% + ] interleave + ")" 0% + " returns bigint as '" 0% + + "insert into " 0% + table 0% + "(" 0% + specs [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + specs [ ", " 0% ] [ bind% ] interleave + "); " 0% + + "select currval(''" 0% table 0% "_id_seq'');' language sql;" 0% + ] + ] postgresql-make 2drop ; + +: drop-function-sql ( specs table -- sql ) [ - >r remove-id r> "drop function add_" % % "(" % - [ "," % ] [ third >sql-type-string % ] interleave - ")" % - ] "" nmake ; - -! 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 ) - [ - [ - dup "drop table " % % ";" % - ] "" make , - over native-id? [ drop-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db insert-sql* ( columns table -- sql slots ) - [ - "select add_" % % - "(" % - dup length [1,b] [ ", " % ] [ "$" % # ] interleave + remove-id + [ ", " % ] [ sql-spec-type f lookup-type % ] interleave ");" % ] "" make ; -M: postgresql-db update-sql* ( columns table -- sql slots ) +: drop-table-sql ( table -- sql ) [ - "update " % - % - " set " % + "drop table " % % ";" % + ] "" make ; + +M: postgresql-db create-sql ( specs table -- seq ) + [ + 2dup create-table-sql , + over find-primary-key native-id? + [ create-function-sql , ] [ 2drop ] if + ] { } make ; + +M: postgresql-db drop-sql ( specs table -- seq ) + [ + dup drop-table-sql , + over find-primary-key native-id? + [ drop-function-sql , ] [ 2drop ] if + ] { } make ; + +: insert-table-sql ( specs table -- sql in-specs out-specs ) + [ + "insert into " 0% 0% + "(" 0% + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ")" 0% + + " values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +: insert-function-sql ( specs table -- sql in-specs out-specs ) + [ + "select add_" 0% 0% + "(" 0% + dup find-primary-key 2, + remove-id + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs ) + over find-primary-key native-id? + [ insert-function-sql ] [ insert-table-sql ] if ; + +M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) + [ + "update " 0% 0% + " set " 0% dup remove-id - dup length [1,b] swap 2array flip - [ ", " % ] [ first2 second % " = $" % # ] interleave - " where " % - [ primary-key? ] find nip second dup % " = $" % length 2 + # - ] "" make ; + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; -M: postgresql-db delete-sql* ( columns table -- slot-names sql ) +M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) [ - "delete from " % - % - " where " % - first second % " = $1" % - ] "" make ; + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; -: 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 ) +: select-by-slots-sql ( tuple -- sql in-specs out-specs ) [ - - ] { } 2 nmake ; + "select from " 0% dup class db-table 0% + " " 0% + dup class db-columns [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave -M: postgresql-db tuple>params ( columns tuple -- obj ) + dup class db-columns + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] postgresql-make ; + +! : select-with-relations ( tuple -- sql in-specs out-specs ) + +M: postgresql-db select-sql ( tuple -- sql in-specs out-specs ) + select-by-slots-sql ; + +M: postgresql-db tuple>params ( specs tuple -- obj ) [ >r dup third swap first r> get-slot-named swap ] curry { } map>assoc ; + +M: postgresql-db type-table ( -- hash ) + H{ + { +native-id+ "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { INTEGER "integer" } + } ; + +M: postgresql-db create-type-table ( -- hash ) + H{ + { +native-id+ "serial primary key" } + } ; + +: postgresql-compound ( str n -- newstr ) + dup number? [ "compound -- not a number" throw ] unless + number>string " " swap 3append ; + +M: postgresql-db compound-modifier ( str n -- newstr ) + postgresql-compound ; -: postgresql-db-modifiers ( -- hashtable ) +M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } - { +foreign-key+ "" } { +assigned-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } @@ -253,16 +299,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -! 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 ; +M: postgresql-db compound-type ( str n -- newstr ) + postgresql-compound ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 30ca260b93..9c22ba2a65 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -47,6 +47,7 @@ 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: select-relations-sql db ( tuple -- seq/statement ) HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: sql-type>factor-type db ( obj type -- obj ) @@ -101,7 +102,8 @@ HOOK: tuple>params db ( columns tuple -- obj ) : define-persistent ( class table columns -- ) >r dupd "db-table" set-word-prop dup r> [ relation? ] partition swapd - [ spec>tuple ] map "db-columns" set-word-prop + [ spec>tuple ] map + "db-columns" set-word-prop "db-relations" set-word-prop ; : tuple>filled-slots ( tuple -- alist ) @@ -117,13 +119,17 @@ SYMBOL: building-seq : n, get-building-seq push ; : n% get-building-seq push-all ; +: n# >r number>string r> n% ; : 0, 0 n, ; : 0% 0 n% ; +: 0# 0 n# ; : 1, 1 n, ; : 1% 1 n% ; +: 1# 1 n# ; : 2, 2 n, ; : 2% 2 n% ; +: 2# 2 n# ; : nmake ( quot exemplars -- seqs ) dup length dup zero? [ 1+ ] when diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b75d3616f1..9354f4fe37 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,21 +1,38 @@ ! 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.deep sequences.lib ; +sequences continuations sequences.deep sequences.lib +words ; IN: db.types +TUPLE: sql-spec slot-name column-name type modifiers primary-key ; ! ID is the Primary key +! +native-id+ can be a columns type or a modifier SYMBOL: +native-id+ +! +assigned-id+ can only be a modifier SYMBOL: +assigned-id+ -: primary-key? ( spec -- ? ) - [ { +native-id+ +assigned-id+ } member? ] contains? ; +: primary-key? ( obj -- ? ) + { +native-id+ +assigned-id+ } member? ; -: contains-id? ( columns id -- ? ) - swap [ member? ] with contains? ; - -: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; -: native-id? ( columns -- ? ) +native-id+ contains-id? ; +: normalize-spec ( spec -- ) + dup sql-spec-type dup primary-key? [ + swap set-sql-spec-primary-key + ] [ + drop dup sql-spec-modifiers [ + primary-key? + ] deep-find + [ swap set-sql-spec-primary-key ] [ drop ] if* + ] if ; + +: find-primary-key ( specs -- obj ) + [ sql-spec-primary-key ] find nip ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+ = ; + +: assigned-id? ( spec -- ? ) + sql-spec-primary-key +assigned-id+ = ; SYMBOL: +foreign-key+ @@ -31,7 +48,7 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ : relation? ( spec -- ? ) - [ +has-many+ = ] deep-find* nip ; + [ +has-many+ = ] deep-find ; SYMBOL: INTEGER SYMBOL: BIG_INTEGER @@ -45,30 +62,15 @@ SYMBOL: VARCHAR SYMBOL: TIMESTAMP SYMBOL: DATE -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -: 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 ; - -! 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 ; + [ ?first3 ] keep 3 ?tail* + { + set-sql-spec-slot-name + set-sql-spec-column-name + set-sql-spec-type + set-sql-spec-modifiers + } sql-spec construct + dup normalize-spec ; : sql-type-hash ( -- assoc ) H{ @@ -79,16 +81,62 @@ TUPLE: sql-spec slot-name column-name type modifiers ; { TIMESTAMP "timestamp" } } ; -! HOOK: sql-type-hash db ( -- obj ) -! HOOK: >sql-type-string db ( obj -- str ) +TUPLE: no-sql-type ; +: no-sql-type ( -- * ) T{ no-sql-type } throw ; -: >sql-type-string ( obj -- str/f ) +TUPLE: no-sql-modifier ; +: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; + +: number>string* ( n/str -- str ) + dup number? [ number>string ] when ; + +: maybe-remove-id ( specs -- obj ) + [ native-id? not ] subset ; + +: remove-relations ( specs -- newcolumns ) + [ relation? not ] subset ; + +: remove-id ( specs -- obj ) + [ sql-spec-primary-key not ] subset ; + +! SQLite Types: http://www.sqlite.org/datatype3.html +! NULL INTEGER REAL TEXT BLOB +! PostgreSQL Types: +! http://developer.postgresql.org/pgdocs/postgres/datatype.html + + + +HOOK: modifier-table db ( -- hash ) +HOOK: compound-modifier db ( str n -- hash ) + +: lookup-modifier ( obj -- str ) dup pair? [ - first >sql-type-string + first2 >r lookup-modifier r> compound-modifier ] [ - sql-type-hash at* [ drop "" ] unless + modifier-table at* + [ "unknown modifier" throw ] unless ] if ; -: full-sql-type-string ( obj -- str ) - [ >sql-type-string ] keep second - number>string " " swap 3append ; + +HOOK: type-table db ( -- hash ) +HOOK: create-type-table db ( -- hash ) +HOOK: compound-type db ( str n -- hash ) + +: lookup-type* ( obj -- str ) + dup pair? [ + first lookup-type* + ] [ + type-table at* + [ no-sql-type ] unless + ] if ; + +: lookup-create-type ( obj -- str ) + dup pair? [ + first2 >r lookup-create-type r> compound-type + ] [ + dup create-type-table at* + [ nip ] [ drop lookup-type* ] if + ] if ; + +: lookup-type ( obj create? -- str ) + [ lookup-create-type ] [ lookup-type* ] if ;