Merge git://factorcode.org/git/factor

extra/db/postgresql/ffi/ffi.factor

@@ -270,7 +270,8 @@ FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
 FUNCTION: char* PQoidStatus ( PGresult* res ) ;
 FUNCTION: Oid   PQoidValue ( PGresult* res ) ;
 FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
-FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
 FUNCTION: int   PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
 FUNCTION: int   PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
 
@@ -297,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,
@@ -346,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 ;
+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,32 +41,130 @@ 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* malloc-char-string ] map >c-void*-array
+            [ param-types ]
-    f f 0 PQexecParams
+            [ param-values ]
-    dup postgresql-result-ok? [
+            [ param-formats ]
+        } cleave
+        0 PQexecParams dup postgresql-result-ok? [
             dup postgresql-result-error-message swap PQclear throw
-    ] unless ;
+        ] unless
+    ] with-destructors ;
+
+: pq-get-is-null ( handle row column -- ? )
+    PQgetisnull 1 = ;
+
+: pq-get-string ( handle row column -- obj )
+    3dup PQgetvalue alien>char-string
+    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 3dup PQgetlength
+    dup 0 > [
+        3nip
+        [
+            memory>byte-array >string
+            0 <uint>
+            [
+                PQunescapeBytea dup zero? [
+                    postgresql-result-error-message throw
+                ] [
+                    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 )
     dup array? [ first ] when
     {
-        { +native-id+ [ ] }
+        { +native-id+ [ pq-get-number ] }
-        { INTEGER [ PQgetvalue string>number ] }
+        { INTEGER [ pq-get-number ] }
-        { BIG-INTEGER [ PQgetvalue string>number ] }
+        { BIG-INTEGER [ pq-get-number ] }
-        { DOUBLE [ PQgetvalue string>number ] }
+        { DOUBLE [ pq-get-number ] }
-        { TEXT [ PQgetvalue ] }
+        { TEXT [ pq-get-string ] }
-        { VARCHAR [ PQgetvalue ] }
+        { VARCHAR [ pq-get-string ] }
-        { DATE [ PQgetvalue ] }
+        { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
-        { TIME [ PQgetvalue ] }
+        { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
-        { TIMESTAMP [ PQgetvalue ] }
+        { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
-        { DATETIME [ PQgetvalue ] }
+        { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
-        { BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
+        { BLOB [ pq-get-blob ] }
-        { FACTOR-BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
+        { FACTOR-BLOB [
+            pq-get-blob
+            dup [ binary [ deserialize ] with-byte-reader ] when ] }
         [ no-sql-type ]
     } case ;
     ! PQgetlength PQgetisnull

extra/db/postgresql/postgresql.factor

@@ -55,7 +55,7 @@ M: postgresql-result-set #columns ( result-set -- n )
     result-set-handle PQnfields ;
 
 M: postgresql-result-set row-column ( result-set column -- obj )
-    >r dup result-set-handle swap result-set-n r> PQgetvalue ;
+    >r dup result-set-handle swap result-set-n r> pq-get-string ;
 
 M: postgresql-result-set row-column-typed ( result-set column -- obj )
     dup pick result-set-out-params nth sql-spec-type
@@ -238,10 +238,13 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
 
         " from " 0% 0%
         [ sql-spec-slot-name swap get-slot-named ] with subset
+        dup empty? [
+            drop
+        ] [
             " where " 0%
-        [ ", " 0% ]
+            [ " and " 0% ]
             [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
-        ";" 0%
+        ] if ";" 0%
     ] postgresql-make ;
 
 M: postgresql-db type-table ( -- hash )
@@ -251,7 +254,12 @@ M: postgresql-db type-table ( -- hash )
         { VARCHAR "varchar" }
         { INTEGER "integer" }
         { DOUBLE "real" }
+        { DATE "date" }
+        { TIME "time" }
+        { DATETIME "timestamp" }
         { TIMESTAMP "timestamp" }
+        { BLOB "bytea" }
+        { FACTOR-BLOB "bytea" }
     } ;
 
 M: postgresql-db create-type-table ( -- hash )

extra/db/sqlite/lib/lib.factor

@@ -3,7 +3,8 @@
 USING: alien.c-types arrays assocs kernel math math.parser
 namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
-io.streams.byte-array byte-arrays io.encodings.binary ;
+io.streams.byte-array byte-arrays io.encodings.binary
+tools.walker ;
 IN: db.sqlite.lib
 
 : sqlite-error ( n -- * )
@@ -137,7 +138,7 @@ IN: db.sqlite.lib
         { BLOB [ sqlite-column-blob ] }
         { FACTOR-BLOB [
             sqlite-column-blob
-            binary [ deserialize ] with-byte-reader
+            dup [ binary [ deserialize ] with-byte-reader ] when
         ] }
         ! { NULL [ 2drop f ] }
         [ no-sql-type ]

extra/db/tuples/tuples-tests.factor

@@ -3,10 +3,12 @@
 USING: io.files kernel tools.test db db.tuples
 db.types continuations namespaces math
 prettyprint tools.walker db.sqlite calendar
-math.intervals ;
+math.intervals db.postgresql ;
 IN: db.tuples.tests
 
-TUPLE: person the-id the-name the-number the-real ts date time blob ;
+TUPLE: person the-id the-name the-number the-real
+ts date time blob factor-blob ;
+
 : <person> ( name age real ts date time blob -- person )
     {
         set-person-the-name
@@ -16,9 +18,10 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ;
         set-person-date
         set-person-time
         set-person-blob
+        set-person-factor-blob
     } person construct ;
 
-: <assigned-person> ( id name age real ts date time blob -- person )
+: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
     <person> [ set-person-the-id ] keep ;
 
 SYMBOL: person1
@@ -82,6 +85,23 @@ SYMBOL: person4
         }
     ] [ T{ person f 3 } select-tuple ] unit-test
 
+    [ ] [ person4 get insert-tuple ] unit-test
+    [
+        T{
+            person
+            f
+            4
+            "eddie"
+            10
+            3.14
+            T{ timestamp f 2008 3 5 16 24 11 0 }
+            T{ timestamp f 2008 11 22 f f f f }
+            T{ timestamp f f f f 12 34 56 f }
+            f
+            H{ { 1 2 } { 3 4 } { 5 "lol" } }
+        }
+    ] [ T{ person f 4 } select-tuple ] unit-test
+
     [ ] [ person drop-table ] unit-test ;
 
 : make-native-person-table ( -- )
@@ -102,10 +122,12 @@ SYMBOL: person4
         { "date" "D" DATE }
         { "time" "T" TIME }
         { "blob" "B" BLOB }
+        { "factor-blob" "FB" FACTOR-BLOB }
     } define-persistent
-    "billy" 10 3.14 f f f f <person> person1 set
+    "billy" 10 3.14 f f f f f <person> person1 set
-    "johnny" 10 3.14 f f f f <person> person2 set
+    "johnny" 10 3.14 f f f f f <person> person2 set
-    "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <person> person3 set ;
+    "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
+    "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
 
 : assigned-person-schema ( -- )
     person "PERSON"
@@ -118,10 +140,12 @@ SYMBOL: person4
         { "date" "D" DATE }
         { "time" "T" TIME }
         { "blob" "B" BLOB }
+        { "factor-blob" "FB" FACTOR-BLOB }
     } define-persistent
-    1 "billy" 10 3.14 f f f f <assigned-person> person1 set
+    1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
-    2 "johnny" 10 3.14 f f f f <assigned-person> person2 set
+    2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
-    3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <assigned-person> person3 set ;
+    3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <assigned-person> person3 set
+    4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
@@ -161,12 +185,15 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-sqlite ( quot -- )
     >r "tuples-test.db" temp-file sqlite-db r> with-db ;
 
-! : test-postgresql ( -- )
+: test-postgresql ( -- )
-!    >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
+>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
 
 [ native-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
+
 TUPLE: serialize-me id data ;
 
 : test-serialize ( -- )
@@ -183,7 +210,8 @@ TUPLE: serialize-me id data ;
         { T{ serialize-me f 1 H{ { 1 2 } } } }
     ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
 
-! [ test-serialize ] test-sqlite
+[ test-serialize ] test-sqlite
+[ test-serialize ] test-postgresql
 
 TUPLE: exam id name score ;