steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Matthew Willis 2008-03-11 00:46:47 -07:00
parent 27c4515be6 f56b54077b
commit e04c5d7ba8
5 changed files with 203 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
extra/db/postgresql/ffi/ffi.factor
View File

@ -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,
size_t* retbuflen ) ;
FUNCTION: void* PQunescapeBytea ( uchar* strtext, 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

146
extra/db/postgresql/lib/lib.factor
View File

@ -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-bind-params
[ number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
[
>r db get db-handle r>
{
[ statement-sql ]
[ statement-bind-params length ]
[ param-types ]
[ param-values ]
[ param-formats ]
} cleave
0 PQexecParams dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] 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+ [ ] }
{ INTEGER [ PQgetvalue string>number ] }
{ BIG-INTEGER [ PQgetvalue string>number ] }
{ DOUBLE [ PQgetvalue string>number ] }
{ TEXT [ PQgetvalue ] }
{ VARCHAR [ PQgetvalue ] }
{ DATE [ PQgetvalue ] }
{ TIME [ PQgetvalue ] }
{ TIMESTAMP [ PQgetvalue ] }
{ DATETIME [ PQgetvalue ] }
{ BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
{ FACTOR-BLOB [ [ PQgetvalue ] 3keep PQgetlength ] }
{ +native-id+ [ pq-get-number ] }
{ INTEGER [ pq-get-number ] }
{ BIG-INTEGER [ pq-get-number ] }
{ DOUBLE [ pq-get-number ] }
{ TEXT [ pq-get-string ] }
{ VARCHAR [ pq-get-string ] }
{ DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
{ TIME [ pq-get-string dup [ hms>timestamp ] when ] }
{ 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
dup [ binary [ deserialize ] with-byte-reader ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull
! PQgetlength PQgetisnull

18
extra/db/postgresql/postgresql.factor
View File

@ -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
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
dup empty? [
drop
] [
" where " 0%
[ " and " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
] 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 )

5
extra/db/sqlite/lib/lib.factor
View File

@ -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 ]

52
extra/db/tuples/tuples-tests.factor
View File

@ -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
"johnny" 10 3.14 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 ;
"billy" 10 3.14 f f f f f <person> person1 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 } 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
2 "johnny" 10 3.14 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 ;
1 "billy" 10 3.14 f f f f f <assigned-person> person1 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 } 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 ( -- )
! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
: test-postgresql ( -- )
>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 ;