! 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 prettyprint quotations
+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 sequences.lib classes locals words tools.walker
-namespaces.lib accessors random db.queries destructors ;
+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 db user pass ;
+ 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 make-db* ( seq db -- db )
- >r first4 r>
- swap >>db
- swap >>pass
- swap >>user
- swap >>host ;
-
M: postgresql-db db-open ( db -- db )
dup {
[ host>> ]
[ port>> ]
[ pgopts>> ]
[ pgtty>> ]
- [ db>> ]
- [ user>> ]
- [ pass>> ]
+ [ database>> ]
+ [ username>> ]
+ [ password>> ]
} cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
handle>> PQfinish ;
-M: postgresql-statement bind-statement* ( statement -- )
- drop ;
+M: postgresql-statement bind-statement* ( statement -- ) drop ;
-GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
+GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
-M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+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 -- obj )
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
nip value>> <low-level-binding> ;
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+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 ;
: result-handle-n ( result-set -- handle n )
[ handle>> ] [ n>> ] bi ;
-M: postgresql-result-set row-column ( result-set column -- obj )
- >r result-handle-n r> pq-get-string ;
+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 -- obj )
+M: postgresql-result-set row-column-typed ( result-set column -- object )
dup pick out-params>> nth type>>
- >r >r result-handle-n r> r> postgresql-column-typed ;
+ [ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [
] [
dup do-postgresql-statement
] if*
- postgresql-result-set construct-result-set
+ postgresql-result-set new-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
dup
- >r db get handle>> f r>
+ [ 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 construct-statement ;
+ postgresql-statement new-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<simple-statement> dup prepare-statement ;
M: postgresql-db bind% ( spec -- )
bind-name% 1, ;
-M: postgresql-db bind# ( spec obj -- )
- >r bind-name% f swap type>> r> <literal-bind> 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%
+ ] interleave
+
+ ", " 0%
+ find-primary-key
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ "));" 0%
] query-make ;
: create-function-sql ( class -- statement )
[
- >r remove-id r>
+ [ remove-id ] dip
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ create-function-sql , ] [ drop ] if
+ dup db-assigned? [ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ drop-function-sql , ] [ drop ] if
+ 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 2,
+ dup find-primary-key first 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
");" 0%
] query-make ;
-M: postgresql-db insert-tuple* ( tuple statement -- )
+M: postgresql-db insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db persistent-table ( -- hashtable )
H{
- { +db-assigned-id+ { "integer" "serial primary key" f } }
- { +user-assigned-id+ { f f "primary key" } }
- { +random-id+ { "bigint" "bigint primary key" f } }
+ { +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 } }
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
- { +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
{ random-generator { f f f } }
} ;
-M: postgresql-db compound ( str obj -- str' )
+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" [
- first2 >r [ unparse join-space ] keep db-columns r>
- swap [ slot-name>> = ] with find nip
- column-name>> paren append
- ] }
- [ "no compound found" 3array throw ]
+ { "references" [ >reference-string ] }
+ [ drop no-compound-found ]
} case ;