blob: 8ad96f450ec85d6b1207b900310b21d49830c988 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
# 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 {}
array set ::redis::multibulkarg {}
# Flag commands requiring last argument as a bulk write operation
foreach redis_bulk_cmd {
set setnx rpush lpush lset lrem sadd srem sismember echo getset smove zadd zrem zscore rpoplpush zincrby
} {
set ::redis::bulkarg($redis_bulk_cmd) {}
}
# Flag commands requiring last argument as a bulk write operation
foreach redis_multibulk_cmd {
mset msetnx
} {
set ::redis::multibulkarg($redis_multibulk_cmd) {}
}
unset redis_bulk_cmd
unset redis_multibulk_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 {}} {
if {[info exists ::redis::bulkarg($method)]} {
set cmd "$method "
append cmd [join [lrange $args 0 end-1]]
append cmd " [string length [lindex $args end]]\r\n"
append cmd [lindex $args end]
::redis::redis_writenl $fd $cmd
} elseif {[info exists ::redis::multibulkarg($method)]} {
set cmd "*[expr {[llength $args]+1}]\r\n"
append cmd "$[string length $method]\r\n$method\r\n"
foreach a $args {
append cmd "$[string length $a]\r\n$a\r\n"
}
::redis::redis_write $fd $cmd
flush $fd
} else {
set cmd "$method "
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 protocol, $type as reply type byte"}
}
}
|
