postgresql can store binary blobs!

extra/db/postgresql/ffi/ffi.factor

@@ -298,8 +298,8 @@ FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
 FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
                                     char* from, size_t length,
                                     size_t* to_length ) ;
-FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
+FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
-                size_t* retbuflen ) ;
+! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
 ! These forms are deprecated!
 FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
 FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
@@ -347,3 +347,23 @@ FUNCTION: int    PQdsplen ( uchar* s, int encoding ) ;
 
 ! Get encoding id from environment variable PGCLIENTENCODING
 FUNCTION: int    PQenv2encoding ( ) ;
+
+! From git, include/catalog/pg_type.h
+: BOOL-OID 16 ; inline
+: BYTEA-OID 17 ; inline
+: CHAR-OID 18 ; inline
+: NAME-OID 19 ; inline
+: INT8-OID 20 ; inline
+: INT2-OID 21 ; inline
+: INT4-OID 23 ; inline
+: TEXT-OID 23 ; inline
+: OID-OID 26 ; inline
+: FLOAT4-OID 700 ; inline
+: FLOAT8-OID 701 ; inline
+: VARCHAR-OID 1043 ; inline
+: DATE-OID 1082 ; inline
+: TIME-OID 1083 ; inline
+: TIMESTAMP-OID 1114 ; inline
+: TIMESTAMPTZ-OID 1184 ; inline
+: INTERVAL-OID 1186 ; inline
+: NUMERIC-OID 1700 ; inline

extra/db/postgresql/lib/lib.factor

@@ -3,7 +3,9 @@
 USING: arrays continuations db io kernel math namespaces
 quotations sequences db.postgresql.ffi alien alien.c-types
 db.types tools.walker ascii splitting math.parser
-combinators combinators.cleave libc shuffle calendar.format ;
+combinators combinators.cleave libc shuffle calendar.format
+byte-arrays destructors prettyprint new-slots accessors
+strings serialize io.encodings.binary io.streams.byte-array ;
 IN: db.postgresql.lib
 
 : postgresql-result-error-message ( res -- str/f )
@@ -39,34 +41,111 @@ IN: db.postgresql.lib
         dup postgresql-result-error-message swap PQclear throw
     ] unless ;
 
+: type>oid ( symbol -- n )
+    dup array? [ first ] when
+    {
+        { BLOB [ BYTEA-OID ] }
+        { FACTOR-BLOB [ BYTEA-OID ] }
+        [ drop 0 ]
+    } case ;
+
+: type>param-format ( symbol -- n )
+    dup array? [ first ] when
+    {
+        { BLOB [ 1 ] }
+        { FACTOR-BLOB [ 1 ] }
+        [ drop 0 ]
+    } case ;
+
+: param-types ( statement -- seq )
+    statement-in-params
+    [ sql-spec-type type>oid ] map
+    >c-uint-array ;
+
+: malloc-byte-array/length
+    [ malloc-byte-array dup free-always ] [ length ] bi ;
+    
+
+: param-values ( statement -- seq seq2 )
+    [ statement-bind-params ]
+    [ statement-in-params ] bi
+    [
+        sql-spec-type {
+            { FACTOR-BLOB [
+                dup [
+                    binary [ serialize ] with-byte-writer
+                    malloc-byte-array/length ] [ 0 ] if ] }
+            { BLOB [
+                dup [ malloc-byte-array/length ] [ 0 ] if ] }
+            [
+                drop number>string* dup [
+                    malloc-char-string dup free-always
+                ] when 0
+            ]
+        } case 2array
+    ] 2map flip dup empty? [
+        drop f f
+    ] [
+        first2 [ >c-void*-array ] [ >c-uint-array ] bi*
+    ] if ;
+
+: param-formats ( statement -- seq )
+    statement-in-params
+    [ sql-spec-type type>param-format ] map
+    >c-uint-array ;
+
 : do-postgresql-bound-statement ( statement -- res )
+    [
         >r db get db-handle r>
-    [ statement-sql ] keep
+        {
-    [ statement-bind-params length f ] keep
+            [ statement-sql ]
-    statement-bind-params
+            [ statement-bind-params length ]
-    [ number>string* dup [ malloc-char-string ] when ] map
+            [ param-types ]
-    [
+            [ param-values ]
-        [
+            [ param-formats ]
-            >c-void*-array f f 0 PQexecParams
+        } cleave
-            dup postgresql-result-ok? [
+        0 PQexecParams dup postgresql-result-ok? [
             dup postgresql-result-error-message swap PQclear throw
         ] unless
-        ] keep
+    ] with-destructors ;
-    ] [ [ free ] each ] [ ] cleanup ;
+
+: pq-get-is-null ( handle row column -- ? )
+    PQgetisnull 1 = ;
 
 : pq-get-string ( handle row column -- obj )
     3dup PQgetvalue alien>char-string
-    dup "" = [ >r PQgetisnull 1 = f r> ? ] [ 3nip ] if ;
+    dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
 
 : pq-get-number ( handle row column -- obj )
     pq-get-string dup [ string>number ] when ;
 
+TUPLE: postgresql-malloc-destructor alien ;
+C: <postgresql-malloc-destructor> postgresql-malloc-destructor
+
+M: postgresql-malloc-destructor dispose ( obj -- )
+    alien>> PQfreemem ;
+
+: postgresql-free-always ( alien -- )
+    <postgresql-malloc-destructor> add-always-destructor ;
+
 : pq-get-blob ( handle row column -- obj/f )
-    [ PQgetvalue ] 3keep PQgetlength
+    [ PQgetvalue ] 3keep 3dup PQgetlength
     dup 0 > [
-        memory>byte-array
+        3nip
+        [
+            memory>byte-array >string
+            0 <uint>
+            [
+                PQunescapeBytea dup zero? [
+                    postgresql-result-error-message throw
                 ] [
-        2drop f
+                    dup postgresql-free-always
+                ] if
+            ] keep
+            *uint memory>byte-array
+        ] with-destructors 
+    ] [
+        drop pq-get-is-null nip [ f ] [ B{ } clone ] if
     ] if ;
 
 : postgresql-column-typed ( handle row column type -- obj )
@@ -83,7 +162,9 @@ IN: db.postgresql.lib
         { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
         { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
         { BLOB [ pq-get-blob ] }
-        { FACTOR-BLOB [ pq-get-blob ] }
+        { FACTOR-BLOB [
+            pq-get-blob
+            binary [ deserialize ] with-byte-reader ] }
         [ no-sql-type ]
     } case ;
     ! PQgetlength PQgetisnull

extra/db/tuples/tuples-tests.factor

@@ -164,8 +164,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-postgresql ( -- )
 >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
 
-[ native-person-schema test-tuples ] test-sqlite
+! [ native-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
+! [ assigned-person-schema test-tuples ] test-sqlite
 
 [ native-person-schema test-tuples ] test-postgresql
 [ assigned-person-schema test-tuples ] test-postgresql