Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Major revision of server communication functions to eliminate in-line…

… commands in anticipation of their demise in Redis; we also tried to reduce unneccessary value copying as much as possible. We also (finally) updated the original set of unit tests.
  • Loading branch information...
commit f3471c5ba41e895cfafd6de550775e41f624b619 1 parent 34afe4f
B. W. Lewis authored
View
2  DESCRIPTION
@@ -1,7 +1,7 @@
Package: rredis
Type: Package
Title: Redis client for R
-Version: 1.1
+Version: 1.2
Date: 2010-01-26
Author: B. W. Lewis
Maintainer: B. W. Lewis <blewis@illposed.net>
View
6 NEWS
@@ -0,0 +1,6 @@
+Significant changes in version 1.2:
+
+1. We completely revamped communication with the Redis server, eliminating
+ in-line messaging in anticipation of it's demise in future Redis versions.
+ We also make a better effort to minimize copying by R prior to sending
+ a message.
View
41 R/allValCMD.R
@@ -1,65 +1,64 @@
# This file contains functions that operate on all kinds of Redis values.
+# msg <- .redismsg(
redisExists <- function(key)
{
- msg <- paste('EXISTS ',key,'\r\n',sep='')
- .sendCmd(msg)==1
+ .redisCmd(.raw('EXISTS'), .raw(key)) == '1'
}
redisDelete <- function(key)
{
- nkeys <- length(key)
- if (nkeys > 1) {
- key <- paste(key, collapse=' ')
- }
- msg <- paste('DEL ',key,'\r\n',sep='')
- ans <- .sendCmd(msg)
+ keylist <- as.list(key)
+ nkeys <- length(keylist)
+ ans <- do.call('.redisCmd',lapply(c(list('DEL'),keylist),charToRaw))
if (ans == 0) warning(paste('No keys were deleted!'))
- else if(nkeys != ans)
- warning(paste(as.character(ans), ' keys were deleted, but ',
- as.character(nkeys - ans), ' were not!', sep=''))
+ else if(nkeys != ans) {
+ w1 = ifelse(ans==1,'was','were')
+ w2 = ifelse((nkeys-ans)==1,' was',' were')
+ warning(paste(as.character(ans), ' keys ',w1,' deleted, but ',
+ as.character(nkeys - ans), w2, ' not!', sep=''))
+ }
ans==nkeys
}
redisType <- function(key)
{
- msg <- paste('TYPE ',key,'\r\n',sep='')
- .sendCmd(msg)
+ .redisCmd(.raw('TYPE'), .raw(key))
}
redisKeys <- function(pattern="*")
{
- .sendCmd(.redismsg('KEYS',pattern))
+ .redisCmd(.raw('KEYS'), .raw(pattern))
}
redisRandomKey <- function()
{
- .sendCmd(.redismsg('RANDOMKEY'))
+ .redisCmd(.raw('RANDOMKEY'))
}
redisRename <- function(old, new, NX=FALSE)
{
- if (NX) cmd <- 'RENAMENX ' else cmd <- 'RENAME '
- ret <- .sendCmd(.redismsg(cmd,old,new))
+ if (NX) cmd <- 'RENAMENX' else cmd <- 'RENAME'
+ ret <- .redisCmd(.raw(cmd),.raw(old),.raw(new))
if (NX) 1==ret else ret
}
redisExpire <- function(key, seconds)
{
- 1==.sendCmd(.redismsg('EXPIRE',key,seconds))
+ 1 == .redisCmd(.raw('EXPIRE'),.raw(key),.raw(as.character(seconds)))
}
redisExpireAt <- function(key, time)
{
- 1==.sendCmd(.redismsg('EXPIREAT',key,time))
+ 1 == .redisCmd(.raw('EXPIREAT'),.raw(key),.raw(as.character(time)))
}
redisTTL <- function(key)
{
- .sendCmd(.redismsg('TTL',key))
+ .redisCmd(.raw('TTL'),.raw(key))
}
redisMove <- function(key, dbindex)
{
- 1==.sendCmd(.redismsg('MOVE',key,dbindex))
+ 1 == .redisCmd(.raw('MOVE'),.raw(key),.raw(as.character(dbindex)))
}
View
22 R/controlCMD.R
@@ -29,38 +29,38 @@ function()
`redisAuth` <-
function(pwd)
{
- .sendCmd(.redismsg('AUTH',pwd))
+ .redisCmd(.raw('AUTH'), .raw(pwd))
}
`redisSave` <-
function()
{
- .sendCmd(.redismsg('SAVE'))
+ .redisCmd(.raw('SAVE'))
}
`redisBgSave` <-
function()
{
- .sendCmd(.redismsg('BGSAVE'))
+ .redisCmd(.raw('BGSAVE'))
}
`redisBgRewriteAOF` <-
function()
{
- .sendCmd(.redismsg('BGREWRITEAOF'))
+ .redisCmd(.raw('BGREWRITEAOF'))
}
`redisShutdown` <-
function()
{
- .sendCmd(.redismsg('SHUTDOWN'))
+ .redisCmd(.raw('SHUTDOWN'))
remove(list='con',envir=.redisEnv)
}
`redisInfo` <-
function()
{
- x <- .sendCmd(.redismsg('INFO'))
+ x <- .redisCmd(.raw('INFO'))
z <- strsplit(x,'\r\n')
w <- unlist(lapply(z,strsplit,':'))
n <- length(w)
@@ -75,22 +75,22 @@ function()
function(host,port)
{
# Use host="no" port="one" to disable slave replication
- .sendCmd(.redismsg('SLAVEOF'),host,port)
+ .redisCmd(.raw('SLAVEOF'),.raw(as.character(host)), .raw(as.character(port)))
}
redisFlushDB <- function() {
- .sendCmd(.redismsg('FLUSHDB'))
+ .redisCmd(.raw('FLUSHDB'))
}
redisFlushAll <- function() {
- .sendCmd(.redismsg('FLUSHALL'))
+ .redisCmd(.raw('FLUSHALL'))
}
redisSelect <- function(index) {
- .sendCmd(.redismsg('SELECT',index))
+ .redisCmd(.raw('SELECT'),.raw(as.character(index)))
}
redisDBSize <- function() {
- .sendCmd(.redismsg('DBSIZE'))
+ .redisCmd(.raw('DBSIZE'))
}
View
47 R/listCMD.R
@@ -1,62 +1,59 @@
# This file contains functions that operate on Redis lists.
redisRPush <- function(key, value) {
- value <- .cerealize(value)
- .sendCmd(.redismsg('RPUSH',key,length(value)), value)
+ .redisCmd(.raw('RPUSH'), .raw(key),value)
}
redisLPush <- function(key, value) {
- value <- .cerealize(value)
- .sendCmd(.redismsg('LPUSH',key,length(value)), value)
+ .redisCmd(.raw('LPUSH'), .raw(key),value)
+}
+
+redisRPop <- function(key) {
+ .redisCmd(.raw('RPOP'), .raw(key))
+}
+
+redisLPop <- function(key) {
+ .redisCmd(.raw('LPOP'), .raw(key))
}
redisLLen <- function(key) {
- .sendCmd(.redismsg('LLEN',key))
+ .redisCmd(.raw('LLEN'), .raw(key))
}
redisLRange <- function(key, start, end) {
start <- charToRaw(as.character(start))
end <- charToRaw(as.character(end))
- cmd <- list(LRANGE=charToRaw(key),start,end)
- .sendCmdMulti(cmd)
+ .redisCmd(.raw('LRANGE'), .raw(key), start, end)
}
redisLTrim <- function(key,start,end) {
start <- charToRaw(as.character(start))
end <- charToRaw(as.character(end))
- cmd <- list(LTRIM=charToRaw(key),start,end)
- .sendCmdMulti(cmd) == "OK"
+ .redisCmd(.raw('LTRIM'), .raw(key), start, end)
}
redisLIndex <- function(key, index) {
- .sendCmd(.redismsg('LINDEX', key, index))
+ .redisCmd(.raw('LINDEX'), .raw(key), index)
}
redisLSet <- function(key, index, value) {
key <- charToRaw(as.character(key))
index <- charToRaw(as.character(index))
- cmd <- list(LSET=key,index,value)
- .sendCmdMulti(cmd) == "OK"
+ .redisCmd(.raw('LSET'), key, index, value) == 'OK'
}
redisLRem <- function(key, count, value) {
- .sendCmd(.redismsg('LREM', key, count, value))
-}
-
-redisRPop <- function(key) {
- .sendCmd(.redismsg('RPOP', key))
-}
-
-redisLPop <- function(key) {
- .sendCmd(.redismsg('LPOP', key))
+ .redisCmd(.raw('LREM'), .raw(key), .raw(as.character(count)), value)
}
redisRPopLPush <- function(src, dest) {
- .sendCmd(.redismsg('RPOPLPUSH',src,dest))
+ .redisCmd(.raw('RPOPLPUSH'), .raw(src), .raw(dest))
}
redisBRPop <- function(keys, timeout=0) {
- x <- .sendCmd(.redismsg('BRPOP', paste(keys, collapse=' '), timeout))
+ keylist <- as.list(keys)
+ tout <- as.character(timeout)
+ x <- do.call('.redisCmd',lapply(c(list('BRPOP'),keylist,tout),charToRaw))
if(length(x)>1) {
n <- x[[1]]
x <- list(x[[2]])
@@ -66,7 +63,9 @@ redisBRPop <- function(keys, timeout=0) {
}
redisBLPop <- function(keys, timeout=0) {
- x <- .sendCmd(.redismsg('BLPOP', paste(keys, collapse=' '), timeout))
+ keylist <- as.list(keys)
+ tout <- as.character(timeout)
+ x <- do.call('.redisCmd',lapply(c(list('BLPOP'),keylist,tout),charToRaw))
if(length(x)>1) {
n <- x[[1]]
x <- list(x[[2]])
View
85 R/redis-internal.R
@@ -23,7 +23,7 @@
.redisPP <- function()
{
# Ping-pong
- .sendCmd('PING\r\n')
+ .redisCmd(.raw('PING'))
}
.cerealize <- function(value)
@@ -32,13 +32,8 @@
else value
}
-.redismsg <- function(...)
-{
- dat <- list(...)
- paste(paste(dat,collapse=' '), '\r\n', sep='')
-}
-.getResponse <- function(names=NULL)
+.getResponse <- function()
{
con <- .redis()
socketSelect(list(con))
@@ -103,7 +98,6 @@
numVars <- as.numeric(substr(l,2,nchar(l)))
if(numVars > 0) {
vals <- vector('list',numVars)
- if(!is.null(names)) names(vals) <- names
for (i in 1:numVars) {
# XXX This extra copy is unfortunate, but so is the default R behavior:
# assigning a list entry to NULL removes it from the list!
@@ -117,50 +111,47 @@
stop('Unknown message type'))
}
-.sendCmd <- function(cmd, bin=NULL, checkResponse=TRUE, ...)
+#
+# .raw is just a shorthand wrapper for charToRaw:
+#
+.raw <- function(word)
+{
+ charToRaw(word)
+}
+
+# .redisCmd corresponds to the Redis "multi bulk" protocol. It
+# expects an argument list of command elements. Arguments that
+# are not of type raw are serialized.
+# Examples:
+# .redisCmd(.raw('INFO'))
+# .redisCmd(.raw('SET'),.raw('X'), runif(5))
+#
+# We use match.call here instead of, for example, as.list() to try to
+# avoid making unnecessary copies of (potentially large) function arguments.
+#
+# We can further improve this by writing a shadow serialization routine that
+# quickly computes the length of a serialized object without serializing it.
+# Then, we could serialize directly to the connection, avoiding the temporary
+# copy (which, unfortunately, is limited to 2GB due to R indexing).
+.redisCmd <- function(...)
{
con <- .redis()
+ f <- match.call()
+ n <- length(f) - 1
+ hdr <- paste('*', as.character(n), '\r\n',sep='')
socketSelect(list(con), write=TRUE)
- cat(cmd, file=con)
- if (!is.null(bin)) {
+ cat(hdr, file=con)
+ for(j in 1:n) {
+ v <- eval(f[[j+1]],envir=sys.frame(-1))
+ if(!is.raw(v)) v <- .cerealize(v)
+ l <- length(v)
+ hdr <- paste('$', as.character(l), '\r\n', sep='')
+ socketSelect(list(con), write=TRUE)
+ cat(hdr, file=con)
socketSelect(list(con), write=TRUE)
- writeBin(bin, con)
+ writeBin(v, con)
socketSelect(list(con), write=TRUE)
cat('\r\n', file=con)
}
- if (checkResponse) .getResponse(...)
-}
-
-# Requires a list of key1=value1, key2=value2, ...
-# This represents the multi-bulk send protocol. Keys are sent as plain
-# text (not as R objects), values as serialized objects.
-# NA or zero-length keys are allowed, for example:
-# list(SADD=charToRaw("mykey"), myvalue)
-# NA or zero-length keys are simply skipped in the outgoing message.
-.sendCmdMulti <- function(keyvalues, ...)
-{
- numItems <- length(keyvalues)
- keys <- names(keyvalues)
- if(is.null(keys)) {
- names(keyvalues) <- NA
- keys <- names(keyvalues)
- }
- n <- numItems + length(keys[(nchar(keys)!=0) & !is.na(keys)])
- foo <- paste('*', as.character(n), '\r\n',sep='')
- .sendCmd(foo,checkResponse=FALSE)
- for (i in 1:numItems) {
- if((nchar(keys[[i]])>0) & (!is.na(keys[[i]]))) {
- foo <- paste('$', as.character(nchar(keys[[i]])), '\r\n',
- keys[[i]], '\r\n', sep='')
- .sendCmd(foo, checkResponse=FALSE)
- }
- keyvalues[[i]] <- .cerealize(keyvalues[[i]])
- l <- length(keyvalues[[i]])
- if(l>0) {
- bar <- paste('$', as.character(l), '\r\n', sep='')
- .sendCmd(bar, bin = keyvalues[[i]], checkResponse=FALSE)
- .sendCmd('\r\n', checkResponse=FALSE)
- }
- }
- .getResponse(...)
+ .getResponse()
}
View
51 R/setVal.R
@@ -1,96 +1,77 @@
redisSInter <- function(keys, ...)
{
sets <- c(as.list(keys),list(...))
- cmd <- list(charToRaw('SINTER'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SINTER'),sets),charToRaw))
}
redisSUnion <- function(keys, ...)
{
sets <- c(as.list(keys),list(...))
- cmd <- list(charToRaw('SUNION'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SUNION'),sets),charToRaw))
}
redisSUnionStore <- function(dest, keys, ...)
{
sets <- c(as.list(dest),as.list(keys),list(...))
- cmd <- list(charToRaw('SUNIONSTORE'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SUNIONSTORE'),sets),charToRaw))
}
redisSInterStore <- function(dest, keys, ...)
{
sets <- c(as.list(dest),as.list(keys),list(...))
- cmd <- list(charToRaw('SINTERSTORE'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SINTERSTORE'),sets),charToRaw))
}
redisSDiff <- function(keys, ...)
{
sets <- c(as.list(keys),list(...))
- cmd <- list(charToRaw('SDIFF'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SDIFF'),sets),charToRaw))
}
redisSDiffStore <- function(dest, keys, ...)
{
sets <- c(as.list(dest),as.list(keys),list(...))
- cmd <- list(charToRaw('SDIFFSTORE'))
- cmd <- c(cmd, lapply(sets,charToRaw))
- .sendCmdMulti(cmd)
+ do.call('.redisCmd',lapply(c(list('SDIFFSTORE'),sets),charToRaw))
}
redisSIsMember <- function(set, element)
{
- cmd <- list(SISMEMBER=charToRaw(set),element)
- 1 == .sendCmdMulti(cmd)
+ set <- as.character(set)
+ element <- as.character(element)
+ 1 == .redisCmd(.raw('SISMEMBER'),.raw(set),.raw(element))
}
redisSRandMember <- function(set)
{
- cmd <- list(SRANDMEMBER=charToRaw(set))
- .sendCmdMulti(cmd)
+ .redisCmd(.raw('SRANDMEMBER'),.raw(set))
}
redisSAdd <- function(set, element)
{
- cmd <- list(SADD=charToRaw(set),element)
- .sendCmdMulti(cmd) == 1
+ .redisCmd(.raw('SADD'),.raw(set),element)
}
redisSPop <- function(set)
{
- msg <- paste('SPOP ',set,'\r\n',sep='')
- .sendCmd(msg)
+ .redisCmd(.raw('SPOP'),.raw(set))
}
redisSMembers <- function(set)
{
- msg <- paste('SMEMBERS ',set,'\r\n',sep='')
- .sendCmd(msg)
+ .redisCmd(.raw('SMEMBERS'),.raw(set))
}
redisSRem <- function(set, element)
{
- cmd <- list(SREM=charToRaw(set),element)
- .sendCmdMulti(cmd) == 1
+ .redisCmd(.raw('SREM'),.raw(set),element)
}
redisSCard <- function(set)
{
- msg <- paste('SCARD ',set,'\r\n',sep='')
- .sendCmd(msg)
+ .redisCmd(.raw('SCARD'),.raw(set))
}
redisSMove <- function(setA, setB, element)
{
- cmd <- list(SMOVE=charToRaw(setA),charToRaw(setB),element)
- .sendCmdMulti(cmd) == 1
+ .redisCmd(.raw('SMOVE'),.raw(setA),.raw(setB),element)
}
-
View
43 R/strValCMD.R
@@ -1,59 +1,56 @@
# This file contains functions that operate on Redis 'string' values.
redisGet <- function(key) {
- .sendCmd(.redismsg('GET',key))
+ .redisCmd(.raw('GET'), .raw(key))
}
-# This is only useful right now because it is faster than mset.
-# We could probably roll them together, but I'm not sure if that
-# will be a pain later. -PS
redisSet <- function(key, value, NX=FALSE) {
value <- .cerealize(value)
- if (NX) cmd <- 'SETNX ' else cmd <- 'SET '
- msg <- paste(cmd,key,' ',length(value),'\r\n',sep='')
- retval <- .sendCmd(msg,value)
+ cmd <- 'SET'
+ if(NX) cmd <- 'SETNX'
+ retval <- .redisCmd(.raw(cmd), .raw(key), value)
if(NX) 1 == retval
- else "OK" == retval
+ else 'OK' == retval
}
redisGetSet <- function(key, value) {
- value <- .cerealize(value)
- msg <- paste('GETSET ',key,' ',length(value),'\r\n',sep='')
- .sendCmd(msg,value)
+ .redisCmd(.raw('GETSET'),.raw(key),value)
}
redisMGet <- function(keys) {
-# keylist <- as.list(keys)
-# cmd <- list(charToRaw('MGET'))
-# cmd <- c(cmd, lapply(keylist,charToRaw))
-# .sendCmdMulti(cmd, names=keys)
- .sendCmd(.redismsg('MGET',paste(keys,collapse=' ')),names=keys)
+ keylist <- as.list(keys)
+ x <- do.call('.redisCmd',lapply(c(list('MGET'),keylist),charToRaw))
+ names(x) <- keylist
+ x
}
redisMSet <- function(keyvalues, NX=FALSE) {
if (NX) cmd <- 'MSETNX' else cmd <- 'MSET'
- cmd <- c(list(charToRaw(cmd)),keyvalues)
- retval <- .sendCmdMulti(cmd)
+ a <- c(alist(),list(.raw(cmd)))
+ rawnames <- lapply(as.list(names(keyvalues)),charToRaw)
+ for(j in 1:length(keyvalues))
+ a <- c(a,list(rawnames[[j]],keyvalues[[j]]))
+ retval <- do.call('.redisCmd', a)
if(NX) 1 == retval
- else "OK" == retval
+ else 'OK' == retval
}
redisIncr <- function(key)
{
- .sendCmd(.redismsg('INCR',key))
+ .redisCmd(.raw('INCR'),.raw(key))
}
redisIncrBy <- function(key, value)
{
- .sendCmd(.redismsg('INCRBY',key,value))
+ .redisCmd(.raw('INCRBY'),.raw(key),.raw(as.character(value)))
}
redisDecrBy <- function(key, value)
{
- .sendCmd(.redismsg('DECRBY',key,value))
+ .redisCmd(.raw('DECRBY'),.raw(key),.raw(as.character(value)))
}
redisDecr <- function(key)
{
- .sendCmd(.redismsg('DECR',key))
+ .redisCmd(.raw('DECR'),.raw(key))
}
View
25 test/basicTest.R
@@ -4,22 +4,25 @@ test01 <- function() {
test02 <- function() {
# legacy exists test
+ redisFlushAll()
checkEquals(FALSE, redisExists('foo'))
}
test03 <- function() {
# delete test
+ redisFlushAll()
checkEquals(FALSE, suppressWarnings(redisDelete('foo')))
}
test04 <- function() {
# empty get test
+ redisFlushAll()
checkTrue(is.null(redisGet('foo')))
}
test05 <- function() {
# simple set test
- checkEquals('OK', redisSet('foo', 'bar'))
+ checkEquals(TRUE, redisSet('foo', 'bar'))
}
test06 <- function() {
@@ -48,12 +51,12 @@ test10 <- function() {
# mget test
redisSet('foo', 'bar')
redisSet('bar', 'foo')
- checkEquals(list('bar', 'foo'), redisMGet(c('foo', 'bar')))
+ checkEquals(list(foo='bar', bar='foo'), redisMGet(c('foo', 'bar')))
}
test11 <- function() {
# simple mset test
- checkEquals('OK', redisMSet(c('foo'), c('foo')))
+ checkEquals(TRUE, redisMSet(list(foo='foo',bar='bar')))
}
test12 <- function() {
@@ -64,8 +67,8 @@ test12 <- function() {
test13 <- function() {
# real mset test
redisDelete(c('foo', 'bar'))
- redisMSet(c('foo', 'bar'), c('foo','bar'))
- checkEquals(list('foo', 'bar'), redisMGet(c('foo', 'bar')))
+ redisMSet(list(foo='bar',bar='foo'))
+ checkEquals(list(foo='bar',bar='foo'), redisMGet(c('foo', 'bar')))
redisDelete(c('foo', 'bar'))
}
@@ -79,9 +82,10 @@ test14 <- function() {
test15 <- function() {
# keys test
- checkEquals('', redisKeys('*'))
+ redisFlushAll()
+ checkEquals(NULL, redisKeys('*'))
redisSet('foo', 1)
- checkEquals('foo', redisKeys('*'))
+ checkEquals(list('foo'), redisKeys('*'))
redisDelete('foo')
}
@@ -118,11 +122,12 @@ test18 <- function() {
test19 <- function() {
# set/mset nx mode test
+ redisFlushAll()
checkTrue(redisSet('foo', 1, NX=TRUE))
checkEquals(FALSE, redisSet('foo', 1, NX=TRUE))
- checkEquals(FALSE, redisMSet('foo', 1, NX=TRUE))
- redisDelete(c('foo','bar'))
- checkTrue(redisMSet(c('foo','bar'), c(1,2), NX=TRUE))
+ checkEquals(FALSE, redisMSet(list(foo=1), NX=TRUE))
+ redisDelete('foo')
+ checkTrue(redisMSet(list(foo=1,bar=2), NX=TRUE))
redisDelete(c('foo','bar'))
}
View
1  test/runTest.R
@@ -1,4 +1,3 @@
require(rredis)
require(RUnit)
runTestFile('basicTest.R')
-
Please sign in to comment.
Something went wrong with that request. Please try again.