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