factor/contrib/postgresql/postgresql.factor

64 lines
2.1 KiB
Factor

! See http://factor.sf.net/license.txt for BSD license.
! adapted from libpq-fe.h version 7.4.7
! tested on debian linux with postgresql 7.4.7
IN: postgresql
USING: kernel alien errors io prettyprint sequences lists namespaces arrays math ;
SYMBOL: postgres-conn
SYMBOL: query-res
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus 0 = [ "couldn't connect to database" throw ] unless ;
: with-postgres ( host port pgopts pgtty db user pass quot -- )
[ >r connect-postgres postgres-conn set r>
[ postgres-conn get PQfinish ] cleanup ] with-scope ; inline
: with-postgres-catch ( host port pgopts pgtty db user pass quot -- )
[ with-postgres ] catch [ "caught: " write print ] when* ;
: test-connection ( host port pgopts pgtty db user pass -- bool )
[ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
: postgres-error ( ret -- ret )
dup 0 = [ PQresultErrorMessage throw ] when ;
: (do-query) ( PGconn query -- PGresult* )
! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
PQexec
dup PQresultStatus PGRES_COMMAND_OK =
over PQresultStatus PGRES_TUPLES_OK =
or [
[ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
] unless ;
: (do-command) ( PGconn query -- PGresult* )
[ (do-query) ] catch
[
swap
"non-fatal error: " print
"\tQuery: " write "'" write write "'" print
"\t" write print
] when* drop ;
: do-command ( str -- )
unit \ (do-command) add postgres-conn get swap call ;
: prepare ( str quot word -- quot )
rot unit swap append swap append postgres-conn get swap ;
: do-query ( str quot -- )
[ (do-query) query-res set ] prepare catch [ rethrow ] [ query-res get PQclear ] if* ;
: result>seq ( -- )
query-res get [ PQnfields ] keep PQntuples
[ [ over [ [ 2dup query-res get -rot PQgetvalue , ] repeat ] { } make , ] repeat ] { } make nip ;
: print-table ( seq -- )
[ [ "\t" append write ] each "\n" write ] each ;