tests/support/redis.tcl

   1 # Tcl clinet library - used by test-redis.tcl script for now
   2 # Copyright (C) 2009 Salvatore Sanfilippo
   3 # Released under the BSD license like Redis itself
   4 #
   5 # Example usage:
   6 #
   7 # set r [redis 127.0.0.1 6379]
   8 # $r lpush mylist foo
   9 # $r lpush mylist bar
  10 # $r lrange mylist 0 -1
  11 # $r close
  12 #
  13 # Non blocking usage example:
  14 #
  15 # proc handlePong {r type reply} {
  16 #     puts "PONG $type '$reply'"
  17 #     if {$reply ne "PONG"} {
  18 #         $r ping [list handlePong]
  19 #     }
  20 # }
  21 #
  22 # set r [redis]
  23 # $r blocking 0
  24 # $r get fo [list handlePong]
  25 #
  26 # vwait forever
  27
  28 package require Tcl 8.5
  29 package provide redis 0.1
  30
  31 namespace eval redis {}
  32 set ::redis::id 0
  33 array set ::redis::fd {}
  34 array set ::redis::blocking {}
  35 array set ::redis::deferred {}
  36 array set ::redis::callback {}
  37 array set ::redis::state {} ;# State in non-blocking reply reading
  38 array set ::redis::statestack {} ;# Stack of states, for nested mbulks
  39 array set ::redis::bulkarg {}
  40 array set ::redis::multibulkarg {}
  41
  42 # Flag commands requiring last argument as a bulk write operation
  43 foreach redis_bulk_cmd {
  44     set setnx rpush lpush rpushx lpushx linsert lset lrem sadd srem sismember echo getset smove zadd zrem zscore zincrby append zrank zrevrank hget hdel hexists setex publish
  45 } {
  46     set ::redis::bulkarg($redis_bulk_cmd) {}
  47 }
  48
  49 # Flag commands requiring last argument as a bulk write operation
  50 foreach redis_multibulk_cmd {
  51     mset msetnx hset hsetnx hmset hmget
  52 } {
  53     set ::redis::multibulkarg($redis_multibulk_cmd) {}
  54 }
  55
  56 unset redis_bulk_cmd
  57 unset redis_multibulk_cmd
  58
  59 proc redis {{server 127.0.0.1} {port 6379} {defer 0}} {
  60     set fd [socket $server $port]
  61     fconfigure $fd -translation binary
  62     set id [incr ::redis::id]
  63     set ::redis::fd($id) $fd
  64     set ::redis::blocking($id) 1
  65     set ::redis::deferred($id) $defer
  66     ::redis::redis_reset_state $id
  67     interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
  68 }
  69
  70 proc ::redis::__dispatch__ {id method args} {
  71     set fd $::redis::fd($id)
  72     set blocking $::redis::blocking($id)
  73     set deferred $::redis::deferred($id)
  74     if {$blocking == 0} {
  75         if {[llength $args] == 0} {
  76             error "Please provide a callback in non-blocking mode"
  77         }
  78         set callback [lindex $args end]
  79         set args [lrange $args 0 end-1]
  80     }
  81     if {[info command ::redis::__method__$method] eq {}} {
  82         if {[info exists ::redis::bulkarg($method)]} {
  83             set cmd "$method "
  84             append cmd [join [lrange $args 0 end-1]]
  85             append cmd " [string length [lindex $args end]]\r\n"
  86             append cmd [lindex $args end]
  87             ::redis::redis_writenl $fd $cmd
  88         } elseif {[info exists ::redis::multibulkarg($method)]} {
  89             set cmd "*[expr {[llength $args]+1}]\r\n"
  90             append cmd "$[string length $method]\r\n$method\r\n"
  91             foreach a $args {
  92                 append cmd "$[string length $a]\r\n$a\r\n"
  93             }
  94             ::redis::redis_write $fd $cmd
  95             flush $fd
  96         } else {
  97             set cmd "$method "
  98             append cmd [join $args]
  99             ::redis::redis_writenl $fd $cmd
 100         }
 101         if {!$deferred} {
 102             if {$blocking} {
 103                 ::redis::redis_read_reply $fd
 104             } else {
 105                 # Every well formed reply read will pop an element from this
 106                 # list and use it as a callback. So pipelining is supported
 107                 # in non blocking mode.
 108                 lappend ::redis::callback($id) $callback
 109                 fileevent $fd readable [list ::redis::redis_readable $fd $id]
 110             }
 111         }
 112     } else {
 113         uplevel 1 [list ::redis::__method__$method $id $fd] $args
 114     }
 115 }
 116
 117 proc ::redis::__method__blocking {id fd val} {
 118     set ::redis::blocking($id) $val
 119     fconfigure $fd -blocking $val
 120 }
 121
 122 proc ::redis::__method__read {id fd} {
 123     ::redis::redis_read_reply $fd
 124 }
 125
 126 proc ::redis::__method__write {id fd buf} {
 127     ::redis::redis_write $fd $buf
 128 }
 129
 130 proc ::redis::__method__flush {id fd} {
 131     flush $fd
 132 }
 133
 134 proc ::redis::__method__close {id fd} {
 135     catch {close $fd}
 136     catch {unset ::redis::fd($id)}
 137     catch {unset ::redis::blocking($id)}
 138     catch {unset ::redis::state($id)}
 139     catch {unset ::redis::statestack($id)}
 140     catch {unset ::redis::callback($id)}
 141     catch {interp alias {} ::redis::redisHandle$id {}}
 142 }
 143
 144 proc ::redis::__method__channel {id fd} {
 145     return $fd
 146 }
 147
 148 proc ::redis::redis_write {fd buf} {
 149     puts -nonewline $fd $buf
 150 }
 151
 152 proc ::redis::redis_writenl {fd buf} {
 153     redis_write $fd $buf
 154     redis_write $fd "\r\n"
 155     flush $fd
 156 }
 157
 158 proc ::redis::redis_readnl {fd len} {
 159     set buf [read $fd $len]
 160     read $fd 2 ; # discard CR LF
 161     return $buf
 162 }
 163
 164 proc ::redis::redis_bulk_read {fd} {
 165     set count [redis_read_line $fd]
 166     if {$count == -1} return {}
 167     set buf [redis_readnl $fd $count]
 168     return $buf
 169 }
 170
 171 proc ::redis::redis_multi_bulk_read fd {
 172     set count [redis_read_line $fd]
 173     if {$count == -1} return {}
 174     set l {}
 175     for {set i 0} {$i < $count} {incr i} {
 176         lappend l [redis_read_reply $fd]
 177     }
 178     return $l
 179 }
 180
 181 proc ::redis::redis_read_line fd {
 182     string trim [gets $fd]
 183 }
 184
 185 proc ::redis::redis_read_reply fd {
 186     set type [read $fd 1]
 187     switch -exact -- $type {
 188         : -
 189         + {redis_read_line $fd}
 190         - {return -code error [redis_read_line $fd]}
 191         $ {redis_bulk_read $fd}
 192         * {redis_multi_bulk_read $fd}
 193         default {return -code error "Bad protocol, $type as reply type byte"}
 194     }
 195 }
 196
 197 proc ::redis::redis_reset_state id {
 198     set ::redis::state($id) [dict create buf {} mbulk -1 bulk -1 reply {}]
 199     set ::redis::statestack($id) {}
 200 }
 201
 202 proc ::redis::redis_call_callback {id type reply} {
 203     set cb [lindex $::redis::callback($id) 0]
 204     set ::redis::callback($id) [lrange $::redis::callback($id) 1 end]
 205     uplevel #0 $cb [list ::redis::redisHandle$id $type $reply]
 206     ::redis::redis_reset_state $id
 207 }
 208
 209 # Read a reply in non-blocking mode.
 210 proc ::redis::redis_readable {fd id} {
 211     if {[eof $fd]} {
 212         redis_call_callback $id eof {}
 213         ::redis::__method__close $id $fd
 214         return
 215     }
 216     if {[dict get $::redis::state($id) bulk] == -1} {
 217         set line [gets $fd]
 218         if {$line eq {}} return ;# No complete line available, return
 219         switch -exact -- [string index $line 0] {
 220             : -
 221             + {redis_call_callback $id reply [string range $line 1 end-1]}
 222             - {redis_call_callback $id err [string range $line 1 end-1]}
 223             $ {
 224                 dict set ::redis::state($id) bulk \
 225                     [expr [string range $line 1 end-1]+2]
 226                 if {[dict get $::redis::state($id) bulk] == 1} {
 227                     # We got a $-1, hack the state to play well with this.
 228                     dict set ::redis::state($id) bulk 2
 229                     dict set ::redis::state($id) buf "\r\n"
 230                     ::redis::redis_readable $fd $id
 231                 }
 232             }
 233             * {
 234                 dict set ::redis::state($id) mbulk [string range $line 1 end-1]
 235                 # Handle *-1
 236                 if {[dict get $::redis::state($id) mbulk] == -1} {
 237                     redis_call_callback $id reply {}
 238                 }
 239             }
 240             default {
 241                 redis_call_callback $id err \
 242                     "Bad protocol, $type as reply type byte"
 243             }
 244         }
 245     } else {
 246         set totlen [dict get $::redis::state($id) bulk]
 247         set buflen [string length [dict get $::redis::state($id) buf]]
 248         set toread [expr {$totlen-$buflen}]
 249         set data [read $fd $toread]
 250         set nread [string length $data]
 251         dict append ::redis::state($id) buf $data
 252         # Check if we read a complete bulk reply
 253         if {[string length [dict get $::redis::state($id) buf]] ==
 254             [dict get $::redis::state($id) bulk]} {
 255             if {[dict get $::redis::state($id) mbulk] == -1} {
 256                 redis_call_callback $id reply \
 257                     [string range [dict get $::redis::state($id) buf] 0 end-2]
 258             } else {
 259                 dict with ::redis::state($id) {
 260                     lappend reply [string range $buf 0 end-2]
 261                     incr mbulk -1
 262                     set bulk -1
 263                 }
 264                 if {[dict get $::redis::state($id) mbulk] == 0} {
 265                     redis_call_callback $id reply \
 266                         [dict get $::redis::state($id) reply]
 267                 }
 268             }
 269         }
 270     }
 271 }