271 lines
7.7 KiB
Factor
271 lines
7.7 KiB
Factor
! Copyright (C) 2007, 2008 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays assocs alien alien.syntax continuations io
|
|
kernel math math.parser namespaces make prettyprint quotations
|
|
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
|
db.tuples db.types tools.annotations math.ranges
|
|
combinators classes locals words tools.walker
|
|
nmake accessors random db.queries destructors db.tuples.private ;
|
|
USE: tools.walker
|
|
IN: db.postgresql
|
|
|
|
TUPLE: postgresql-db < db
|
|
host port pgopts pgtty database username password ;
|
|
|
|
: <postgresql-db> ( -- postgresql-db )
|
|
postgresql-db new-db ;
|
|
|
|
TUPLE: postgresql-statement < statement ;
|
|
|
|
TUPLE: postgresql-result-set < result-set ;
|
|
|
|
M: postgresql-db db-open ( db -- db )
|
|
dup {
|
|
[ host>> ]
|
|
[ port>> ]
|
|
[ pgopts>> ]
|
|
[ pgtty>> ]
|
|
[ database>> ]
|
|
[ username>> ]
|
|
[ password>> ]
|
|
} cleave connect-postgres >>handle ;
|
|
|
|
M: postgresql-db dispose ( db -- )
|
|
handle>> PQfinish ;
|
|
|
|
M: postgresql-statement bind-statement* ( statement -- ) drop ;
|
|
|
|
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
|
|
|
|
M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
|
|
slot-name>> swap get-slot-named <low-level-binding> ;
|
|
|
|
M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
|
|
nip value>> <low-level-binding> ;
|
|
|
|
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
|
|
dup generator-singleton>> eval-generator
|
|
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
|
|
|
|
M: postgresql-statement bind-tuple ( tuple statement -- )
|
|
tuck in-params>>
|
|
[ postgresql-bind-conversion ] with map
|
|
>>bind-params drop ;
|
|
|
|
M: postgresql-result-set #rows ( result-set -- n )
|
|
handle>> PQntuples ;
|
|
|
|
M: postgresql-result-set #columns ( result-set -- n )
|
|
handle>> PQnfields ;
|
|
|
|
: result-handle-n ( result-set -- handle n )
|
|
[ handle>> ] [ n>> ] bi ;
|
|
|
|
M: postgresql-result-set row-column ( result-set column -- object )
|
|
[ result-handle-n ] dip pq-get-string ;
|
|
|
|
M: postgresql-result-set row-column-typed ( result-set column -- object )
|
|
dup pick out-params>> nth type>>
|
|
[ result-handle-n ] 2dip postgresql-column-typed ;
|
|
|
|
M: postgresql-statement query-results ( query -- result-set )
|
|
dup bind-params>> [
|
|
over [ bind-statement ] keep
|
|
do-postgresql-bound-statement
|
|
] [
|
|
dup do-postgresql-statement
|
|
] if*
|
|
postgresql-result-set new-result-set
|
|
dup init-result-set ;
|
|
|
|
M: postgresql-result-set advance-row ( result-set -- )
|
|
[ 1+ ] change-n drop ;
|
|
|
|
M: postgresql-result-set more-rows? ( result-set -- ? )
|
|
[ n>> ] [ max>> ] bi < ;
|
|
|
|
M: postgresql-statement dispose ( query -- )
|
|
dup handle>> PQclear
|
|
f >>handle drop ;
|
|
|
|
M: postgresql-result-set dispose ( result-set -- )
|
|
[ handle>> PQclear ]
|
|
[
|
|
0 >>n
|
|
0 >>max
|
|
f >>handle drop
|
|
] bi ;
|
|
|
|
M: postgresql-statement prepare-statement ( statement -- )
|
|
dup
|
|
[ db get handle>> f ] dip
|
|
[ sql>> ] [ in-params>> ] bi
|
|
length f PQprepare postgresql-error
|
|
>>handle drop ;
|
|
|
|
M: postgresql-db <simple-statement> ( sql in out -- statement )
|
|
postgresql-statement new-statement ;
|
|
|
|
M: postgresql-db <prepared-statement> ( sql in out -- statement )
|
|
<simple-statement> dup prepare-statement ;
|
|
|
|
: bind-name% ( -- )
|
|
CHAR: $ 0,
|
|
sql-counter [ inc ] [ get 0# ] bi ;
|
|
|
|
M: postgresql-db bind% ( spec -- )
|
|
bind-name% 1, ;
|
|
|
|
M: postgresql-db bind# ( spec object -- )
|
|
[ bind-name% f swap type>> ] dip
|
|
<literal-bind> 1, ;
|
|
|
|
: create-table-sql ( class -- statement )
|
|
[
|
|
dupd
|
|
"create table " 0% 0%
|
|
"(" 0% [ ", " 0% ] [
|
|
dup column-name>> 0%
|
|
" " 0%
|
|
dup type>> lookup-create-type 0%
|
|
modifiers 0%
|
|
] interleave
|
|
|
|
", " 0%
|
|
find-primary-key
|
|
"primary key(" 0%
|
|
[ "," 0% ] [ column-name>> 0% ] interleave
|
|
"));" 0%
|
|
] query-make ;
|
|
|
|
: create-function-sql ( class -- statement )
|
|
[
|
|
[ remove-id ] dip
|
|
"create function add_" 0% dup 0%
|
|
"(" 0%
|
|
over [ "," 0% ]
|
|
[
|
|
type>> lookup-type 0%
|
|
] interleave
|
|
")" 0%
|
|
" returns bigint as '" 0%
|
|
|
|
"insert into " 0%
|
|
dup 0%
|
|
"(" 0%
|
|
over [ ", " 0% ] [ column-name>> 0% ] interleave
|
|
") values(" 0%
|
|
swap [ ", " 0% ] [ drop bind-name% ] interleave
|
|
"); " 0%
|
|
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
|
|
] query-make ;
|
|
|
|
M: postgresql-db create-sql-statement ( class -- seq )
|
|
[
|
|
[ create-table-sql , ] keep
|
|
dup db-assigned? [ create-function-sql , ] [ drop ] if
|
|
] { } make ;
|
|
|
|
: drop-function-sql ( class -- statement )
|
|
[
|
|
"drop function add_" 0% 0%
|
|
"(" 0%
|
|
remove-id
|
|
[ ", " 0% ] [ type>> lookup-type 0% ] interleave
|
|
");" 0%
|
|
] query-make ;
|
|
|
|
: drop-table-sql ( table -- statement )
|
|
[
|
|
"drop table " 0% 0% drop
|
|
] query-make ;
|
|
|
|
M: postgresql-db drop-sql-statement ( class -- seq )
|
|
[
|
|
[ drop-table-sql , ] keep
|
|
dup db-assigned? [ drop-function-sql , ] [ drop ] if
|
|
] { } make ;
|
|
|
|
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
|
|
[
|
|
"select add_" 0% 0%
|
|
"(" 0%
|
|
dup find-primary-key first 2,
|
|
remove-id
|
|
[ ", " 0% ] [ bind% ] interleave
|
|
");" 0%
|
|
] query-make ;
|
|
|
|
M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
|
|
[
|
|
"insert into " 0% 0%
|
|
"(" 0%
|
|
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
|
")" 0%
|
|
|
|
" values(" 0%
|
|
[ ", " 0% ] [
|
|
dup type>> +random-id+ = [
|
|
[
|
|
bind-name%
|
|
slot-name>>
|
|
f
|
|
random-id-generator
|
|
] [ type>> ] bi <generator-bind> 1,
|
|
] [
|
|
bind%
|
|
] if
|
|
] interleave
|
|
");" 0%
|
|
] query-make ;
|
|
|
|
M: postgresql-db insert-tuple-set-key ( tuple statement -- )
|
|
query-modify-tuple ;
|
|
|
|
M: postgresql-db persistent-table ( -- hashtable )
|
|
H{
|
|
{ +db-assigned-id+ { "integer" "serial" f } }
|
|
{ +user-assigned-id+ { f f f } }
|
|
{ +random-id+ { "bigint" "bigint" f } }
|
|
|
|
{ +foreign-id+ { f f "references" } }
|
|
|
|
{ +on-delete+ { f f "on delete" } }
|
|
{ +restrict+ { f f "restrict" } }
|
|
{ +cascade+ { f f "cascade" } }
|
|
{ +set-null+ { f f "set null" } }
|
|
{ +set-default+ { f f "set default" } }
|
|
|
|
{ TEXT { "text" "text" f } }
|
|
{ VARCHAR { "varchar" "varchar" f } }
|
|
{ INTEGER { "integer" "integer" f } }
|
|
{ BIG-INTEGER { "bigint" "bigint" f } }
|
|
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
|
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
|
{ DOUBLE { "real" "real" f } }
|
|
{ DATE { "date" "date" f } }
|
|
{ TIME { "time" "time" f } }
|
|
{ DATETIME { "timestamp" "timestamp" f } }
|
|
{ TIMESTAMP { "timestamp" "timestamp" f } }
|
|
{ BLOB { "bytea" "bytea" f } }
|
|
{ FACTOR-BLOB { "bytea" "bytea" f } }
|
|
{ URL { "varchar" "varchar" f } }
|
|
{ +autoincrement+ { f f "autoincrement" } }
|
|
{ +unique+ { f f "unique" } }
|
|
{ +default+ { f f "default" } }
|
|
{ +null+ { f f "null" } }
|
|
{ +not-null+ { f f "not null" } }
|
|
{ system-random-generator { f f f } }
|
|
{ secure-random-generator { f f f } }
|
|
{ random-generator { f f f } }
|
|
} ;
|
|
|
|
ERROR: no-compound-found string object ;
|
|
M: postgresql-db compound ( string object -- string' )
|
|
over {
|
|
{ "default" [ first number>string join-space ] }
|
|
{ "varchar" [ first number>string paren append ] }
|
|
{ "references" [ >reference-string ] }
|
|
[ drop no-compound-found ]
|
|
} case ;
|