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*
14 : postgresql-result-error-message ( res -- str/f )
18 PQresultErrorMessage [ blank? ] trim
21 : postgres-result-error ( res -- )
22 postgresql-result-error-message [ throw ] when* ;
24 : (postgresql-error-message) ( handle -- str )
26 "\n" split [ [ blank? ] trim ] map "\n" join ;
28 : postgresql-error-message ( -- str )
29 db-connection get handle>> (postgresql-error-message) ;
31 : postgresql-error ( res -- res )
32 dup [ postgresql-error-message throw ] unless ;
34 ERROR: postgresql-result-null ;
36 M: postgresql-result-null summary ( obj -- str )
37 drop "PQexec returned f." ;
39 : postgresql-result-ok? ( res -- ? )
40 [ postgresql-result-null ] unless*
42 PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
44 : connect-postgres ( host port pgopts pgtty db user pass -- conn )
46 dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
48 : do-postgresql-statement ( statement -- res )
49 db-connection get handle>> swap sql>> PQexec dup postgresql-result-ok? [
50 [ postgresql-result-error-message ] [ PQclear ] bi throw
53 : type>oid ( symbol -- n )
54 dup array? [ first ] when
56 { BLOB [ BYTEA-OID ] }
57 { FACTOR-BLOB [ BYTEA-OID ] }
61 : type>param-format ( symbol -- n )
62 dup array? [ first ] when
69 : param-types ( statement -- seq )
70 in-params>> [ type>> type>oid ] uint-array{ } map-as ;
72 : malloc-byte-array/length ( byte-array -- alien length )
73 [ malloc-byte-array &free ] [ length ] bi ;
75 : default-param-value ( obj -- alien n )
76 number>string* dup [ utf8 malloc-string &free ] when 0 ;
78 : param-values ( statement -- seq seq2 )
79 [ bind-params>> ] [ in-params>> ] bi
81 [ value>> ] [ type>> ] bi* {
83 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
85 { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
86 { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
87 { TIME [ dup [ timestamp>hms ] when default-param-value ] }
88 { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
89 { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
90 { URL [ dup [ present ] when default-param-value ] }
91 [ drop default-param-value ]
96 first2 [ >void*-array ] [ >uint-array ] bi*
99 : param-formats ( statement -- seq )
100 in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
102 : do-postgresql-bound-statement ( statement -- res )
104 [ db-connection get handle>> ] dip
107 [ bind-params>> length ]
112 0 PQexecParams dup postgresql-result-ok? [
113 [ postgresql-result-error-message ] [ PQclear ] bi throw
117 : pq-get-is-null ( handle row column -- ? )
120 : pq-get-string ( handle row column -- obj )
121 3dup PQgetvalue utf8 alien>string
122 dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
124 : pq-get-number ( handle row column -- obj )
125 pq-get-string dup [ string>number ] when ;
127 TUPLE: postgresql-malloc-destructor alien ;
128 C: <postgresql-malloc-destructor> postgresql-malloc-destructor
130 M: postgresql-malloc-destructor dispose ( obj -- )
133 : &postgresql-free ( alien -- alien )
134 dup <postgresql-malloc-destructor> &dispose drop ; inline
136 : pq-get-blob ( handle row column -- obj/f )
137 [ PQgetvalue ] 3keep 3dup PQgetlength
141 memory>byte-array >string
144 PQunescapeBytea dup zero? [
145 postgresql-result-error-message throw
149 ] [ ] with-out-parameters memory>byte-array
152 drop pq-get-is-null nip [ f ] [ B{ } clone ] if
155 : postgresql-column-typed ( handle row column type -- obj )
156 dup array? [ first ] when
158 { +db-assigned-id+ [ pq-get-number ] }
159 { +random-id+ [ pq-get-number ] }
160 { INTEGER [ pq-get-number ] }
161 { BIG-INTEGER [ pq-get-number ] }
162 { DOUBLE [ pq-get-number ] }
163 { TEXT [ pq-get-string ] }
164 { VARCHAR [ pq-get-string ] }
165 { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
166 { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
167 { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
168 { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
169 { BLOB [ pq-get-blob ] }
170 { URL [ pq-get-string dup [ >url ] when ] }
173 dup [ bytes>object ] when ] }