Copyright date fixed in COPYING file.

[redis.git] / tests / support / redis.tcl

diff --git a/tests/support/redis.tcl b/tests/support/redis.tcl
index 0f4e401ffc1d5881f99ca77ed0a5abd88d890e90..99415b6409e91272862f696ac9829a894db305a5 100644 (file)
--- a/tests/support/redis.tcl
+++ b/tests/support/redis.tcl
@@ -32,35 +32,18 @@ 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

-array set ::redis::bulkarg {}
-array set ::redis::multibulkarg {}

 
 

-# Flag commands requiring last argument as a bulk write operation
-foreach redis_bulk_cmd {
-    set setnx rpush lpush lset lrem sadd srem sismember echo getset smove zadd zrem zscore zincrby append zrank zrevrank hget hdel hexists setex
-} {
-    set ::redis::bulkarg($redis_bulk_cmd) {}
-}
-
-# Flag commands requiring last argument as a bulk write operation
-foreach redis_multibulk_cmd {
-    mset msetnx hset hsetnx hmset hmget
-} {
-    set ::redis::multibulkarg($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 +51,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"


@@ -76,33 +60,24 @@ proc ::redis::__dispatch__ {id method args} {
         set args [lrange $args 0 end-1]
     }
     if {[info command ::redis::__method__$method] eq {}} {
         set args [lrange $args 0 end-1]
     }
     if {[info command ::redis::__method__$method] eq {}} {

-        if {[info exists ::redis::bulkarg($method)]} {
-            set cmd "$method "
-            append cmd [join [lrange $args 0 end-1]]
-            append cmd " [string length [lindex $args end]]\r\n"
-            append cmd [lindex $args end]
-            ::redis::redis_writenl $fd $cmd
-        } elseif {[info exists ::redis::multibulkarg($method)]} {
-            set cmd "*[expr {[llength $args]+1}]\r\n"
-            append cmd "$[string length $method]\r\n$method\r\n"
-            foreach a $args {
-                append cmd "$[string length $a]\r\n$a\r\n"
-            }
-            ::redis::redis_write $fd $cmd
-            flush $fd
-        } else {
-            set cmd "$method "
-            append cmd [join $args]
-            ::redis::redis_writenl $fd $cmd
+        set cmd "*[expr {[llength $args]+1}]\r\n"
+        append cmd "$[string length $method]\r\n$method\r\n"
+        foreach a $args {
+            append cmd "$[string length $a]\r\n$a\r\n"

         }
         }

-        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]
+        ::redis::redis_write $fd $cmd
+        flush $fd
+
+        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 +89,18 @@ 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__write {id fd buf} {
+    ::redis::redis_write $fd $buf
+}
+
+proc ::redis::__method__flush {id fd} {
+    flush $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)}


@@ -155,9 +142,15 @@ proc ::redis::redis_multi_bulk_read fd {
     set count [redis_read_line $fd]
     if {$count == -1} return {}
     set l {}
     set count [redis_read_line $fd]
     if {$count == -1} return {}
     set l {}

+    set err {}

     for {set i 0} {$i < $count} {incr i} {
     for {set i 0} {$i < $count} {incr i} {

-        lappend l [redis_read_reply $fd]
+        if {[catch {
+            lappend l [redis_read_reply $fd]
+        } e] && $err eq {}} {
+            set err $e
+        }

     }
     }

+    if {$err ne {}} {return -code error $err}

     return $l
 }
 
     return $l
 }
 


@@ -173,7 +166,7 @@ proc ::redis::redis_read_reply fd {
         - {return -code error [redis_read_line $fd]}
         $ {redis_bulk_read $fd}
         * {redis_multi_bulk_read $fd}
         - {return -code error [redis_read_line $fd]}
         $ {redis_bulk_read $fd}
         * {redis_multi_bulk_read $fd}

-        default {return -code error "Bad protocol, $type as reply type byte"}
+        default {return -code error "Bad protocol, '$type' as reply type byte"}

     }
 }
 
     }
 }