tests for BLPOP/BRPOP via an option in the tcl client that defers reading the reply

diff --git a/tests/support/redis.tcl b/tests/support/redis.tcl
index 8f7d77114947948b0a6a637441e7f6b027c9a65f..338dcf77e07c3e654bd24bca67431490c6f48e10 100644 (file)
--- a/tests/support/redis.tcl
+++ b/tests/support/redis.tcl
@@ -32,6 +32,7 @@ namespace eval redis {}
 set ::redis::id 0
 array set ::redis::fd {}
 array set ::redis::blocking {}
 set ::redis::id 0
 array set ::redis::fd {}
 array set ::redis::blocking {}

+array set ::redis::deferred {}

 array set ::redis::callback {}
 array set ::redis::state {} ;# State in non-blocking reply reading
 array set ::redis::statestack {} ;# Stack of states, for nested mbulks
 array set ::redis::callback {}
 array set ::redis::state {} ;# State in non-blocking reply reading
 array set ::redis::statestack {} ;# Stack of states, for nested mbulks


@@ -55,12 +56,13 @@ foreach redis_multibulk_cmd {
 unset redis_bulk_cmd
 unset redis_multibulk_cmd
 
 unset redis_bulk_cmd
 unset redis_multibulk_cmd
 

-proc redis {{server 127.0.0.1} {port 6379}} {
+proc redis {{server 127.0.0.1} {port 6379} {defer 0}} {

     set fd [socket $server $port]
     fconfigure $fd -translation binary
     set id [incr ::redis::id]
     set ::redis::fd($id) $fd
     set ::redis::blocking($id) 1
     set fd [socket $server $port]
     fconfigure $fd -translation binary
     set id [incr ::redis::id]
     set ::redis::fd($id) $fd
     set ::redis::blocking($id) 1

+    set ::redis::deferred($id) $defer

     ::redis::redis_reset_state $id
     interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
 }
     ::redis::redis_reset_state $id
     interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
 }


@@ -68,6 +70,7 @@ proc redis {{server 127.0.0.1} {port 6379}} {
 proc ::redis::__dispatch__ {id method args} {
     set fd $::redis::fd($id)
     set blocking $::redis::blocking($id)
 proc ::redis::__dispatch__ {id method args} {
     set fd $::redis::fd($id)
     set blocking $::redis::blocking($id)

+    set deferred $::redis::deferred($id)

     if {$blocking == 0} {
         if {[llength $args] == 0} {
             error "Please provide a callback in non-blocking mode"
     if {$blocking == 0} {
         if {[llength $args] == 0} {
             error "Please provide a callback in non-blocking mode"


@@ -95,14 +98,16 @@ proc ::redis::__dispatch__ {id method args} {
             append cmd [join $args]
             ::redis::redis_writenl $fd $cmd
         }
             append cmd [join $args]
             ::redis::redis_writenl $fd $cmd
         }

-        if {$blocking} {
-            ::redis::redis_read_reply $fd
-        } else {
-            # Every well formed reply read will pop an element from this
-            # list and use it as a callback. So pipelining is supported
-            # in non blocking mode.
-            lappend ::redis::callback($id) $callback
-            fileevent $fd readable [list ::redis::redis_readable $fd $id]
+        if {!$deferred} {
+            if {$blocking} {
+                ::redis::redis_read_reply $fd
+            } else {
+                # Every well formed reply read will pop an element from this
+                # list and use it as a callback. So pipelining is supported
+                # in non blocking mode.
+                lappend ::redis::callback($id) $callback
+                fileevent $fd readable [list ::redis::redis_readable $fd $id]
+            }

         }
     } else {
         uplevel 1 [list ::redis::__method__$method $id $fd] $args
         }
     } else {
         uplevel 1 [list ::redis::__method__$method $id $fd] $args


@@ -114,6 +119,10 @@ proc ::redis::__method__blocking {id fd val} {
     fconfigure $fd -blocking $val
 }
 
     fconfigure $fd -blocking $val
 }
 

+proc ::redis::__method__read {id fd} {
+    ::redis::redis_read_reply $fd
+}
+

 proc ::redis::__method__close {id fd} {
     catch {close $fd}
     catch {unset ::redis::fd($id)}
 proc ::redis::__method__close {id fd} {
     catch {close $fd}
     catch {unset ::redis::fd($id)}

diff --git a/tests/support/test.tcl b/tests/support/test.tcl
index 988189bfa10887fbce8cbfe3fedf5290f1a75325..8849c9d6ab7501bf7ca173ec97c38f8e9482edba 100644 (file)
--- a/tests/support/test.tcl
+++ b/tests/support/test.tcl
@@ -17,7 +17,7 @@ proc assert_equal {expected value} {
 }
 
 proc assert_error {pattern code} {
 }
 
 proc assert_error {pattern code} {

-    if {[catch $code error]} {
+    if {[catch {uplevel 1 $code} error]} {

         assert_match $pattern $error
     } else {
         puts "!! ERROR\nExpected an error but nothing was catched"
         assert_match $pattern $error
     } else {
         puts "!! ERROR\nExpected an error but nothing was catched"

diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
index da6520a361dcf34837453606e356b68a0a840cd9..dac91bef3974196f7c04dd29a1e269f7cca50a01 100644 (file)
--- a/tests/test_helper.tcl
+++ b/tests/test_helper.tcl
@@ -42,6 +42,22 @@ proc r {args} {
     [srv $level "client"] {*}$args
 }
 
     [srv $level "client"] {*}$args
 }
 

+proc redis_deferring_client {args} {
+    set level 0
+    if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+
+    # create client that defers reading reply
+    set client [redis [srv $level "host"] [srv $level "port"] 1]
+
+    # select the right db and read the response (OK)
+    $client select 9
+    $client read
+    return $client
+}
+

 # Provide easy access to INFO properties. Same semantic as "proc r".
 proc s {args} {
     set level 0
 # Provide easy access to INFO properties. Same semantic as "proc r".
 proc s {args} {
     set level 0

diff --git a/tests/unit/type/list.tcl b/tests/unit/type/list.tcl
index ecae5d228f09f92e1b0fd6bce01d8bb1eea43864..498cdfbb0d0d3a61c398a1a89a9e37479eaaebb7 100644 (file)
--- a/tests/unit/type/list.tcl
+++ b/tests/unit/type/list.tcl
@@ -78,6 +78,99 @@ start_server {
         assert_encoding linkedlist $key
     }
 
         assert_encoding linkedlist $key
     }
 

+    foreach type {ziplist linkedlist} {
+        test "BLPOP, BRPOP: single existing list - $type" {
+            set rd [redis_deferring_client]
+            create_$type blist {a b c d}
+
+            $rd blpop blist 1
+            assert_equal {blist a} [$rd read]
+            $rd brpop blist 1
+            assert_equal {blist d} [$rd read]
+
+            $rd blpop blist 1
+            assert_equal {blist b} [$rd read]
+            $rd brpop blist 1
+            assert_equal {blist c} [$rd read]
+        }
+
+        test "BLPOP, BRPOP: multiple existing lists - $type" {
+            set rd [redis_deferring_client]
+            create_$type blist1 {a b c}
+            create_$type blist2 {d e f}
+
+            $rd blpop blist1 blist2 1
+            assert_equal {blist1 a} [$rd read]
+            $rd brpop blist1 blist2 1
+            assert_equal {blist1 c} [$rd read]
+            assert_equal 1 [r llen blist1]
+            assert_equal 3 [r llen blist2]
+
+            $rd blpop blist2 blist1 1
+            assert_equal {blist2 d} [$rd read]
+            $rd brpop blist2 blist1 1
+            assert_equal {blist2 f} [$rd read]
+            assert_equal 1 [r llen blist1]
+            assert_equal 1 [r llen blist2]
+        }
+
+        test "BLPOP, BRPOP: second list has an entry - $type" {
+            set rd [redis_deferring_client]
+            r del blist1
+            create_$type blist2 {d e f}
+
+            $rd blpop blist1 blist2 1
+            assert_equal {blist2 d} [$rd read]
+            $rd brpop blist1 blist2 1
+            assert_equal {blist2 f} [$rd read]
+            assert_equal 0 [r llen blist1]
+            assert_equal 1 [r llen blist2]
+        }
+    }
+
+    foreach {pop} {BLPOP BRPOP} {
+        test "$pop: with single empty list argument" {
+            set rd [redis_deferring_client]
+            r del blist1
+            $rd $pop blist1 1
+            r rpush blist1 foo
+            assert_equal {blist1 foo} [$rd read]
+            assert_equal 0 [r exists blist1]
+        }
+
+        test "$pop: second argument is not a list" {
+            set rd [redis_deferring_client]
+            r del blist1 blist2
+            r set blist2 nolist
+            $rd $pop blist1 blist2 1
+            assert_error "ERR*wrong kind*" {$rd read}
+        }
+
+        test "$pop: timeout" {
+            set rd [redis_deferring_client]
+            r del blist1 blist2
+            $rd $pop blist1 blist2 1
+            assert_equal {} [$rd read]
+        }
+
+        test "$pop: arguments are empty" {
+            set rd [redis_deferring_client]
+            r del blist1 blist2
+
+            $rd $pop blist1 blist2 1
+            r rpush blist1 foo
+            assert_equal {blist1 foo} [$rd read]
+            assert_equal 0 [r exists blist1]
+            assert_equal 0 [r exists blist2]
+
+            $rd $pop blist1 blist2 1
+            r rpush blist2 foo
+            assert_equal {blist2 foo} [$rd read]
+            assert_equal 0 [r exists blist1]
+            assert_equal 0 [r exists blist2]
+        }
+    }
+

     test {LPUSHX, RPUSHX - generic} {
         r del xlist
         assert_equal 0 [r lpushx xlist a]
     test {LPUSHX, RPUSHX - generic} {
         r del xlist
         assert_equal 0 [r lpushx xlist a]