f89c3a35 |
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 { |
28173a49 |
23 | set setnx rpush lpush lset lrem sadd srem sismember echo getset smove zadd zrem zscore rpoplpush zincrby |
f89c3a35 |
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 | } |