`cl-memcached` library by Abhijit 'quasi' Rao and
Chaitanya Gupta .
+Date Started: July 1, 2011
+
Overview
--------
-This package is based on the cl-memcached library.
+This package is based on the `cl-memcached` library.
It is substantially modified for use with the memstore
package. The primary areas of additional functionality
are:
package to provide those functions as well as utilitizing other
`kmrcl` functions to simplify code.
-* Nearly the entire code base has been reworked for improved
- robustness and efficiency.
+* Added functions to support all memcached API commands,
+ such as `flush_all` and `version`.
+
+* Support for the `moreply` command argument accepted by
+ many commands.
+
+* Support the `noreply` argument that many API commands accept.
+
+* Write nearly the entire code base for improved
+ clarity, robustness, and efficiency.
(mc-put-in-pool ,us :memcache ,mc)
(ignore-errors (usocket:socket-close ,mc)))))))
+(defun write-string-bytes (string stream)
+ (loop for char across string
+ do (write-byte (char-code char) stream)))
+
(defun send-mc-command (s &rest args &aux started)
- (flet ((write-string-bytes (str stream)
- (loop for char across str
- do (write-byte (char-code char) stream))))
- (dolist (arg args)
- (unless (null arg)
- (if started
- (write-byte (char-code #\space) s)
- (setq started t))
- (typecase arg
- (string (write-string-bytes arg s))
- (character (write-byte (char-code arg) s))
- (t (write-string-bytes (princ-to-string arg) s)))))
- (write-string-bytes +crlf+ s)
- (force-output s)))
+ (dolist (arg args)
+ (unless (null arg)
+ (if started
+ (write-byte (char-code #\space) s)
+ (setq started t))
+ (typecase arg
+ #+nil (keyword (if (eq :no-reply arg)
+ (write-string-bytes "noreply" s)
+ (write-string-bytes (string-downcase
+ (symbol-name arg)) s)))
+ (string (write-string-bytes arg s))
+ (character (write-byte (char-code arg) s))
+ (t (write-string-bytes (princ-to-string arg) s)))))
+ (write-string-bytes +crlf+ s)
+ (force-output s))
;;;
;;;
(defun mc-store (key data &key (memcache *memcache*) ((:command command) :set) ((:exptime exptime) 0)
- ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0))
+ ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0)
+ no-reply)
"Stores data in the memcached server using the :command command.
key => key by which the data is stored. this is of type SIMPLE-STRING
data => data to be stored into the cache. data is a sequence of type (UNSIGNED-BYTE 8)
(:append "append")
(:prepend "prepend")
(:cas "cas"))
- key flags exptime len (when (eq command :cas) cas-unique))
+ key flags exptime len (when (eq command :cas) cas-unique) (when no-reply "noreply"))
(write-sequence data s)
(send-mc-command s)
- (read-crlf-line s))))
+ (if no-reply
+ (values)
+ (read-crlf-line s)))))
(defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
(command :get))
res
(car res))))
-(defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*))
+(defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*) (no-reply))
"Deletes a particular 'key' and it's associated data from the memcached server"
(declare (type fixnum time))
(with-pool-maybe (s memcache use-pool)
- (send-mc-command s "delete" key time)
- (read-crlf-line s)))
+ (send-mc-command s "delete" key time (when no-reply "noreply"))
+ (if no-reply
+ (values)
+ (read-crlf-line s))))
+
-(defun incr-or-decr (cmd key delta memcache use-pool)
+(defun incr-or-decr (cmd key delta memcache use-pool no-reply)
(declare (type fixnum delta))
(let* ((res (with-pool-maybe (s memcache use-pool)
- (send-mc-command s cmd key delta)
- (read-crlf-line s)))
- (int (ignore-errors (parse-integer res))))
+ (send-mc-command s cmd key delta (if no-reply "noreply"))
+ (if no-reply
+ (values)
+ (read-crlf-line s))))
+ (int (unless no-reply
+ (ignore-errors (parse-integer res)))))
(or int res)))
-(defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
+(defun mc-version (&key (memcache *memcache*) (use-pool *use-pool*))
+ (let* ((raw (with-pool-maybe (s memcache use-pool)
+ (send-mc-command s "version")
+ (read-crlf-line s)))
+ (split (delimited-string-to-list raw)))
+ (when (string-equal (first split) "VERSION")
+ (second split))))
+
+(defun mc-verbosity (v &key (memcache *memcache*) (use-pool *use-pool*) (no-reply))
+ (declare (type integer v))
+ (let ((res (with-pool-maybe (s memcache use-pool)
+ (send-mc-command s "verbosity" v (when no-reply "noreply"))
+ (if no-reply
+ (values)
+ (read-crlf-line s)))))
+ res))
+
+(defun mc-flush-all (&key (time nil) (memcache *memcache*) (use-pool *use-pool*) (no-reply))
+ (declare (type (or null integer) time))
+ (let ((res (with-pool-maybe (s memcache use-pool)
+ (if time
+ (send-mc-command s "flush_all" time (when no-reply "noreply"))
+ (send-mc-command s "flush_all" (when no-reply "noreply")))
+ (if no-reply
+ (values)
+ (read-crlf-line s)))))
+ res))
+
+(defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply))
"Implements the INCR command. Increments the value of a key.
Please read memcached documentation for more information.
key is a string
delta is an integer"
- (incr-or-decr "incr" key delta memcache use-pool))
+ (incr-or-decr "incr" key delta memcache use-pool no-reply))
-(defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
+(defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply))
"Implements the DECR command. Decrements the value of a key.
Please read memcached documentation for more information."
- (incr-or-decr "decr" key delta memcache use-pool))
+ (incr-or-decr "decr" key delta memcache use-pool no-reply))
(defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args
&aux results)
;;; Error Conditions
(define-condition memcached-server-unreachable (error)
- ())
+ ((error :initarg :error)))
(define-condition memcache-pool-empty (error)
())
(define-condition cannot-make-pool-object (error)
- ())
+ ((error :initarg :error)))
(define-condition bad-pool-object (error)
())
(defun mc-make-pool-item (&key (memcache *memcache*))
(handler-case (usocket:socket-connect (ip memcache) (port memcache) :element-type '(unsigned-byte 8))
- (usocket:socket-error () (error 'memcached-server-unreachable))
- (error () (error 'cannot-make-pool-object))))
+ (usocket:socket-error (e) (error 'memcached-server-unreachable :error e))
+ (error (e) (error 'cannot-make-pool-object :error e))))
(defun mc-pool-grow (memcache)
(let (grow-count pool-item-list)
#:mc-decr
#:mc-stats
#:mc-get-stat
+ #:mc-version
+ #:mc-verbosity
+ #:mc-flush-all
#:memcache-stats
#:make-memcache-instance
#:mc-server-check
(:documentation "This class represents an instance of the Memcached server"))
-(defconstant* *membase17-stat-names*
+(defconstant* +membase17-stat-names+
'("accepting_conns" "auth_cmds" "auth_errors" "bucket_active_conns" "bucket_conns"
"bytes_read" "bytes_written" "cas_badval" "cas_hits" "cas_misses" "cmd_flush"
"cmd_get" "cmd_set" "conn_yields" "connection_structures" "curr_connections"
:author "Kevin M. Rosenberg <kevin@rosenberg.net>"
:version "1.0"
:licence "BSD"
- :depends-on (memcache cl-store flexi-streams zlib)
+ :depends-on (memcache cl-store flexi-streams zlib salza2 chipz)
:components ((:module src
:serial t
:components
((:file "package")
+ (:file "compress")
(:file "memstore")))))
(defmethod operation-done-p ((o test-op) (c (eql (find-system :memstore))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE IDENTIFICATION
;;
-;; Name: main.lisp
-;; Purpose: memstore main functions
+;; Name: memstore.lisp
+;; Purpose: Memstore primary functions
;; Date Started: July 2011
;;
;; Copyright (c) 2011 Kevin M. Rosenberg
"Determines if compression is enabled.")
(defvar *compression-threshold* 5000
"Minimum size of object before attempting compression.")
-(defvar *debug* nil)
-(defvar *realm* "ms:")
-(defvar *encoding* (flex:make-external-format :utf-8))
+(defvar *debug* nil
+ "Controls output of debugging messages.")
+(defvar *namespace* "ms:"
+ "String to prepend to keys for memcache. Default is 'ms:'.")
+(defvar *encoding* (flex:make-external-format :utf-8)
+ "Character encoding to use with converting strings to octets.")
(defun serialize-clstore (obj)
+ "Converts a Lisp object into a vector of octets using CL-STORE."
(let ((s (make-in-memory-output-stream :element-type 'octet)))
(cl-store:store obj s)
(get-output-stream-sequence s)))
(defun deserialize-clstore (data)
+ "Restores a Lisp object from a vector of octets using CL-STORE."
(let ((s (make-in-memory-input-stream data)))
(cl-store:restore s)))
(declare (ignore pos))
obj))
-(defun serialize (obj &key (compression-enabled *compression-enabled*)
+(defun ms-serialize (obj &key (compression-enabled *compression-enabled*)
(compression-threshold *compression-threshold*))
"Converts a lisp object into a vector of octets.
Returns a cons of (flags . data)."
compression-enabled compression-threshold dlen))
(when (and compression-enabled compression-threshold
(> dlen compression-threshold))
- (multiple-value-bind (compressed clen) (zlib:compress data :fixed)
+ (multiple-value-bind (compressed clen) (compress data)
(when *debug*
(format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
(when (< clen (* dlen (- 1 *compression-savings*)))
(format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
(cons flags data)))
-(defun deserialize (ser)
+(defun ms-deserialize (ser)
"Converts a cons of storage flags and vector of octets into a lisp object."
(let ((flags (car ser))
(data (cdr ser)))
(when (plusp (logand flags +flag-zlib+))
- (setq data (zlib:uncompress data)))
+ (setq data (uncompress data)))
(cond
((plusp (logand flags +flag-clstore+))
(deserialize-clstore data))
(defun make-key (key)
- (concatenate 'string *realm* key))
+ "Prepends the *namespace* to a key."
+ (concatenate 'string *namespace* key))
-(defun remove-realm (key)
- (subseq key (length *realm*)))
+(defun remove-namespace (key)
+ "Strips the current *namespace* from beginning of key."
+ (subseq key (length *namespace*)))
-(defun mem-store (key obj &key (memcache *memcache*) (command :set)
+(defun ms-store (key obj &key (memcache *memcache*) (command :set)
(exptime 0) (use-pool *use-pool*)
(compression-enabled *compression-enabled*)
(compression-threshold *compression-threshold*))
"Stores an object in cl-memcached. Tries to print-readably object
to a string for storage. If unable to do so, uses cl-store to serialize
object. Optionally compresses value if meets compression criteria."
- (let ((ser (serialize obj :compression-enabled compression-enabled
+ (let ((ser (ms-serialize obj :compression-enabled compression-enabled
:compression-threshold compression-threshold)))
(mc-store (make-key key) (cdr ser)
:memcache memcache
:use-pool use-pool :flags (car ser))))
(defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
- (command :get))
+ (command :get))
+ "Retrieves a list of objects from memcache from the keys in KEYS-LIST."
(let ((items (mc-get
(mapcar 'make-key keys-list)
:memcache memcache
(data (third item)))
(ecase command
(:get
- (list (remove-realm key) (deserialize (cons flags data))))
+ (list (remove-namespace key) (ms-deserialize (cons flags data))))
(:gets
- (list (remove-realm key) (deserialize (cons flags data)) (fourth item))))))
+ (list (remove-namespace key) (ms-deserialize (cons flags data)) (fourth item))))))
items)))
-(defun mem-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
- (command :get))
+(defun ms-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
+ (command :get))
+ "Lisp objects are restored by memcache server. A key, or list of keys,
+is used to identify objects. Command is either :get or :gets. The latter
+is used to get memcached's unique object number for storage with :cas."
(let* ((multp (listp key-or-keys))
(keys (if multp key-or-keys (list key-or-keys)))
(items (get-objects keys :memcache memcache :use-pool use-pool
(values (second item) t (third item)))))
(values nil nil)))))
-(defun mem-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
+(defun ms-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
+ "Deletes a keyed object from memcache. Key is prepended with *namespace*."
(mc-del (make-key key) :memcache memcache :use-pool use-pool :time time))
-(defun mem-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
+(defun ms-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
+ "Increments a keyed integer object. Key is prepended with *namespace*."
(mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
-(defun mem-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
+(defun ms-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
+ "Decrements a keyed integer object. Key is prepended with *namespace*."
(mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
#:*compression-threshold*
#:*compression-enabled*
#:*compression-savings*
- #:*realm*
- #:mem-store
- #:mem-restore
- #:mem-del
- #:mem-incr
- #:mem-decr))
+ #:*namespace*
+ #:ms-serialize
+ #:ms-deserialize
+ #:ms-store
+ #:ms-restore
+ #:ms-del
+ #:ms-incr
+ #:ms-decr))
(defpackage #:memstore-tests
(:import-from #:rtest #:*compile-tests* #:*expected-failures*)
(:use #:memstore #:cl #:rtest)
- (:import-from #:memstore #:mem-store #:mem-restore #:mem-del
- #:serialize #:deserialize
+ (:import-from #:memstore #:ms-store #:ms-restore #:ms-del
+ #:ms-serialize #:ms-deserialize
#:serialize-clstore #:deserialize-clstore
#:serialize-string #:deserialize-string
#:+flag-wstring+ #:+flag-clstore+
- #:+flag-zlib+ #:*realm*)
+ #:+flag-zlib+ #:*namespace*
+ #:compress #:uncompress)
(:import-from #:memcache #:*memcache* #:*use-pool*
#:make-memcache-instance))
(in-package #:memstore-tests)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *test-cnt* 0)
- (defvar *test-realm* "__mctest__:"))
+ (defvar *test-namespace* "__mctest__:"))
(unless *memcache*
(setq *memcache* (make-memcache-instance :name "Memcache test")))
(defmacro def-readably-value* (val)
`(progn
(deftest ,(intern (format nil "DS.~D" *test-cnt*) '#:keyword)
- (let* ((ser (serialize (quote ,val)))
+ (let* ((ser (ms-serialize (quote ,val)))
(flags (car ser)))
(cond
((stringp (quote ,val))
(unless (and (plusp (logand flags +flag-wstring+))
(zerop (logand flags +flag-clstore+)))
(error "Should be stored as wstring."))))
- (deserialize ser))
+ (ms-deserialize ser))
,val)
(deftest ,(intern (format nil "RS.~D" *test-cnt*) '#:keyword)
(deserialize-clstore (serialize-clstore (quote ,val)))
(deserialize-string (serialize-string (quote ,val)))
,val)
(deftest ,(intern (format nil "MC.~D" *test-cnt*) '#:keyword)
- (let ((*realm* ,*test-realm*)
+ (let ((*namespace* ,*test-namespace*)
(key (format nil "~D" ,*test-cnt*)))
- (mem-store key (quote ,val))
- (multiple-value-bind (res found) (mem-restore key)
- (mem-del key)
+ (ms-store key (quote ,val))
+ (multiple-value-bind (res found) (ms-restore key)
+ (ms-del key)
(values found (equalp res (quote ,val)))))
t t)
,(incf *test-cnt*)))
(let ((h (make-hash-table :test 'equal)))
(setf (gethash "a" h) "A")
(setf (gethash "b" h) "B")
- (let ((ds (deserialize (serialize h))))
+ (let ((ds (ms-deserialize (ms-serialize h))))
(list (hash-table-count ds) (gethash "a" ds) (gethash "b" ds))))
(2 "A" "B"))
(deftest :ht.2
(defvar *long-string* (make-string 10000 :initial-element #\space))
(defvar *long-array* (make-array '(10000) :initial-element 0))
(deftest :l.1
- (let* ((ser (serialize *long-string*))
+ (let* ((ser (ms-serialize *long-string*))
(data (cdr ser))
(flags (car ser)))
(values (< (length data) (length *long-string*))
(eql (logand flags +flag-zlib+) +flag-zlib+)
(zerop (logand flags +flag-wstring+))
(zerop (logand flags +flag-clstore+))
- (string-equal *long-string* (deserialize ser))))
+ (string-equal *long-string* (ms-deserialize ser))))
t t t t t)
(deftest :l.2
- (let* ((ser (serialize *long-array*))
+ (let* ((ser (ms-serialize *long-array*))
(data (cdr ser))
(flags (car ser)))
(values (< (length data) (length *long-array*))
(eql (logand flags +flag-zlib+) +flag-zlib+)
(eql (logand flags +flag-wstring+) +flag-wstring+)
(zerop (logand flags +flag-clstore+))
- (equalp *long-array* (deserialize ser))))
+ (equalp *long-array* (ms-deserialize ser))))
t t t t t)
(deftest :incr.1
- (let ((*realm* *test-realm*))
+ (let ((*namespace* *test-namespace*))
(values
- (mem-store "i" 0)
- (mem-restore "i")
- (mem-incr "i")
- (mem-incr "i" :delta 5)
- (mem-incr "i" :delta 3)
- (mem-decr "i" :delta 2)
- (mem-decr "i")
- (mem-del "i")))
+ (ms-store "i" 0)
+ (ms-restore "i")
+ (ms-incr "i")
+ (ms-incr "i" :delta 5)
+ (ms-incr "i" :delta 3)
+ (ms-decr "i" :delta 2)
+ (ms-decr "i")
+ (ms-del "i")))
"STORED" 0 1 6 9 7 6 "DELETED")
(deftest :nf.1
- (let ((*realm* *test-realm*))
- (mem-restore "a"))
+ (let ((*namespace* *test-namespace*))
+ (ms-restore "a"))
nil nil)
+
+(defmacro def-compress-test (length id)
+ (let ((len (gensym "LENGTH-")))
+ `(deftest ,(intern (format nil "Z.~D" id)
+ (find-package '#:keyword))
+ (block z
+ (let* ((,len ,length)
+ (a (make-array (list ,len) :element-type '(unsigned-byte 8))))
+ (dotimes (j ,len)
+ (setf (aref a j) (random 256)))
+ (let* ((comp (compress a))
+ (uncomp (uncompress comp)))
+ (unless (equalp a uncomp)
+ (throw 'z :error)))))
+ nil)))
+
+(def-compress-test (random 10000) 0)
+(def-compress-test (random 10000) 1)
+(def-compress-test (random 10000) 2)
+(def-compress-test (random 10000) 3)
+(def-compress-test (random 10000) 4)
+(def-compress-test (random 10000) 5)
+(def-compress-test (random 10000) 6)
+(def-compress-test (random 10000) 7)
+(def-compress-test (random 10000) 8)
+(def-compress-test (random 10000) 9)
+(def-compress-test (random 10000) 10)
+
+
projects / memstore.git / commitdiff