Doug Coleman
parent
78d5798082
commit
c12600815f
|
|
@ -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: <simple-statement> db ( str -- statement )
|
||||
HOOK: <prepared-statement> db ( str -- statement )
|
||||
HOOK: <prepared-statement> 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 ;
|
||||
|
||||
: <result-set> ( 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
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 <puppy>
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 <postgresql-db> 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 <simple-statement> ( sql -- statement )
|
|||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db <prepared-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
M: postgresql-db <prepared-statement> ( pair -- statement )
|
||||
?first2
|
||||
{ set-statement-sql set-statement-slot-names }
|
||||
statement construct <postgresql-statement> ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue