basis/db/postgresql/lib/lib.factor

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