! 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 ;
+USING: arrays assocs formatting kernel math math.parser
+sequences strings make ;
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 ;
+
+: write-command-multi ( sequence command -- )
+ prepend
+ [ dup number? [ number>string ] when ] map
+ write-resp ;
+
+:: (script-eval) ( script keys args command -- )
+ [ script , keys length , keys % args % ] { } make
+ { command }
+ write-command-multi ;
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 ;
+! Connection
+: quit ( -- ) { "QUIT" } write-resp ;
+: ping ( -- ) { "PING" } write-resp ;
+: auth ( password -- ) 1array "AUTH" write-command ;
+
+! String values
+: 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 -- ) 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 -- ) 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 ;
+ swapd 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 ;
-
-#! 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 ;
+ swapd 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 -- ) 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 ;
-
-#! 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
+ [ reverse ] dip suffix "SUNIONSTORE" write-command ;
+: smembers ( key -- ) 1array "SMEMBERS" write-command ;
+
+! Hashes
+: 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 -- )
+ 3array "HINCRBY" write-command ;
+: hincrbyfloat ( float field key -- )
+ 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 -- ) 1array "SELECT" write-command ;
+: move ( integer key -- ) 2array "MOVE" write-command ;
+: swapdb ( old new -- ) 2array "SWAPDB" 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 ;
-
-#! Remote server control
-: info ( -- ) "INFO" write crlf ;
-: monitor ( -- ) "MONITOR" write crlf ;
+! Persistence control
+: save ( -- ) { "SAVE" } write-resp ;
+: bgsave ( -- ) { "BGSAVE" } write-resp ;
+: lastsave ( -- ) { "LASTSAVE" } write-resp ;
+: shutdown ( -- ) { "SHUTDOWN" } write-resp ;
+
+! Remote server control
+: info ( -- ) { "INFO" } write-resp ;
+: monitor ( -- ) { "MONITOR" } write-resp ;
+
+! Lua
+: script-load ( script -- ) 1array { "SCRIPT" "LOAD" } write-command-multi ;
+: script-exists ( scripts -- ) { "SCRIPT" "EXISTS" } write-command-multi ;
+: script-flush ( -- ) { } { "SCRIPT" "FLUSH" } write-command-multi ;
+: script-kill ( -- ) { } { "SCRIPT" "KILL" } write-command-multi ;
+! YES | SYNC | NO
+: script-debug ( debug -- ) 1array { "SCRIPT" "DEBUG" } write-command-multi ;
+: script-evalsha ( sha keys args -- ) "EVALSHA" (script-eval) ;
+: script-eval ( script keys args -- ) "EVAL" (script-eval) ;
projects / factor.git / blobdiff