Merge branch 'master' of git://factorcode.org/git/factor

db4
U-C4\Administrator 2009-05-10 19:20:55 -05:00
commit 1e0ed4f4de
17 changed files with 400 additions and 18 deletions

View File

@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: c-bool> ( int -- ? )
0 = not ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
@ -409,8 +410,8 @@ CONSTANT: primitive-types
"uchar" define-primitive-type
<c-type>
[ alien-unsigned-1 zero? not ] >>getter
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer

View File

@ -4,7 +4,7 @@ IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test

View File

@ -2,11 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
cpu.ppc.assembler.backend literals compiler.cfg.registers
alien alien.accessors alien.c-types literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame ;
compiler.cfg.stack-frame compiler.units ;
IN: cpu.ppc
! PowerPC register assignments:
@ -713,4 +713,14 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
"bool" c-type 4 >>size 4 >>align drop
[
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
] with-compilation-unit

View File

@ -2,8 +2,8 @@ IN: urls.encoding.tests
USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test

View File

@ -25,12 +25,14 @@ TUPLE: url protocol username password host port path query anchor ;
] if ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when
] bi* ;
[
":" split1 [ url-decode ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when
] bi*
] [ f f ] if* ;
GENERIC: >url ( obj -- url )

View File

@ -21,7 +21,7 @@ C: <rsa> rsa
CONSTANT: public-key 65537
: rsa-primes ( numbits -- p q )
2/ 2 unique-primes first2 ;
2/ 2 swap unique-primes first2 ;
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.

