Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
7c1dc2336a
|
|
@ -14,11 +14,14 @@ IN: cairo
|
|||
|
||||
<< "cairo" {
|
||||
{ [ win32? ] [ "cairo.dll" ] }
|
||||
{ [ macosx? ] [ "libcairo.dylib" ] }
|
||||
! { [ macosx? ] [ "libcairo.dylib" ] }
|
||||
{ [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
|
||||
{ [ unix? ] [ "libcairo.so.2" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
! cairo_status_t
|
||||
LIBRARY: cairo
|
||||
|
||||
TYPEDEF: int cairo_status_t
|
||||
C-ENUM:
|
||||
CAIRO_STATUS_SUCCESS
|
||||
CAIRO_STATUS_NO_MEMORY
|
||||
|
|
@ -45,12 +48,12 @@ C-ENUM:
|
|||
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
|
||||
;
|
||||
|
||||
! cairo_content_t
|
||||
TYPEDEF: int cairo_content_t
|
||||
: CAIRO_CONTENT_COLOR HEX: 1000 ;
|
||||
: CAIRO_CONTENT_ALPHA HEX: 2000 ;
|
||||
: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
|
||||
|
||||
! cairo_operator_t
|
||||
TYPEDEF: int cairo_operator_t
|
||||
C-ENUM:
|
||||
CAIRO_OPERATOR_CLEAR
|
||||
CAIRO_OPERATOR_SOURCE
|
||||
|
|
@ -68,34 +71,34 @@ C-ENUM:
|
|||
CAIRO_OPERATOR_SATURATE
|
||||
;
|
||||
|
||||
! cairo_line_cap_t
|
||||
TYPEDEF: int cairo_line_cap_t
|
||||
C-ENUM:
|
||||
CAIRO_LINE_CAP_BUTT
|
||||
CAIRO_LINE_CAP_ROUND
|
||||
CAIRO_LINE_CAP_SQUARE
|
||||
;
|
||||
|
||||
! cair_line_join_t
|
||||
TYPEDEF: int cair_line_join_t
|
||||
C-ENUM:
|
||||
CAIRO_LINE_JOIN_MITER
|
||||
CAIRO_LINE_JOIN_ROUND
|
||||
CAIRO_LINE_JOIN_BEVEL
|
||||
;
|
||||
|
||||
! cairo_fill_rule_t
|
||||
TYPEDEF: int cairo_fill_rule_t
|
||||
C-ENUM:
|
||||
CAIRO_FILL_RULE_WINDING
|
||||
CAIRO_FILL_RULE_EVEN_ODD
|
||||
;
|
||||
|
||||
! cairo_font_slant_t
|
||||
TYPEDEF: int cairo_font_slant_t
|
||||
C-ENUM:
|
||||
CAIRO_FONT_SLANT_NORMAL
|
||||
CAIRO_FONT_SLANT_ITALIC
|
||||
CAIRO_FONT_SLANT_OBLIQUE
|
||||
;
|
||||
|
||||
! cairo_font_weight_t
|
||||
TYPEDEF: int cairo_font_weight_t
|
||||
C-ENUM:
|
||||
CAIRO_FONT_WEIGHT_NORMAL
|
||||
CAIRO_FONT_WEIGHT_BOLD
|
||||
|
|
@ -159,7 +162,7 @@ C-STRUCT: cairo_matrix_t
|
|||
{ "double" "x0" }
|
||||
{ "double" "y0" } ;
|
||||
|
||||
! cairo_format_t
|
||||
TYPEDEF: int cairo_format_t
|
||||
C-ENUM:
|
||||
CAIRO_FORMAT_ARGB32
|
||||
CAIRO_FORMAT_RGB24
|
||||
|
|
@ -167,7 +170,7 @@ C-ENUM:
|
|||
CAIRO_FORMAT_A1
|
||||
;
|
||||
|
||||
! cairo_antialias_t
|
||||
TYPEDEF: int cairo_antialias_t
|
||||
C-ENUM:
|
||||
CAIRO_ANTIALIAS_DEFAULT
|
||||
CAIRO_ANTIALIAS_NONE
|
||||
|
|
@ -175,7 +178,7 @@ C-ENUM:
|
|||
CAIRO_ANTIALIAS_SUBPIXEL
|
||||
;
|
||||
|
||||
! cairo_subpixel_order_t
|
||||
TYPEDEF: int cairo_subpixel_order_t
|
||||
C-ENUM:
|
||||
CAIRO_SUBPIXEL_ORDER_DEFAULT
|
||||
CAIRO_SUBPIXEL_ORDER_RGB
|
||||
|
|
@ -184,7 +187,7 @@ C-ENUM:
|
|||
CAIRO_SUBPIXEL_ORDER_VBGR
|
||||
;
|
||||
|
||||
! cairo_hint_style_t
|
||||
TYPEDEF: int cairo_hint_style_t
|
||||
C-ENUM:
|
||||
CAIRO_HINT_STYLE_DEFAULT
|
||||
CAIRO_HINT_STYLE_NONE
|
||||
|
|
@ -193,7 +196,7 @@ C-ENUM:
|
|||
CAIRO_HINT_STYLE_FULL
|
||||
;
|
||||
|
||||
! cairo_hint_metrics_t
|
||||
TYPEDEF: int cairo_hint_metrics_t
|
||||
C-ENUM:
|
||||
CAIRO_HINT_METRICS_DEFAULT
|
||||
CAIRO_HINT_METRICS_OFF
|
||||
|
|
@ -420,7 +423,11 @@ C-ENUM:
|
|||
: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
|
||||
"void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
|
||||
|
||||
|
||||
FUNCTION: uchar* cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
|
||||
FUNCTION: cairo_format_t cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
|
||||
FUNCTION: int cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
|
||||
FUNCTION: int cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
|
||||
FUNCTION: int cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
|
||||
|
||||
! Cairo pdf
|
||||
|
||||
|
|
@ -437,3 +444,16 @@ C-ENUM:
|
|||
|
||||
: cairo_pdf_surface_set_size ( surface width height -- )
|
||||
"void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ;
|
||||
|
||||
! Cairo png
|
||||
|
||||
TYPEDEF: void* cairo_write_func_t
|
||||
TYPEDEF: void* cairo_read_func_t
|
||||
|
||||
FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png ( char* filename ) ;
|
||||
|
||||
FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
|
||||
|
||||
FUNCTION: cairo_status_t cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
|
||||
|
||||
FUNCTION: cairo_status_t cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
USING: kernel math sequences namespaces ;
|
||||
IN: crypto.rc4
|
||||
|
||||
! http://en.wikipedia.org/wiki/RC4_%28cipher%29
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: i
|
||||
SYMBOL: j
|
||||
SYMBOL: s
|
||||
SYMBOL: key
|
||||
SYMBOL: l
|
||||
|
||||
! key scheduling algorithm, initialize s
|
||||
: ksa ( -- )
|
||||
256 [ ] map s set
|
||||
0 j set
|
||||
256 [
|
||||
dup s get nth j get + over l get mod key get nth + 255 bitand j set
|
||||
dup j get s get exchange drop
|
||||
] each ;
|
||||
|
||||
: generate ( -- n )
|
||||
i get 1+ 255 bitand i set
|
||||
j get i get s get nth + 255 bitand j set
|
||||
i get j get s get exchange
|
||||
i get s get nth j get s get nth + 255 bitand s get nth ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: rc4 ( key -- )
|
||||
[
|
||||
[ key set ] keep
|
||||
length l set
|
||||
ksa
|
||||
0 i set
|
||||
0 j set
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -20,8 +20,7 @@ GENERIC: db-open ( db -- )
|
|||
HOOK: db-close db ( handle -- )
|
||||
: make-db ( seq class -- db ) construct-empty make-db* ;
|
||||
|
||||
: dispose-statements ( seq -- )
|
||||
[ dispose drop ] assoc-each ;
|
||||
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
|
||||
|
||||
: dispose-db ( db -- )
|
||||
dup db [
|
||||
|
|
@ -46,8 +45,8 @@ GENERIC: bind-tuple ( tuple statement -- )
|
|||
GENERIC: query-results ( query -- result-set )
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC# row-column-typed 1 ( result-set n -- sql )
|
||||
GENERIC# row-column 1 ( result-set column -- obj )
|
||||
GENERIC# row-column-typed 1 ( result-set column -- sql )
|
||||
GENERIC: advance-row ( result-set -- )
|
||||
GENERIC: more-rows? ( result-set -- ? )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||
db.types tools.walker ascii splitting ;
|
||||
db.types tools.walker ascii splitting math.parser
|
||||
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 )
|
||||
|
|
@ -38,13 +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+ [ 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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io
|
|||
kernel math math.parser namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators sequences.lib classes locals words tools.walker ;
|
||||
combinators sequences.lib classes locals words tools.walker
|
||||
combinators.cleave namespaces.lib ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
|
|
@ -53,11 +54,12 @@ M: postgresql-result-set #rows ( result-set -- n )
|
|||
M: postgresql-result-set #columns ( result-set -- n )
|
||||
result-set-handle PQnfields ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
M: postgresql-result-set row-column ( result-set column -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> pq-get-string ;
|
||||
|
||||
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
|
||||
>r row-column r> sql-type>factor-type ;
|
||||
M: postgresql-result-set row-column-typed ( result-set column -- obj )
|
||||
dup pick result-set-out-params nth sql-spec-type
|
||||
>r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup statement-bind-params [
|
||||
|
|
@ -236,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 )
|
||||
|
|
@ -249,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 )
|
||||
|
|
|
|||
|
|
@ -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 -- * )
|
||||
|
|
@ -127,9 +128,9 @@ IN: db.sqlite.lib
|
|||
{ +native-id+ [ sqlite3_column_int64 ] }
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
{ TEXT [ sqlite3_column_text ] }
|
||||
{ VARCHAR [ sqlite3_column_text ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
{ DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
|
||||
{ TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
|
||||
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
|
||||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue