├── .gitignore
├── LICENSE
├── README.md
├── cl-redis.asd
├── commands.lisp
├── connection.lisp
├── float.lisp
├── package.lisp
├── redis.lisp
└── test.lisp


/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.fasl
3 | \#*
4 | .\#*
5 | *.log
6 | .*
7 | !.gitignore
8 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 |  Copyright (c) 2009-2012 Vsevolod Dyomkin <vseloved@gmail.com>
 2 | 
 3 |  Permission is hereby granted, free of charge, to any person
 4 |  obtaining a copy of this software and associated documentation
 5 |  files (the "Software"), to deal in the Software without
 6 |  restriction, including without limitation the rights to use,
 7 |  copy, modify, merge, publish, distribute, sublicense, and/or sell
 8 |  copies of the Software, and to permit persons to whom the
 9 |  Software is furnished to do so, subject to the following
10 |  conditions:
11 | 
12 |  Except as contained in this notice, the name(s) of the above
13 |  copyright holders shall not be used in advertising or otherwise
14 |  to promote the sale, use or other dealings in this Software
15 |  without prior written authorization.
16 | 
17 |  The above copyright notice and this permission notice shall be
18 |  included in all copies or substantial portions of the Software.
19 | 
20 |  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
21 |  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
22 |  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
23 |  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
24 |  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
25 |  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
26 |  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
27 |  OTHER DEALINGS IN THE SOFTWARE.
28 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # CL-REDIS — A fast and robust Common Lisp client for Redis
  2 |   (tested with Redis version 3.0.0 (2.9.104 to be precise))
  3 | 
  4 | ## Usage
  5 | 
  6 | ### Quickstart
  7 | 
  8 | 1. Make sure a Redis server is running.
  9 | 2. `(ql:quickload 'cl-redis)`
 10 | 3. Connect to the server to the given host and port with
 11 |    `(redis:connect :host <host> :port <port>)`
 12 |    (`host` defaults to `127.0.0.1`, `port` — to `6379`).
 13 | 4. Interact with the server using Redis commands from the `red` package.
 14 | 
 15 | ```lisp
 16 | CL-USER> (red:ping)
 17 | "PONG"
 18 | ```
 19 | 
 20 | 5. Disconnect from the server with `(redis:disconnect)`.
 21 | 6. Alternatively, wrap the whole interaction session in `with-connection` macro,
 22 |    which accepts the same arguments as `connect` does, opens a socket connection,
 23 |    executes the body of the macro with the current connection (`*connection*`)
 24 |    bound to this new connection, and ensures that the connection is closed
 25 |    afterwards.
 26 | 
 27 | ### Available commands
 28 | 
 29 | 
 30 | 
 31 | ### Code organization
 32 | 
 33 | The system provides 2 packages: `REDIS` and `RED`.  All the
 34 | functionality is available from the `REDIS` package.  Not to cause
 35 | symbol clashes, Redis commands are defined in this package with a
 36 | prefix (which defaults to `red-` and is set at compilation time).
 37 | The package `RED` is a syntactic sugar — it just provides the Redis
 38 | commands without a prefix.  So it is not intended to be imported to
 39 | avoid symbol conflicts with package `COMMON-LISP` — just use the
 40 | package-qualified symbol names: i.e. the same Redis command (for
 41 | instance `GET`) can be called as `RED-GET` (if you import the `REDIS` package)
 42 | or `RED:GET`.
 43 | 
 44 | 
 45 | ## Installation
 46 | 
 47 | Available through [quicklisp](http://quicklisp.org/).
 48 | 
 49 | ### Dependencies
 50 | 
 51 | - [usocket](http://common-lisp.net/project/usocket/)
 52 | - [flexi-streams](http://common-lisp.net/project/flexi-streams/)
 53 | - [rutils](http://github.com/vseloved/rutils)
 54 | - only for tests: [nuts](http://github.com/vseloved/nuts),
 55 |   [bordeaux-threads](http://common-lisp.net/project/bordeaux-threads)
 56 | 
 57 | 
 58 | ## Debugging and error recovery
 59 | 
 60 | If `*echo-p*` is `T`, all client-server communications will be
 61 | echoed to the stream `*echo-stream*`, which defaults to `*standard-output*`.
 62 | 
 63 | Error handling is mimicked after
 64 | [Postmodern](http://common-lisp.net/project/postmodern/).
 65 | In particular, whenever an error occurs that breaks the communication stream,
 66 | a condition of type `redis-connection-error` is signalled offering
 67 | a `:reconnect` restart.  If it is selected the whole Redis command will be
 68 | resent, if the reconnection attempt succeeds.
 69 | Furthermore, `connect` checks if a connection to Redis is already established,
 70 | and offers two restarts (`:leave` and `:replace`) if this is the case.
 71 | 
 72 | When the server respondes with an error reply
 73 | (i.e., a reply that starts with `-`),
 74 | a condition of type `redis-error-reply` is signalled.
 75 | 
 76 | There's also a high-level `with-persistent-connection` macro,
 77 | that tries to do the right thing™
 78 | (i.e. automatically reopen the connection once, if it is broken).
 79 | 
 80 | 
 81 | ## Advanced usage
 82 | 
 83 | ### PubSub
 84 | 
 85 | Since there's no special command to receive messages from Redis via PubSub
 86 | here's how you do it:
 87 | 
 88 | ```lisp
 89 | (bt:make-thread (lambda ()
 90 |                   (with-connection ()
 91 |                     (red:subscribe "foo")
 92 |                     (loop :for msg := (expect :anything) :do
 93 |                       (print msg))))
 94 |                 "pubsub-listener")
 95 | ```
 96 | 
 97 | To publish, obviously:
 98 | 
 99 | ```lisp
100 | (with-connection ()
101 |   (red:publish "foo" "test"))
102 | ```
103 | 
104 | ### Pipelining
105 | 
106 | For better performance Redis allows to pipeline commands
107 | and delay receiving results until the end,
108 | and process them all in oine batch afterwards.
109 | To support that there's `with-pipelining` macro.
110 | Compare execution times in the following examples
111 | (with pipelining and without: 6.567 secs vs. 2023.924 secs!):
112 | 
113 | ```lisp
114 | (let ((names (let (acc)
115 |                (dotimes (i 1000 (nreverse acc))
116 |                  (push (format nil "n~a" i) acc))))
117 |       (vals  (let (big-acc)
118 |                (dotimes (i 1000 (nreverse big-acc))
119 |                  (let (acc)
120 |                    (dotimes (i (random 100))
121 |                      (push (list (random 10) (format nil "n~a" i)) acc))
122 |                    (push (nreverse acc) big-acc))))))
123 |   (time (redis:with-connection ()
124 |           (redis:with-pipelining
125 |             (loop :for k :in names :for val :in vals :do
126 |               (dolist (v val)
127 |                 (apply #'red:zadd k v)))
128 |             (red:zunionstore "result" (length names) names)
129 |             (red:zrange "result" 0 -1))))
130 | 
131 |   ;; Evaluation took:
132 |   ;;  6.567 seconds of real time
133 |   ;;  3.900243 seconds of total run time (3.200200 user, 0.700043 system)
134 | 
135 |   (time (redis:with-connection ()
136 |           (loop :for k :in names :for val :in vals :do
137 |             (dolist (v val)
138 |               (apply #'red:zadd k v)))
139 |           (red:zunionstore "result" (length names) names)
140 |           (red:zrange "result" 0 -1))))
141 | 
142 |   ;; Evaluation took:
143 |   ;; 2023.924 seconds of real time
144 |   ;; 3.560222 seconds of total run time (2.976186 user, 0.584036 system)
145 | ```
146 | 
147 | Note, that `with-pipelining` calls theoretically may nest,
148 | but the results will only be available to the highest-level pipeline,
149 | all the nested pipelines will return :PIPELINED.
150 | So a warining is signalled in this situation.
151 | 
152 | 
153 | ## Internals
154 | 
155 | Generic functions `tell` and `expect` implement the Redis protocol
156 | according to the [spec](http://redis.io/topics/protocol).
157 | `tell` specifies how a request to Redis is formatted,
158 | `expect` — how the response is handled.
159 | The best way to implement another method on `expect` is usually with
160 | `def-expect-method`, which arranges reading data from the socket
161 | and provides a variable `reply`, which holds the decoded reply data
162 | from the server with the initial character removed. For example:
163 | 
164 | ```lisp
165 | (def-expect-method :ok
166 |   (assert (string= reply "OK"))
167 |   reply)
168 | ```
169 | 
170 | Redis operations are defined as ordinary functions by `def-cmd`
171 | for which only arguments and return type should be provided.
172 | `def-cmd` prefixes all the defined functions' names with `*cmd-prefix*`,
173 | which defaults to `'red`.
174 | (Note, that setting of `*cmd-prefix*` will have its effects at compile time).
175 | It also exports them from `REDIS` package,
176 | and from `RED` package without the prefix.
177 | 
178 | An example of command definition is given below:
179 | 
180 | ```lisp
181 | (def-cmd KEYS (pattern) :multi
182 |   "Return all the keys matching the given pattern.")
183 | ```
184 | 
185 | See `commands.lisp` for all defined commands.
186 | 
187 | 
188 | ## Not implemented
189 | 
190 | - The following commands are not implemented,
191 |   because they are not intended for use in client:
192 |   `MONITOR`, `DEBUG OBJECT`, and `DEBUG SEGFAULT`.
193 | - Support for Unix domain sockets — planned
194 | - [Consistent hashing](http://en.wikipedia.org/wiki/Consistent_hashing)
195 |   isn't built-in.  Actually, such thing is orthogonal to the functionality
196 |   of this library and, probably, should be implemented in a separate library.
197 | - Connection pooling is also not implemented, because in the presence of
198 |   `with-persistent-connection` it is actually not needed so much.
199 |   Persistent connections are more simple, efficient and less error-prone
200 |   for dedicated threads.  But there are other use-cases for pooling,
201 |   so it will probably be implemented in future releases.
202 | 
203 | 
204 | ## Credits
205 | 
206 | The library is developed and maintained by Vsevolod Dyomkin
207 | <vseloved@gmail.com>.
208 | 
209 | At the initial stages Alexandr Manzyuk <manzyuk@googlemail.com>
210 | developed the connection handling code following the implementation in
211 | [Postmodern](http://common-lisp.net/project/postmodern/). It was since
212 | partially rewritten to accommodate more advanced connection handling
213 | strategies, like persistent connection.
214 | 
215 | 
216 | ## License
217 | 
218 | MIT (See LICENSE file for details).
219 | 


--------------------------------------------------------------------------------
/cl-redis.asd:
--------------------------------------------------------------------------------
 1 | ;;; CL-REDIS system definition
 2 | ;;; (c) Vsevolod Dyomkin, Oleksandr Manzyuk.  See LICENSE file for permissions
 3 | 
 4 | (in-package :asdf)
 5 | 
 6 | (defsystem #:cl-redis
 7 |   :version "2.3.8"
 8 |   :author "Vsevolod Dyomkin <vseloved@gmail.com>, Oleksandr Manzyuk <manzyuk@gmail.com>"
 9 |   :maintainer "Vsevolod Dyomkin <vseloved@gmail.com>"
10 |   :licence "MIT"
11 |   :description "A fast and robust Common Lisp client for Redis"
12 |   :depends-on (#:rutils #:cl-ppcre #:usocket #:flexi-streams #:babel #:cl+ssl #:trivial-gray-streams)
13 |   :serial t
14 |   :components ((:file "package")
15 |                (:file "float")
16 |                (:file "connection")
17 |                (:file "redis")
18 |                (:file "commands")))
19 | 
20 | 
21 | (defmethod perform ((o test-op)
22 |                     (c (eql (find-system 'cl-redis))))
23 |   (operate 'load-op '#:cl-redis)
24 |   (operate 'test-op '#:cl-redis-test))
25 | 
26 | (defsystem #:cl-redis-test
27 |   :version "2.3.8"
28 |   :author "Vsevolod Dyomkin <vseloved@gmail.com>"
29 |   :maintainer "Vsevolod Dyomkin <vseloved@gmail.com>"
30 |   :licence "MIT"
31 |   :description "CL-Redis test suite"
32 |   :depends-on (#:cl-redis #:bordeaux-threads #:flexi-streams #:should-test)
33 |   :components ((:file "test")))
34 | 
35 | (defmethod perform ((o test-op)
36 |                     (c (eql (find-system 'cl-redis-test))))
37 |   (asdf:load-system '#:cl-redis-test)
38 |   (funcall (read-from-string "cl-redis-test:run-tests")))
39 | 
40 | ;;; end
41 | 


--------------------------------------------------------------------------------
/commands.lisp:
--------------------------------------------------------------------------------
  1 | ;;; CL-REDIS commands
  2 | ;;; (c) Vsevolod Dyomkin, Oleksandr Manzyuk. see LICENSE file for permissions
  3 | 
  4 | 
  5 | (in-package #:redis)
  6 | 
  7 | 
  8 | ;;; Connection handling
  9 | 
 10 | (def-cmd PING () :status
 11 |   "Ping server.")
 12 | 
 13 | (def-cmd QUIT () :end
 14 |   "Close the connection.")
 15 | 
 16 | (def-cmd AUTH (pass) :status
 17 |   "Simple password authentication if enabled.")
 18 | 
 19 | (def-cmd SELECT (index) :status
 20 |   "Select the DB having the specified index.")
 21 | 
 22 | (def-cmd ECHO (message) :bulk
 23 |   "Returns message.")
 24 | 
 25 | 
 26 | ;;; Any key type commands
 27 | 
 28 | (def-cmd EXISTS (key) :boolean
 29 |   "Test if a key exists.")
 30 | 
 31 | (def-cmd DEL (key &rest keys) :integer
 32 |   "Delete a key.")
 33 | 
 34 | (def-cmd TYPE (key) :inline
 35 |   "Return the type of the value stored at key.")
 36 | 
 37 | (def-cmd KEYS (pattern) :multi
 38 |   "Return all the keys matching a given pattern.")
 39 | 
 40 | (def-cmd RANDOMKEY () :bulk
 41 |   "Return a random key from the key space.")
 42 | 
 43 | (def-cmd RENAME (oldname newname) :status
 44 |   "Rename the old key in the new one, destroing the newname key if it
 45 | already exists.")
 46 | 
 47 | (def-cmd RENAMENX (oldname newname) :boolean
 48 |   "Rename the old key in the new one, if the newname key does not
 49 | already exist.")
 50 | 
 51 | (def-cmd EXPIRE (key secs) :boolean
 52 |   "Set a time to live in SECS on KEY.")
 53 | 
 54 | (def-cmd EXPIREAT (key timestamp) :boolean
 55 |   "Set a timeout on KEY. After the timeout has expired, the key will
 56 |    automatically be deleted.
 57 |    EXPIREAT has the same effect and semantic as EXPIRE, but instead of
 58 |    specifying the number of seconds representing the TTL, it takes
 59 |    an absolute UNIX timestamp (seconds since January 1, 1970).
 60 |    As in the case of EXPIRE command, if key is updated before the timeout has
 61 |    expired, then the timeout is removed as if the PERSIST command was invoked
 62 |    on KEY.")
 63 | 
 64 | (def-cmd PEXPIRE (key milliseconds) :boolean
 65 |   "Set a KEY's time to live in MILLISECONDS.")
 66 | 
 67 | (def-cmd PEXPIREAT (key milliseconds-timestamp) :boolean
 68 |   "Set the expiration for a KEY as a Unix timestamp specified in milliseconds.")
 69 | 
 70 | (def-cmd PERSIST (key) :boolean
 71 |   "Remove the existing timeout on KEY.")
 72 | 
 73 | (def-cmd TTL (key) :integer
 74 |   "Get the time to live in seconds of KEY.")
 75 | 
 76 | (def-cmd PTTL (key) :integer
 77 |   "Get the time to live in milliseconds of KEY.")
 78 | 
 79 | (def-cmd MOVE (key dbindex) :boolean
 80 |   "Move the key from the currently selected DB to the DB having as
 81 |    index dbindex.")
 82 | 
 83 | (def-cmd SORT (key &rest args
 84 |                    &key  by     ; A pattern.
 85 |                          start
 86 |                          end
 87 |                          get    ; A pattern or a list of patterns.
 88 |                          desc   ; Should sort be descending?
 89 |                          alpha  ; Should sort be lexicographical?
 90 |                          store  ; Store result into key
 91 |                          )
 92 |   (if store
 93 |       :integer
 94 |       :multi)
 95 |   "Sort a Set or a List accordingly to the specified parameters.")
 96 | 
 97 | (defmethod tell ((cmd (eql 'SORT)) &rest args)
 98 |   (ds-bind (key &key by get desc alpha start end store) args
 99 |     (assert (or (and start end)
100 |                 (and (null start) (null end))))
101 |     (apply #'tell "SORT"
102 |            (cl:append (list key)
103 |                       (when by    `("BY" ,by))
104 |                       (when get   (etypecase get
105 |                                     (string `("GET" ,get))
106 |                                     (list (loop for item in get
107 |                                              collect "GET" collect item))))
108 |                       (when desc  '("DESC"))
109 |                       (when alpha '("ALPHA"))
110 |                       (when start `("LIMIT" ,start ,end))
111 |                       (when store `("STORE" ,store))))))
112 | 
113 | (def-cmd OBJECT-REFCOUNT (key) :integer
114 |   "The OBJECT command allows to inspect the internals of Redis Objects
115 |    associated with keys. It is useful for debugging or to understand if your keys
116 |    are using the specially encoded data types to save space. Your application may
117 |    also use the information reported by the OBJECT command to implement application
118 |    level key eviction policies when using Redis as a Cache.
119 |    OBJECT REFCOUNT <key> returns the number of references of the value associated
120 |    with the specified key.")
121 | 
122 | (def-cmd OBJECT-ENCODING (key) :bulk
123 |   "The OBJECT command allows to inspect the internals of Redis Objects
124 |    associated with keys. It is useful for debugging or to understand if your keys
125 |    are using the specially encoded data types to save space. Your application may
126 |    also use the information reported by the OBJECT command to implement application
127 |    level key eviction policies when using Redis as a Cache.
128 |    OBJECT ENCODING <key> returns the kind of internal representation used in order
129 |    to store the value associated with a key.")
130 | 
131 | (def-cmd OBJECT-IDLETIME (key) :integer
132 |   "The OBJECT command allows to inspect the internals of Redis Objects
133 |    associated with keys. It is useful for debugging or to understand if your keys
134 |    are using the specially encoded data types to save space. Your application may
135 |    also use the information reported by the OBJECT command to implement application
136 |    level key eviction policies when using Redis as a Cache.
137 |    OBJECT IDLETIME <key> returns the number of seconds since the object stored
138 |    at the specified key is idle (not requested by read or write operations). While
139 |    the value is returned in seconds the actual resolution of this timer is 10
140 |    seconds, but may vary in future implementations.")
141 | 
142 | (def-cmd DUMP (key) :bytes
143 |   "Return a serialized version of the value stored at the specified KEY.")
144 | 
145 | (def-cmd RESTORE (key ttl serialized-value) :status
146 |   "Create a KEY using the provided SERIALIZED-VALUE,
147 |    previously obtained using DUMP.")
148 | 
149 | (defmethod tell ((cmd (eql 'RESTORE)) &rest args)
150 |   (ds-bind (key ttl bytes) args
151 |     (format-redis-number #\* (1+ (length args)))
152 |     (dolist (arg (list cmd key ttl))
153 |       (let ((arg (ensure-string arg)))
154 |         (format-redis-number #\$ (babel:string-size-in-octets arg :encoding :UTF-8))
155 |         (format-redis-string  arg)))
156 |     (let ((out (conn-stream *connection*)))
157 |       (format-redis-number #\$ (length bytes))
158 |       (write-sequence bytes (flex:flexi-stream-stream out))
159 |       (terpri out)
160 |       (force-output out))))
161 | 
162 | (def-cmd MIGRATE (host port key destination-db timeout) :status
163 |   "Atomically transfer a key from a Redis instance to another one.")
164 | 
165 | (def-cmd CLIENT-GETNAME () :bulk
166 |   "The CLIENT GETNAME returns the name of the current connection as set by
167 |    CLIENT SETNAME. Since every new connection starts without an associated name,
168 |    if no name was assigned a null bulk reply is returned.")
169 | 
170 | (def-cmd CLIENT-SETNAME (connection-name) :status
171 |   "The CLIENT SETNAME command assigns a name to the current connection.
172 |    The assigned name is displayed in the output of CLIENT LIST so that
173 |    it is possible to identify the client that performed a given connection.")
174 | 
175 | (def-cmd CLIENT-PAUSE (timeout) :status
176 |   "CLIENT PAUSE is a connections control command able to suspend all the Redis
177 |    clients for the specified amount of time (in milliseconds).")
178 | 
179 | (def-cmd CLUSTER-SLOTS () :multi
180 |   "CLUSTER SLOTS returns details about which cluster slots map to which Redis
181 |    instances.")
182 | 
183 | (def-cmd ROLE () :bulk
184 |   "Provide information on the role of a Redis instance in the context
185 |    of replication, by returning if the instance is currently a master, slave,
186 |    or sentinel. The command also returns additional information about the state
187 |    of the replication (if the role is master or slave) or the list of monitored
188 |    master names (if the role is sentinel).")
189 | 
190 | (def-cmd COMMAND () :multi
191 |   "Returns Array reply of details about all Redis commands.
192 |    Cluster clients must be aware of key positions in commands so commands can go
193 |    to matching instances, but Redis commands vary between accepting one key,
194 |    multiple keys, or even multiple keys separated by other data.
195 |    You can use COMMAND to cache a mapping between commands and key positions
196 |    for each command to enable exact routing of commands to cluster instances.")
197 | 
198 | (def-cmd COMMAND-COUNT () :integer
199 |   "Returns Integer reply of number of total commands in this Redis server.")
200 | 
201 | (def-cmd COMMAND-GETKEYS (command-name &rest args) :multi
202 |   "Returns Array reply of keys from a full Redis command.
203 |    COMMAND GETKEYS is a helper command to let you find the keys from
204 |    a full Redis command.
205 |    COMMAND shows some commands as having movablekeys meaning the entire command
206 |    must be parsed to discover storage or retrieval keys.
207 |    You can use COMMAND GETKEYS to discover key positions directly from how Redis
208 |    parses the commands.")
209 | 
210 | (def-cmd COMMAND-INFO (command-name &rest args) :multi
211 |   "Returns Array reply of details about multiple Redis commands.
212 |    Same result format as COMMAND except you can specify which commands get
213 |    returned.
214 |    If you request details about non-existing commands, their return position
215 |    will be nil.")
216 | 
217 | (def-cmd TIME () :multi
218 |   "The TIME command returns the current server time as a two items lists:
219 |    a Unix timestamp and the amount of microseconds already elapsed
220 |    in the current second.
221 |    Basically the interface is very similar to the one of the
222 |    gettimeofday system call.")
223 | 
224 | 
225 | ;;; Scan commands
226 | 
227 | (def-cmd SCAN (cursor &rest args &key match count) :multi
228 |   "The SCAN command and the closely related commands SSCAN, HSCAN and ZSCAN
229 |    are used in order to incrementally iterate over a collection of elements.
230 |    SCAN iterates the set of keys in the currently selected Redis database.")
231 | 
232 | (flet ((tell-scan (cmd args)
233 |          (ds-bind (key &key match count) args
234 |            (apply #'tell cmd
235 |                   (cl:append (list key)
236 |                              (when match `("MATCH" ,match))
237 |                              (when count `("COUNT" ,count)))))))
238 | 
239 |   (defmethod tell ((cmd (eql 'SCAN)) &rest args)
240 |     (tell-scan "SCAN" args)))
241 | 
242 | (def-cmd SSCAN (key cursor &rest args &key match count) :multi
243 |   "The SCAN command and the closely related commands SCAN, HSCAN and ZSCAN
244 |    are used in order to incrementally iterate over a collection of elements.
245 |    SSCAN iterates elements of Sets types.")
246 | 
247 | (def-cmd HSCAN (key cursor &rest args &key match count) :multi
248 |   "The HSCAN command and the closely related commands SCAN, SSCAN and ZSCAN
249 |    are used in order to incrementally iterate over a collection of elements.
250 |    HSCAN iterates fields of Hash types and their associated values.")
251 | 
252 | (def-cmd ZSCAN (key cursor &rest args &key match count) :multi
253 |   "The ZSCAN command and the closely related commands SCAN, SSCAN and HSCAN
254 |    are used in order to incrementally iterate over a collection of elements.
255 |    ZSCAN iterates elements of Sorted Set types and their associated scores.")
256 | 
257 | (flet ((tell-scan (cmd args)
258 |          (ds-bind (key cursor &key match count) args
259 |            (apply #'tell cmd
260 |                   (cl:append (list key cursor)
261 |                              (when match `("MATCH" ,match))
262 |                              (when count `("COUNT" ,count)))))))
263 |   (defmethod tell ((cmd (eql 'SSCAN)) &rest args)
264 |     (tell-scan "SSCAN" args))
265 |   (defmethod tell ((cmd (eql 'HSCAN)) &rest args)
266 |     (tell-scan "HSCAN" args))
267 |   (defmethod tell ((cmd (eql 'ZSCAN)) &rest args)
268 |     (tell-scan "ZSCAN" args)))
269 | 
270 | 
271 | ;;; String commands
272 | 
273 | (def-cmd SET (key value) :status
274 |   "Set a key to a string value.")
275 | 
276 | (def-cmd GET (key) :bulk
277 |   "Return the string value of the key.")
278 | 
279 | (def-cmd GETSET (key value) :bulk
280 |   "Set a key to a string returning the old value of the key.")
281 | 
282 | (def-cmd MGET (&rest keys) :multi
283 |   "Multi-get, return the strings values of the keys.")
284 | 
285 | (def-cmd SETNX (key value) :boolean
286 |   "Set a key to a string value if the key does not exist.")
287 | 
288 | (def-cmd SETEX (key time value) :status
289 |   "Set KEY to hold the string VALUE and set KEY to timeout after a given number
290 | of seconds. This command is equivalent to executing the following commands:
291 |     SET mykey value
292 |     EXPIRE mykey seconds
293 | SETEX is atomic, and can be reproduced by using the previous two commands inside
294 | an MULTI/EXEC block. It is provided as a faster alternative to the given
295 | sequence of operations, because this operation is very common when Redis is used
296 | as a cache.
297 | An error is returned when seconds is invalid.")
298 | 
299 | (def-cmd MSET (&rest key-value-plist) :status
300 |   "Set multiple keys to multiple values in a single atomic operation.")
301 | 
302 | (def-cmd MSETNX (&rest key-value-plist) :boolean
303 |   "Set multiple keys to multiple values in a single atomic operation
304 | if none of the keys already exist.")
305 | 
306 | (def-cmd INCR (key) :integer
307 |   "Increment the integer value of KEY.")
308 | 
309 | (def-cmd INCRBY (key increment) :integer
310 |   "Increment the integer value of KEY by .")
311 | 
312 | (def-cmd INCRBYFLOAT (key increment) :float
313 |   "Increment the float value of KEY by INCREMENT.")
314 | 
315 | (def-cmd DECR (key) :integer
316 |   "Decrement the integer value of KEY.")
317 | 
318 | (def-cmd DECRBY (key decrement) :integer
319 |   "Decrement the integer value of KEY by DECREMENT.")
320 | 
321 | (def-cmd APPEND (key value) :integer
322 |   "Append the specified string to the string stored at key.")
323 | 
324 | (def-cmd SUBSTR (key start end) :bulk
325 |   "Return a substring out of a larger string.
326 | Warning: left for backwards compatibility. It is now called: GETRANGE.")
327 | 
328 | (def-cmd STRLEN (key) :integer
329 |   "Returns the length of the string value stored at KEY.")
330 | 
331 | (def-cmd SETBIT (key offset value) :integer
332 |   "Sets or clears the bit at OFFSET in the string value stored at KEY.")
333 | 
334 | (def-cmd GETBIT (key offset) :integer
335 |   "Returns the bit value at OFFSET in the string value stored at KEY.")
336 | 
337 | (def-cmd BITCOUNT (key &optional start end) :integer
338 |   "Count set bits in a string at KEY
339 | \(with optional bounding indices START and END).")
340 | 
341 | (def-cmd BITFIELD (key &rest args) :multi
342 |   "Treats a Redis string as an array of bits, takes a list of
343 | \operations, returns an array of replies.")
344 | 
345 | (def-cmd BITFIELD_RO (key &rest args) :multi
346 |   "Read-only variant of BITFIELD")
347 | 
348 | (defmethod tell :before ((cmd (eql 'BITCOUNT)) &rest args)
349 |   (assert (or (null (second args)) (third args))))
350 | 
351 | (def-cmd BITOP (operation destkey key &rest keys) :integer
352 |   "Perform bitwise OPERATION between strings ar KEY and KEYS
353 | and store the result ad DSTKEY.")
354 | 
355 | (def-cmd BITPOS (key bit &optional start end) :integer
356 |   "Return the position of the first bit set to 1 or 0 in a string.")
357 | 
358 | (def-cmd SETRANGE (key offset value) :integer
359 |   "Overwrites part of the string stored at KEY, starting at the specified
360 | OFFSET, for the entire length of VALUE. If the OFFSET is larger than the
361 | current length of the string at KEY, the string is padded with zero-bytes
362 | to make OFFSET fit. Non-existing keys are considered as empty strings,
363 | so this command will make sure it holds a string large enough to be able
364 | to set value at OFFSET. Note that the maximum OFFSET that you can set
365 | is 229^-1 (536870911), as Redis Strings are limited to 512 megabytes.")
366 | 
367 | (def-cmd GETRANGE (key offset value) :bulk
368 |   "Returns the substring of the string value stored at key, determined by
369 | the offsets START and END (both are inclusive). Negative offsets can be
370 | used in order to provide an offset starting from the end of the string.
371 | So -1 means the last character, -2 the penultimate and so forth.")
372 | 
373 | 
374 | ;; Hash commands
375 | 
376 | (def-cmd HSET (key field value) :boolean
377 |   "Set the hash FIELD to the specified VALUE. Creates the hash if needed.")
378 | 
379 | (def-cmd HSETNX (key field value) :boolean
380 |   "Set the hash FIELD to the specified VALUE, if the KEY doesn't exist yet.")
381 | 
382 | (def-cmd HGET (key field) :bulk
383 |   "Retrieve the value of the specified hash FIELD.")
384 | 
385 | (def-cmd HMSET (key &rest fields-and-values) :status
386 |   "Set the hash FIELDS to their respective VALUES.")
387 | 
388 | (def-cmd HMGET (key field &rest fields) :multi
389 |   "Get the values associated with the specified FIELDS in the hash
390 | stored at KEY.")
391 | 
392 | (def-cmd HINCRBY (key field integer) :integer
393 |   "Increment the integer value of the hash at KEY on FIELD with INTEGER.")
394 | 
395 | (def-cmd HINCRBYFLOAT (key field increment) :float
396 |   "Increment the float value of the hash at KEY on FIELD with INCREMENT.")
397 | 
398 | (def-cmd HEXISTS (key field) :boolean
399 |   "Test for existence of a specified FIELD in a hash.")
400 | 
401 | (def-cmd HDEL (key field) :boolean
402 |   "Remove the specified FIELD from a hash.")
403 | 
404 | (def-cmd HLEN (key) :integer
405 |   "Return the number of items in a hash.")
406 | 
407 | (def-cmd HKEYS (key) :multi
408 |   "Return all the fields in a hash.")
409 | 
410 | (def-cmd HVALS (key) :multi
411 |   "Return all the values in a hash.")
412 | 
413 | (def-cmd HGETALL (key) :multi
414 |   "Return all the fields and associated values in a hash.")
415 | 
416 | #+v.3.2.0
417 | (def-cmd HSTRLEN (key field) :integer
418 |   "Returns the string length of the value associated with field
419 |    in the hash stored at key.
420 |    If the key or the field do not exist, 0 is returned.")
421 | 
422 | 
423 | ;;; List commands
424 | 
425 | (def-cmd RPUSH (key &rest values) :integer
426 |   "Append an element to the tail of the list value at KEY.")
427 | 
428 | (def-cmd LPUSH (key &rest values) :integer
429 |   "Append an element to the head of the list value at KEY.")
430 | 
431 | (def-cmd RPUSHX (key value) :integer
432 |   "Inserts value at the tail of the list stored at KEY, only if KEY
433 | already exists and holds a list. In contrary to RPUSH, no operation
434 | will be performed when KEY does not yet exist.")
435 | 
436 | (def-cmd LPUSHX (key value) :integer
437 |   "Inserts value at the head of the list stored at KEY, only if KEY
438 | already exists and holds a list. In contrary to LPUSH, no operation
439 | will be performed when KEY does not yet exist.")
440 | 
441 | (def-cmd LLEN (key) :integer
442 |   "Return the length of the List value at key.")
443 | 
444 | (def-cmd LRANGE (key start end) :multi
445 |   "Return a range of elements from the List at key.")
446 | 
447 | (def-cmd LTRIM (key start end) :status
448 |   "Trim the list at key to the specified range of elements.")
449 | 
450 | (def-cmd LINDEX (key index) :bulk
451 |   "Return the element at index position from the List at key.")
452 | 
453 | (def-cmd LSET (key index value) :status
454 |   "Set a new value as the element at index position of the List at key.")
455 | 
456 | (def-cmd LREM (key count value) :integer
457 |   "Remove the first-N, last-N, or all the elements matching value from
458 | the List at key.")
459 | 
460 | (def-cmd LPOP (key) :bulk
461 |   "Return and remove (atomically) the first element of the List at key.")
462 | 
463 | (def-cmd RPOP (key) :bulk
464 |   "Return and remove (atomically) the last element of the List at key.")
465 | 
466 | (def-cmd BLPOP (&rest keys-and-timeout) :multi
467 |   "Blocking LPOP.")
468 | 
469 | (def-cmd BRPOP (&rest keys-and-timeout) :multi
470 |   "Blocking RPOP.")
471 | 
472 | (def-cmd RPOPLPUSH (source destination) :bulk
473 |   "Atomically returns and removes the last element (tail) of the list
474 | stored at SOURCE, and pushes the element at the first element (head) of the list
475 | stored at DESTINATION.
476 | For example: consider SOURCE holding the list a,b,c, and DESTINATION holding
477 | the list x,y,z. Executing RPOPLPUSH results in SOURCE holding a,b and
478 | DESTINATION holding c,x,y,z.
479 | If SOURCE does not exist, the value nil is returned and no operation is
480 | performed. If SOURCE and DESTINATION are the same, the operation is equivalent
481 | to removing the last element from the list and pushing it as first element
482 | of the list, so it can be considered as a list rotation command.")
483 | 
484 | (def-cmd BRPOPLPUSH (source destination timeout) :anything  ; bulk or null multi-bulk
485 |   "BRPOPLPUSH is the blocking variant of RPOPLPUSH. When source contains
486 | elements, this command behaves exactly like RPOPLPUSH. When source is empty,
487 | Redis will block the connection until another client pushes to it or until
488 | TIMEOUT is reached. A TIMEOUT of zero can be used to block indefinitely.
489 | See RPOPLPUSH for more information.")
490 | 
491 | (def-cmd LINSERT (key before/after pivot value) :integer
492 |   "Inserts VALUE in the list stored at KEY either BEFORE or AFTER
493 | the reference value PIVOT. When KEY does not exist, it is considered an empty
494 | list and no operation is performed. An error is returned when KEY exists,
495 | but does not hold a list value PIVOT.
496 | 
497 | Note: before/after can only have 2 values: :before or :after.")
498 | 
499 | (defmethod tell :before ((cmd (eql 'LINSERT)) &rest args)
500 |   (assert (member (second args) '(:before :after))))
501 | 
502 | 
503 | ;;; Set commands
504 | 
505 | (def-cmd SADD (key &rest members) :integer
506 |   "Add the specified member to the Set value at key.")
507 | 
508 | (def-cmd SREM (key &rest members) :integer
509 |   "Remove the specified member from the Set value at key.")
510 | 
511 | (def-cmd SPOP (key) :bulk
512 |   "Remove and return (pop) a random element from the Set value at key.")
513 | 
514 | (def-cmd SMOVE (srckey dstkey member) :boolean
515 |   "Move the specified member from one Set to another atomically.")
516 | 
517 | (def-cmd SCARD (key) :integer
518 |   "Return the number of elements (the cardinality) of the Set at key.")
519 | 
520 | (def-cmd SISMEMBER (key member) :boolean
521 |   "Test if the specified value is a member of the Set at key.")
522 | 
523 | (def-cmd SINTER (&rest keys) :multi
524 |   "Return the intersection between the Sets stored at key1, key2, ...,
525 |    keyN.")
526 | 
527 | (def-cmd SINTERSTORE (dstkey &rest keys) :integer
528 |   "Compute the intersection between the Sets stored at key1, key2, ...,
529 |    keyN, and store the resulting Set at dstkey.")
530 | 
531 | (def-cmd SUNION (&rest keys) :multi
532 |   "Return the union between the Sets stored at key1, key2, ..., keyN.")
533 | 
534 | (def-cmd SUNIONSTORE (dstkey &rest keys) :integer
535 |   "Compute the union between the Sets stored at key1, key2, ..., keyN,
536 |    and store the resulting Set at dstkey.")
537 | 
538 | (def-cmd SDIFF (&rest keys) :multi
539 |   "Return the difference between the Set stored at key1 and all the
540 |    Sets key2, ..., keyN.")
541 | 
542 | (def-cmd SDIFFSTORE (dstkey &rest keys) :integer
543 |   "Compute the difference between the Set key1 and all the Sets key2, ...,
544 |    keyN, and store the resulting Set at dstkey.")
545 | 
546 | (def-cmd SMEMBERS (key) :multi
547 |   "Return all the members of the Set value at key.")
548 | 
549 | (def-cmd SRANDMEMBER (key &optional count) :anything
550 |   "Get one or COUNT random members from a set at KEY.
551 |    When called with the additional count argument,
552 |    return an array of count distinct elements if count is positive.
553 |    If called with a negative count the behavior changes and the command
554 |    is allowed to return the same element multiple times.
555 |    In this case the numer of returned elements is the absolute
556 |    value of the specified count.")
557 | 
558 | 
559 | ;;; Sorted set (zset) commands
560 | 
561 | (def-cmd ZADD (key &rest score-member-pairs) :integer
562 |   "Add the specified MEMBER to the Set value at KEY or update the
563 |    SCORE if it already exist.  If nil is returned, the element already
564 |    existed in the set.  Just the score was updated.")
565 | 
566 | (def-cmd ZREM (key &rest members) :integer
567 |   "Remove the specified MEMBER from the Set value at KEY.")
568 | 
569 | (def-cmd ZINCRBY (key increment member) :integer
570 |   "If the MEMBER already exists increment its score by INCREMENT,
571 |    otherwise add the member setting INCREMENT as score.")
572 | 
573 | (def-cmd ZRANK (key member) :integer
574 |   "Return the rank (or index) or MEMBER in the sorted set at KEY,
575 |    with scores being ordered from low to high.")
576 | 
577 | (def-cmd ZREVRANK (key member) :integer
578 |   "Return the rank (or index) or MEMBER in the sorted set at KEY,
579 |    with scores being ordered from high to low.")
580 | 
581 | (def-cmd ZRANGE (key start end &optional withscores) :multi
582 |   "Return a range of elements from the sorted set at KEY.")
583 | 
584 | (def-cmd ZREVRANGE (key start end &optional withscores) :multi
585 |   "Return a range of elements from the sorted set at KEY, exactly like
586 |    ZRANGE, but the sorted set is ordered in traversed in reverse order,
587 |    from the greatest to the smallest score.")
588 | 
589 | (macrolet ((proper-withscores ()
590 |              `(when (and (= 4 (length args))
591 |                          (last1 args))
592 |                 (setf (car (last args)) :withscores))))
593 |   (defmethod tell :before ((cmd (eql 'ZRANGE)) &rest args)
594 |     (proper-withscores))
595 |   (defmethod tell :before ((cmd (eql 'ZREVRANGE)) &rest args)
596 |     (proper-withscores)))
597 | 
598 | (def-cmd ZRANGEBYSCORE (key min max &rest args &key withscores limit) :multi
599 |   "Returns all the elements in the sorted set at KEY with a score between
600 |    MIN and MAX (including elements with score equal to MIN or MAX).
601 |    The elements are considered to be ordered from low to high scores.
602 |    The elements having the same score are returned in lexicographical order
603 |    (this follows from a property of the sorted set implementation in Redis and
604 |    does not involve further computation).
605 |    The optional LIMIT argument can be used to only get a range of the matching
606 |    elements (similar to SELECT LIMIT offset, count in SQL).
607 |    The optional WITHSCORES argument makes the command return both the element and
608 |    its score, instead of the element alone.")
609 | 
610 | (def-cmd ZREVRANGEBYSCORE (key max min &rest args &key withscores limit) :multi
611 |   "Returns all the elements in the sorted set at KEY with a score between
612 |    MAX and MIN (including elements with score equal to MAX or MIN).
613 |    In contrary to the default ordering of sorted sets, for this command the
614 |    elements are considered to be ordered from high to low scores.
615 |    The elements having the same score are returned in reverse lexicographical
616 |    order. Apart from the reversed ordering,
617 |    ZREVRANGEBYSCORE is similar to ZRANGEBYSCORE.")
618 | 
619 | (def-cmd ZREVRANGEBYLEX (key max min &rest args &key withscores limit) :multi
620 |   "When all the elements in a sorted set are inserted with the same score,
621 |    in order to force lexicographical ordering, this command returns
622 |    all the elements in the sorted set at key with a value between max and min.
623 |    Apart from the reversed ordering, ZREVRANGEBYLEX is similar to ZRANGEBYLEX.")
624 | 
625 | (flet ((tell-zrevrange (cmd key start end &key withscores limit)
626 |          (apply #'tell (princ-to-string cmd)
627 |                 (cl:append (list key start end)
628 |                            (when withscores '("WITHSCORES"))
629 |                            (when limit
630 |                              (assert (and (consp limit)
631 |                                           (atom (cdr limit))))
632 |                              (list "LIMIT" (car limit) (cdr limit)))))))
633 |   (defmethod tell ((cmd (eql 'ZRANGEBYSCORE)) &rest args)
634 |     (apply #'tell-zrevrange cmd args))
635 |   (defmethod tell ((cmd (eql 'ZREVRANGEBYSCORE)) &rest args)
636 |     (apply #'tell-zrevrange cmd args))
637 |   (defmethod tell ((cmd (eql 'ZREVRANGEBYLEX)) &rest args)
638 |     (apply #'tell-zrevrange cmd args)))
639 | 
640 | (def-cmd ZCARD (key) :integer
641 |   "Return the cardinality (number of elements) of the sorted set at KEY.")
642 | 
643 | (def-cmd ZCOUNT (key min max) :integer
644 |   "Returns the number of elements in the sorted set at KEY with a score between
645 |    MIN and MAX.")
646 | 
647 | (def-cmd ZLEXCOUNT (key min max) :integer
648 |   "When all the elements in a sorted set are inserted with the same score,
649 |    in order to force lexicographical ordering,
650 |    this command returns the number of elements in the sorted set at key
651 |    with a value between min and max.
652 |    The min and max arguments have the same meaning as described for ZRANGEBYLEX.")
653 | 
654 | (def-cmd ZSCORE (key element) :float
655 |   "Return the score associated with the specified ELEMENT of the
656 |    sorted set at KEY.")
657 | 
658 | (def-cmd ZREMRANGEBYRANK (key min max) :integer
659 |   "Remove all the elements with rank >= MIN and rank <= MAX from the
660 |    sorted set.")
661 | 
662 | (def-cmd ZREMRANGEBYSCORE (key min max) :integer
663 |   "Remove all the elements with score >= MIN and score <= MAX from the
664 |    sorted set.")
665 | 
666 | (def-cmd ZREMRANGEBYLEX (key min max) :integer
667 |   "When all the elements in a sorted set are inserted with the same score,
668 |    in order to force lexicographical ordering, this command removes all elements
669 |    in the sorted set stored at KEY between the lexicographical range
670 |    specified by MIN and MAX.
671 |    The meaning of MIN and MAX are the same of the ZRANGEBYLEX command.
672 |    Similarly, this command actually returns the same elements that ZRANGEBYLEX
673 |    would return if called with the same min and max arguments.")
674 | 
675 | (def-cmd ZUNIONSTORE (dstkey n keys &rest args &key weights aggregate) :integer
676 |   "Perform a union in DSTKEY over a number (N) of sorted sets at KEYS
677 |    with optional WEIGHTS and AGGREGATE.")
678 | 
679 | (def-cmd ZINTERSTORE (dstkey n keys &rest args &key weights aggregate) :integer
680 |   "Perform an intersection in DSTKEY over a number (N) of sorted sets at KEYS
681 |    with optional WEIGHTS and AGGREGATE.")
682 | 
683 | (flet ((tell-zstore (cmd dstkey n keys &key weights aggregate)
684 |          (assert (integerp n))
685 |          (assert (= n (length keys)))
686 |          (when weights
687 |            (assert (= (length keys) (length weights)))
688 |            (assert (every #'numberp weights)))
689 |          (when aggregate
690 |            (assert (member aggregate '(:sum :min :max))))
691 |          (apply #'tell (ensure-string cmd)
692 |                 (cl:append (list dstkey n)
693 |                            keys
694 |                            (when weights (cons "WEIGHTS" weights))
695 |                            (when aggregate (list "AGGREGATE" aggregate))))))
696 |   (defmethod tell ((cmd (eql 'ZUNIONSTORE)) &rest args)
697 |     (apply #'tell-zstore cmd args))
698 |   (defmethod tell ((cmd (eql 'ZINTERSTORE)) &rest args)
699 |     (apply #'tell-zstore cmd args)))
700 | 
701 | 
702 | ;;; HyperLogLog commands
703 | 
704 | (def-cmd PFADD (key element &rest elements) :integer
705 |   "Adds all the element arguments to the HyperLogLog data structure stored
706 |    at the variable name specified as first argument.
707 |    As a side effect of this command the HyperLogLog internals may be updated
708 |    to reflect a different estimation of the number of unique items added so far
709 |    (the cardinality of the set).
710 |    If the approximated cardinality estimated by the HyperLogLog changed after
711 |    executing the command, PFADD returns 1, otherwise 0 is returned.
712 |    The command automatically creates an empty HyperLogLog structure (that is,
713 |    a Redis String of a specified length and with a given encoding) if
714 |    the specified key does not exist.
715 |    To call the command without elements but just the variable name is valid,
716 |    this will result into no operation performed if the variable already exists,
717 |    or just the creation of the data structure if the key does not exist
718 |    (in the latter case 1 is returned).")
719 | 
720 | (def-cmd PFCOUNT (key &rest keys) :integer
721 |   "When called with a single key, returns the approximated cardinality computed
722 |    by the HyperLogLog data structure stored at the specified variable,
723 |    which is 0 if the variable does not exist.
724 |    When called with multiple keys, returns the approximated cardinality of
725 |    the union of the HyperLogLogs passed, by internally merging the HyperLogLogs
726 |    stored at the provided keys into a temporary hyperLogLog.
727 |    The HyperLogLog data structure can be used in order to count unique elements
728 |    in a set using just a small constant amount of memory, specifically 12k bytes
729 |    for every HyperLogLog (plus a few bytes for the key itself).
730 |    The returned cardinality of the observed set is not exact, but approximated
731 |    with a standard error of 0.81%.
732 |    For example, in order to take the count of all the unique search queries
733 |    performed in a day, a program needs to call PFADD every time a query is
734 |    processed. The estimated number of unique queries can be retrieved with
735 |    PFCOUNT at any time.
736 |    Note: as a side effect of calling this function, it is possible that
737 |    the HyperLogLog is modified, since the last 8 bytes encode the latest
738 |    computed cardinality for caching purposes. So PFCOUNT is technically
739 |    a write command.")
740 | 
741 | (def-cmd PFMERGE (destkey sourcekey &rest sourcekeys) :status
742 |   "Merge multiple HyperLogLog values into an unique value that will approximate
743 |    the cardinality of the union of the observed Sets of the source HyperLogLog
744 |    structures.
745 |    The computed merged HyperLogLog is set to the destination variable,
746 |    which is created if does not exist (defaulting to an empty HyperLogLog).")
747 | 
748 | ;;; Transaction commands
749 | 
750 | (def-cmd MULTI () :status
751 |   "Redis atomic transactions' start.")
752 | 
753 | (def-cmd EXEC () :queued
754 |   "Redis atomic transactions' commit.")
755 | 
756 | (def-cmd DISCARD () :status
757 |   "Redis atomic transactions' rollback.")
758 | 
759 | (def-cmd WATCH (key &rest keys) :status
760 |   "Marks the given keys to be watched for conditional execution of a transaction.")
761 | 
762 | (def-cmd UNWATCH () :status
763 |   "Flushes all the previously watched keys for a transaction.
764 |    If you call EXEC or DISCARD, there's no need to manually call UNWATCH.")
765 | 
766 | 
767 | ;;; Publish/Subscribe
768 | 
769 | (def-cmd SUBSCRIBE (&rest channels) :pubsub
770 |   "Redis Public/Subscribe messaging paradigm implementation.")
771 | 
772 | (def-cmd UNSUBSCRIBE (&rest channels) :pubsub
773 |   "Redis Public/Subscribe messaging paradigm implementation.")
774 | 
775 | (def-cmd PSUBSCRIBE (&rest patterns) :pubsub
776 |   "Redis Public/Subscribe messaging paradigm implementation.")
777 | 
778 | (def-cmd PUNSUBSCRIBE (&rest patterns) :pubsub
779 |   "Redis Public/Subscribe messaging paradigm implementation.")
780 | 
781 | (def-cmd PUBLISH (channel message) :integer
782 |   "Redis Public/Subscribe messaging paradigm implementation.")
783 | 
784 | 
785 | ;;; Server control commands
786 | 
787 | (def-cmd SAVE () :status
788 |   "Synchronously save the DB on disk.")
789 | 
790 | (def-cmd BGSAVE () :inline
791 |   "Asynchronously save the DB on disk.")
792 | 
793 | (def-cmd LASTSAVE () :integer
794 |   "Return the UNIX time stamp of the last successfully saving of the
795 |    dataset on disk.")
796 | 
797 | (def-cmd SHUTDOWN () :end
798 |   "Synchronously save the DB on disk, then shutdown the server.")
799 | 
800 | (def-cmd BGREWRITEAOF () :status
801 |   "Rewrite the append only file in background when it gets too big.")
802 | 
803 | (def-cmd INFO (&optional section) :bulk
804 |   "Provide information and statistics about the server.")
805 | 
806 | (def-cmd SLAVEOF (hostname port) :status
807 |   "Change the replication settings.")
808 | 
809 | (def-cmd CONFIG-GET (pattern) :multi
810 |   "Configure a Redis server at runtime: get glob PATTERN value.")
811 | 
812 | (def-cmd CONFIG-SET (parameter value) :status
813 |   "Configure a Redis server at runtime: set PARAMETER VALUE.")
814 | 
815 | (def-cmd CONFIG-RESETSTAT () :status
816 |   "Resets the statistics reported by Redis using the INFO command.")
817 | 
818 | (def-cmd CONFIG-REWRITE () :status
819 |   "The CONFIG REWRITE command rewrites the redis.conf file the server
820 |    was started with, applying the minimal changes needed to make it reflecting
821 |    the configuration currently used by the server, that may be different
822 |    compared to the original one because of the use of the CONFIG SET command.")
823 | 
824 | (def-cmd FLUSHDB () :status
825 |   "Remove all the keys of the currently selected DB.")
826 | 
827 | (def-cmd FLUSHALL () :status
828 |   "Remove all the keys from all the databases.")
829 | 
830 | (def-cmd DBSIZE () :integer
831 |   "Return the number of keys in the current db.")
832 | 
833 | (def-cmd SYNC () :multi
834 |   "Synchronize with slave.")
835 | 
836 | (def-cmd SLOWLOG (subcommand &optional argument) :anything
837 |   "Manages the Redis slow queries log.")
838 | 
839 | 
840 | ;;; Scripting commands
841 | 
842 | (def-cmd EVAL (script numkeys &rest key-values) :anything
843 |   "Execute a Lua script server side.")
844 | 
845 | (def-cmd EVALSHA (sha1 numkeys &rest key-values) :anything
846 |   "Execute a stored Lua script server side.")
847 | 
848 | (def-cmd SCRIPT-LOAD (script) :bulk
849 |   "Load the specified Lua script into the script cache.")
850 | 
851 | (def-cmd SCRIPT-EXISTS (script &rest scripts) :multi
852 |   "Check existence of scripts in the script cache.")
853 | 
854 | (def-cmd SCRIPT-KILL () :status
855 |   "Kill the script currently in execution.")
856 | 
857 | (def-cmd SCRIPT-FLUSH () :status
858 |   "Remove all the scripts from the script cache.")
859 | 
860 | 
861 | ;;; not supported commands: MONITOR, DEBUG OBJECT, DEBUG SEGFAULT - use redis-cli for that
862 | 
863 | ;;; end
864 | 


--------------------------------------------------------------------------------
/connection.lisp:
--------------------------------------------------------------------------------
  1 | ;;; CL-REDIS connection handling
  2 | ;;; (c) Vsevolod Dyomkin, Oleksandr Manzyuk. see LICENSE file for permissions
  3 | 
  4 | (in-package :redis)
  5 | 
  6 | 
  7 | (eval-always (defparameter +utf8+ '(:utf-8 :eol-style :crlf)))
  8 | 
  9 | 
 10 | ;;; Debugging support
 11 | 
 12 | (defvar *echo-p* nil
 13 |   "Whether the server-client communication should be echoed to the
 14 | stream specified by *ECHO-STREAM*.  The default is NIL, meaning no
 15 | echoing.")
 16 | 
 17 | (defvar *echo-stream* *standard-output*
 18 |   "A stream to which the server-client communication will be echoed
 19 | for debugging purposes.  The default is *STANDARD-OUTPUT*.")
 20 | 
 21 | 
 22 | ;;; Low-level connection handling
 23 | 
 24 | (defvar *connection* nil "The current Redis connection.")
 25 | 
 26 | ;; First, define the SSL stream methods
 27 | (defmacro define-ssl-stream-methods ()
 28 |   `(progn
 29 |      ;; For SSL streams
 30 |      (defmethod trivial-gray-streams:stream-clear-input ((stream cl+ssl::ssl-stream))
 31 |        (trivial-gray-streams:stream-clear-input (cl+ssl::ssl-stream-socket stream)))
 32 | 
 33 |      (defmethod trivial-gray-streams:stream-read-sequence
 34 |          ((stream cl+ssl::ssl-stream) sequence start end &rest args)
 35 |        (declare (ignore args))
 36 |        (handler-case
 37 |            (let ((bytes-read 0))
 38 |              (loop while (< bytes-read (- end start))
 39 |                    do (let ((byte (read-byte stream nil nil)))
 40 |                         (when (null byte)
 41 |                           (return bytes-read))
 42 |                         (setf (elt sequence (+ start bytes-read)) byte)
 43 |                         (incf bytes-read)))
 44 |              bytes-read)
 45 |          (cl+ssl::ssl-error-zero-return () bytes-read)
 46 |          (cl+ssl::ssl-error-syscall () -1)
 47 |          (cl+ssl::ssl-error-ssl () -1)))
 48 | 
 49 |      (defmethod trivial-gray-streams:stream-write-sequence
 50 |          ((stream cl+ssl::ssl-stream) sequence start end &rest args)
 51 |        (declare (ignore args))
 52 |        (handler-case
 53 |            (loop for i from start below end
 54 |                  do (write-byte (elt sequence i) stream)
 55 |                  finally (return sequence))
 56 |          (cl+ssl::ssl-error-zero-return () sequence)
 57 |          (cl+ssl::ssl-error-syscall () sequence)
 58 |          (cl+ssl::ssl-error-ssl () sequence)))
 59 | 
 60 |      ;; For regular fd-streams
 61 |      (defmethod trivial-gray-streams:stream-clear-input ((stream sb-sys:fd-stream))
 62 |        (sb-impl::clear-input stream))
 63 | 
 64 |      (defmethod trivial-gray-streams:stream-read-sequence
 65 |          ((stream sb-sys:fd-stream) sequence start end &rest args)
 66 |        (declare (ignore args))
 67 |        (read-sequence sequence stream :start start :end end))
 68 | 
 69 |      (defmethod trivial-gray-streams:stream-write-sequence
 70 |          ((stream sb-sys:fd-stream) sequence start end &rest args)
 71 |        (declare (ignore args))
 72 |        (write-sequence sequence stream :start start :end end)
 73 |        sequence)))
 74 | 
 75 | ;; Execute the macro to define the methods
 76 | (define-ssl-stream-methods)
 77 | 
 78 | (defclass redis-connection ()
 79 |   ((host
 80 |     :initarg  :host
 81 |     :initform #(127 0 0 1)
 82 |     :reader   conn-host)
 83 |    (port
 84 |     :initarg  :port
 85 |     :initform 6379
 86 |     :reader   conn-port)
 87 |    (auth
 88 |     :initarg  :auth
 89 |     :initform nil
 90 |     :reader conn-auth)
 91 |    (socket
 92 |     :initform nil
 93 |     :accessor conn-socket)
 94 |    (stream
 95 |     :initform nil
 96 |     :accessor conn-stream)
 97 |    (ssl
 98 |     :initarg :ssl
 99 |     :initform nil
100 |     :reader conn-ssl)
101 |    (verify
102 |     :initarg :verify
103 |     :initform nil
104 |     :reader conn-verify)
105 |    (certificate
106 |     :initarg :certificate
107 |     :initform nil
108 |     :reader conn-certificate)
109 |    (key
110 |     :initarg :key
111 |     :initform nil
112 |     :reader conn-key)
113 |    (cipher-list
114 |     :initarg :cipher-list
115 |     :initform nil
116 |     :reader conn-cipher-list))
117 |   (:documentation "Representation of a Redis connection."))
118 | 
119 | (defmethod initialize-instance :after ((conn redis-connection) &key)
120 |   (open-connection conn))
121 | 
122 | (defmethod conn-stream ((object null))
123 |   (error 'redis-connection-error
124 | 	 :error "No connection to Redis server was not established."))
125 | 
126 | (defun connection-open-p (conn)
127 |   "Is the socket of CONNECTION open?"
128 |   (and-it (conn-stream conn)
129 |           (open-stream-p it)))
130 | 
131 | (defun open-connection (conn)
132 |   "Create a socket connection to the host and port of CONNECTION and
133 | set the socket of CONN to the associated socket."
134 |   (let ((socket (usocket:socket-connect (conn-host conn) (conn-port conn)
135 |                                          :element-type 'flex:octet)))
136 |     (setf (conn-socket conn) socket)
137 |     (let ((socket-stream (usocket:socket-stream socket)))
138 |       (setf (conn-stream conn)
139 |             (flex:make-flexi-stream
140 |              (if (conn-ssl conn)
141 |                  (cl+ssl:make-ssl-client-stream
142 |                   socket-stream
143 |                   :verify (conn-verify conn)
144 |                   :certificate (conn-certificate conn)
145 |                   :key (conn-key conn)
146 |                   :cipher-list (conn-cipher-list conn))
147 |                  socket-stream)
148 |              :external-format +utf8+
149 |              #-lispworks :element-type
150 |              #-lispworks 'flex:octet))))
151 |   (when (conn-auth conn)
152 |     (let ((*connection* conn)) ; AUTH needs *CONNECTION* to be bound
153 |                                ; to the current connection.  At this
154 |                                ; stage, *CONNECTION* is not bound yet.
155 |       (auth (conn-auth conn)))))
156 | 
157 | (defun close-connection (conn)
158 |   "Close the socket of CONN."
159 |   (when (connection-open-p conn)
160 |     (handler-case
161 |         (usocket:socket-close (conn-socket conn))
162 |       (error (e)
163 |         (warn "Ignoring the error that happened while trying to close ~
164 | Redis socket: ~A" e)))))
165 | 
166 | (defun reopen-connection (conn)
167 |   "Close and reopen CONN."
168 |   (close-connection conn)
169 |   (open-connection conn))
170 | 
171 | 
172 | ;;; Top-level API
173 | 
174 | (defun connected-p ()
175 |   "Is there a current connection?"
176 |   (and *connection* (connection-open-p *connection*)))
177 | 
178 | (defun connect (&key (host #(127 0 0 1))
179 |                      (port 6379)
180 |                      auth
181 |                      ssl
182 |                      verify
183 |                      certificate
184 |                      key
185 |                      cipher-list)
186 |   "Connect to Redis server."
187 |   (when (connected-p)
188 |     (restart-case (error 'redis-error
189 |                          :error "A connection to Redis server is already established.")
190 |       (:leave ()
191 |         :report "Leave it."
192 |         (return-from connect))
193 |       (:replace ()
194 |         :report "Replace it with a new connection."
195 |         (disconnect))))
196 |   (setf *connection* (make-instance 'redis-connection
197 |                                     :host host
198 |                                     :port port
199 |                                     :auth auth
200 |                                     :ssl ssl
201 |                                     :verify verify
202 |                                     :certificate certificate
203 |                                     :key key
204 |                                     :cipher-list cipher-list)))
205 | 
206 | 
207 | (defun disconnect ()
208 |   "Disconnect from Redis server."
209 |   (when *connection*
210 |     (close-connection *connection*)
211 |     (setf *connection* nil)))
212 | 
213 | (defun reconnect ()
214 |   "Close and reopen the connection to Redis server."
215 |   (reopen-connection *connection*))
216 | 
217 | (defmacro with-connection ((&key (host #(127 0 0 1))
218 |                                  (port 6379)
219 |                                  auth
220 |                                  ssl
221 |                                  verify
222 |                                  certificate
223 |                                  key
224 |                                  cipher-list)
225 |                            &body body)
226 |   "Evaluate BODY with the current connection bound to a new connection
227 | specified by the given HOST and PORT"
228 |   `(let ((*connection* (make-instance 'redis-connection
229 |                                       :host ,host
230 |                                       :port ,port
231 |                                       :auth ,auth
232 |                                       :ssl ,ssl
233 |                                       :verify ,verify
234 |                                       :certificate ,certificate
235 |                                       :key ,key
236 |                                       :cipher-list ,cipher-list)))
237 |      (unwind-protect (progn ,@body)
238 |        (disconnect))))
239 | 
240 | 
241 | ;;; Handling connection errors
242 | 
243 | (defmacro reconnect-restart-case ((&key error comment) &body body)
244 |   "Signal the condition of type REDIS-CONNECTION-ERROR denoted by
245 | the given ERROR and COMMENT offering a :RECONNECT restart to re-evaluate BODY."
246 |   `(if *pipelined*
247 |        ;; don't intercept connection-errors inside a pipeline -
248 |        ;; it will be done on the highest level of a pipeline to allow
249 |        ;; the whole pipeline (with possible nestsed pipelines) to restart
250 |        (progn ,@body)
251 |        (restart-case (error 'redis-connection-error
252 |                             :error ,error :message ,comment)
253 |          (:reconnect ()
254 |            :report "Try to reconnect and repeat action."
255 |            (reconnect)
256 |            ,@body))))
257 | 
258 | (defmacro with-reconnect-restart (&body body)
259 |   "When, during the execution of BODY, an error occurs that breaks
260 | the connection, a REDIS-CONNECTION-ERROR is signalled,
261 | offering a :RECONNECT restart that will re-evaluate body after
262 | the conenction is re-established."
263 |   (with-gensyms (e)
264 |     `(handler-case (progn ,@body)
265 |        (usocket:connection-refused-error (,e)
266 |          ;; Errors of this type commonly occur when there is no Redis server
267 |          ;; running, or when one tries to connect to the wrong host or port.
268 |          (reconnect-restart-case
269 |            (:error ,e
270 |             :comment "Make sure Redis server is running and check your connection parameters.")
271 |            ,@body))
272 |        ((or usocket:socket-error stream-error end-of-file
273 |             #+lispworks comm:socket-error) (,e)
274 |          (reconnect-restart-case (:error ,e)
275 |            ,@body)))))
276 | 
277 | 
278 | ;;; Convenience macros
279 | 
280 | (defmacro with-recursive-connection ((&key (host #(127 0 0 1))
281 |                                            (port 6379)
282 |                                            auth
283 |                                            ssl
284 |                                            verify
285 |                                            certificate
286 |                                            key
287 |                                            cipher-list)
288 |                                      &body body)
289 |   "Execute BODY with *CONNECTION* bound to the default Redis
290 | connection. If connection is already established, reuse it."
291 |   `(if (connected-p)
292 |        (progn ,@body)
293 |        (with-connection (:host ,host
294 |                          :port ,port
295 |                          :auth ,auth
296 |                          :ssl ,ssl
297 |                          :verify ,verify
298 |                          :certificate ,certificate
299 |                          :key ,key
300 |                          :cipher-list ,cipher-list)
301 |          ,@body)))
302 | 
303 | (defmacro with-persistent-connection ((&key (host #(127 0 0 1))
304 |                                             (port 6379)
305 |                                             auth
306 |                                             ssl
307 |                                             verify
308 |                                             certificate
309 |                                             key
310 |                                             cipher-list)
311 |                                       &body body)
312 |   "Execute BODY inside WITH-CONNECTION. But if connection is broken
313 | due to REDIS-CONNECTION-ERROR (a network error or timeout),
314 | transparently reopen it."
315 |   `(with-connection (:host ,host
316 |                      :port ,port
317 |                      :auth ,auth
318 |                      :ssl ,ssl
319 |                      :verify ,verify
320 |                      :certificate ,certificate
321 |                      :key ,key
322 |                      :cipher-list ,cipher-list)
323 |      (handler-bind ((redis-connection-error
324 |                      (lambda (e)
325 |                        (declare (ignore e))
326 |                        (warn "Reconnecting to Redis.")
327 |                        (invoke-restart :reconnect))))
328 |        ,@body)))
329 | 
330 | ;;; end
331 | 


--------------------------------------------------------------------------------
/float.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Parsing floats
 2 | ;;; taken from ARNESI
 3 | 
 4 | (in-package #:redis)
 5 | 
 6 | 
 7 | (defun radix-values (radix)
 8 |   (assert (<= 2 radix 35)
 9 |           (radix)
10 |           "RADIX must be between 2 and 35 (inclusive), not ~D." radix)
11 |   (make-array radix
12 |               :displaced-to "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
13 |               :displaced-index-offset 0
14 |               :element-type
15 |               #+lispworks 'base-char
16 |               #-lispworks 'character))
17 | 
18 | (defun parse-float (float-string &key (start 0) (end nil) (radix 10)
19 |                                       (junk-allowed t)
20 |                                       (type 'single-float)
21 |                                       (decimal-character #\.))
22 |   (let ((radix-array (radix-values radix))
23 |         (integer-part 0)
24 |         (mantissa 0)
25 |         (mantissa-size 1)
26 |         (sign 1))
27 |     (with-input-from-string (float-stream
28 |                              (string-upcase (string-trim '(#\Space #\Tab) float-string))
29 |                              :start start :end end)
30 |       (labels ((peek () (peek-char nil float-stream nil nil nil))
31 |                (next () (read-char float-stream nil nil nil))
32 |                (sign () ;; reads the (optional) sign of the number
33 |                  (cond
34 |                    ((char= (peek) #\+) (next) (setf sign 1))
35 |                    ((char= (peek) #\-) (next) (setf sign -1)))
36 |                  (integer-part))
37 |                (integer-part ()
38 |                  (cond
39 |                    ((position (peek) radix-array)
40 |                     ;; the next char is a valid char
41 |                     (setf integer-part (+ (* integer-part radix)
42 |                                           (position (next) radix-array)))
43 |                     ;; again
44 |                     (return-from integer-part (integer-part)))
45 |                    ((null (peek))
46 |                     ;; end of string
47 |                     (done))
48 |                    ((char= decimal-character (peek))
49 |                     ;; the decimal seperator
50 |                     (next)
51 |                     (return-from integer-part (mantissa)))
52 |                    ;; junk
53 |                    (junk-allowed (done))
54 |                    (t (bad-string))))
55 |                (mantissa ()
56 |                  (cond
57 |                    ((position (peek) radix-array)
58 |                     (setf mantissa (+ (* mantissa radix)
59 |                                       (position (next) radix-array))
60 |                           mantissa-size (* mantissa-size radix))
61 |                     (return-from mantissa
62 |                       (mantissa)))
63 |                    ((or (null (peek)) junk-allowed)
64 |                     ;; end of string
65 |                     (done))
66 |                    (t (bad-string))))
67 |                (bad-string ()
68 |                  (error "Unable to parse ~S." float-string))
69 |                (done ()
70 |                  (return-from parse-float
71 |                    (coerce (* sign (+ integer-part (/ mantissa mantissa-size))) type))))
72 |         (sign)))))
73 | 


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | ;;; CL-REDIS package definition
 2 | ;;; (c) Vsevolod Dyomkin, see LICENSE file for permissions
 3 | 
 4 | (in-package :cl-user)
 5 | 
 6 | 
 7 | (defpackage #:redis
 8 |   (:use #:common-lisp #:rutil)
 9 |   (:shadow #:quit #:sort #:set #:get #:substr #:eval #:type #:append
10 |            #:watch #:unwatch #:shutdown #:time #:keys)
11 |   (:export #:redis-connection
12 |            #:connect
13 |            #:disconnect
14 |            #:reconnect
15 |            #:*connection*
16 |            #:open-connection
17 |            #:close-connection
18 |            #:connected-p
19 |            #:with-connection
20 |            #:with-recursive-connection
21 |            #:with-persistent-connection
22 | 
23 |            #:*echo-p*
24 |            #:*echo-stream*
25 | 
26 |            #:*cmd-prefix*
27 | 
28 |            #:def-cmd
29 |            #:def-expect-method
30 |            #:expect
31 |            #:tell
32 | 
33 |            #:redis-error
34 |            #:redis-error-message
35 |            #:redis-bad-reply
36 |            #:redis-error-reply
37 |            #:redis-connection-error
38 | 
39 |            #:with-pipelining))
40 | 
41 | (defpackage #:red
42 |   (:use #| nothing |# ))
43 | 
44 | 
45 | ;;; end
46 | 


--------------------------------------------------------------------------------
/redis.lisp:
--------------------------------------------------------------------------------
  1 | ;;; CL-REDIS implementation of the wire protocol
  2 | ;;; (c) Vsevolod Dyomkin, Oleksandr Manzyuk. see LICENSE file for permissions
  3 | 
  4 | (in-package #:redis)
  5 | 
  6 | 
  7 | ;; Utils.
  8 | 
  9 | (defun format-redis-number (char number)
 10 |   "Write a prefix char and a number to the stream of the current connection.
 11 | If *ECHOP-P* is not NIL, write that string to *ECHO-STREAM*, too."
 12 |   (let* ((out (conn-stream *connection*))
 13 |          (soc (flex:flexi-stream-stream out)))
 14 |     (when *echo-p* (format *echo-stream* " > ~A~A~%" char number))
 15 |     (write-byte (char-code char) soc)
 16 |     (princ number out)
 17 |     (write-byte 13 soc)
 18 |     (write-byte 10 soc)))
 19 | 
 20 | (defun format-redis-string (string)
 21 |   "Write a string and CRLF-terminator to the stream of the current connection.
 22 | If *ECHOP-P* is not NIL, write that string to *ECHO-STREAM*, too."
 23 |   (let ((soc (flex:flexi-stream-stream (conn-stream *connection*))))
 24 |     (when *echo-p* (format *echo-stream* " > ~A~%" string))
 25 |     (write-sequence (babel:string-to-octets string :encoding :UTF-8) soc)
 26 |     (write-byte 13 soc)
 27 |     (write-byte 10 soc)))
 28 | 
 29 | (defun ensure-string (obj)
 30 |   (typecase obj
 31 |     (string obj)
 32 |     (symbol (string obj))
 33 |     (t (prin1-to-string obj))))
 34 | 
 35 | ;;; Conditions
 36 | 
 37 | (define-condition redis-error (error)
 38 |   ((error :initform nil
 39 |           :initarg :error
 40 |           :reader redis-error-error)
 41 |    (message :initform nil
 42 |             :initarg :message
 43 |             :reader redis-error-message))
 44 |   (:report (lambda (e stream)
 45 |              (format stream
 46 |                      "Redis error: ~A~:[~;~2&~:*~A~]"
 47 |                      (redis-error-error e)
 48 |                      (redis-error-message e))))
 49 |   (:documentation "Any Redis-related error."))
 50 | 
 51 | (define-condition redis-connection-error (redis-error)
 52 |   ()
 53 |   (:documentation "Conditions of this type are signaled when errors occur
 54 | that break the connection stream.  They offer a :RECONNECT restart."))
 55 | 
 56 | (define-condition redis-error-reply (redis-error)
 57 |   ()
 58 |   (:documentation "Error reply is received from Redis server."))
 59 | 
 60 | (define-condition redis-bad-reply (redis-error)
 61 |   ()
 62 |   (:documentation "Redis protocol error is detected."))
 63 | 
 64 | 
 65 | ;;; Sending commands to the server
 66 | 
 67 | (defgeneric tell (cmd &rest args)
 68 |   (:documentation "Send a command to Redis server over a socket connection.
 69 | CMD is the command name (a string or a symbol), and ARGS are its arguments
 70 | \(keyword arguments are also supported)."))
 71 | 
 72 | (defmethod tell :after (cmd &rest args)
 73 |   (declare (ignore cmd args))
 74 |   (force-output (conn-stream *connection*)))
 75 | 
 76 | (defmethod tell (cmd &rest args)
 77 |   (let ((all-args (cl:append (ppcre:split "-" (ensure-string cmd))
 78 |                              args)))
 79 |     (format-redis-number #\* (length all-args))
 80 |     (dolist (arg all-args)
 81 |       (let ((arg (ensure-string arg)))
 82 |         (format-redis-number #\$ (babel:string-size-in-octets arg :encoding :UTF-8))
 83 |         (format-redis-string arg)))))
 84 | 
 85 | 
 86 | ;; Pipelining
 87 | 
 88 | (defvar *pipelined* nil
 89 |   "Indicates, that commands are sent in pipelined mode.")
 90 | 
 91 | (defvar *pipeline* nil
 92 |   "A list of expected results from the current pipeline.")
 93 | 
 94 | (defmacro with-pipelining (&body body)
 95 |   "Delay execution of EXPECT's inside BODY to the end, so that all
 96 | commands are first sent to the server and then their output is received
 97 | and collected into a list.  So commands return :PIPELINED instead of the
 98 | expected results."
 99 |   `(if *pipelined*
100 |        (progn
101 |          (warn "Already in a pipeline.")
102 |          ,@body)
103 |        (with-reconnect-restart
104 |          (let (*pipeline*)
105 |            (let ((*pipelined* t))
106 |              ,@body)
107 |            (mapcar #'expect (reverse *pipeline*))))))
108 | 
109 | 
110 | ;;; Receiving replies
111 | 
112 | (defgeneric expect (type &key timeout)
113 |   (:documentation "Receive and process the reply of the given type from Redis server.
114 | 
115 | If specified, TIMEOUT is the number of seconds to wait for a reply before
116 | returning.
117 | 
118 | Returns two values, the first is the reply or NIL. The second is a real number
119 | indicating the time remaining in the timeout or NIL if the read timed out/there
120 | was no timeout."))
121 | 
122 | (defmethod expect :around (type &key timeout)
123 |   (if *pipelined*
124 |       (progn (push type *pipeline*)
125 |              :pipelined)
126 |       ;; Wait for the socket to be ready, up to TIMEOUT seconds
127 |       (let (remaining-timeout)
128 |         (if (or (null timeout)
129 |                 (setq remaining-timeout
130 |                       (nth-value 1 (usocket:wait-for-input (conn-socket *connection*)
131 |                                                            :timeout timeout))))
132 |             (call-next-method)
133 |             (values nil remaining-timeout)))))
134 | 
135 | (eval-always
136 | 
137 | (defmacro with-redis-in ((line char) &body body)
138 |   `(let* ((,line (read-line (conn-stream *connection*)))
139 |           (,char (char ,line 0)))
140 |      (when *echo-p* (format *echo-stream* "<  ~A~%" ,line))
141 |      ,@body))
142 | 
143 | (defmacro def-expect-method (type &body body)
144 |   "Define a specialized EXPECT method.  BODY may refer to the ~
145 | variable REPLY, which is bound to the reply received from Redis ~
146 | server with the first character removed."
147 |   (with-unique-names (line char)
148 |     `(defmethod expect ((type (eql ,type)) &key &allow-other-keys)
149 |        ,(fmt "Receive and process the reply of type ~A." type)
150 |        (with-redis-in (,line ,char)
151 |          (let ((reply (subseq ,line 1)))
152 |            (if (string= ,line "+QUEUED") "QUEUED"
153 |                (case ,char
154 |                  (#\- (error 'redis-error-reply :message reply))
155 |                  ((#\+ #\: #\$ #\*) ,@body)
156 |                  (otherwise
157 |                   (error 'redis-bad-reply
158 |                          :message (fmt "Received ~C as the initial reply byte."
159 |                                        ,char))))))))))
160 | ) ; end of eval-always
161 | 
162 | (defmethod expect ((type (eql :anything)) &key &allow-other-keys)
163 |   "Receive and process status reply, which is just a string, preceeded with +."
164 |   (case (peek-char nil (conn-stream *connection*))
165 |     (#\+ (expect :status))
166 |     (#\: (expect :integer))
167 |     (#\$ (expect :bulk))
168 |     (#\* (expect :multi))
169 |     (otherwise (expect :status))))  ; will do error-signalling
170 | 
171 | (defmethod expect ((type (eql :status)) &key &allow-other-keys)
172 |   "Receive and process status reply, which is just a string, preceeded with +."
173 |   (with-redis-in (line char)
174 |     (case char
175 |       (#\- (error 'redis-error-reply :message (subseq line 1)))
176 |       (#\+ (subseq line 1))
177 |       (otherwise (error 'redis-bad-reply
178 |                         :message (fmt "Received ~C as the initial reply byte."
179 |                                       char))))))
180 | 
181 | (def-expect-method :inline
182 |   reply)
183 | 
184 | (def-expect-method :boolean
185 |   (ecase (char reply 0)
186 |     (#\0 nil)
187 |     (#\1 t)))
188 | 
189 | (def-expect-method :integer
190 |   (values (parse-integer reply)))
191 | 
192 | (defmacro read-bulk-reply (&key post-processing (decode t))
193 |   (with-gensyms (n bytes in str)
194 |     `(let ((,n (parse-integer reply)))
195 |        (unless (< ,n 0)
196 |          (let ((,bytes (make-array ,n :element-type 'flex:octet))
197 |                (,in (conn-stream *connection*)))
198 |            (read-sequence ,bytes ,in)
199 |            (read-byte ,in)               ; #\Return
200 |            (read-byte ,in)               ; #\Linefeed
201 |            ,(if decode
202 |                 `(let ((,str (babel:octets-to-string ,bytes :encoding :UTF-8)))
203 |                    (when *echo-p* (format *echo-stream* "<  ~A~%" ,str))
204 |                    (unless (string= "nil" ,str)
205 |                      (if ,post-processing
206 |                          (funcall ,post-processing ,str)
207 |                          ,str)))
208 |                 bytes))))))
209 | 
210 | (def-expect-method :bulk
211 |   (read-bulk-reply))
212 | 
213 | (def-expect-method :multi
214 |   (let ((n (parse-integer reply)))
215 |     (unless (= n -1)
216 |       (loop :repeat n
217 |          :collect (ecase (peek-char nil (conn-stream *connection*))
218 |                     (#\: (expect :integer))
219 |                     (#\$ (expect :bulk))
220 |                     (#\* (expect :multi)))))))
221 | 
222 | (def-expect-method :queued
223 |   (let ((n (parse-integer reply)))
224 |     (unless (= n -1)
225 |       (loop :repeat n
226 |          :collect (expect :anything)))))
227 | 
228 | (defmethod expect ((type (eql :pubsub)) &key &allow-other-keys)
229 |   (let ((in (conn-stream *connection*)))
230 |     (loop :collect (with-redis-in (line char)
231 |                      (list (expect :bulk)
232 |                            (expect :bulk)
233 |                            (expect :inline)))
234 |        :do (let ((next-char (read-char-no-hang in)))
235 |              (if next-char (unread-char next-char in)
236 |                  (loop-finish))))))
237 | 
238 | (defmethod expect ((type (eql :end)) &key &allow-other-keys)
239 |   ;; Used for commands QUIT and SHUTDOWN (does nothing)
240 |   )
241 | 
242 | (defmethod expect ((type (eql :list)) &key &allow-other-keys)
243 |   ;; Used to make Redis KEYS command return a list of strings (keys)
244 |   ;; rather than a single string
245 |   (cl-ppcre:split " " (expect :bulk)))
246 | 
247 | (def-expect-method :float
248 |   (read-bulk-reply :post-processing (lambda (x)
249 |                                       (parse-float x :type 'double-float))))
250 | 
251 | (def-expect-method :bytes
252 |   (read-bulk-reply :decode nil))
253 | 
254 | 
255 | ;;; Command definition
256 | 
257 | (defparameter *cmd-prefix* 'red
258 |   "Prefix for functions names that implement Redis commands.")
259 | 
260 | (defmacro def-cmd (cmd (&rest args) reply-type docstring)
261 |   "Define and export a function with the name <*CMD-REDIX*>-<CMD> for
262 | processing a Redis command CMD.  Here REPLY-TYPE is the expected reply
263 | format."
264 |   (let ((cmd-name (intern (fmt "~:@(~A-~A~)" *cmd-prefix* cmd))))
265 |     `(eval-always
266 |        (defun ,cmd ,args
267 |          ,docstring
268 |          (return-from ,cmd
269 |            (with-reconnect-restart
270 |              ,(cond-it
271 |                ((position '&optional args)
272 |                 `(apply #'tell ',cmd ,@(subseq args 0 it)
273 |                         (let ((optional-args (list ,@(nthcdr (1+ it) args))))
274 |                           (subseq optional-args 0 (position nil optional-args)))))
275 |                ((position '&rest args)
276 |                 `(apply #'tell ',cmd ,@(subseq args 0 it) ,(nth (1+ it) args)))
277 |                (t `(tell ',cmd ,@args)))
278 |              (prog1 (expect ,reply-type)
279 |                (unless *pipelined*
280 |                  (clear-input (conn-stream *connection*)))))))
281 |        (abbr ,cmd-name ,cmd)
282 |        (export ',cmd-name '#:redis)
283 |        (import ',cmd '#:red)
284 |        (export ',cmd '#:red))))
285 | 
286 | ;;; end
287 | 


--------------------------------------------------------------------------------
/test.lisp:
--------------------------------------------------------------------------------
   1 | ;;; CL-REDIS testsuite package definition
   2 | ;;; (c) Vsevolod Dyomkin, Oleksandr Manzyuk. see LICENSE file for permissions
   3 | 
   4 | (in-package :cl-user)
   5 | 
   6 | (defpackage #:cl-redis-test
   7 |   (:use :common-lisp #:rutil #:redis #:should-test)
   8 |   (:export #:run-tests))
   9 | 
  10 | (in-package #:cl-redis-test)
  11 | (named-readtables:in-readtable rutils-readtable)
  12 | 
  13 | 
  14 | (defun run-tests ()
  15 |   (st:test :package '#:cl-redis-test))
  16 | 
  17 | 
  18 | ;;; utils
  19 | 
  20 | (defun find-s (str seq)
  21 |   (find str seq :test #'string=))
  22 | 
  23 | (defun null-diff (set1 set2)
  24 |   (null (set-exclusive-or set1 set2 :test #'equal)))
  25 | 
  26 | (defmacro with-test-db (&body body)
  27 |   `(with-connection ()
  28 |      (red-select 15)
  29 |      (red-flushdb)
  30 |      (unwind-protect (progn ,@body)
  31 |        (red-flushdb))))
  32 | 
  33 | (defun expect-from-str (expected input)
  34 |   (let ((server (usocket:socket-listen usocket:*wildcard-host* 63799
  35 |                                        :reuseaddress t)))
  36 |     (unwind-protect
  37 |          (let ((bt:*default-special-bindings*
  38 |                 (append `((*connection* . ,*connection*)
  39 |                           (*trace-output* . ,*trace-output*))
  40 |                         bt:*default-special-bindings*)))
  41 |            (bt:make-thread
  42 |             (lambda ()
  43 |               (let ((client
  44 |                      (flex:make-flexi-stream
  45 |                       (usocket:socket-stream (usocket:socket-accept
  46 |                                               server :element-type
  47 |                                               'flex:octet))
  48 |                       :external-format redis::+utf8+
  49 |                       :element-type 'flex:octet)))
  50 |                 (mapcar #`((write-sequence (if (stringp %)
  51 |                                                (flex:string-to-octets
  52 |                                                 % :external-format redis::+utf8+)
  53 |                                                (map 'vector #'code-char %))
  54 |                                            client)
  55 |                            (write-byte (char-code #\Return) client)
  56 |                            (write-byte (char-code #\Linefeed) client))
  57 |                         (mklist input))
  58 |                 (finish-output client))))
  59 |            (with-connection (:port 63799)
  60 |              (expect expected)))
  61 |       (usocket:socket-close server))))
  62 | 
  63 | 
  64 | ;;; tests
  65 | 
  66 | (deftest expect ()
  67 |   (should be string= "OK"
  68 |           (expect-from-str :status "+OK"))
  69 |   (should be string= "10$"
  70 |           (expect-from-str :inline "+10$"))
  71 |   (should be null
  72 |           (expect-from-str :boolean "+0$"))
  73 |   (should be = 10
  74 |           (expect-from-str :integer "+10"))
  75 |   (should be = 10.0d0
  76 |           (expect-from-str :float '("+4" "10.0")))
  77 |   (should be string= "abc"
  78 |           (expect-from-str :bulk '("+3" "abc")))
  79 |   (should be string= ""
  80 |           (expect-from-str :bulk '("+0" "")))
  81 |   (should be equal '("a" nil)
  82 |           (expect-from-str :multi '("*2" "$1" "a" "$-1")))
  83 |   ;; undocumented case for $0, let's be on the safe side
  84 |   (should be equal '("a" "")
  85 |           (expect-from-str :anything '("*2" "$1" "a" "$0" "")))
  86 |   (should be equal '("a" "b" "c")
  87 |           (expect-from-str :list '("+5" "a b c")))
  88 |   (should be equal '("OK" ("a"))
  89 |           (expect-from-str :queued '("*2" "+OK" "*1" "$1" "a")))
  90 |   (should be equal '(("subscribe" "chan1" "1") ("subscribe" "chan2" "2"))
  91 |           (expect-from-str :pubsub '("*3" "$9" "subscribe"
  92 |                                      "$5" "chan1" ":1"
  93 |                                      "*3" "$9" "subscribe"
  94 |                                      "$5" "chan2" ":2")))
  95 |   (should be equalp #(1 2 3)
  96 |           (expect-from-str :bytes '("*3" #(1 2 3)))))
  97 | 
  98 | (deftest tell ()
  99 |   (with-connection ()
 100 |     (let ((*echo-p* t)
 101 |           (*echo-stream* (make-string-output-stream)))
 102 |       (should be string=
 103 |               (fmt " > *3~% > $4~% > HGET~% > $2~% > h1~% > $5~% > f1~%~~~%")
 104 |               (progn (tell 'hget "h1" (format nil "~A~%~B" "f1" "~"))
 105 |                      (get-output-stream-string *echo-stream*))))))
 106 | 
 107 | (deftest connection ()
 108 |   (should be null
 109 |           (disconnect))
 110 |   (should be redis::connection-open-p
 111 |           (connect))
 112 |   (should signal redis-error
 113 |           (connect))
 114 |   (should be null
 115 |           (disconnect))
 116 |   (with-connection ()
 117 |     (should be string= "Hello World!"
 118 |             (red-echo "Hello World!"))
 119 |     (should signal redis-error-reply
 120 |             (red-auth "pass")))
 121 |   ;; QUIT - futile
 122 |   )
 123 | 
 124 | (deftest *-commands ()
 125 |   (with-test-db
 126 |     (should be string= "OK"
 127 |             (red-set "mykey" "Hello"))
 128 |     (should be true
 129 |             (red-expire "mykey" 10))
 130 |     (should be = 10
 131 |             (red-ttl "mykey"))
 132 |     (should be true
 133 |             (red-pexpire "mykey" 10000))
 134 |     (should be < 10001
 135 |             (red-pttl "mykey"))
 136 |     (should be true
 137 |             (red-persist "mykey"))
 138 |     (should be = -1
 139 |             (red-ttl "mykey"))
 140 |     (should be true
 141 |             (red-exists "mykey"))
 142 |     (should be true
 143 |             (red-expireat "mykey" (- (get-universal-time) 2208988800)))
 144 |     (should be null
 145 |             (red-exists "mykey"))
 146 |     (should be string= "OK"
 147 |             (red-set "mykey" "Hello"))
 148 |     (should be true
 149 |             (red-pexpireat "mykey" (* 1000 (- (get-universal-time) 2208988800))))
 150 |     (should be null
 151 |             (red-exists "mykey"))
 152 |     (should be = 1
 153 |             (red-lpush "mylist" "Hello World"))
 154 |     (should be = 1
 155 |             (red-object-refcount "mylist"))
 156 |     (should be string= "ziplist"
 157 |             (red-object-encoding "mylist"))
 158 |     (should be = -1
 159 |             (red-object-idletime "mykey"))
 160 |     (should be string= "OK"
 161 |             (red-set "foo" 1000))
 162 |     (should be string= "int"
 163 |             (red-object-encoding "foo"))
 164 |     (should be = 7
 165 |             (red-append "foo" "bar"))
 166 |     (should be string= "1000bar"
 167 |             (red-get "foo"))
 168 |     (should be string= "raw"
 169 |             (red-object-encoding "foo"))
 170 |     (should be true
 171 |             (red-move "foo" 14))
 172 |     (should be null
 173 |             (red-move "foo" 14))
 174 |     (should be true
 175 |             (red-select 14))
 176 |     (should be true
 177 |             (red-del "foo"))
 178 |     (should be true
 179 |             (red-select 15))
 180 |     (should be string= "OK"
 181 |             (red-set "mykey" 10))
 182 |     (should be equalp #(0 192 10 6 0 248 114 63 197 251 251 95 40)
 183 |             (red-dump "mykey"))
 184 |     (should be true
 185 |             (red-del "mykey"))
 186 |     (should be string= "OK"
 187 |             (red-restore "mykey" 0 #(0 192 10 6 0 248 114 63 197 251 251 95 40)))
 188 |     (should be string= "string"
 189 |             (red-type "mykey"))
 190 |     (should be string= "10"
 191 |             (red-get "mykey"))))
 192 | 
 193 | (deftest sort-command ()
 194 |   (with-test-db
 195 |     (should be true
 196 |             (red-rpush "numbers" "1"))
 197 |     (should be true
 198 |             (red-rpush "числа" "1"))
 199 |     (should be true
 200 |             (red-rpush "numbers" "2"))
 201 |     (should be true
 202 |             (red-rpush "числа" "2"))
 203 |     (should be true
 204 |             (red-rpush "numbers" "3"))
 205 |     (should be true
 206 |             (red-rpush "числа" "3"))
 207 |     (should be true
 208 |             (red-set "object_1" "o1"))
 209 |     (should be true
 210 |             (red-set "об'єкт_1" "о1"))
 211 |     (should be true
 212 |             (red-set "object_2" "o2"))
 213 |     (should be true
 214 |             (red-set "об'єкт_2" "о2"))
 215 |     (should be true
 216 |             (red-set "object_3" "o3"))
 217 |     (should be true
 218 |             (red-set "об'єкт_3" "о3"))
 219 |     (should be true
 220 |             (red-set "weight_1" "47"))
 221 |     (should be true
 222 |             (red-set "вага_1" "47"))
 223 |     (should be true
 224 |             (red-set "weight_2" "13"))
 225 |     (should be true
 226 |             (red-set "вага_2" "13"))
 227 |     (should be true
 228 |             (red-set "weight_3" "32"))
 229 |     (should be true
 230 |             (red-set "вага_3" "32"))
 231 |     (should be equal '("1" "2" "3")
 232 |             (red-sort "numbers"))
 233 |     (should be = 3
 234 |             (red-sort "numbers" :store "stored"))
 235 |     (should be equal '("1" "2" "3")
 236 |             (red-lrange "stored" 0 -1))
 237 |     (should be equal '("1" "2" "3")
 238 |             (red-sort "числа"))
 239 |     (should be equal '("2" "3")
 240 |             (red-sort "numbers" :start 1 :end 2))
 241 |     (should be equal '("2" "3")
 242 |             (red-sort "числа" :start 1 :end 2))
 243 |     (should be equal '("3" "2" "1")
 244 |             (red-sort "numbers" :desc t))
 245 |     (should be equal '("2" "1")
 246 |             (red-sort "numbers" :desc t :start 1 :end 2))
 247 |     (should be equal '("3" "2" "1")
 248 |             (red-sort "числа" :desc t))
 249 |     (should be equal '("2" "1")
 250 |             (red-sort "числа"
 251 |                       :desc t :start 1 :end 2))
 252 |     (should be equal '("2" "3" "1")
 253 |             (red-sort "numbers" :by "weight_*"))
 254 |     (should be equal '("2" "3" "1")
 255 |             (red-sort "числа"
 256 |                       :by "вага_*"))
 257 |     (should be equal '("o2" "o3" "o1")
 258 |             (red-sort "numbers" :by "weight_*" :get "object_*"))
 259 |     (should be equal '("о2" "о3" "о1")
 260 |             (red-sort "числа"
 261 |                       :by "вага_*"
 262 |                       :get "об'єкт_*"))
 263 |     (should be equal '("o1" "o3" "o2")
 264 |             (red-sort "numbers" :by "weight_*" :get "object_*" :desc t))
 265 |     (should be equal '("о1" "о3" "о2")
 266 |             (red-sort "числа"
 267 |                       :by "вага_*"
 268 |                       :get "об'єкт_*"
 269 |                       :desc t))))
 270 | 
 271 | (deftest str-commands ()
 272 |   (with-test-db
 273 |     (should be true
 274 |             (red-set "y" "1"))
 275 |     (should be true
 276 |             (red-set "ігрек" "1"))
 277 |     (should be string= "1"
 278 |             (red-getset "y" "2"))
 279 |     (should be string= "1"
 280 |             (red-getset "ігрек" "2"))
 281 |     (should be string= "2"
 282 |             (red-get "y"))
 283 |     (should be string= "2"
 284 |             (red-get "ігрек"))
 285 |     (should be true
 286 |             (red-set "z" "3"))
 287 |     (should be true
 288 |             (red-set "зед" "3"))
 289 |     (should be equal '("2" "3")
 290 |             (red-mget "y" "z"))
 291 |     (should be equal '("2" "3")
 292 |             (red-mget "ігрек" "зед"))
 293 |     (should be equal '("2" nil)
 294 |             (red-mget "y" "a"))
 295 |     (should be equal '("2" nil)
 296 |             (red-mget "ігрек" "а"))
 297 |     (should be null
 298 |             (red-setnx "z" "3"))
 299 |     (should be null
 300 |             (red-setnx "зед" "3"))
 301 |     (should be true
 302 |             (red-setnx "u" "3"))
 303 |     (should be true
 304 |             (red-setnx "ю" "3"))
 305 |     (should be string= "OK"
 306 |             (red-setex "v" 1 0))
 307 |     (should be null
 308 |             (progn (sleep 2) (red-get "v")))
 309 |     (should be = 4
 310 |             (red-incr "u"))
 311 |     (should be = 4
 312 |             (red-incr "ю"))
 313 |     (should be = 6
 314 |             (red-incrby "u" 2))
 315 |     (should be = 6
 316 |             (red-incrby "ю" 2))
 317 |     (should be = 5.0
 318 |             (red-incrbyfloat "u" -1.0))
 319 |     (should be = 5
 320 |             (red-decr "ю"))
 321 |     (should be = 3
 322 |             (red-decrby "ю" 2))
 323 |     (should be true
 324 |             (red-exists "u"))
 325 |     (should be true
 326 |             (red-exists "ю"))
 327 |     (should be null
 328 |             (red-exists "v"))
 329 |     (should be null
 330 |             (red-exists "ві"))
 331 |     (should be true
 332 |             (red-del "u"))
 333 |     (should be true
 334 |             (red-del "ю"))
 335 |     (should be null
 336 |             (red-exists "u"))
 337 |     (should be null
 338 |             (red-exists "ю"))
 339 |     (should be string= "none"
 340 |             (red-type "u"))
 341 |     (should be string= "none"
 342 |             (red-type "ю"))
 343 |     (should be string= "string"
 344 |             (red-type "z"))
 345 |     (should be string= "string"
 346 |             (red-type "зед"))
 347 |     (should be null-diff '("y" "ігрек"
 348 |                            "z" "зед")
 349 |             (red-keys "*"))
 350 |     (should be string= "OK"
 351 |             (red-rename "z" "c"))
 352 |     (should be string= "OK"
 353 |             (red-rename "зед" "це"))
 354 |     (should signal redis-error-reply
 355 |             (red-rename "z" "d"))
 356 |     (should be string= "3"
 357 |             (red-get "c"))
 358 |     (should be string= "3"
 359 |             (red-get "це"))
 360 |     (should be null
 361 |             (red-renamenx "y" "c"))
 362 |     (should be null
 363 |             (red-renamenx "ігрек" "це"))
 364 |     (should be true
 365 |             (red-renamenx "y" "b"))
 366 |     (should be true
 367 |             (red-renamenx "ігрек" "бе"))
 368 |     (should signal redis-error-reply
 369 |             (red-renamenx "b" "b"))
 370 |     (should signal redis-error-reply
 371 |             (red-renamenx "бе" "бе"))
 372 |     (should be = 4
 373 |             (red-dbsize))
 374 |     (should be true
 375 |             (red-expire "b" 1))
 376 |     (should be true
 377 |             (red-expire "бе" 1))
 378 |     (should be null
 379 |             (progn (sleep 2) (red-get "b")))
 380 |     (should be null
 381 |             (red-get "бе"))
 382 |     (should be null
 383 |             (red-expire "b" 1))
 384 |     (should be find-s '("c" "це")
 385 |             (red-randomkey))
 386 |     (should be true
 387 |             (red-expire "c" 600))
 388 |     (should be true
 389 |             (red-expire "це" 600))
 390 |     (should be < 601
 391 |             (red-ttl "c"))
 392 |     (should be < 601
 393 |             (red-ttl "це"))
 394 |     (should be true
 395 |             (red-mset "k1" "v1" "k2" "v2"))
 396 |     (should be true
 397 |             (red-mset "ка1" "ве1"
 398 |                       "ка2" "ве2"))
 399 |     (should be null
 400 |             (red-msetnx "k1" "w1" "k3" "v3"))
 401 |     (should be null
 402 |             (red-msetnx "ка1"
 403 |                         "дубльве1"
 404 |                         "ка3"
 405 |                         "ве3"))
 406 |     (should be null
 407 |             (red-exists "k3"))
 408 |     (should be null
 409 |             (red-exists "ка3"))
 410 |     (should be true
 411 |             (red-msetnx "k4" "v4" "k5" "v5"))
 412 |     (should be true
 413 |             (red-msetnx "ка4" "ве4"
 414 |                         "ка5" "ве5"))
 415 |     (should be equal '("v1" "v2" "v4" "v5")
 416 |             (red-mget "k1" "k2" "k4" "k5"))
 417 |     (should be equal '("ве1" "ве2"
 418 |                        "ве4" "ве5")
 419 |             (red-mget "ка1" "ка2"
 420 |                       "ка4" "ка5"))
 421 |     (should be true
 422 |             (red-mset "k1" "w1" "k2" "v2"))
 423 |     (should be true
 424 |             (red-mset "ка1"
 425 |                       "дубльве1"
 426 |                       "ка2"
 427 |                       "ве2"))
 428 |     (should be equal "w1"
 429 |             (red-get "k1"))
 430 |     (should be equal "дубльве1"
 431 |             (red-get "ка1"))
 432 |     (should be null
 433 |             (red-exists "mykey"))
 434 |     (should be = 6
 435 |             (red-append "mykey" "Hello "))
 436 |     (should be = 11
 437 |             (red-append "mykey" "World"))
 438 |     (should be string= "Hello World"
 439 |             (red-get "mykey"))
 440 |     (should be string= "OK"
 441 |             (red-set "s" "This is a string"))
 442 |     (should be string= "This"
 443 |             (red-substr "s" 0 3))
 444 |     (should be string= "ing"
 445 |             (red-substr "s" -3 -1))
 446 |     (should be string= "This is a string"
 447 |             (red-substr "s" 0 -1))
 448 |     (should be string= " string"
 449 |             (red-substr "s" 9 100000))
 450 |     (should be string= "OK"
 451 |             (red-set "mykey" "This is a string"))
 452 |     (should be string= "This"
 453 |             (red-getrange "mykey" 0 3))
 454 |     (should be string= "ing"
 455 |             (red-getrange "mykey" -3 -1))
 456 |     (should be string= "This is a string"
 457 |             (red-getrange "mykey" 0 -1))
 458 |     (should be = 16
 459 |             (red-setrange "mykey" 10 "Redis"))
 460 |     (should be string= "This is a Redisg"
 461 |             (red-get "mykey"))
 462 |     (should be = 11
 463 |             (red-setrange "key2" 6 "Redis"))
 464 |     (should be string= "Redis"
 465 |             (red-get "key2"))
 466 |     (should be string= "Redisg"
 467 |             (red-getrange "mykey" 10 100))
 468 |     (should be zerop
 469 |             (red-setbit "mykey" 7 1))
 470 |     (should be = 1
 471 |             (red-getbit "mykey" 7))
 472 |     (should be zerop
 473 |             (red-getbit "mykey" 10000))
 474 |     (should be = 55
 475 |             (red-bitcount "mykey"))
 476 |     (should be = 16
 477 |             (red-bitop "NOT" "mykey2" "mykey"))
 478 |     (should be equal '("1" "1")
 479 | 	    (red-bitfield "bitfield:test" "incrby" "u2" 100 1 "OVERFLOW" "SAT" "incrby" "u2" 102 1))
 480 |     (should be equal '("1")
 481 | 	    (red-bitfield_ro "bitfield:test" "GET" "u2" 100))
 482 |     (should be string= "Uhis is a Redisg"
 483 |             (red-get "mykey"))
 484 |     (should be = 16
 485 |             (red-strlen "mykey"))
 486 |     (should be zerop
 487 |             (red-strlen "nonex key"))
 488 |     (should be string= "OK"
 489 |             (red:set "mykey" (apply #'fmt "~C~C~C"
 490 |                                     (mapcar #'code-char '(#xf0 #xff #x00)))))
 491 |     (should be = 2
 492 |             (red:bitpos "mykey" 0))
 493 |     (should be string= "OK"
 494 |             (red:set "mykey" (apply #'fmt "~C~C~C"
 495 |                                     (mapcar #'code-char '(#x00 #xff #xf0)))))
 496 |     (should be = 8
 497 |             (red:bitpos "mykey" 1 0))
 498 |     (should be = 16
 499 |             (red:bitpos "mykey" 1 2))
 500 |     (should be string= "OK"
 501 |             (red:set "mykey" (apply #'fmt "~C~C~C"
 502 |                                     (mapcar #'code-char '(#x00 #x00 #x00)))))
 503 |     (should be = -1
 504 |             (red:bitpos "mykey" 1))))
 505 | 
 506 | (deftest l-commands ()
 507 |   (with-test-db
 508 |     (should be = 1
 509 |             (red-rpush "l" "1"))
 510 |     (should be = 1
 511 |             (red-rpush "эл" "1"))
 512 |     (should be = 2
 513 |             (red-rpush "l" "1"))
 514 |     (should be = 2
 515 |             (red-rpush "эл" "1"))
 516 |     (should be = 3
 517 |             (red-rpush "l" "1"))
 518 |     (should be = 3
 519 |             (red-rpush "эл" "1"))
 520 |     (should be = 3
 521 |             (red-lrem "l" 0 "1"))
 522 |     (should be = 3
 523 |             (red-lrem "эл" 0 "1"))
 524 |     (should be = 0
 525 |             (red-lrem "l" 0 "a"))
 526 |     (should be = 0
 527 |             (red-lrem "эл" 0 "а"))
 528 |     (should be true
 529 |             (red-lpush "l" "1"))
 530 |     (should be true
 531 |             (red-lpush "эл" "1"))
 532 |     (should be true
 533 |             (red-lpush "l" "0"))
 534 |     (should be true
 535 |             (red-lpush "эл" "0"))
 536 |     (should be = 2
 537 |             (red-llen "l"))
 538 |     (should be = 2
 539 |             (red-llen "эл"))
 540 |     (should be equal '("0")
 541 |             (red-lrange "l" 0 0))
 542 |     (should be equal '("0")
 543 |             (red-lrange "эл" 0 0))
 544 |     (should be equal '("0" "1")
 545 |             (red-lrange "l" 0 -1))
 546 |     (should be equal '("0" "1")
 547 |             (red-lrange "l" 0 2))
 548 |     (should be equal '("0" "1")
 549 |             (red-lrange "l" 0 10))
 550 |     (should be null
 551 |             (red-lrange "l" 2 1))
 552 |     (should be null
 553 |             (red-lrange "l" 2 3))
 554 |     (should be string= "0"
 555 |             (red-lindex "l" 0))
 556 |     (should be string= "0"
 557 |             (red-lindex "эл" 0))
 558 |     (should be true
 559 |             (red-lset "l" 0 "a"))
 560 |     (should be true
 561 |             (red-lset "эл" 0 "а"))
 562 |     (should be equal '("a" "1")
 563 |             (red-lrange "l" 0 10))
 564 |     (should be equal '("а" "1")
 565 |             (red-lrange "эл" 0 10))
 566 |     (should be true
 567 |             (red-ltrim "l" 0 0))
 568 |     (should be true
 569 |             (red-ltrim "эл" 0 0))
 570 |     (should be equal '("a")
 571 |             (red-lrange "l" 0 10))
 572 |     (should be equal '("а")
 573 |             (red-lrange "эл" 0 10))
 574 |     (should be true
 575 |             (red-ltrim "l" 2 3))
 576 |     (should be true
 577 |             (red-ltrim "эл" 2 3))
 578 |     (should be null
 579 |             (red-lrange "l" 0 10))
 580 |     (should be null
 581 |             (red-lrange "эл" 0 10))
 582 |     (should be true
 583 |             (red-lpush "l" "2"))
 584 |     (should be true
 585 |             (red-lpush "эл" "2"))
 586 |     (should be true
 587 |             (red-rpush "l" "3"))
 588 |     (should be true
 589 |             (red-rpush "эл" "3"))
 590 |     (should be true
 591 |             (red-rpush "l" "4"))
 592 |     (should be true
 593 |             (red-rpush "эл" "4"))
 594 |     (should be true
 595 |             (red-rpush "эл" "5"))
 596 |     (should be true
 597 |             (red-rpush "эл" "6"))
 598 |     (should be string= "2"
 599 |             (red-lpop "l"))
 600 |     (should be string= "2"
 601 |             (red-lpop "эл"))
 602 |     (should be string= "4"
 603 |             (red-rpop "l"))
 604 |     (should be string= "3"
 605 |             (red-rpop "l"))
 606 |     (should be string= "6"
 607 |             (red-rpop "эл"))
 608 |     (should be null
 609 |             (red-blpop "l" 1))
 610 |     (should be true
 611 |             (red-rpush "l" "5"))
 612 |     (should be equal '("l" "5")
 613 |             (red-blpop "l" 1))
 614 |     (should be equal '("эл" "3")
 615 |             (red-blpop "эл" 1))
 616 |     (should be true
 617 |             (red-rpush "l" "0"))
 618 |     (should be true
 619 |             (red-rpush "l" "1"))
 620 |     (should be true
 621 |             (red-rpush "l" "2"))
 622 |     (should be equal '("0" "1" "2")
 623 |             (red-lrange "l" 0 -1))
 624 |     (should be string= "4"
 625 |             (red-lpop "эл"))
 626 |     (should be string= "5"
 627 |             (red-lpop "эл"))
 628 |     (should be null
 629 |             (red-lrange "эл" 0 -1))
 630 |     (should be string= "2"
 631 |             (red-rpoplpush "l" "эл"))
 632 |     (should be string= "1"
 633 |             (red-rpoplpush "l" "l"))
 634 |     (should be string= "0"
 635 |             (red-brpoplpush "l" "l" 0))
 636 |     (should be null
 637 |             (progn (sleep 2) (red-brpoplpush "abc" "l" 1)))
 638 |     (should be equal '("2")
 639 |             (red-lrange "эл" 0 1))
 640 |     (should be equal '("0" "1")
 641 |             (red-lrange "l" 0 2))
 642 |     (should be string= "1"
 643 |             (red-rpop "l"))
 644 |     (should signal redis-error-reply
 645 |             (red-get "l"))
 646 |     (should signal redis-error-reply
 647 |             (red-get "эл"))
 648 |     (should be = 1
 649 |             (red-lpush "mylist" "World"))
 650 |     (should be = 2
 651 |             (red-lpushx "mylist" "Hello"))
 652 |     (should be = 0
 653 |             (red-lpushx "myotherlist" "Hello"))
 654 |     (should be equal '("Hello" "World")
 655 |             (red-lrange "mylist" 0 -1))
 656 |     (should be null
 657 |             (red-lrange "myotherlist" 0 -1))
 658 |     (should be = 1
 659 |             (red-rpush "mylist2" "Hello"))
 660 |     (should be = 2
 661 |             (red-rpushx "mylist2" "World"))
 662 |     (should be zerop
 663 |             (red-rpushx "myotherlist" "Hello"))
 664 |     (should be equal '("Hello" "World")
 665 |             (red-lrange "mylist2" 0 -1))
 666 |     (should be null
 667 |             (red-lrange "myotherlist" 0 -1))
 668 |     (should be = 3
 669 |             (red-linsert "mylist2" :before "World" "There"))
 670 |     (should be equal '("Hello" "There" "World")
 671 |             (red-lrange "mylist2" 0 -1))
 672 |     (should be = 4
 673 |             (red-linsert "mylist2" :after "World" "!"))
 674 |     (should be equal '("Hello" "There" "World" "!")
 675 |             (red-lrange "mylist2" 0 -1))
 676 |     (should signal simple-error
 677 |             (red-linsert "mylist2" :inside "World" "1"))
 678 |     (should be = -1
 679 |             (red-linsert "mylist2" :before "W" "1"))))
 680 | 
 681 | (deftest s-commands ()
 682 |   (with-test-db
 683 |     (should be = 1
 684 |             (red-sadd "s" "1"))
 685 |     (should be = 1
 686 |             (red-sadd "э" "1"))
 687 |     (should be = 0
 688 |             (red-sadd "s" "1"))
 689 |     (should be = 0
 690 |             (red-sadd "э" "1"))
 691 |     (should be = 1
 692 |             (red-sadd "s" "2"))
 693 |     (should be = 1
 694 |             (red-sadd "э" "2"))
 695 |     (should be find-s '("2" "1")
 696 |             (red-srandmember "s"))
 697 |     (should be equal '("1" "2")
 698 |             (red-srandmember "s" 2))
 699 |     (should be find-s '("2" "1")
 700 |             (red-spop "s"))
 701 |     (should be find-s '("2" "1")
 702 |             (red-spop "э"))
 703 |     (should be true
 704 |             (or (red-sadd "s" "2") (red-sadd "s" "1")))
 705 |     (should be true
 706 |             (or (red-sadd "э" "2") (red-sadd "э" "1")))
 707 |     (should be true
 708 |             (red-srem "s" "1"))
 709 |     (should be true
 710 |             (red-srem "э" "1"))
 711 |     (should be string= "2"
 712 |             (red-spop "s"))
 713 |     (should be string= "2"
 714 |             (red-spop "э"))
 715 |     (should be null
 716 |             (red-spop "s"))
 717 |     (should be null
 718 |             (red-spop "э"))
 719 |     (should be true
 720 |             (red-sadd "s" "2"))
 721 |     (should be true
 722 |             (red-sadd "э" "2"))
 723 |     (should be true
 724 |             (red-sismember "s" "2"))
 725 |     (should be true
 726 |             (red-sismember "э" "2"))
 727 |     (should be true
 728 |             (red-sadd "s" "1"))
 729 |     (should be true
 730 |             (red-sadd "э" "1"))
 731 |     (should be true
 732 |             (red-smove "s" "s2" "1"))
 733 |     (should be true
 734 |             (red-smove "э" "э2" "1"))
 735 |     (should be true
 736 |             (red-sismember "s2" "1"))
 737 |     (should be true
 738 |             (red-sismember "э2" "1"))
 739 |     (should be null
 740 |             (red-smove "s" "s2" "3"))
 741 |     (should be null
 742 |             (red-smove "э" "э2" "3"))
 743 |     (should be null
 744 |             (red-sismember "s2" "3"))
 745 |     (should be null
 746 |             (red-sismember "э2" "3"))
 747 |     (should be true
 748 |             (red-sadd "s" "1"))
 749 |     (should be true
 750 |             (red-sadd "э" "1"))
 751 |     (should be true
 752 |             (red-smove "s" "s2" "1"))
 753 |     (should be true
 754 |             (red-smove "э" "э2" "1"))
 755 |     (should be = 1
 756 |             (red-scard "s"))
 757 |     (should be = 1
 758 |             (red-scard "э"))
 759 |     (should be null
 760 |             (red-sinter "s" "s2"))
 761 |     (should be null
 762 |             (red-sinter "э" "э2"))
 763 |     (should be true
 764 |             (red-sadd "s" "1"))
 765 |     (should be true
 766 |             (red-sadd "э" "1"))
 767 |     (should be equal '("1")
 768 |             (red-sinter "s" "s2"))
 769 |     (should be equal '("1")
 770 |             (red-sinter "э" "э2"))
 771 |     (should be true
 772 |             (red-sinterstore "s3" "s" "s2"))
 773 |     (should be true
 774 |             (red-sinterstore "э3" "э" "э2"))
 775 |     (should be equal '("1")
 776 |             (red-smembers "s3"))
 777 |     (should be equal '("1")
 778 |             (red-smembers "э3"))
 779 |     (should be null-diff '("1" "2")
 780 |             (red-sunion "s" "s2"))
 781 |     (should be null-diff '("1" "2")
 782 |             (red-sunion "э" "э2"))
 783 |     (should be true
 784 |             (red-sunionstore "s4" "s" "s2"))
 785 |     (should be true
 786 |             (red-sunionstore "э4" "э" "э2"))
 787 |     (should be null-diff '("1" "2")
 788 |             (red-smembers "s4"))
 789 |     (should be equal '("1" "2")
 790 |             (red-smembers "э4"))
 791 |     (should be equal '("2")
 792 |             (red-sdiff "s4" "s3"))
 793 |     (should be equal '("2")
 794 |             (red-sdiff "э4" "э3"))
 795 |     (should be true
 796 |             (red-sdiffstore "s5" "s4" "s3"))
 797 |     (should be true
 798 |             (red-sdiffstore "э5" "э4" "э3"))
 799 |     (should be equal '("2")
 800 |             (red-smembers "s5"))
 801 |     (should be equal '("2")
 802 |             (red-smembers "э5"))))
 803 | 
 804 | (deftest z-commands ()
 805 |   (with-test-db
 806 |     (should be true
 807 |             (red-zadd "set" 1 "e1"))
 808 |     (should be true
 809 |             (red-zadd "множина"
 810 |                       1 "елемент1"))
 811 |     (should be true
 812 |             (red-zadd "set" 2 "e2"))
 813 |     (should be true
 814 |             (red-zadd "множина"
 815 |                       2 "елемент2"))
 816 |     (should be true
 817 |             (red-zadd "set" 3 "e3"))
 818 |     (should be true
 819 |             (red-zadd "множина"
 820 |                       3 "елемент3"))
 821 |     (should be true
 822 |             (red-zrem "set" "e2"))
 823 |     (should be true
 824 |             (red-zrem "множина"
 825 |                       "елемент2"))
 826 |     (should be zerop
 827 |             (red-zrem "set" "e2"))
 828 |     (should be zerop
 829 |             (red-zrem "множина"
 830 |                       "елемент2"))
 831 |     (should be true
 832 |             (red-zadd "set" 10 "e2"))
 833 |     (should be true
 834 |             (red-zadd "множина"
 835 |                       10 "елемент2"))
 836 |     (should be true
 837 |             (red-zadd "set" 4 "e4"))
 838 |     (should be true
 839 |             (red-zadd "множина"
 840 |                       4 "елемент4"))
 841 |     (should be true
 842 |             (red-zadd "set" 5 "e5"))
 843 |     (should be true
 844 |             (red-zadd "множина"
 845 |                       5 "елемент5"))
 846 |     (should be = 5
 847 |             (red-zcard "set"))
 848 |     (should be = 10.0d0
 849 |             (red-zscore "set" "e2"))
 850 |     (should be = 4
 851 |             (red-zrank "set" "e2"))
 852 |     (should be zerop
 853 |             (red-zrevrank "set" "e2"))
 854 |     (should be equal '("e3" "e4" "e5")
 855 |             (red-zrange "set" 1 3))
 856 |     (should be equal '("елемент3"
 857 |                        "елемент4"
 858 |                        "елемент5")
 859 |             (red-zrange "множина" 1 3))
 860 |     (should be equal '("e4" "e3" "e1")
 861 |             (red-zrevrange "set" 2 4))
 862 |     (should be equal '("елемент4" "4"
 863 |                        "елемент3" "3"
 864 |                        "елемент1" "1")
 865 |             (red-zrevrange "множина"
 866 |                            2 4 :withscores))
 867 |     (should be equal '("e5" "e2")
 868 |             (red-zrangebyscore "set" 5 10))
 869 |     (should be equal '("елемент1"
 870 |                        "елемент3"
 871 |                        "елемент4"
 872 |                        "елемент5"
 873 |                        "елемент2")
 874 |             (red-zrangebyscore "множина"
 875 |                                "-inf" "+inf"))
 876 |     (should be equal '("e5" "5" "e4" "4")
 877 |             (red-zrevrangebyscore "set" "(10" 4 :withscores t))
 878 |     (should be equal '("елемент5" "5")
 879 |             (red-zrevrangebyscore
 880 |              "множина"
 881 |              10 5 :withscores t :limit '(1 . 1)))
 882 |     (should be = 3
 883 |             (red-zremrangebyscore "set" 2 7))
 884 |     (should be = 3
 885 |             (red-zremrangebyrank
 886 |              "множина" 0 2))
 887 |     (should be equal '("e1" "e2")
 888 |             (red-zrange "set" 0 -1))
 889 |     (should be equal '("елемент5"
 890 |                        "елемент2")
 891 |             (red-zrange "множина" 0 -1))
 892 |     (should be = 7
 893 |             (red:zadd "myzset" 0 "a" 0 "b" 0 "c" 0 "d" 0 "e" 0 "f" 0 "g"))
 894 |     (should be equal '("c" "b" "a")
 895 |             (red:zrevrangebylex "myzset" "[c" "-"))
 896 |     (should be equal '("b" "a")
 897 |             (red:zrevrangebylex "myzset" "(c" "-"))
 898 |     (should be equal '("f" "e" "d" "c" "b")
 899 |             (red:zrevrangebylex "myzset" "(g" "[aaa"))
 900 |     (should be = 1
 901 |             (red:zadd "myzset" 0 "aaaa" 0 "b" 0 "c" 0 "d" 0 "e"))
 902 |     (should be = 5
 903 |             (red:zadd "myzset" 0 "foo" 0 "zap" 0 "zip" 0 "ALPHA" 0 "alpha"))
 904 |     (should be equal '("ALPHA" "a" "aaaa" "alpha" "b" "c" "d" "e" "f" "foo" "g"
 905 |                        "zap" "zip")
 906 |             (red:zrange "myzset" 0 -1))
 907 |     (should be = 8
 908 |             (red:zremrangebylex "myzset" "[alpha" "[omega"))
 909 |     (should be equal '("ALPHA" "a" "aaaa" "zap" "zip")
 910 |             (red:zrange "myzset" 0 -1))
 911 |     (should be = 4
 912 |             (red-zunionstore
 913 |              "s1" 2 '("set" "множина")))
 914 |     (should be zerop
 915 |             (red-zinterstore
 916 |              "s2" 2 '("set" "множина")
 917 |              :weights '(1 2) :aggregate :min))
 918 |     (should be = 2
 919 |             (red-zinterstore "s3" 2 '("set" "s1") :aggregate :sum))
 920 |     (should be true
 921 |             (red-zadd "myzset" 1 "one"))
 922 |     (should be true
 923 |             (red-zadd "myzset" 1 "two"))
 924 |     (should be true
 925 |             (red-zadd "myzset" 1 "three"))
 926 |     (should be = 8
 927 |             (red-zcount "myzset" "-inf" "+inf"))
 928 |     (should be zerop
 929 |             (red-zcount "myzset" "(1" "3"))
 930 |     (should be = 4
 931 |             (red:zadd "myzset" 0 "a" 0 "b" 0 "c" 0 "d" 0 "e"))
 932 |     (should be = 2
 933 |             (red:zadd "myzset" 0 "f" 0 "g"))
 934 |     (should be = 14
 935 |             (red:zlexcount "myzset" "-" "+"))
 936 |     (should be = 5
 937 |             (red:zlexcount "myzset" "[b" "[f"))
 938 |     (should be = 1
 939 |             (red-zincrby "myzset" 3 "two"))))
 940 | 
 941 | (deftest h-commands ()
 942 |   (with-test-db
 943 |     (should be true
 944 |             (red-hset "h1" "f1" "a"))
 945 |     (should be true
 946 |             (red-hset "h1" "f2" "b"))
 947 |     (should be null
 948 |             (red-hset "h1" "f1" "c"))
 949 |     (should be string= "c"
 950 |             (red-hget "h1" "f1"))
 951 |     (should be equal '("c" "b")
 952 |             (red-hmget "h1" "f1" "f2"))
 953 |     (should be string= "OK"
 954 |             (red-hmset "h1" "f1" "1" "f2" "2"))
 955 |     (should be = 3
 956 |             (red-hincrby "h1" "f2" "1"))
 957 |     (should be zerop
 958 |             (red-hincrby "h1" "f1" "-1"))
 959 |     (should be = 0.1d0
 960 |             (red-hincrbyfloat "h1" "f1" "0.1"))
 961 |     (should be true
 962 |             (red-hexists "h1" "f1"))
 963 |     (should be null
 964 |             (red-hexists "h1" "f3"))
 965 |     (should be true
 966 |             (red-hdel "h1" "f1"))
 967 |     (should be null
 968 |             (red-hdel "h1" "f3"))
 969 |     (should be = 1
 970 |             (red-hlen "h1"))
 971 |     (should be equal '("f2")
 972 |             (red-hkeys "h1"))
 973 |     (should be equal '("3")
 974 |             (red-hvals "h1"))
 975 |     (should be equal '("f2" "3")
 976 |             (red-hgetall "h1"))
 977 |     (should be true
 978 |             (red-hsetnx "myhash" "field" "Hello"))
 979 |     (should be null
 980 |             (red-hsetnx "myhash" "field" "World"))
 981 |     (should be string= "Hello"
 982 |             (red-hget "myhash" "field"))
 983 |     #+v.3.2.0
 984 |     (should be = 5
 985 |             (red-hstrlen "myhash" "field"))))
 986 | 
 987 | (deftest pf-commands ()
 988 |   (with-test-db
 989 |     (should be = 1
 990 |             (red:pfadd "hll" "a" "b" "c" "d" "e" "f" "g"))
 991 |     (should be = 7
 992 |             (red:pfcount "hll"))
 993 |     (should be = 1
 994 |             (red:pfadd "hll1" "foo" "bar" "zap" "a"))
 995 |     (should be = 1
 996 |             (red:pfadd "hll2" "a" "b" "c" "foo"))
 997 |     (should be string= "OK"
 998 |             (red:pfmerge "hll3" "hll1" "hll2"))
 999 |     (should be = 6
1000 |             (red:pfcount "hll3"))))
1001 | 
1002 | (deftest transaction-commands ()
1003 |   (with-test-db
1004 |     (should be string= "OK"
1005 |             (red-multi))
1006 |     (should be string= "QUEUED"
1007 |             (red-incr "foo"))
1008 |     (should be string= "QUEUED"
1009 |             (red-incr "bar"))
1010 |     (should be string= "QUEUED"
1011 |             (red-incr "bar"))
1012 |     (should be equal '(1 1 2)
1013 |             (red-exec))
1014 |     (should be string= "OK"
1015 |             (red-multi))
1016 |     (should be string= "QUEUED"
1017 |             (red-set "a" "abc"))
1018 |     (should be string= "QUEUED"
1019 |             (red-lpop "a"))
1020 |     (should signal redis-error-reply
1021 |             (red-exec))
1022 |     (should be true
1023 |             (red-set "foo" "1"))
1024 |     (should be string= "OK"
1025 |             (red-multi))
1026 |     (should be string= "QUEUED"
1027 |             (red-incr "foo"))
1028 |     (should be string= "OK"
1029 |             (red-discard))
1030 |     (should be string= "1"
1031 |             (red-get "foo"))
1032 |     (should be string= "OK"
1033 |             (red-watch "abc"))
1034 |     (should be string= "OK"
1035 |             (red-unwatch))))
1036 | 
1037 | (deftest pubsub-commands ()
1038 |   (with-test-db
1039 |     (should be equal '(("subscribe" "foo" "1") ("subscribe" "bar" "2"))
1040 |             (red-subscribe "foo" "bar"))
1041 |     (should be equal '("message" "foo" "test")
1042 |             (progn (bt:make-thread (lambda ()
1043 |                                      (let ((*echo-p* nil))
1044 |                                        (sleep 1)
1045 |                                        (with-connection ()
1046 |                                          (red-publish "foo" "test")))))
1047 |                    (expect :multi)))
1048 |     (should be equal '(nil nil)
1049 |             (multiple-value-list (expect :multi :timeout 2)))
1050 |     (should be equal '(("unsubscribe" "bar" "1"))
1051 |             (red-unsubscribe "bar"))
1052 |     (should be equal '(("unsubscribe" "foo" "0"))
1053 |             (red-unsubscribe))
1054 |     (should be equal '(("psubscribe" "news.*" "1"))
1055 |             (red-psubscribe "news.*"))
1056 |     (should be equal '("pmessage" "news.*" "news.1" "puf")
1057 |             (progn (bt:make-thread (lambda ()
1058 |                                      (let ((*echo-p* nil))
1059 |                                        (sleep 1)
1060 |                                        (with-connection ()
1061 |                                        (red-publish "news.1" "puf")))))
1062 |                    (expect :multi)))
1063 |     (should be equal '(("punsubscribe" "news.*" "0"))
1064 |             (red-punsubscribe))
1065 |     (should be zerop
1066 |             (red-publish "test" "test"))))
1067 | 
1068 | (deftest pipelining-commands ()
1069 |   (with-test-db
1070 |     (should be equal '("PONG" 0)
1071 |             (with-pipelining
1072 |               (red-ping)
1073 |               (red-dbsize)))
1074 |     (handler-bind ((warning #`(invoke-restart (find-restart 'muffle-warning %))))
1075 |       (should be equal '("PONG" "PONG")
1076 |               (with-pipelining
1077 |                 (red-ping)
1078 |                 (with-pipelining
1079 |                   (red-ping)))))))
1080 | 
1081 | (deftest server-commands ()
1082 |   (with-test-db
1083 |     (should be true
1084 |             (red:save))
1085 |     (should be true
1086 |             (red:bgsave))
1087 |     (should be integerp
1088 |             (red:lastsave))
1089 |     (should be string= "redis_version"
1090 |             (let ((info (red:info)))
1091 |               (if (char= #\# (char info 0))
1092 |                   (sub info 10 23)
1093 |                   (sub info 0 13))))
1094 |     (should be string= "OK"
1095 |             (red:slaveof "no" "one"))
1096 |     (should be string= "save"
1097 |             (first (red:config-get "save")))
1098 |     (should be string= "OK"
1099 |             (handler-case (red:config-rewrite)
1100 |               (redis-error (e)
1101 |                 (if (string= "ERR The server is running without a config file"
1102 |                              (redis-error-message e))
1103 |                     "OK"
1104 |                     (error e)))))
1105 |     (should be string= "OK"
1106 |             (red:config-set "timeout" 200))
1107 |     (should be string= "OK"
1108 |             (red:config-resetstat))
1109 |     ;; the next commands have unpredicatble results - just let be, that they run
1110 |     (should be null
1111 |             (red:slowlog :get 10))
1112 |     (should be true
1113 |             (red:slowlog :len))
1114 |     (should be true
1115 |             (red:slowlog :reset))
1116 |     (should be plusp
1117 |             (reduce '+ (mapcar 'parse-integer (red:time))))
1118 |     (should be string= "OK"
1119 |             (red:client-setname "test"))
1120 |     (should be string= "test"
1121 |             (red:client-getname))
1122 |     (should be string= "OK"
1123 |             (red:client-pause 1))
1124 |     ;; SYNC, BGREWRITEAOF - may be too long
1125 |     ;; SHUTDOWN - futile
1126 |     ;; FLUSHALL - don't do this at home
1127 |     ;; MIGRATE - don't have other host
1128 |     ;; CLUSRE-SLOTS - need cluster
1129 |     ;; COMMAND, COMMAND-COUNT, COMMAND-GETKEYS, COMMAND-INFO - ???
1130 |     ))
1131 | 
1132 | 
1133 | (deftest scripting-commands ()
1134 |   (let ((sha1 "080c414e64bca1184bc4f6220a19c4d495ac896d"))
1135 |     (with-test-db
1136 |       (should be = 10
1137 |               (red:eval "return 10" 0))
1138 |       (should be equal '(1 2 (3 "Hello World!"))
1139 |               (red:eval "return {1,2,{3,'Hello World!'}}" 0))
1140 |       (should be string= sha1
1141 |               (red:script-load "return 10"))
1142 |       (should be = 10
1143 |               (red:evalsha sha1 0))
1144 |       (should be equal '(1 0)
1145 |               (red:script-exists sha1 "ffffffffffffffffffffffffffffffffffffffff"))
1146 |       (should signal redis-error-reply
1147 |               (red:script-kill))
1148 |       (progn
1149 |         (bt:make-thread #`(with-connection ()
1150 |                             (ignore-errors
1151 |                               (red:evalsha (red:script-load
1152 |                                             "while true do print(1) end")
1153 |                                            0))))
1154 |         (sleep 1)  ; waiting for the previous thread to start
1155 |         (should be string= "OK"
1156 |                 (red:script-kill)))
1157 |       (should be string= "OK"
1158 |               (red:script-flush))
1159 |       (should be equal '(0 0)
1160 |               (red:script-exists sha1 "ffffffffffffffffffffffffffffffffffffffff")))))
1161 | 
1162 | ;;; end
1163 | 


--------------------------------------------------------------------------------