1
extra/redis/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -0,0 +1,138 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test redis.command-writer io.streams.string ;
IN: redis.command-writer.tests
#! Connection
[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
#! String values
[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
[ "GETSET key 3\r\nfoo\r\n" ] [
[ "foo" "key" getset ] with-string-writer
] unit-test
[ "MGET key1 key2 key3\r\n" ] [
[ { "key1" "key2" "key3" } mget ] with-string-writer
] unit-test
[ "SETNX key 3\r\nfoo\r\n" ] [
[ "foo" "key" setnx ] with-string-writer
] unit-test
[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
#! Key space
[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
[ "RENAME key newkey\r\n" ] [
[ "newkey" "key" rename ] with-string-writer
] unit-test
[ "RENAMENX key newkey\r\n" ] [
[ "newkey" "key" renamenx ] with-string-writer
] unit-test
[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
#! Lists
[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
#! Sets
[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
[ "foo" "dstkey" "srckey" smove ] with-string-writer
] unit-test
[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
[ "SISMEMBER key 3\r\nfoo\r\n" ] [
[ "foo" "key" sismember ] with-string-writer
] unit-test
[ "SINTER key1 key2 key3\r\n" ] [
[ { "key1" "key2" "key3" } sinter ] with-string-writer
] unit-test
[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
[ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
] unit-test
[ "SUNION key1 key2 key3\r\n" ] [
[ { "key1" "key2" "key3" } sunion ] with-string-writer
] unit-test
[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
[ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
] unit-test
[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
#! Multiple db
[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
#! Sorting
#! Persistence control
[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
#! Remote server control
[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test

View File

@ -0,0 +1,104 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: io io.crlf kernel math.parser sequences strings interpolate locals ;
IN: redis.command-writer
<PRIVATE
GENERIC: write-value-with-length ( value -- )
M: string write-value-with-length
[ length number>string write crlf ]
[ write ] bi ;
: space ( -- ) CHAR: space write1 ;
: write-key/value ( value key -- )
write space
write-value-with-length ;
: write-key/integer ( integer key -- )
write space
number>string write ;
PRIVATE>
#! Connection
: quit ( -- ) "QUIT" write crlf ;
: ping ( -- ) "PING" write crlf ;
: auth ( password -- ) "AUTH " write write crlf ;
#! String values
: set ( value key -- ) "SET " write write-key/value crlf ;
: get ( key -- ) "GET " write write crlf ;
: getset ( value key -- ) "GETSET " write write-key/value crlf ;
: mget ( keys -- ) "MGET " write " " join write crlf ;
: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
: incr ( key -- ) "INCR " write write crlf ;
: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
: decr ( key -- ) "DECR " write write crlf ;
: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
: exists ( key -- ) "EXISTS " write write crlf ;
: del ( key -- ) "DEL " write write crlf ;
: type ( key -- ) "TYPE " write write crlf ;
#! Key space
: keys ( pattern -- ) "KEYS " write write crlf ;
: randomkey ( -- ) "RANDOMKEY" write crlf ;
: rename ( newkey key -- ) "RENAME " write write space write crlf ;
: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
: dbsize ( -- ) "DBSIZE" write crlf ;
: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
#! Lists
: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
: llen ( key -- ) "LLEN " write write crlf ;
: lrange ( start end key -- )
"LRANGE " write write [ space number>string write ] bi@ crlf ;
: ltrim ( start end key -- )
"LTRIM " write write [ space number>string write ] bi@ crlf ;
: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
: lset ( value index key -- )
"LSET " write write-key/integer space write-value-with-length crlf ;
: lrem ( value amount key -- )
"LREM " write write-key/integer space write-value-with-length crlf ;
: lpop ( key -- ) "LPOP " write write crlf ;
: rpop ( key -- ) "RPOP " write write crlf ;
#! Sets
: sadd ( member key -- )
"SADD " write write space write-value-with-length crlf ;
: srem ( member key -- )
"SREM " write write space write-value-with-length crlf ;
: smove ( member newkey key -- )
"SMOVE " write write space write space write-value-with-length crlf ;
: scard ( key -- ) "SCARD " write write crlf ;
: sismember ( member key -- )
"SISMEMBER " write write space write-value-with-length crlf ;
: sinter ( keys -- ) "SINTER " write " " join write crlf ;
: sinterstore ( keys destkey -- )
"SINTERSTORE " write write space " " join write crlf ;
: sunion ( keys -- ) "SUNION " write " " join write crlf ;
: sunionstore ( keys destkey -- )
"SUNIONSTORE " write write " " join space write crlf ;
: smembers ( key -- ) "SMEMBERS " write write crlf ;
#! Multiple db
: select ( integer -- ) "SELECT " write number>string write crlf ;
: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
: flushdb ( -- ) "FLUSHDB" write crlf ;
: flushall ( -- ) "FLUSHALL" write crlf ;
#! Sorting
! sort
#! Persistence control
: save ( -- ) "SAVE" write crlf ;
: bgsave ( -- ) "BGSAVE" write crlf ;
: lastsave ( -- ) "LASTSAVE" write crlf ;
: shutdown ( -- ) "SHUTDOWN" write crlf ;
#! Remote server control
: info ( -- ) "INFO" write crlf ;
: monitor ( -- ) "MONITOR" write crlf ;

View File

@ -0,0 +1 @@
Definitions of messages sent to Redis

74
extra/redis/redis.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: io redis.response-parser redis.command-writer ;
IN: redis
#! Connection
: redis-quit ( -- ) quit flush ;
: redis-ping ( -- response ) ping flush read-response ;
: redis-auth ( password -- response ) auth flush read-response ;
#! String values
: redis-set ( value key -- response ) set flush read-response ;
: redis-get ( key -- response ) get flush read-response ;
: redis-getset ( value key -- response ) getset flush read-response ;
: redis-mget ( keys -- response ) mget flush read-response ;
: redis-setnx ( value key -- response ) setnx flush read-response ;
: redis-incr ( key -- response ) incr flush read-response ;
: redis-incrby ( integer key -- response ) incrby flush read-response ;
: redis-decr ( key -- response ) decr flush read-response ;
: redis-decrby ( integer key -- response ) decrby flush read-response ;
: redis-exists ( key -- response ) exists flush read-response ;
: redis-del ( key -- response ) del flush read-response ;
: redis-type ( key -- response ) type flush read-response ;
#! Key space
: redis-keys ( pattern -- response ) keys flush read-response ;
: redis-randomkey ( -- response ) randomkey flush read-response ;
: redis-rename ( newkey key -- response ) rename flush read-response ;
: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
: redis-dbsize ( -- response ) dbsize flush read-response ;
: redis-expire ( integer key -- response ) expire flush read-response ;
#! Lists
: redis-rpush ( value key -- response ) rpush flush read-response ;
: redis-lpush ( value key -- response ) lpush flush read-response ;
: redis-llen ( key -- response ) llen flush read-response ;
: redis-lrange ( start end key -- response ) lrange flush read-response ;
: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
: redis-lindex ( integer key -- response ) lindex flush read-response ;
: redis-lset ( value index key -- response ) lset flush read-response ;
: redis-lrem ( value amount key -- response ) lrem flush read-response ;
: redis-lpop ( key -- response ) lpop flush read-response ;
: redis-rpop ( key -- response ) rpop flush read-response ;
#! Sets
: redis-sadd ( member key -- response ) sadd flush read-response ;
: redis-srem ( member key -- response ) srem flush read-response ;
: redis-smove ( member newkey key -- response ) smove flush read-response ;
: redis-scard ( key -- response ) scard flush read-response ;
: redis-sismember ( member key -- response ) sismember flush read-response ;
: redis-sinter ( keys -- response ) sinter flush read-response ;
: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ;
: redis-sunion ( keys -- response ) sunion flush read-response ;
: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ;
: redis-smembers ( key -- response ) smembers flush read-response ;
#! Multiple db
: redis-select ( integer -- response ) select flush read-response ;
: redis-move ( integer key -- response ) move flush read-response ;
: redis-flushdb ( -- response ) flushdb flush read-response ;
: redis-flushall ( -- response ) flushall flush read-response ;
#! Sorting
! sort
#! Persistence control
: redis-save ( -- response ) save flush read-response ;
: redis-bgsave ( -- response ) bgsave flush read-response ;
: redis-lastsave ( -- response ) lastsave flush read-response ;
: redis-shutdown ( -- response ) shutdown flush read-response ;
#! Remote server control
: redis-info ( -- response ) info flush read-response ;
: redis-monitor ( -- response ) monitor flush read-response ;

View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -0,0 +1,20 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test redis.response-parser io.streams.string ;
IN: redis.response-parser.tests
[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test
[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test
[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test
[ { "hello" "world!" } ] [
"*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader
] unit-test
[ { "hello" f "world!" } ] [
"*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [
read-response
] with-string-reader
] unit-test

View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io kernel math math.parser sequences ;
IN: redis.response-parser
<PRIVATE
: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
: read-multi-bulk ( n -- seq/f )
dup 0 < [ drop f ] [
iota [ drop (read-multi-bulk) ] map
] if ;
: handle-response ( string -- string ) ; ! TODO
: handle-error ( string -- string ) ; ! TODO
PRIVATE>
: read-response ( -- response )
readln unclip {
{ CHAR: : [ string>number ] }
{ CHAR: + [ handle-response ] }
{ CHAR: $ [ string>number read-bulk ] }
{ CHAR: * [ string>number read-multi-bulk ] }
{ CHAR: - [ handle-error ] }
} case ;

View File

@ -0,0 +1 @@
Parser for responses sent by the Redis server

1
extra/redis/summary.txt Normal file
View File

@ -0,0 +1 @@
Words for communicating with the Redis key-value database