! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io io.crlf kernel math.parser sequences strings interpolate locals ;
+USING: arrays assocs formatting io io.crlf kernel math
+math.parser sequences strings locals ;
IN: redis.command-writer
<PRIVATE
-GENERIC: write-value-with-length ( value -- )
+GENERIC: write-resp ( value -- )
-M: string write-value-with-length
- [ length number>string write crlf ]
- [ write ] bi ;
+M: string write-resp ( string -- )
+ [ length ] keep "$%s\r\n%s\r\n" printf ;
-: space ( -- ) CHAR: space write1 ;
+M: integer write-resp ( integer -- )
+ ":%s\r\n" printf ;
-: write-key/value ( value key -- )
- write space
- write-value-with-length ;
+M: sequence write-resp ( sequence -- )
+ [ length "*%s\r\n" printf ] keep
+ [ write-resp ] each ;
-: write-key/integer ( integer key -- )
- write space
- number>string write ;
+: write-command ( sequence command -- )
+ suffix reverse
+ [ dup number? [ number>string ] when ] map
+ write-resp ;
PRIVATE>
#! Connection
-: quit ( -- ) "QUIT" write crlf ;
-: ping ( -- ) "PING" write crlf ;
-: auth ( password -- ) "AUTH " write write crlf ;
+: quit ( -- ) { "QUIT" } write-resp ;
+: ping ( -- ) { "PING" } write-resp ;
+: auth ( password -- ) 1array "AUTH" write-command ;
#! 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 ;
+: set ( value key -- ) 2array "SET" write-command ;
+: get ( key -- ) 1array "GET" write-command ;
+: getset ( value key -- ) 2array "GETSET" write-command ;
+: mget ( keys -- ) reverse "MGET" write-command ;
+: setnx ( value key -- ) 2array "SETNX" write-command ;
+: incr ( key -- ) 1array "INCR" write-command ;
+: incrby ( integer key -- ) 2array "INCRBY" write-command ;
+: decr ( key -- ) 1array "DECR" write-command ;
+: decrby ( integer key -- ) 2array "DECRBY" write-command ;
+: exists ( key -- ) 1array "EXISTS" write-command ;
+: del ( key -- ) 1array "DEL" write-command ;
+: type ( key -- ) 1array "TYPE" write-command ;
#! 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 ;
+: keys ( pattern -- ) 1array "KEYS" write-command ;
+: randomkey ( -- ) { "RANDOMKEY" } write-resp ;
+: rename ( newkey key -- ) 2array "RENAME" write-command ;
+: renamenx ( newkey key -- ) 2array "RENAMENX" write-command ;
+: dbsize ( -- ) { "DBSIZE" } write-resp ;
+: expire ( integer key -- ) 2array "EXPIRE" write-command ;
#! 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 ;
+: rpush ( value key -- ) 2array "RPUSH" write-command ;
+: lpush ( value key -- ) 2array "LPUSH" write-command ;
+: llen ( key -- ) 1array "LLEN" write-command ;
: lrange ( start end key -- )
- "LRANGE " write write [ space number>string write ] bi@ crlf ;
+ [ swap ] dip 3array "LRANGE" write-command ;
: 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 ;
+ [ swap ] dip 3array "LTRIM" write-command ;
+: lindex ( integer key -- ) 2array "LINDEX" write-command ;
+: lset ( value index key -- ) 3array "LSET" write-command ;
+: lrem ( value amount key -- ) 3array "LREM" write-command ;
+: lpop ( key -- ) 1array "LPOP" write-command ;
+: rpop ( key -- ) 1array "RPOP" write-command ;
#! 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 ;
+: sadd ( member key -- ) 2array "SADD" write-command ;
+: srem ( member key -- ) 2array "SREM" write-command ;
: smove ( member newkey key -- )
- "SMOVE " write write space write space write-value-with-length crlf ;
-: scard ( key -- ) "SCARD " write write crlf ;
+ 3array "SMOVE" write-command ;
+: scard ( key -- ) 1array "SCARD" write-command ;
: sismember ( member key -- )
- "SISMEMBER " write write space write-value-with-length crlf ;
-: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+ 2array "SISMEMBER" write-command ;
+: sinter ( keys -- ) reverse "SINTER" write-command ;
: sinterstore ( keys destkey -- )
- "SINTERSTORE " write write space " " join write crlf ;
-: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+ [ reverse ] dip suffix "SINTERSTORE" write-command ;
+: sunion ( keys -- ) reverse "SUNION" write-command ;
: sunionstore ( keys destkey -- )
- "SUNIONSTORE " write write " " join space write crlf ;
-: smembers ( key -- ) "SMEMBERS " write write crlf ;
+ [ reverse ] dip suffix "SUNIONSTORE" write-command ;
+: smembers ( key -- ) 1array "SMEMBERS" write-command ;
#! Hashes
-: hdel ( field key -- ) "HDEL " write write space write crlf ;
-: hexists ( field key -- ) "HEXISTS " write write space write crlf ;
-: hget ( field key -- ) "HGET " write write space write crlf ;
-: hgetall ( key -- ) "HGETALL " write write crlf ;
+: hdel ( field key -- ) 2array "HDEL" write-command ;
+: hexists ( field key -- ) 2array "HEXISTS" write-command ;
+: hget ( field key -- ) 2array "HGET" write-command ;
+: hgetall ( key -- ) 1array "HGETALL" write-command ;
: hincrby ( integer field key -- )
- "HINCRBY " write write space write space number>string write crlf ;
+ 3array "HINCRBY" write-command ;
: hincrbyfloat ( float field key -- )
- "HINCRBYFLOAT " write write space write space number>string write crlf ;
-: hkeys ( key -- ) "HKEYS " write write crlf ;
-: hlen ( key -- ) "HLEN " write write crlf ;
-: hmget ( seq key -- )
- "HMGET " write write space " " join write crlf ;
-: hmset ( assoc key -- )
- "HMSET " write write space
- >alist [ " " join ] map " " join write crlf ;
-: hset ( value field key -- ) "HSET " write write space write
- space write crlf ;
-: hsetnx ( value field key -- ) "HSETNX " write write space
- write space write crlf ;
-: hvals ( key -- ) "HVALS " write write crlf ;
+ 3array "HINCRBYFLOAT" write-command ;
+: hkeys ( key -- ) 1array "HKEYS" write-command ;
+: hlen ( key -- ) 1array "HLEN" write-command ;
+: hmget ( seq key -- ) prefix reverse "HMGET" write-command ;
+: hmset ( assoc key -- )
+ [
+ >alist concat reverse
+ ] dip suffix "HMSET" write-command ;
+: hset ( value field key -- ) 3array "HSET" write-command ;
+: hsetnx ( value field key -- )
+ 3array "HSETNX" write-command ;
+: hvals ( key -- ) 1array "HVALS" write-command ;
#! 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 ;
+: select ( integer -- ) 1array "SELECT" write-command ;
+: move ( integer key -- ) 2array "MOVE" write-command ;
+: flushdb ( -- ) { "FLUSHDB" } write-resp ;
+: flushall ( -- ) { "FLUSHALL" } write-resp ;
#! Sorting
! sort
#! Persistence control
-: save ( -- ) "SAVE" write crlf ;
-: bgsave ( -- ) "BGSAVE" write crlf ;
-: lastsave ( -- ) "LASTSAVE" write crlf ;
-: shutdown ( -- ) "SHUTDOWN" write crlf ;
+: save ( -- ) { "SAVE" } write-resp ;
+: bgsave ( -- ) { "BGSAVE" } write-resp ;
+: lastsave ( -- ) { "LASTSAVE" } write-resp ;
+: shutdown ( -- ) { "SHUTDOWN" } write-resp ;
#! Remote server control
-: info ( -- ) "INFO" write crlf ;
-: monitor ( -- ) "MONITOR" write crlf ;
+: info ( -- ) { "INFO" } write-resp ;
+: monitor ( -- ) { "MONITOR" } write-resp ;
projects / factor.git / blobdiff