X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=blobdiff_plain;f=extra%2Fredis%2Fcommand-writer%2Fcommand-writer.factor;h=6657f64b0a5bffab56afafe7de1874912ac44aa3;hp=e5e635f45770d952f28abcb2424558a2a265d950;hb=5060e8bd5fdc18dc1bea82f06cf1b9a2699441b6;hpb=028235b9ffc8972bbf74d41eee1ef970ac01d007

diff --git a/extra/redis/command-writer/command-writer.factor b/extra/redis/command-writer/command-writer.factor
index e5e635f457..6657f64b0a 100644
--- a/extra/redis/command-writer/command-writer.factor
+++ b/extra/redis/command-writer/command-writer.factor
@@ -1,104 +1,144 @@
 ! 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) ;