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