client-libraries/tcl/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
  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
  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         } else {
  63             set cmd "$method "
  64             append cmd [join $args]
  65             ::redis::redis_writenl $fd $cmd
  66         }
  67         ::redis::redis_read_reply $fd
  68     } else {
  69         uplevel 1 [list ::redis::__method__$method $id $fd] $args
  70     }
  71 }
  72
  73 proc ::redis::__method__close {id fd} {
  74     catch {close $fd}
  75     catch {unset ::redis::fd($id)}
  76     catch {interp alias {} ::redis::redisHandle$id {}}
  77 }
  78
  79 proc ::redis::__method__channel {id fd} {
  80     return $fd
  81 }
  82
  83 proc ::redis::redis_write {fd buf} {
  84     puts -nonewline $fd $buf
  85 }
  86
  87 proc ::redis::redis_writenl {fd buf} {
  88     redis_write $fd $buf
  89     redis_write $fd "\r\n"
  90     flush $fd
  91 }
  92
  93 proc ::redis::redis_readnl {fd len} {
  94     set buf [read $fd $len]
  95     read $fd 2 ; # discard CR LF
  96     return $buf
  97 }
  98
  99 proc ::redis::redis_bulk_read {fd} {
 100     set count [redis_read_line $fd]
 101     if {$count == -1} return {}
 102     set buf [redis_readnl $fd $count]
 103     return $buf
 104 }
 105
 106 proc ::redis::redis_multi_bulk_read fd {
 107     set count [redis_read_line $fd]
 108     if {$count == -1} return {}
 109     set l {}
 110     for {set i 0} {$i < $count} {incr i} {
 111         lappend l [redis_read_reply $fd]
 112     }
 113     return $l
 114 }
 115
 116 proc ::redis::redis_read_line fd {
 117     string trim [gets $fd]
 118 }
 119
 120 proc ::redis::redis_read_reply fd {
 121     set type [read $fd 1]
 122     switch -exact -- $type {
 123         : -
 124         + {redis_read_line $fd}
 125         - {return -code error [redis_read_line $fd]}
 126         $ {redis_bulk_read $fd}
 127         * {redis_multi_bulk_read $fd}
 128         default {return -code error "Bad protocol, $type as reply type byte"}
 129     }
 130 }