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 package provide redis 0.1
  14
  15 namespace eval redis {}
  16 set ::redis::id 0
  17 array set ::redis::fd {}
  18 array set ::redis::bulkarg {}
  19 array set ::redis::multibulkarg {}
  20
  21 # Flag commands requiring last argument as a bulk write operation
  22 foreach redis_bulk_cmd {
  23     set setnx rpush lpush lset lrem sadd srem sismember echo getset smove zadd zrem zscore
  24 } {
  25     set ::redis::bulkarg($redis_bulk_cmd) {}
  26 }
  27
  28 # Flag commands requiring last argument as a bulk write operation
  29 foreach redis_multibulk_cmd {
  30     mset msetnx
  31 } {
  32     set ::redis::multibulkarg($redis_multibulk_cmd) {}
  33 }
  34
  35 unset redis_bulk_cmd
  36 unset redis_multibulk_cmd
  37
  38 proc redis {{server 127.0.0.1} {port 6379}} {
  39     set fd [socket $server $port]
  40     fconfigure $fd -translation binary
  41     set id [incr ::redis::id]
  42     set ::redis::fd($id) $fd
  43     interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
  44 }
  45
  46 proc ::redis::__dispatch__ {id method args} {
  47     set fd $::redis::fd($id)
  48     if {[info command ::redis::__method__$method] eq {}} {
  49         if {[info exists ::redis::bulkarg($method)]} {
  50             set cmd "$method "
  51             append cmd [join [lrange $args 0 end-1]]
  52             append cmd " [string length [lindex $args end]]\r\n"
  53             append cmd [lindex $args end]
  54             ::redis::redis_writenl $fd $cmd
  55         } elseif {[info exists ::redis::multibulkarg($method)]} {
  56             set cmd "*[expr {[llength $args]+1}]\r\n"
  57             append cmd "$[string length $method]\r\n$method\r\n"
  58             foreach a $args {
  59                 append cmd "$[string length $a]\r\n$a\r\n"
  60             }
  61             ::redis::redis_write $fd $cmd
  62             flush $fd
  63         } else {
  64             set cmd "$method "
  65             append cmd [join $args]
  66             ::redis::redis_writenl $fd $cmd
  67         }
  68         ::redis::redis_read_reply $fd
  69     } else {
  70         uplevel 1 [list ::redis::__method__$method $id $fd] $args
  71     }
  72 }
  73
  74 proc ::redis::__method__close {id fd} {
  75     catch {close $fd}
  76     catch {unset ::redis::fd($id)}
  77     catch {interp alias {} ::redis::redisHandle$id {}}
  78 }
  79
  80 proc ::redis::__method__channel {id fd} {
  81     return $fd
  82 }
  83
  84 proc ::redis::redis_write {fd buf} {
  85     puts -nonewline $fd $buf
  86 }
  87
  88 proc ::redis::redis_writenl {fd buf} {
  89     redis_write $fd $buf
  90     redis_write $fd "\r\n"
  91     flush $fd
  92 }
  93
  94 proc ::redis::redis_readnl {fd len} {
  95     set buf [read $fd $len]
  96     read $fd 2 ; # discard CR LF
  97     return $buf
  98 }
  99
 100 proc ::redis::redis_bulk_read {fd} {
 101     set count [redis_read_line $fd]
 102     if {$count == -1} return {}
 103     set buf [redis_readnl $fd $count]
 104     return $buf
 105 }
 106
 107 proc ::redis::redis_multi_bulk_read fd {
 108     set count [redis_read_line $fd]
 109     if {$count == -1} return {}
 110     set l {}
 111     for {set i 0} {$i < $count} {incr i} {
 112         lappend l [redis_read_reply $fd]
 113     }
 114     return $l
 115 }
 116
 117 proc ::redis::redis_read_line fd {
 118     string trim [gets $fd]
 119 }
 120
 121 proc ::redis::redis_read_reply fd {
 122     set type [read $fd 1]
 123     switch -exact -- $type {
 124         : -
 125         + {redis_read_line $fd}
 126         - {return -code error [redis_read_line $fd]}
 127         $ {redis_bulk_read $fd}
 128         * {redis_multi_bulk_read $fd}
 129         default {return -code error "Bad protocol, $type as reply type byte"}
 130     }
 131 }