basis/db/postgresql/lib/lib.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays continuations db io kernel math namespaces
   4 quotations sequences db.postgresql.ffi alien alien.c-types
   5 db.types tools.walker ascii splitting math.parser combinators
   6 libc shuffle calendar.format byte-arrays destructors prettyprint
   7 accessors strings serialize io.encodings.binary io.encodings.utf8
   8 alien.strings io.streams.byte-array summary present urls ;
   9 IN: db.postgresql.lib
  10
  11 : postgresql-result-error-message ( res -- str/f )
  12     dup zero? [
  13         drop f
  14     ] [
  15         PQresultErrorMessage [ blank? ] trim
  16     ] if ;
  17
  18 : postgres-result-error ( res -- )
  19     postgresql-result-error-message [ throw ] when* ;
  20
  21 : (postgresql-error-message) ( handle -- str )
  22     PQerrorMessage
  23     "\n" split [ [ blank? ] trim ] map "\n" join ;
  24
  25 : postgresql-error-message ( -- str )
  26     db get handle>> (postgresql-error-message) ;
  27
  28 : postgresql-error ( res -- res )
  29     dup [ postgresql-error-message throw ] unless ;
  30
  31 ERROR: postgresql-result-null ;
  32
  33 M: postgresql-result-null summary ( obj -- str )
  34     drop "PQexec returned f." ;
  35
  36 : postgresql-result-ok? ( res -- ? )
  37     [ postgresql-result-null ] unless*
  38     PQresultStatus
  39     PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
  40
  41 : connect-postgres ( host port pgopts pgtty db user pass -- conn )
  42     PQsetdbLogin
  43     dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
  44
  45 : do-postgresql-statement ( statement -- res )
  46     db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
  47         [ postgresql-result-error-message ] [ PQclear ] bi throw
  48     ] unless ;
  49
  50 : type>oid ( symbol -- n )
  51     dup array? [ first ] when
  52     {
  53         { BLOB [ BYTEA-OID ] }
  54         { FACTOR-BLOB [ BYTEA-OID ] }
  55         [ drop 0 ]
  56     } case ;
  57
  58 : type>param-format ( symbol -- n )
  59     dup array? [ first ] when
  60     {
  61         { BLOB [ 1 ] }
  62         { FACTOR-BLOB [ 1 ] }
  63         [ drop 0 ]
  64     } case ;
  65
  66 : param-types ( statement -- seq )
  67     in-params>> [ type>> type>oid ] map >c-uint-array ;
  68
  69 : malloc-byte-array/length ( byte-array -- alien length )
  70     [ malloc-byte-array &free ] [ length ] bi ;
  71
  72 : default-param-value ( obj -- alien n )
  73     number>string* dup [ utf8 malloc-string &free ] when 0 ;
  74
  75 : param-values ( statement -- seq seq2 )
  76     [ bind-params>> ] [ in-params>> ] bi
  77     [
  78         >r value>> r> type>> {
  79             { FACTOR-BLOB [
  80                 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
  81             ] }
  82             { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
  83             { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
  84             { TIME [ dup [ timestamp>hms ] when default-param-value ] }
  85             { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
  86             { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
  87             { URL [ dup [ present ] when default-param-value ] }
  88             [ drop default-param-value ]
  89         } case 2array
  90     ] 2map flip [
  91         f f
  92     ] [
  93         first2 [ >c-void*-array ] [ >c-uint-array ] bi*
  94     ] if-empty ;
  95
  96 : param-formats ( statement -- seq )
  97     in-params>> [ type>> type>param-format ] map >c-uint-array ;
  98
  99 : do-postgresql-bound-statement ( statement -- res )
 100     [
 101         >r db get handle>> r>
 102         {
 103             [ sql>> ]
 104             [ bind-params>> length ]
 105             [ param-types ]
 106             [ param-values ]
 107             [ param-formats ]
 108         } cleave
 109         0 PQexecParams dup postgresql-result-ok? [
 110             [ postgresql-result-error-message ] [ PQclear ] bi throw
 111         ] unless
 112     ] with-destructors ;
 113
 114 : pq-get-is-null ( handle row column -- ? )
 115     PQgetisnull 1 = ;
 116
 117 : pq-get-string ( handle row column -- obj )
 118     3dup PQgetvalue utf8 alien>string
 119     dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
 120
 121 : pq-get-number ( handle row column -- obj )
 122     pq-get-string dup [ string>number ] when ;
 123
 124 TUPLE: postgresql-malloc-destructor alien ;
 125 C: <postgresql-malloc-destructor> postgresql-malloc-destructor
 126
 127 M: postgresql-malloc-destructor dispose ( obj -- )
 128     alien>> PQfreemem ;
 129
 130 : &postgresql-free ( alien -- alien )
 131     dup <postgresql-malloc-destructor> &dispose drop ; inline
 132
 133 : pq-get-blob ( handle row column -- obj/f )
 134     [ PQgetvalue ] 3keep 3dup PQgetlength
 135     dup 0 > [
 136         3nip
 137         [
 138             memory>byte-array >string
 139             0 <uint>
 140             [
 141                 PQunescapeBytea dup zero? [
 142                     postgresql-result-error-message throw
 143                 ] [
 144                     &postgresql-free
 145                 ] if
 146             ] keep
 147             *uint memory>byte-array
 148         ] with-destructors
 149     ] [
 150         drop pq-get-is-null nip [ f ] [ B{ } clone ] if
 151     ] if ;
 152
 153 : postgresql-column-typed ( handle row column type -- obj )
 154     dup array? [ first ] when
 155     {
 156         { +db-assigned-id+ [ pq-get-number ] }
 157         { +random-id+ [ pq-get-number ] }
 158         { INTEGER [ pq-get-number ] }
 159         { BIG-INTEGER [ pq-get-number ] }
 160         { DOUBLE [ pq-get-number ] }
 161         { TEXT [ pq-get-string ] }
 162         { VARCHAR [ pq-get-string ] }
 163         { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
 164         { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
 165         { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
 166         { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
 167         { BLOB [ pq-get-blob ] }
 168         { URL [ pq-get-string dup [ >url ] when ] }
 169         { FACTOR-BLOB [
 170             pq-get-blob
 171             dup [ bytes>object ] when ] }
 172         [ no-sql-type ]
 173     } case ;