libs/postgresql/postgresql.factor

   1 ! See http://factor.sf.net/license.txt for BSD license.
   2
   3 ! adapted from libpq-fe.h version 7.4.7
   4 ! tested on debian linux with postgresql 7.4.7
   5
   6 IN: postgresql
   7 USING: kernel alien errors io prettyprint sequences namespaces arrays math ;
   8
   9 SYMBOL: db
  10 SYMBOL: query-res
  11
  12 : connect-postgres ( host port pgopts pgtty db user pass -- conn )
  13     PQsetdbLogin
  14     dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
  15
  16 : with-postgres ( host port pgopts pgtty db user pass quot -- )
  17     [ >r connect-postgres db set r>
  18     [ db get PQfinish ] cleanup ] with-scope ; inline
  19
  20 : with-postgres-catch ( host port pgopts pgtty db user pass quot -- )
  21     [ with-postgres ] catch [ "caught: " write print ] when* ;
  22
  23 : postgres-error ( ret -- ret )
  24     dup zero? [ PQresultErrorMessage throw ] when ;
  25
  26 : (do-query) ( PGconn query -- PGresult* )
  27     ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
  28     ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
  29     PQexec
  30     dup PQresultStatus PGRES_COMMAND_OK =
  31     over PQresultStatus PGRES_TUPLES_OK =
  32     or [
  33         [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
  34     ] unless ;
  35
  36 : (do-command) ( PGconn query -- PGresult* )
  37     [ (do-query) ] catch
  38     [
  39         swap
  40         "non-fatal error: " print
  41         "\tQuery: " write "'" write write "'" print
  42         "\t" write print
  43     ] when* drop ;
  44
  45 : do-command ( str -- )
  46     unit \ (do-command) add db get swap call ;
  47
  48 : prepare ( str quot word -- conn quot )
  49     rot unit swap append swap append db get swap ;
  50
  51 : do-query ( str quot -- )
  52     [ (do-query) query-res set ] prepare catch
  53     [ rethrow ] [ query-res get PQclear ] if* ;
  54
  55 : result>seq ( -- seq )
  56     query-res get [ PQnfields ] keep PQntuples
  57     [ swap [ query-res get -rot PQgetvalue ] map-with ] map-with ;
  58
  59 : print-table ( seq -- )
  60     [ [ write bl ] each "\n" write ] each ;
  61