Tcl client library

diff --git a/client-libraries/tcl/redis.tcl b/client-libraries/tcl/redis.tcl
new file mode 100644 (file)
index 0000000..6cc713d
--- /dev/null
+++ b/client-libraries/tcl/redis.tcl
@@ -0,0 +1,111 @@
+# Tcl clinet library - used by test-redis.tcl script for now
+# Copyright (C) 2009 Salvatore Sanfilippo
+# Released under the BSD license like Redis itself
+#
+# Example usage:
+#
+# set r [redis 127.0.0.1 6379]
+# $r lpush mylist foo
+# $r lpush mylist bar
+# $r lrange mylist 0 -1
+# $r close
+
+package provide redis 0.1
+
+namespace eval redis {}
+set ::redis::id 0
+array set ::redis::fd {}
+array set ::redis::bulkarg {}
+
+# Flag commands requiring last argument as a bulk write operation
+foreach redis_bulk_cmd {
+    set setnx rpush lpush lset lrem sadd srem sismember echo
+} {
+    set ::redis::bulkarg($redis_bulk_cmd) {}
+}
+unset redis_bulk_cmd
+
+proc redis {{server 127.0.0.1} {port 6379}} {
+    set fd [socket $server $port]
+    fconfigure $fd -translation binary
+    set id [incr ::redis::id]
+    set ::redis::fd($id) $fd
+    interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
+}
+
+proc ::redis::__dispatch__ {id method args} {
+    set fd $::redis::fd($id)
+    if {[info command ::redis::__method__$method] eq {}} {
+        set cmd "$method "
+        if {[info exists ::redis::bulkarg($method)]} {
+            append cmd [join [lrange $args 0 end-1]]
+            append cmd " [string length [lindex $args end]]\r\n"
+            append cmd [lindex $args end]
+        } else {
+            append cmd [join $args]
+        }
+        ::redis::redis_writenl $fd $cmd
+        ::redis::redis_read_reply $fd
+    } else {
+        uplevel 1 [list ::redis::__method__$method $id $fd] $args
+    }
+}
+
+proc ::redis::__method__close {id fd} {
+    catch {close $fd}
+    catch {unset ::redis::fd($id)}
+    catch {interp alias {} ::redis::redisHandle$id {}}
+}
+
+proc ::redis::__method__channel {id fd} {
+    return $fd
+}
+
+proc ::redis::redis_write {fd buf} {
+    puts -nonewline $fd $buf
+}
+
+proc ::redis::redis_writenl {fd buf} {
+    redis_write $fd $buf
+    redis_write $fd "\r\n"
+    flush $fd
+}
+
+proc ::redis::redis_readnl {fd len} {
+    set buf [read $fd $len]
+    read $fd 2 ; # discard CR LF
+    return $buf
+}
+
+proc ::redis::redis_bulk_read {fd} {
+    set count [redis_read_line $fd]
+    if {$count == -1} return {}
+    set buf [redis_readnl $fd $count]
+    return $buf
+}
+
+proc ::redis::redis_multi_bulk_read fd {
+    set count [redis_read_line $fd]
+    if {$count == -1} return {}
+    set l {}
+    for {set i 0} {$i < $count} {incr i} {
+        lappend l [redis_read_reply $fd]
+    }
+    return $l
+}
+
+proc ::redis::redis_read_line fd {
+    string trim [gets $fd]
+}
+
+proc ::redis::redis_read_reply fd {
+    set type [read $fd 1]
+    switch -exact -- $type {
+        : -
+        + {redis_read_line $fd}
+        - {return -code error [redis_read_line $fd]}
+        $ {redis_bulk_read $fd}
+        * {redis_multi_bulk_read $fd}
+        default {return -code error "Bad protocl, $type as reply type byte"}
+    }
+}