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