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
  40 proc redis {{server 127.0.0.1} {port 6379} {defer 0}} {
  41     set fd [socket $server $port]
  42     fconfigure $fd -translation binary
  43     set id [incr ::redis::id]
  44     set ::redis::fd($id) $fd
  45     set ::redis::blocking($id) 1
  46     set ::redis::deferred($id) $defer
  47     ::redis::redis_reset_state $id
  48     interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
  49 }
  50
  51 proc ::redis::__dispatch__ {id method args} {
  52     set fd $::redis::fd($id)
  53     set blocking $::redis::blocking($id)
  54     set deferred $::redis::deferred($id)
  55     if {$blocking == 0} {
  56         if {[llength $args] == 0} {
  57             error "Please provide a callback in non-blocking mode"
  58         }
  59         set callback [lindex $args end]
  60         set args [lrange $args 0 end-1]
  61     }
  62     if {[info command ::redis::__method__$method] eq {}} {
  63         set cmd "*[expr {[llength $args]+1}]\r\n"
  64         append cmd "$[string length $method]\r\n$method\r\n"
  65         foreach a $args {
  66             append cmd "$[string length $a]\r\n$a\r\n"
  67         }
  68         ::redis::redis_write $fd $cmd
  69         flush $fd
  70
  71         if {!$deferred} {
  72             if {$blocking} {
  73                 ::redis::redis_read_reply $fd
  74             } else {
  75                 # Every well formed reply read will pop an element from this
  76                 # list and use it as a callback. So pipelining is supported
  77                 # in non blocking mode.
  78                 lappend ::redis::callback($id) $callback
  79                 fileevent $fd readable [list ::redis::redis_readable $fd $id]
  80             }
  81         }
  82     } else {
  83         uplevel 1 [list ::redis::__method__$method $id $fd] $args
  84     }
  85 }
  86
  87 proc ::redis::__method__blocking {id fd val} {
  88     set ::redis::blocking($id) $val
  89     fconfigure $fd -blocking $val
  90 }
  91
  92 proc ::redis::__method__read {id fd} {
  93     ::redis::redis_read_reply $fd
  94 }
  95
  96 proc ::redis::__method__write {id fd buf} {
  97     ::redis::redis_write $fd $buf
  98 }
  99
 100 proc ::redis::__method__flush {id fd} {
 101     flush $fd
 102 }
 103
 104 proc ::redis::__method__close {id fd} {
 105     catch {close $fd}
 106     catch {unset ::redis::fd($id)}
 107     catch {unset ::redis::blocking($id)}
 108     catch {unset ::redis::state($id)}
 109     catch {unset ::redis::statestack($id)}
 110     catch {unset ::redis::callback($id)}
 111     catch {interp alias {} ::redis::redisHandle$id {}}
 112 }
 113
 114 proc ::redis::__method__channel {id fd} {
 115     return $fd
 116 }
 117
 118 proc ::redis::redis_write {fd buf} {
 119     puts -nonewline $fd $buf
 120 }
 121
 122 proc ::redis::redis_writenl {fd buf} {
 123     redis_write $fd $buf
 124     redis_write $fd "\r\n"
 125     flush $fd
 126 }
 127
 128 proc ::redis::redis_readnl {fd len} {
 129     set buf [read $fd $len]
 130     read $fd 2 ; # discard CR LF
 131     return $buf
 132 }
 133
 134 proc ::redis::redis_bulk_read {fd} {
 135     set count [redis_read_line $fd]
 136     if {$count == -1} return {}
 137     set buf [redis_readnl $fd $count]
 138     return $buf
 139 }
 140
 141 proc ::redis::redis_multi_bulk_read fd {
 142     set count [redis_read_line $fd]
 143     if {$count == -1} return {}
 144     set l {}
 145     set err {}
 146     for {set i 0} {$i < $count} {incr i} {
 147         if {[catch {
 148             lappend l [redis_read_reply $fd]
 149         } e] && $err eq {}} {
 150             set err $e
 151         }
 152     }
 153     if {$err ne {}} {return -code error $err}
 154     return $l
 155 }
 156
 157 proc ::redis::redis_read_line fd {
 158     string trim [gets $fd]
 159 }
 160
 161 proc ::redis::redis_read_reply fd {
 162     set type [read $fd 1]
 163     switch -exact -- $type {
 164         : -
 165         + {redis_read_line $fd}
 166         - {return -code error [redis_read_line $fd]}
 167         $ {redis_bulk_read $fd}
 168         * {redis_multi_bulk_read $fd}
 169         default {return -code error "Bad protocol, '$type' as reply type byte"}
 170     }
 171 }
 172
 173 proc ::redis::redis_reset_state id {
 174     set ::redis::state($id) [dict create buf {} mbulk -1 bulk -1 reply {}]
 175     set ::redis::statestack($id) {}
 176 }
 177
 178 proc ::redis::redis_call_callback {id type reply} {
 179     set cb [lindex $::redis::callback($id) 0]
 180     set ::redis::callback($id) [lrange $::redis::callback($id) 1 end]
 181     uplevel #0 $cb [list ::redis::redisHandle$id $type $reply]
 182     ::redis::redis_reset_state $id
 183 }
 184
 185 # Read a reply in non-blocking mode.
 186 proc ::redis::redis_readable {fd id} {
 187     if {[eof $fd]} {
 188         redis_call_callback $id eof {}
 189         ::redis::__method__close $id $fd
 190         return
 191     }
 192     if {[dict get $::redis::state($id) bulk] == -1} {
 193         set line [gets $fd]
 194         if {$line eq {}} return ;# No complete line available, return
 195         switch -exact -- [string index $line 0] {
 196             : -
 197             + {redis_call_callback $id reply [string range $line 1 end-1]}
 198             - {redis_call_callback $id err [string range $line 1 end-1]}
 199             $ {
 200                 dict set ::redis::state($id) bulk \
 201                     [expr [string range $line 1 end-1]+2]
 202                 if {[dict get $::redis::state($id) bulk] == 1} {
 203                     # We got a $-1, hack the state to play well with this.
 204                     dict set ::redis::state($id) bulk 2
 205                     dict set ::redis::state($id) buf "\r\n"
 206                     ::redis::redis_readable $fd $id
 207                 }
 208             }
 209             * {
 210                 dict set ::redis::state($id) mbulk [string range $line 1 end-1]
 211                 # Handle *-1
 212                 if {[dict get $::redis::state($id) mbulk] == -1} {
 213                     redis_call_callback $id reply {}
 214                 }
 215             }
 216             default {
 217                 redis_call_callback $id err \
 218                     "Bad protocol, $type as reply type byte"
 219             }
 220         }
 221     } else {
 222         set totlen [dict get $::redis::state($id) bulk]
 223         set buflen [string length [dict get $::redis::state($id) buf]]
 224         set toread [expr {$totlen-$buflen}]
 225         set data [read $fd $toread]
 226         set nread [string length $data]
 227         dict append ::redis::state($id) buf $data
 228         # Check if we read a complete bulk reply
 229         if {[string length [dict get $::redis::state($id) buf]] ==
 230             [dict get $::redis::state($id) bulk]} {
 231             if {[dict get $::redis::state($id) mbulk] == -1} {
 232                 redis_call_callback $id reply \
 233                     [string range [dict get $::redis::state($id) buf] 0 end-2]
 234             } else {
 235                 dict with ::redis::state($id) {
 236                     lappend reply [string range $buf 0 end-2]
 237                     incr mbulk -1
 238                     set bulk -1
 239                 }
 240                 if {[dict get $::redis::state($id) mbulk] == 0} {
 241                     redis_call_callback $id reply \
 242                         [dict get $::redis::state($id) reply]
 243                 }
 244             }
 245         }
 246     }
 247 }