--- /dev/null
+Copyright (c) 2011 Kevin M. Rosenberg
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of the contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
--- /dev/null
+MemStore
+========
+
+_A high-level interface for the memcached and membase servers_
+
+Written by Kevin M. Rosenberg <kevin@rosenberg.net>
+
+Prerequisites
+-------------
+
+This library incorporates a heavily modified version of `cl-memcached`
+version 0.4.1. The primary need for the modification is to support the
+`flags` field supported by the memcached server. The flag field is
+used to store information required to deserialize the object data from
+memcached. In addition to adding the `flags` field, the library has
+been heavily refactored.
+
+This library also requires Common Lisp libraries of cl-store,
+flexi-streams, and zlib.
+
+Overview
+--------
+
+Memstore allows efficient storing of simple objects as well as
+easy storing of complex objects and optional compression.
+
+When storing an object, if the object is a string then that is
+directly written to the memcached server. For non-strings, an attempt
+to made to write the object to a string with `*print-readably*` bound
+to `t`. If that succeeds, then the string is converted to a vector of
+octets. If that fails, the `cl-store` is used to serialize that object
+to a vector of octets.
+
+Next, optional compression is applied to the octets. First, the
+`*compression-enabled*` flag is checked to see if compression is
+enabled. Next, the length of the objects is compared to
+`*compression-threshold*`. Only objects larger than
+`*compression-threshold*` will be compressed. For objects that qualify
+for compression, the size of the compressed object is compared to the
+length of the uncompressed object to decide if the object is shrunk
+enough to make the compression worthwhile.
+
+The `flags` parameter to cl-memcached stores whether cl-store or
+write-to-string is used to serialize the object and whether
+compression is applied. `mem-restore` uses those flags to determine
+how to reconstruct the object.
--- /dev/null
+;;; -*- Mode: Common-Lisp -*-
+;
+;;; Copyright (c) 2005-2006, quasi. All rights reserved. Cleartrip.
+;;; Copyright (c) 2011 Kevin Rosenberg. All rights reserved.
+
+(in-package #:cl-user)
+(defpackage #:memcache-system
+ (:use #:cl #:asdf))
+(in-package #:memcache-system)
+
+(defsystem #:memcache
+ :version "0.5.0"
+ :author "Kevin Rosenberg <kevin@rosenberg.net>, quasi <quasi@cleartrip.com>"
+ :depends-on (usocket kmrcl)
+ :components ((:module memcache
+ :serial t
+ :components
+ ((:file "package")
+ (:file "specials")
+ (:file "util")
+ (:file "compat")
+ (:file "memcache")))))
+
--- /dev/null
+Copyright (c) 2006, Abhijit 'quasi' Rao. All rights reserved.
+Copyright (c) 2006, Cleartrip Travel Services.
+Copyright (c) 2011 Kevin Rosenberg
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials
+ provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
--- /dev/null
+Memcache
+========
+
+_Library for memcached protocol_
+
+Author: Kevin Rosenberg <kevin@rosenberg.net>, based on the
+`cl-memcached` library by Abhijit 'quasi' Rao and
+Chaitanya Gupta .
+
+Overview
+--------
+
+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:
+
+* Support for flags field with get and set functions.
+ This is required as memstore stores bit flags denoting
+ how the data is serialized. That information is required
+ to deserialize the data.
+
+* Support for additional memcached functionality, such as
+ the gets command for retrieving CAS identifiers. The CAS
+ unique ID is used for the added `:cas` storage command.
+ Other storage commands newly supported are `:append` and
+ `:prepend`.
+
+* All communication now uses `mc-send-command` function with
+ transparently supports writing strings with `write-byte`.
+ This allows `usocket` to be used on other Lisp implementations
+ besides AllegroCL. Because cl-memcached used `write-string`
+ with usocket-stream, only AllegroCL was supported.
+ By sending all data as (unsigned-byte 8), all Lisp implementions
+ supported by `usocket` are now supported with `memcached`.
+
+* Encapsulated reading and writing to socket stream to avoid
+ handling \#return characters in high-level code.
+
+* Changes to support the change in statistics fields with membase.
+ Some fields were no longer present. Also, membase 1.7 has
+ 187 statistics fields versus the 20 fields supported in
+ `cl-memcached`. New function `mc-get-stat` allows to retrieving
+ any statistics field by name.
+
+* More robust `print-object` functions to avoid errors if fields
+ in statistics are not present.
+
+* Removed compatibility functions in `compat.lisp` and using `kmrcl`
+ 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.
--- /dev/null
+(in-package #:memcache)
+
+;;;
+;;; queue implementation from http://aima.cs.berkeley.edu/lisp/utilities/queue.lisp
+;;;
+
+(defstruct q
+ (key #'identity)
+ (last nil)
+ (elements nil))
+
+(defun make-empty-queue ()
+ (make-q))
+
+(defun empty-queue? (q)
+ "Are there no elements in the queue?"
+ (= (length (q-elements q)) 0))
+
+(defun queue-front (q)
+ "Return the element at the front of the queue."
+ (elt (q-elements q) 0))
+
+(defun remove-front (q)
+ "Remove the element from the front of the queue and return it."
+ (if (listp (q-elements q))
+ (pop (q-elements q))
+ nil))
+
+
+(defun enqueue-at-end (q items)
+ "Add a list of items to the end of the queue."
+ ;; To make this more efficient, keep a pointer to the last cons in the queue
+ (let ((items (list items)))
+ (cond ((null items) nil)
+ ((or (null (q-last q)) (null (q-elements q)))
+ (setf (q-last q) (last items)
+ (q-elements q) (nconc (q-elements q) items)))
+ (t (setf (cdr (q-last q)) items
+ (q-last q) (last items))))))
+
+;; the wrappers
+
+(defun make-queue ()
+ ""
+ #+allegro (make-instance 'mp:queue)
+ #-allegro (make-empty-queue))
+
+(defmacro enqueue (queue what)
+ ""
+ #+allegro `(mp:enqueue ,queue ,what)
+ #-allegro `(enqueue-at-end ,queue ,what))
+
+(defmacro dequeue (queue)
+ ""
+ #+allegro `(mp:dequeue ,queue)
+ #-allegro `(remove-front ,queue))
+
+(defmacro queue-empty-p (queue)
+ ""
+ #+allegro `(mp:queue-empty-p ,queue)
+ #-allegro `(empty-queue? ,queue))
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>CL-MEMCACHED</title>
+ <style type="text/css">
+ body {font-family:'monaco','verdana','monospace'; font-size:12px; margin-left:0px; margin-right:0px;margin-top:0px;}
+ pre { padding: 5px; font-family:'courier new','monospace';}
+ .code { padding:5px; background-color:#f0f0f0; font-family:'courier', 'monospace'; font-size:9pt;}
+ blockquote { font-family:'courier new', 'monospace', 'verdana'; font-size:10pt;}
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; }
+ a.noborder { border:0px }
+ a.noborder:hover { border:0px } a.none { border:1px solid white; }
+ a.none { border:1px solid white; }
+ a.none:hover { border:1px solid white; }
+ a { border:1px solid white; }
+ a:hover { border: 1px solid black; }
+ a.noborder { border:0px }
+ a.noborder:hover { border:0px }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<div style="border:solid blue 0px;padding: 25px;background-color:pink; border-bottom:solid red 2px;">
+<h2>CL-MEMCACHED <small>- Common Lisp interface to the memcached object caching system.</small></h2>
+</div>
+
+<div style="margin:15px;margin-left:20px;">
+
+<br> <br><h3><a name=abstract class=none>Abstract</a></h3>
+
+<p>CL-MEMCACHED is a library to interface with the <a href="http://www.danga.com/memcached/" >memcached</a> object caching system.
+<p><i>What is Memcached??</i> According to the home page :
+<blockquote>
+
+<a href="http://www.danga.com/memcached/" >memcached</a> is a high-performance, distributed memory object caching system, generic in nature, but intended for use in speeding up dynamic web applications by alleviating database load.
+
+<br><br>
+
+<a href="http://www.danga.com/" >Danga</a> Interactive developed memcached to enhance the speed of <a href="http://livejournal.com" >LiveJournal.com</a>, a site which was already doing 20 million+ dynamic page views per day for 1 million users with a bunch of webservers and a bunch of database servers. memcached dropped the database load to almost nothing, yielding faster page load times for users, better resource utilization, and faster access to the databases on a memcache miss.
+</blockquote>
+
+<p>CL-MEMCACHED implements most of the memcached <a href="http://code.sixapart.com/svn/memcached/trunk/server/doc/protocol.txt" >protocol</a>. The code has been tested on Allegro CL and does not work on other Lisp's right now. See file compat.lisp to help.
+
+<p>We have used memcached (1.1.2) in production for over 20 months and have found it to give excellent performance and good stability. The CL-MEMCACHED has evolved over this period of time from a hack to it's current state. Our memcached servers have been up for over 60 days at a time having served over a terabyte of data to the network in this period.
+
+
+
+<br><br><p>Here are some sample performance statistics of CL-MEMCACHED and other memcached clients :
+<br>
+<table border=1 style="font-size:9pt;text-align:right;" cellpadding='10px'>
+ <tr><th>client</th><th>lang implementation</th><th>10,000 writes<br>1K data (in msec)</th><th>10,000 reads<br>1K data (in msec)</th><th>10,000 writes<br>10K data (in msec)</th><th>10,000 reads<br>10K data (in msec)</th></tr>
+ <tr><td>cl-memcached</td><td>Allegro 8.0 (AMD64)</td><td>950</td><td>830</td><td>2,130</td><td>1,330</td></tr>
+ <tr><td>memcached-client-1.2.0</td><td>ruby 1.8.5</td><td>727</td><td>874</td><td>1,129</td><td>1,296</td></tr>
+ <tr><td>python-memcached-1.36</td><td>python 2.5.1</td><td>892</td><td>951</td><td>1,092</td><td>1,259</td></tr>
+ <tr><td>php-memcached-2.1.2</td><td>php 4.3.9</td><td>507</td><td>513</td><td>400,000</td><td>660</td></tr>
+</table>
+
+<br>
+<p>The code comes with a <a href="http://www.opensource.org/licenses/bsd-license.php">BSD-style license</a> so you can basically do with it whatever you want.
+
+<p><font color=red>Download shortcut:</font> <a href="cl-memcached-latest.tar.gz">cl-memcached-latest.tar.gz</a>.
+
+
+<br><br> <br><h3><a class=none name="lists">Lists</a></h3>
+
+<br>The devel mailing list is <a href="http://common-lisp.net/mailman/listinfo/cl-memcached-devel" >cl-memcached-devel</a>.
+<br>The announce mailing list is <a href="http://common-lisp.net/mailman/listinfo/cl-memcached-announce" >cl-memcached-announce</a>.
+
+<br> <br><h3><a class=none name="example_usage">Example Usage</a></h3>
+
+<p>quick start
+<pre class='code'>
+CL-USER> (asdf:oos 'asdf:load-op :cl-memcached)
+
+CL-USER> (setf *my-cache* (cl-memcached:mc-make-memcache-instance :ip "127.0.0.1" :name "My test cache"))
+#<CL-MEMCACHED:MEMCACHE My test cache on 127.0.0.1:11211 SIZE:64Mb>
+
+CL-USER> (cl-memcached:mc-store "test-key" "This is Test-DATA" :memcache *my-cache* :use-pool t)
+"STORED"
+
+CL-USER> (cl-memcached:mc-get+ "test-key" :memcache *my-cache* :use-pool t)
+"This is Test-DATA"
+
+CL-USER> (cl-memcached:mc-get '("test-key") :memcache *my-cache* :use-pool t)
+(("test-key"
+ #(84 104 105 115 32 105 115 32 84 101 115 116 45 68 65 84 65)))
+
+CL-USER> (cl-memcached:mc-get '("test-key") :memcache *my-cache* :use-pool t :is-string t)
+(("test-key" "This is Test-DATA"))
+
+CL-USER> (cl-memcached:mc-store "test-key-2" "This is Test-DATA Again" :memcache *my-cache* :use-pool t)
+"STORED"
+
+CL-USER> (cl-memcached:mc-get '("test-key" "test-key-2") :memcache *my-cache* :use-pool t :is-string t)
+(("test-key" "This is Test-DATA")
+ ("test-key-2" "This is Test-DATA Again"))
+
+</pre>
+
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li><a href="#download">Download</a>
+ <li><a href="#dictionary">The CL-MEMCACHED dictionary</a>
+ <ol>
+ <li><a href="#*memcache*"><code>*memcache*</code></a>
+ <li><a href="#*use-pool*"><code>*use-pool*</code></a>
+ <li><a href="#*pool-get-trys?*"><code>*pool-get-trys?*</code></a>
+ <li><a href="#mc-decr"><code>mc-decr</code></a>
+ <li><a href="#mc-del"><code>mc-del</code></a>
+ <li><a href="#mc-get"><code>mc-get</code></a>
+ <li><a href="#mc-get+"><code>mc-get+</code></a>
+ <li><a href="#mc-incr"><code>mc-incr</code></a>
+ <li><a href="#mc-make-memcache-instance"><code>mc-make-memcache-instance</code></a>
+ <li><a href="#mc-pool-init"><code>mc-pool-init</code></a>
+ <li><a href="#mc-server-check"><code>mc-server-check</code></a>
+ <li><a href="#mc-stats"><code>mc-stats</code></a>
+ <li><a href="#mc-store"><code>mc-store</code></a>
+ <li><a href="#memcache"><code>memcache</code></a>
+ </ol>
+ <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+<br> <br><h3><a class=none name="download">Download</a></h3>
+
+CL-MEMCACHED together with this documentation can be downloaded from <a
+href="cl-memcached-latest.tar.gz">cl-memcached-latest.tar.gz</a>. The
+current version is 0.4.1. (I will be setting up a SVN repo soon)
+
+<br> <br><h3><a class=none name="dictionary">The CL-MEMCACHED dictionary</a></h3>
+
+
+
+<!-- Entry for *MEMCACHE* -->
+
+<p><br>[Special variable]<br><a class=none name='*memcache*'><b>*memcache*</b></a>
+<blockquote><br>
+
+We can set the current memcache instance to this if there is only one in use.
+
+</blockquote>
+
+<!-- End of entry for *MEMCACHE* -->
+
+
+<!-- Entry for *USE-POOL* -->
+
+<p><br>[Special variable]<br><a class=none name='*use-pool*'><b>*use-pool*</b></a>
+<blockquote><br>
+<pre>
+This controls if we use the connection pool by default. One can set it at each call level, but it is also
+possible to set this global policy.
+
+Default value for the USE-POOL is <i>nil</i>, which means a new connection is make every request.
+</pre>
+</blockquote>
+
+<!-- End of entry for *USE-POOL* -->
+
+<!-- Entry for *POOL-GET-TRYS?* -->
+
+<p><br>[Special variable]<br><a class=none name='*pool-get-trys?'><b>*pool-get-trys?*</b></a>
+<blockquote><br>
+<pre>
+This controls the policy for the fetching connectors from the pool. There are two approaches :
+a) where we throw an error if pool is empty
+b) where we sleep an try again to see if one is available.
+
+The default value is nil which is the a) approach.
+</pre>
+</blockquote>
+
+<!-- End of entry for *POOL-GET-TRYS?* -->
+
+
+<!-- Entry for MC-STORE -->
+
+<p><br>[Function]<br><a class=none name='mc-store'><b>mc-store</b> <i>key data <tt>&key</tt> memcache command timeout use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+Stores data in the memcached server.
+
+<pre><i>key</i> - key by which the data is stored. this is of type SIMPLE-STRING
+<i>data</i> - data to be stored into the cache. data is a sequence of type (UNSIGNED-BYTE 8)
+<i>length</i> - size of data
+<i>memcache</i> - The instance of class memcache which represnts the memcached we want to use.
+<i>command</i> - The storage command we want to use. There are 3 available : set, add & replace.
+<i>timeout</i> - The time in seconds when this data expires. 0 is never expire.
+</pre>
+</blockquote>
+
+<!-- End of entry for MC-STORE -->
+
+
+<!-- Entry for MC-GET -->
+
+<p><br>[Function]<br><a class=none name='mc-get'><b>mc-get</b> <i>keys-list <tt>&key</tt> memcache use-pool is-string</i> => <i>result</i></a>
+<blockquote><br>
+
+Retrive value for key from memcached server.
+<pre>
+<i>keys-list</i> - is a list of the keys, seperated by whitespace, by which data is stored in memcached
+<i>memcache</i> - The instance of class memcache which represnts the memcached we want to use.
+
+Returns a list of lists where each list has two elements key and value
+<i>key</i> - is of type SIMPLE-STRING
+<i>value</i> is of type (UNSIGNED-BYTE 8)
+</pre>
+</blockquote>
+
+<!-- End of entry for MC-GET -->
+
+
+<!-- Entry for MC-GET+ -->
+
+<p><br>[Function]<br><a class=none name='mc-get+'><b>mc-get+</b> <i>key-or-list-of-keys <tt>&key</tt> memcache use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+To be used for non-binary data only. If one key is given
+returns the response in string format
+
+</blockquote>
+
+<!-- End of entry for MC-GET+ -->
+
+
+
+<!-- Entry for MC-DECR -->
+
+<p><br>[Function]<br><a class=none name='mc-decr'><b>mc-decr</b> <i>key <tt>&key</tt> memcache value use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+Implements the DECR command. Decrements the value of a key. Please read memcached documentation for more information
+
+</blockquote>
+
+<!-- End of entry for MC-DECR -->
+
+
+<!-- Entry for MC-DEL -->
+
+<p><br>[Function]<br><a class=none name='mc-del'><b>mc-del</b> <i>key <tt>&key</tt> memcache time use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+Deletes a particular 'key' and it's associated data from the memcached server
+
+</blockquote>
+
+<!-- End of entry for MC-DEL -->
+
+
+
+<!-- Entry for MC-INCR -->
+
+<p><br>[Function]<br><a class=none name='mc-incr'><b>mc-incr</b> <i>key <tt>&key</tt> memcache value use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+Implements the INCR command. Increments the value of a key. Please read memcached documentation for more information
+
+</blockquote>
+
+<!-- End of entry for MC-INCR -->
+
+
+<!-- Entry for MC-MAKE-MEMCACHE-INSTANCE -->
+
+<p><br>[Function]<br><a class=none name='mc-make-memcache-instance'><b>mc-make-memcache-instance</b> <i><tt>&key</tt> ip port name pool-size</i> => <i>result</i></a>
+<blockquote><br>
+
+Creates an instance of class MEMCACHE which represents a memcached server
+
+</blockquote>
+
+<!-- End of entry for MC-MAKE-MEMCACHE-INSTANCE -->
+
+
+<!-- Entry for MC-POOL-INIT -->
+
+<p><br>[Function]<br><a class=none name='mc-pool-init'><b>mc-pool-init</b> <i><tt>&key</tt> memcache</i> => <i>result</i></a>
+<blockquote><br>
+
+Cleans up the pool for this particular instance of memcache
+& reinits it with POOL-SIZE number of objects required by this pool
+
+</blockquote>
+
+<!-- End of entry for MC-POOL-INIT -->
+
+
+<!-- Entry for MC-SERVER-CHECK -->
+
+<p><br>[Function]<br><a class=none name='mc-server-check'><b>mc-server-check</b> <i><tt>&key</tt> memcache</i> => <i>result</i></a>
+<blockquote><br>
+
+Performs some basic tests on the Memcache instance and outputs a status string
+
+</blockquote>
+
+<!-- End of entry for MC-SERVER-CHECK -->
+
+
+<!-- Entry for MC-STATS -->
+
+<p><br>[Function]<br><a class=none name='mc-stats'><b>mc-stats</b> <i><tt>&key</tt> memcache use-pool</i> => <i>result</i></a>
+<blockquote><br>
+
+Returns a struct of type memcache-stats which contains internal statistics from the
+memcached server instance. Please refer to documentation of <a href="#memcache-stats" >memcache-stats</a> for detailed
+information about each slot.
+
+</blockquote>
+
+<!-- End of entry for MC-STATS -->
+
+<!-- Entry for MEMCACHED-STATS -->
+
+<p><br>[Structure]<br><a class=none name='memcache-stats'><b>memcache-stats</b></a>
+<blockquote><br>
+The structure which holds the statistics from the memcached server. The fields are :
+<pre>
+field-name accessor-function documentation
+---------- ----------------- -------------
+pid mc-stats-pid Process id of this server process
+uptime mc-stats-uptime Number of seconds this server has been running
+time mc-stats-time current UNIX time according to the server
+version mc-stats-version Version string of this server
+rusage-user mc-stats-rusage-user Accumulated user time for this process
+rusage-system mc-stats-rusage-system Accumulated system time for this process
+curr-items mc-stats-curr-items Current number of items stored by the server
+total-items mc-stats-total-items Total number of items stored by this server ever since it started
+bytes mc-stats-bytes Current number of bytes used by this server to store items
+curr-connections mc-stats-curr-connections Number of open connections
+total-connections mc-stats-total-connections Total number of connections opened since the server started running
+connection-structures mc-stats-connection-structures Number of connection structures allocated by the server
+cmd-get mc-stats-cmd-get Cumulative number of retrieval requests
+cmd-set mc-stats-cmd-set Cumulative number of storage requests
+get-hits mc-stats-get-hits Number of keys that have been requested and found present
+get-misses mc-stats-get-misses Number of items that have been requested and not found
+evictions mc-stats-evictions Number of items removed from cache because they passed their expiration time
+bytes-read mc-stats-bytes-read Total number of bytes read by this server from network
+bytes-written mc-stats-bytes-written Total number of bytes sent by this server to network
+limit-maxbytes mc-stats-limit-maxbytes Number of bytes this server is allowed to use for storage.
+</pre>
+</blockquote>
+
+<!-- End of entry for MC-STATS -->
+
+
+
+<!-- Entry for MEMCACHE -->
+
+<p><br>[Standard class]<br><a class=none name='memcache'><b>memcache</b></a>
+<blockquote><br>
+
+This class represents an instance of the Memcached server
+
+<pre class='code'>
+(defclass memcache ()
+ ((name
+ :initarg :name
+ :reader name
+ :type simple-string
+ :documentation "Name of this Memcache instance")
+ (ip
+ :initarg :ip
+ :initform "127.0.0.1"
+ :accessor ip
+ :type simple-string
+ :documentation "The IP address of the Memcached server this instance represents")
+ (port
+ :initarg :port
+ :initform 11211
+ :accessor port
+ :type fixnum
+ :documentation "The port on which the Memcached server this instance represents runs")
+ (memcached-server-storage-size
+ :initform 0
+ :reader memcached-server-storage-size
+ :type fixnum
+ :documentation "Memory allocated to the Memcached Server")
+ (pool-size
+ :initarg :pool-size
+ :initform 2
+ :reader pool-size)
+ (pool
+ :reader pool))
+ (:documentation "This class represents an instance of the Memcached server"))
+</pre>
+
+</blockquote>
+
+<!-- End of entry for MEMCACHE -->
+
+
+<br> <br><h3><a class=none name="known_isues">Known Issues</a></h3>
+
+The pooling functionality is still experimental. This is mainly because strategies to deal with network errors are not in place.
+
+<br> <br><h3><a class=none name="todo">TODO</a></h3>
+
+<br>- Add facility to created a replicated memcached pair.
+<br>- Support for a memcached cluster (distributedness)
+
+
+<br><h3>People</h3>
+<p>Abhijit 'quasi' Rao
+<p>Chaitanya Gupta
+
+
+<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+<p>Thanks to Mr. <a href="http://blog.cleartrip.com/" >Hrush Bhatt</a> of <a href="http://www.cleartrip.com/" >Cleartrip</a> for allowing us to make this library available under a BSD licence.
+
+
+<P>This documentation was prepared with the help of <a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>.
+</p>
+</div>
+</body>
+</html>
--- /dev/null
+;;; -*- Mode: Common-Lisp -*-
+
+;;; Copyright (c) 2006, Abhijit 'quasi' Rao. All rights reserved.
+;;; Copyright (c) 2006, Cleartrip Travel Services.
+;;; Copyright (c) 2011 Kevin Rosenberg
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:memcache)
+
+(defmethod print-object ((mc memcache) stream)
+ (print-unreadable-object (mc stream :type t :identity t)
+ (format stream "~A on ~A:~A ~AMB"
+ (when (slot-boundp mc 'name) (name mc))
+ (when (slot-boundp mc 'ip) (ip mc))
+ (when (slot-boundp mc 'port) (port mc))
+ (when (and (slot-boundp mc 'memcached-server-storage-size)
+ (numberp (slot-value mc 'memcached-server-storage-size)))
+ (/ (memcached-server-storage-size mc) 1024 1024)))))
+
+(defmethod initialize-instance :after ((memcache memcache) &rest initargs)
+ (declare (ignore initargs))
+ (setf (slot-value memcache 'pool) (make-instance 'memcache-connection-pool
+ :name (concatenate 'simple-string (name memcache) " - Connection Pool")
+ :max-capacity (pool-size memcache)))
+ (handler-case (mc-pool-init :memcache memcache)
+ (error () nil))
+ (let ((stats (handler-case (mc-stats :memcache memcache)
+ (error () nil))))
+ (if stats
+ (setf (slot-value memcache 'memcached-server-storage-size) (mc-stats-limit-maxbytes stats))
+ (setf (slot-value memcache 'memcached-server-storage-size) -1))))
+
+(defun make-memcache-instance (&key (ip "127.0.0.1") (port 11211)
+ (name "Memcache") (pool-size 5))
+ "Creates an instance of class MEMCACHE which represents a memcached server."
+ (make-instance 'memcache :name name :ip ip :port port :pool-size pool-size))
+
+
+(defmacro with-pool-maybe ((stream memcache use-pool) &body body)
+ "Macro to wrap the use-pool/dont-use-pool stuff and the cleanup
+around a body of actual action statements"
+ (let ((mc (gensym "MEMCACHE-"))
+ (up (gensym "USE-POOL-"))
+ (us (gensym "USOCKET-")))
+ `(let* ((,mc ,memcache)
+ (,up ,use-pool)
+ (,us (if ,up
+ (if *pool-get-trys?*
+ (mc-get-from-pool-with-try :memcache ,mc)
+ (mc-get-from-pool :memcache ,mc))
+ (mc-make-pool-item :memcache ,mc))))
+ (unwind-protect
+ (when ,us
+ (let ((,stream (usocket:socket-stream ,us)))
+ (handler-case
+ (progn ,@body)
+ (error (c)
+ (when ,up
+ (mc-chuck-from-pool ,us ,mc))
+ (error c)))))
+ (if ,up
+ (mc-put-in-pool ,us :memcache ,mc)
+ (ignore-errors (usocket:socket-close ,mc)))))))
+
+(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)))
+
+
+;;;
+;;;
+;;; Memcached API functionality
+;;;
+;;;
+
+(defun mc-store (key data &key (memcache *memcache*) ((:command command) :set) ((:exptime exptime) 0)
+ ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0))
+ "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)
+length => size of data
+memcache => The instance of class memcache which represnts the memcached we want to use.
+command => The storage command we want to use. There are 3 available : set, add & replace.
+exptime => The time in seconds when this data expires. 0 is never expire."
+ (declare (type fixnum exptime) (type simple-string key))
+ (when (and (eq command :cas) (not (integerp cas-unique)))
+ (error "CAS command, but CAS-UNIQUE not set."))
+ (let ((len (length data)))
+ (with-pool-maybe (s memcache use-pool)
+ (send-mc-command
+ s
+ (ecase command
+ (:set "set")
+ (:add "add")
+ (:replace "replace")
+ (:append "append")
+ (:prepend "prepend")
+ (:cas "cas"))
+ key flags exptime len (when (eq command :cas) cas-unique))
+ (write-sequence data s)
+ (send-mc-command s)
+ (read-crlf-line s))))
+
+(defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
+ (command :get))
+ "Retrive value for key from memcached server.
+keys-list => is a list of the keys, seperated by whitespace, by which data is stored in memcached
+memcache => The instance of class memcache which represnts the memcached we want to use.
+
+Returns a list of lists where each list has three elements key, flags, and value
+key is of type SIMPLE-STRING
+value is of type (UNSIGNED-BYTE 8)"
+ (let* ((multp (listp key-or-keys))
+ (keys-list (if multp key-or-keys (list key-or-keys)))
+ (res
+ (with-pool-maybe (s memcache use-pool)
+ (apply 'send-mc-command s (ecase command
+ (:get "get")
+ (:gets "gets"))
+ keys-list)
+ (loop for x = (read-crlf-line s)
+ until (string-equal x "END")
+ collect (let* ((status-line (delimited-string-to-list x))
+ (flags (parse-integer (third status-line)))
+ (len (parse-integer (fourth status-line)))
+ (cas-unique (when (eq command :gets)
+ (parse-integer (fifth status-line))))
+ (seq (make-sequence '(vector (unsigned-byte 8)) len)))
+ (read-sequence seq s)
+ (read-crlf-line s)
+ (if (eq command :gets)
+ (list (second status-line) flags seq cas-unique)
+ (list (second status-line) flags seq)))))))
+ (if multp
+ res
+ (car res))))
+
+(defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*))
+ "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)))
+
+(defun incr-or-decr (cmd key delta memcache use-pool)
+ (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))))
+ (or int res)))
+
+(defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
+ "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))
+
+(defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
+ "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))
+
+(defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args
+ &aux results)
+ "Returns Raw stats data from memcached server to be used by the mc-stats function"
+ (with-pool-maybe (s memcache use-pool)
+ (send-mc-command s "stats" args)
+ (with-output-to-string (str)
+ (loop for line = (read-crlf-line s)
+ do (push line results)
+ until (or (string-equal "END" line)
+ (string-equal "ERROR" line)))))
+ (nreverse results))
+
+(defun mc-get-stat (key stats)
+ (when (stringp key) (setq key (ensure-keyword key)))
+ (get-alist key (mc-stats-all-stats stats)))
+
+;;; Collects statistics from the memcached server
+(defun mc-stats (&key (memcache *memcache*) (use-pool *use-pool*))
+ "Returns a struct of type memcache-stats which contains internal statistics from the
+memcached server instance. Please refer to documentation of memcache-stats for detailed
+information about each slot"
+ (let* ((result (mc-stats-raw :memcache memcache :use-pool use-pool))
+ (split (loop with xx = nil
+ for x in result
+ do (setf xx (delimited-string-to-list x))
+ when (and (string= (first xx) "STAT") (second xx))
+ collect (cons (second xx) (third xx))))
+ (all-stats (sort split (lambda (a b) (string-greaterp (car a) (car b)))))
+ (results))
+ (dolist (r all-stats)
+ (push (cons (ensure-keyword (car r))
+ (let* ((val (cdr r))
+ (int (ignore-errors (parse-integer val)))
+ (float (unless int (ignore-errors (parse-float val)))))
+ (cond
+ ((integerp int) int)
+ ((numberp float) float)
+ (t val))))
+ results))
+ (make-memcache-stats
+ :all-stats results
+ :pid (get-alist :pid results)
+ :uptime (get-alist :uptime results)
+ :time (get-alist :time results)
+ :version (get-alist :version results)
+ :rusage-user (get-alist :rusage_user results)
+ :rusage-system (get-alist :rusage_system results)
+ :curr-items (get-alist :curr_items results)
+ :curr-items-total (get-alist :curr_items_tot results)
+ :curr-connections (get-alist :curr_connections results)
+ :total-connections (get-alist :total_connections results)
+ :connection-structures (get-alist :connection_structures results)
+ :cmd-get (get-alist :cmd_get results)
+ :cmd-set (get-alist :cmd_set results)
+ :get-hits (get-alist :get_hits results)
+ :get-misses (get-alist :get_misses results)
+ :bytes-read (get-alist :bytes_read results)
+ :bytes-written (get-alist :bytes_written results)
+ :limit-maxbytes (get-alist :limit_maxbytes results)
+ )))
+
+
+;;; Error Conditions
+
+(define-condition memcached-server-unreachable (error)
+ ())
+
+(define-condition memcache-pool-empty (error)
+ ())
+
+(define-condition cannot-make-pool-object (error)
+ ())
+
+(define-condition bad-pool-object (error)
+ ())
+
+;;;
+;;;
+;;; Memcached Pooled Access
+;;;
+;;;
+
+(defclass memcache-connection-pool ()
+ ((name
+ :initarg :name
+ :reader name
+ :initform "Connection Pool"
+ :type simple-string
+ :documentation "Name of this pool")
+ (pool
+ :initform (make-queue)
+ :accessor pool)
+ (pool-lock
+ :reader pool-lock
+ :initform (make-lock "Memcache Connection Pool Lock"))
+ (max-capacity
+ :initarg :max-capacity
+ :reader max-capacity
+ :initform 2
+ :type fixnum
+ :documentation "Total capacity of the pool to hold pool objects")
+ (current-size
+ :accessor current-size
+ :initform 0)
+ (currently-in-use
+ :accessor currently-in-use
+ :initform 0
+ :type fixnum
+ :documentation "Pool objects currently in Use")
+ (total-uses
+ :accessor total-uses
+ :initform 0
+ :documentation "Total uses of the pool")
+ (total-created
+ :accessor total-created
+ :initform 0
+ :type fixnum
+ :documentation "Total pool objects created")
+ (pool-grow-requests
+ :initform 0
+ :accessor pool-grow-requests
+ :type fixnum
+ :documentation "Pool Grow Request pending Action")
+ (pool-grow-lock
+ :initform (make-lock "Pool Grow Lock")
+ :reader pool-grow-lock))
+ (:documentation "A memcached connection pool object"))
+
+(defmethod print-object ((mcp memcache-connection-pool) stream)
+ (print-unreadable-object (mcp stream :type t :identity t)
+ (format stream "Capacity:~d, Currently in use:~d"
+ (when (slot-boundp mcp 'max-capacity) (max-capacity mcp))
+ (when (slot-boundp mcp 'currently-in-use) (currently-in-use mcp)))))
+
+(defun mc-put-in-pool (conn &key (memcache *memcache*))
+ (with-lock-held ((pool-lock (pool memcache)))
+ (enqueue (pool (pool memcache)) conn)
+ (decf (currently-in-use (pool memcache)))))
+
+(defun mc-get-from-pool (&key (memcache *memcache*))
+ "Returns a pool object from pool."
+ (let (pool-object (state t))
+ (with-lock-held ((pool-lock (pool memcache)))
+ (if (queue-empty-p (pool (pool memcache)))
+ (setf state nil)
+ (progn (incf (currently-in-use (pool memcache)))
+ (incf (total-uses (pool memcache)))
+ (setf pool-object (dequeue (pool (pool memcache)))))))
+ (if state
+ pool-object
+ (error 'memcache-pool-empty))))
+
+(defun mc-get-from-pool-with-try (&key (memcache *memcache*) (tries 5) (try-interval 1))
+ ""
+ (let ((tr 1))
+ (loop
+ (progn (when (> tr tries)
+ (return nil))
+ (let ((conn (handler-case (mc-get-from-pool :memcache memcache)
+ (memcache-pool-empty () nil))))
+ (if (not conn)
+ (progn (incf tr)
+ (warn "memcache ~a : Connection Pool Empty! I will try again after ~d secs." (name memcache) try-interval)
+ (process-sleep try-interval))
+ (return conn)))))))
+
+(defun mc-pool-init (&key (memcache *memcache*))
+ "Cleans up the pool for this particular instance of memcache
+& reinits it with POOL-SIZE number of objects required by this pool"
+ (mc-pool-cleanup memcache)
+ (dotimes (i (pool-size memcache))
+ (mc-pool-grow-request memcache))
+ (mc-pool-grow memcache))
+
+(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))))
+
+(defun mc-pool-grow (memcache)
+ (let (grow-count pool-item-list)
+ (with-lock-held ((pool-grow-lock (pool memcache)))
+ (setf grow-count (pool-grow-requests (pool memcache)))
+ (setf pool-item-list (remove nil (loop for x from 1 to grow-count
+ collect (mc-make-pool-item :memcache memcache))))
+ (loop for x from 1 to (length pool-item-list)
+ do (with-lock-held ((pool-lock (pool memcache)))
+ (enqueue (pool (pool memcache)) (pop pool-item-list))
+ (incf (total-created (pool memcache)))
+ (incf (current-size (pool memcache))))
+ do (decf (pool-grow-requests (pool memcache)))))))
+
+(defun mc-destroy-pool-item (pool-item)
+ (ignore-errors (usocket:socket-close pool-item)))
+
+(defun mc-pool-grow-request (memcache)
+ (with-lock-held ((pool-grow-lock (pool memcache)))
+ (if (> (max-capacity (pool memcache)) (+ (current-size (pool memcache))
+ (pool-grow-requests (pool memcache))))
+ (incf (pool-grow-requests (pool memcache)))
+ (warn "memcache: Pool is at capacity."))))
+
+(defun mc-chuck-from-pool (object memcache)
+ (mc-destroy-pool-item object)
+ (with-lock-held ((pool-lock (pool memcache)))
+ (decf (current-size (pool memcache))))
+ #|(loop while (mc-pool-grow-request memcache))
+ (mc-pool-grow memcache)|#
+ (mc-pool-init :memcache memcache))
+
+(defun mc-pool-cleanup (memcache)
+ (with-lock-held ((pool-lock (pool memcache)))
+ (with-lock-held ((pool-grow-lock (pool memcache)))
+ (loop
+ when (queue-empty-p (pool (pool memcache)))
+ do (return)
+ else do (mc-destroy-pool-item (dequeue (pool (pool memcache)))))
+ (setf (current-size (pool memcache)) 0
+ (currently-in-use (pool memcache)) 0
+ (pool-grow-requests (pool memcache)) 0
+ (total-created (pool memcache)) 0
+ (total-uses (pool memcache)) 0))))
--- /dev/null
+;;; -*- Mode: Common-Lisp -*-
+
+;;; Copyright (c) 2005-2006, quasi. All rights reserved.
+;;; Copyright (c) 2011 Kevin Rosenberg
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package #:cl-user)
+
+(defpackage #:memcache
+ (:use #:cl)
+ (:nicknames #:mc)
+ (:shadowing-import-from #:kmrcl #:get-alist #:defconstant*
+ #:delimited-string-to-list #:ensure-keyword
+ #:parse-float #:make-lock #:with-lock-held
+ #:process-sleep)
+ (:export #:*memcache*
+ #:memcache
+ #:mc-store
+ #:mc-get
+ #:mc-del
+ #:mc-incr
+ #:mc-decr
+ #:mc-stats
+ #:mc-get-stat
+ #:memcache-stats
+ #:make-memcache-instance
+ #:mc-server-check
+ #:mc-pool-init
+ #:*use-pool*))
+
--- /dev/null
+;;; -*- Mode: Common-Lisp -*-
+
+;;; Copyright (c) 2006, Abhijit 'quasi' Rao. All rights reserved.
+;;; Copyright (c) 2006, Cleartrip Travel Services.
+;;; Copyright (c) 2011 Kevin Rosenberg
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+(in-package #:memcache)
+
+(defvar *memcache* nil
+ "Represents a particular Memcached server")
+
+(defvar *use-pool* nil
+ "Default value for the USE-POOL keyword parameter in memcached functions")
+
+(defvar *pool-get-trys?* nil
+ "If true then it will try to wait and sleep for a while if pool item in unavailable,
+if nil then will return immideatly")
+
+(defconstant* +crlf+
+ (concatenate 'string
+ (string (code-char 13))
+ (string (code-char 10))))
+
+(defconstant* +mc-END-ret+
+ (concatenate 'string
+ (string "END")
+ (string #\return)))
+
+(defstruct
+ (memcache-stats
+ (:conc-name mc-stats-)
+ (:print-function
+ (lambda (struct stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (struct stream :type t :identity t)
+ (format stream "pid:~A size:~d MB curr:~d total:~D"
+ (mc-stats-pid struct)
+ (/ (mc-stats-limit-maxbytes struct) 1024 1024)
+ (mc-stats-curr-items struct)
+ (mc-stats-curr-items-total struct))))))
+"The structure which holds the statistics from the memcached server. The fields are :
+field-name accessor-function documentation
+---------- ----------------- -------------
+pid mc-stats-pid Process id of this server process
+uptime mc-stats-uptime Number of seconds this server has been running
+time mc-stats-time current UNIX time according to the server
+version mc-stats-version Version string of this server
+rusage-user mc-stats-rusage-user Accumulated user time for this process
+rusage-system mc-stats-rusage-system Accumulated system time for this process
+curr-items mc-stats-curr-items Current number of items stored by the server
+curr-items-total mc-stats-curr-items-total
+curr-connections mc-stats-curr-connections Number of open connections
+total-connections mc-stats-total-connections Total number of connections opened since the server started running
+connection-structures mc-stats-connection-structures Number of connection structures allocated by the server
+cmd-get mc-stats-cmd-get Cumulative number of retrieval requests
+cmd-set mc-stats-cmd-set Cumulative number of storage requests
+get-hits mc-stats-get-hits Number of keys that have been requested and found present
+get-misses mc-stats-get-misses Number of items that have been requested and not found
+bytes-read mc-stats-bytes-read Total number of bytes read by this server from network
+bytes-written mc-stats-bytes-written Total number of bytes sent by this server to network
+limit-maxbytes mc-stats-limit-maxbytes Number of bytes this server is allowed to use for storage.
+"
+ all-stats
+ pid uptime time version rusage-user rusage-system curr-items curr-items-total
+ curr-connections total-connections connection-structures cmd-get cmd-set
+ get-hits get-misses bytes-read bytes-written limit-maxbytes)
+
+;;;
+;;; The main class which represents the memcached server
+;;;
+(defclass memcache ()
+ ((name
+ :initarg :name
+ :reader name
+ :type simple-string
+ :documentation "Name of this Memcache instance")
+ (ip
+ :initarg :ip
+ :initform "127.0.0.1"
+ :accessor ip
+ :type simple-string
+ :documentation "The IP address of the Memcached server this instance represents")
+ (port
+ :initarg :port
+ :initform 11211
+ :accessor port
+ :type fixnum
+ :documentation "The port on which the Memcached server this instance represents runs")
+ (memcached-server-storage-size
+ :initform 0
+ :reader memcached-server-storage-size
+ :type fixnum
+ :documentation "Memory allocated to the Memcached Server")
+ (pool-size
+ :initarg :pool-size
+ :initform 2
+ :reader pool-size)
+ (pool
+ :reader pool))
+ (:documentation "This class represents an instance of the Memcached server"))
+
+
+(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"
+ "curr_items" "curr_items_tot" "daemon_connections" "decr_hits" "decr_misses"
+ "delete_hits" "delete_misses" "ep_bg_fetched" "ep_commit_num" "ep_commit_time"
+ "ep_commit_time_total" "ep_data_age" "ep_data_age_highwat" "ep_db_cleaner_status"
+ "ep_db_strategy" "ep_dbinit" "ep_dbname" "ep_dbshards" "ep_diskqueue_drain"
+ "ep_diskqueue_fill" "ep_diskqueue_items" "ep_diskqueue_memory"
+ "ep_diskqueue_pending" "ep_expired" "ep_flush_all" "ep_flush_duration"
+ "ep_flush_duration_highwat" "ep_flush_duration_total" "ep_flush_preempts"
+ "ep_flusher_state" "ep_flusher_todo" "ep_io_num_read" "ep_io_num_write"
+ "ep_io_read_bytes" "ep_io_write_bytes" "ep_item_begin_failed"
+ "ep_item_commit_failed" "ep_item_flush_expired" "ep_item_flush_failed"
+ "ep_items_rm_from_checkpoints" "ep_kv_size" "ep_latency_arith_cmd"
+ "ep_latency_get_cmd" "ep_latency_store_cmd" "ep_max_data_size" "ep_max_txn_size"
+ "ep_mem_high_wat" "ep_mem_low_wat" "ep_min_data_age" "ep_num_active_non_resident"
+ "ep_num_checkpoint_remover_runs" "ep_num_eject_failures" "ep_num_eject_replicas"
+ "ep_num_expiry_pager_runs" "ep_num_non_resident" "ep_num_not_my_vbuckets"
+ "ep_num_pager_runs" "ep_num_value_ejects" "ep_onlineupdate"
+ "ep_onlineupdate_revert_add" "ep_onlineupdate_revert_delete"
+ "ep_onlineupdate_revert_update" "ep_oom_errors" "ep_overhead" "ep_pending_ops"
+ "ep_pending_ops_max" "ep_pending_ops_max_duration" "ep_pending_ops_total"
+ "ep_queue_age_cap" "ep_queue_size" "ep_storage_age" "ep_storage_age_highwat"
+ "ep_storage_type" "ep_store_max_concurrency" "ep_store_max_readers"
+ "ep_store_max_readwrite" "ep_tap_bg_fetch_requeued" "ep_tap_bg_fetched"
+ "ep_tap_keepalive" "ep_tmp_oom_errors" "ep_too_old" "ep_too_young"
+ "ep_total_cache_size" "ep_total_del_items" "ep_total_enqueued" "ep_total_new_items"
+ "ep_total_persisted" "ep_uncommitted_items" "ep_vb_total" "ep_vbucket_del"
+ "ep_vbucket_del_fail" "ep_version" "ep_warmed_up" "ep_warmup" "ep_warmup_dups"
+ "ep_warmup_oom" "ep_warmup_thread" "ep_warmup_time" "get_hits" "get_misses"
+ "incr_hits" "incr_misses" "libevent" "limit_maxbytes" "listen_disabled_num"
+ "mem_used" "pid" "pointer_size" "rejected_conns" "rusage_system" "rusage_user"
+ "threads" "time" "total_connections" "uptime" "vb_active_curr_items"
+ "vb_active_eject" "vb_active_ht_memory" "vb_active_itm_memory" "vb_active_num"
+ "vb_active_num_non_resident" "vb_active_ops_create" "vb_active_ops_delete"
+ "vb_active_ops_reject" "vb_active_ops_update" "vb_active_perc_mem_resident"
+ "vb_active_queue_age" "vb_active_queue_drain" "vb_active_queue_fill"
+ "vb_active_queue_memory" "vb_active_queue_pending" "vb_active_queue_size"
+ "vb_dead_num" "vb_pending_curr_items" "vb_pending_eject" "vb_pending_ht_memory"
+ "vb_pending_itm_memory" "vb_pending_num" "vb_pending_num_non_resident"
+ "vb_pending_ops_create" "vb_pending_ops_delete" "vb_pending_ops_reject"
+ "vb_pending_ops_update" "vb_pending_perc_mem_resident" "vb_pending_queue_age"
+ "vb_pending_queue_drain" "vb_pending_queue_fill" "vb_pending_queue_memory"
+ "vb_pending_queue_pending" "vb_pending_queue_size" "vb_replica_curr_items"
+ "vb_replica_eject" "vb_replica_ht_memory" "vb_replica_itm_memory" "vb_replica_num"
+ "vb_replica_num_non_resident" "vb_replica_ops_create" "vb_replica_ops_delete"
+ "vb_replica_ops_reject" "vb_replica_ops_update" "vb_replica_perc_mem_resident"
+ "vb_replica_queue_age" "vb_replica_queue_drain" "vb_replica_queue_fill"
+ "vb_replica_queue_memory" "vb_replica_queue_pending" "vb_replica_queue_size"
+ "version"))
--- /dev/null
+(in-package #:memcache)
+
+(defun mc-server-check (&key (memcache *memcache*))
+ "Performs some basic tests on the Memcache instance and outputs a status string"
+ (with-output-to-string (s)
+ (let ((key "MEMCACHESERVERCHECK")
+ (data "IS THE SERVER OK ? PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE PLEASE")
+ (server-response (mc-make-pool-item :memcache memcache)))
+ (if server-response
+ (progn
+ (format s "Checking Memcached Server ~A running on ~A:~A ..." (name memcache) (ip memcache) (port memcache))
+ (format s "~%Sending data of length ~D with key ~A..." (length data) key)
+ (format s "~%Storage Command Rreturned : ~A" (handler-case (mc-store key data :memcache memcache)
+ (socket-error () (format t "~2%CANNOT CONNECT TO CACHE !~%"))
+ (error (c) (format t "GET COMMAND ERROR ~A" c))))
+ (format s "~%Trying to get back stored data with key ~A" key)
+ (format s "~%Retrieve Command Returned : ~a" (when (handler-case (mc-get (list key) :memcache memcache)
+ (socket-error () (format t "~2%CANNOT CONNECT TO CACHE !~%"))
+ (error (c) (format t "GET COMMAND ERROR ~A" c)))
+ "DATA"))
+ (format s "~%Delete Command Returned : ~A" (handler-case (mc-del key :memcache memcache)
+ (socket-error () (format t "~2%CANNOT CONNECT TO CACHE !~%"))
+ (error (c) (format t "DEL COMMAND ERROR ~A" c))))
+ (format s "~2%~a" (mc-stats :memcache memcache)))
+ (format s "~2%CANNOT CONNECT TO CACHE SERVER ! ~%")))))
+
+
+
+(defun mc-make-benchmark-data (n)
+ (make-array (list n) :initial-element 0))
+
+
+(defun mc-benchmark (n data-size &key (memcache *memcache*) (use-pool t) (action :write))
+ (let ((data (make-array (list data-size) :initial-element 0)))
+ (dotimes (i n)
+ (let ((key (concatenate 'simple-string "key_" (princ-to-string i))))
+ (case action
+ (:write (mc-store key data :memcache memcache :use-pool use-pool :exptime 600))
+ (:read (mc-get (list key) :memcache memcache :use-pool use-pool)))))))
+
+
+
+;; if you have cl-who installed, print a pretty html table for the memcached stats
+
+#+cl-who
+(defun memcached-details-table-helper (&key (memcache *memcache*) (stream *standard-output*))
+ ""
+ (cl-who:with-html-output-to-string (stream)
+
+ (:table :border 1 :cellpadding 4 :width "90%" :style "border:solid black 4px;font-family:monospace;font-size:12px"
+ (let ((stats (memcache:mc-stats :memcache memcache :use-pool nil)))
+ (cl-who:htm
+ (:tr (:th :colspan 2 (:h4 (format stream "Name: ~A | Server IP : ~A | Port : ~A" (memcache::name memcache) (memcache::ip memcache) (memcache::port memcache)))))
+ (:tr
+ (:td (format stream "Process ID")) (:td (format stream "~a" (memcache::mc-stats-pid stats))))
+ (:tr
+ (:td (format stream "Server Uptime")) (:td (format stream "~a" (kmrcl:seconds-to-condensed-time-string
+ (memcache::mc-stats-uptime stats)))))
+ (:tr
+ (:td (format stream "System Time")) (:td (format stream "~a" (memcache::mc-stats-time stats))))
+ (:tr
+ (:td (format stream "Server Version")) (:td (format stream "~a" (memcache::mc-stats-version stats))))
+ (:tr
+ (:td (format stream "Accumulated user time")) (:td (format stream "~a" (memcache::mc-stats-rusage-user stats))))
+ (:tr
+ (:td (format stream "Accumulated system time")) (:td (format stream "~a" (memcache::mc-stats-rusage-system stats))))
+ (:tr
+ (:td (format stream "Current items stored in server")) (:td (format stream "~a" (memcache::mc-stats-curr-items stats))))
+ (:tr
+ (:td (format stream "Current items total")) (:td (:b (format stream "~a" (memcache::mc-stats-curr-items-total stats)))))
+ (:tr
+ (:td (format stream "Current bytes used by server to store items")) (:td (format stream "~a MB" (float (/ (memcache::mc-stats-bytes stats) 1048576)))))
+ (:tr
+ (:td (format stream "Number of open connections")) (:td (format stream "~a" (memcache::mc-stats-curr-connections stats))))
+ (:tr
+ (:td (format stream "Total number of connections opened since server start")) (:td (format stream "~a" (memcache::mc-stats-total-connections stats))))
+ (:tr
+ (:td (format stream "Number of connection structures allocated by server")) (:td (format stream "~a" (memcache::mc-stats-connection-structures stats))))
+ (:tr
+ (:td (format stream "Cumulative number of Retrieval requests")) (:td (:b (format stream "~a" (memcache::mc-stats-cmd-get stats)))))
+ (:tr
+ (:td (format stream "Cumulative number of Storage requests")) (:td (:b (format stream "~a" (memcache::mc-stats-cmd-set stats)))))
+ (:tr
+ (:td (format stream "Number of keys that have been requested and found present")) (:td (format stream "~a" (memcache::mc-stats-get-hits stats))))
+ (:tr
+ (:td (format stream "Number of items that have been requested and not found")) (:td (format stream "~a" (memcache::mc-stats-get-misses stats))))
+ (:tr
+ (:td (format stream "Total number of bytes read by server from network")) (:td (format stream "~a MB" (float (/ (memcache::mc-stats-bytes-read stats) 1048576)))))
+ (:tr
+ (:td (format stream "Total number of bytes sent by this server to network")) (:td (format stream "~a MB" (float (/ (memcache::mc-stats-bytes-written stats) 1048576)))))
+ (:tr
+ (:td (format stream "Number of bytes this server is allowed to use for storage")) (:td (format stream "~f MB" (float (/ (memcache::mc-stats-limit-maxbytes stats) 1048576))))))))))
+
+(defun read-crlf-line (s)
+ "Reads a line from socket s. For platform independence, use read-bytes
+to avoid differences in line endings across platforms."
+ (with-output-to-string (str)
+ (do* ((byte (read-byte s nil nil) (read-byte s nil nil))
+ (cr nil))
+ ((or (null byte) (eql byte 10))
+ (when (and (eql byte 10) (not cr))
+ (error "Newline with Return character.")))
+ (cond
+ ((eql byte 13)
+ (setq cr t))
+ (t
+ (write-char (code-char byte) str))))))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; File: memstore-tests.asd
+;;;; Author: Kevin Rosenberg
+;;;; Created: March 2011
+;;;;
+;;;; This file is part of the Memstore package.
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+(defpackage #:memstore-tests-system (:use #:asdf #:cl))
+(in-package #:memstore-tests-system)
+
+(defsystem memstore-tests
+ :name "Memstore tests"
+ :author "Kevin Rosenberg"
+ :licence "BSD"
+ :description "A regression test suite for memstore."
+ :depends-on (memstore rt)
+ :components ((:module src
+ :components
+ ((:file "tests")))))
+
+(defmethod operation-done-p ((o test-op)
+ (c (eql (find-system :memstore-tests))))
+ ;; Always returns NIL so that tests are never marked as done.
+ nil)
+
+(defmethod perform ((o test-op) (c (eql (find-system :memstore-tests))))
+ (flet ((run-tests (&rest args)
+ (apply (intern (string '#:run-tests)
+ (find-package '#:memstore-tests))
+ args)))
+ (load-system c)
+ (run-tests :compiled nil)
+ (run-tests :compiled t)))
--- /dev/null
+;;;; -*- Mode: Common-Lisp -*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: memstore.asd
+;;;; Purpose: ASDF system definition for memstore package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: July 2011
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defpackage #:memstore-system (:use #:asdf #:cl))
+(in-package #:memstore-system)
+
+(defsystem memstore
+ :name "memstore"
+ :author "Kevin M. Rosenberg <kevin@rosenberg.net>"
+ :version "1.0"
+ :licence "BSD"
+ :depends-on (memcache cl-store flexi-streams zlib)
+ :components ((:module src
+ :serial t
+ :components
+ ((:file "package")
+ (:file "memstore")))))
+
+(defmethod operation-done-p ((o test-op) (c (eql (find-system :memstore))))
+ ;; Always returns NIL so that tests are never marked as done.
+ nil)
+
+(defmethod perform ((o test-op) (c (eql (find-system 'memstore))))
+ (asdf:load-system 'memstore-tests)
+ (asdf:test-system 'memstore-tests))
--- /dev/null
+;; -*- Mode: Lisp -*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FILE IDENTIFICATION
+;;
+;; Name: main.lisp
+;; Purpose: memstore main functions
+;; Date Started: July 2011
+;;
+;; Copyright (c) 2011 Kevin M. Rosenberg
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of the author nor the names of the contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;; SUCH DAMAGE.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package #:memstore)
+
+(defconstant +flag-wstring+ (ash 1 0)
+ "Bit set if stored with write-to-string.")
+(defconstant +flag-clstore+ (ash 1 1)
+ "Bit set if stored with cl-store.")
+(defconstant +flag-zlib+ (ash 1 2)
+ "Bit set if data compressed with zlib.")
+
+(defvar *compression-savings* 0.20
+ "Compression required before saving compressed value.")
+(defvar *compression-enabled* t
+ "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))
+
+
+(defun serialize-clstore (obj)
+ (let ((s (make-in-memory-output-stream :element-type 'octet)))
+ (cl-store:store obj s)
+ (get-output-stream-sequence s)))
+
+(defun deserialize-clstore (data)
+ (let ((s (make-in-memory-input-stream data)))
+ (cl-store:restore s)))
+
+(defun serialize-string (obj)
+ "Tries to write object to string, then convert to vector of octets
+Catches error while using *print-readably*. Returns nil if unable to
+ write to string."
+ (let* ((*print-readably* t)
+ (str (ignore-errors (write-to-string obj))))
+ (when (stringp str)
+ (flex:string-to-octets str :external-format *encoding*))))
+
+(defun deserialize-string (str)
+ (multiple-value-bind (obj pos)
+ (read-from-string (flex:octets-to-string str :external-format *encoding*))
+ (declare (ignore pos))
+ obj))
+
+(defun 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)."
+ (let* ((flags 0)
+ (data
+ (cond
+ ((stringp obj)
+ (flex:string-to-octets obj :external-format :utf8))
+ (t
+ (let ((ser (serialize-string obj)))
+ (etypecase ser
+ (vector
+ (setq flags (logior flags +flag-wstring+))
+ ser)
+ (null
+ (setq flags (logior flags +flag-clstore+))
+ (serialize-clstore obj)))))))
+ (dlen (length data)))
+ (when *debug*
+ (format t "Compression enabled:~A compression-threshold:~A dlen:~D~%"
+ compression-enabled compression-threshold dlen))
+ (when (and compression-enabled compression-threshold
+ (> dlen compression-threshold))
+ (multiple-value-bind (compressed clen) (zlib:compress data :fixed)
+ (when *debug*
+ (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
+ (when (< clen (* dlen (- 1 *compression-savings*)))
+ (setq data compressed)
+ (setq flags (logior flags +flag-zlib+)))))
+ (when *debug*
+ (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
+ (cons flags data)))
+
+(defun 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)))
+ (cond
+ ((plusp (logand flags +flag-clstore+))
+ (deserialize-clstore data))
+ ((plusp (logand flags +flag-wstring+))
+ (deserialize-string data))
+ (t
+ (flex:octets-to-string data :external-format :utf8)))))
+
+
+(defun make-key (key)
+ (concatenate 'string *realm* key))
+
+(defun remove-realm (key)
+ (subseq key (length *realm*)))
+
+(defun mem-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
+ :compression-threshold compression-threshold)))
+ (mc-store (make-key key) (cdr ser)
+ :memcache memcache
+ :command command :exptime exptime
+ :use-pool use-pool :flags (car ser))))
+
+(defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
+ (command :get))
+ (let ((items (mc-get
+ (mapcar 'make-key keys-list)
+ :memcache memcache
+ :use-pool use-pool
+ :command command)))
+ (mapcar (lambda (item)
+ (let ((key (first item))
+ (flags (second item))
+ (data (third item)))
+ (ecase command
+ (:get
+ (list (remove-realm key) (deserialize (cons flags data))))
+ (:gets
+ (list (remove-realm key) (deserialize (cons flags data)) (fourth item))))))
+ items)))
+
+(defun mem-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
+ (command :get))
+ (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
+ :command command)))
+ (if multp
+ items
+ (if items
+ (let ((item (car items)))
+ (ecase command
+ (:get
+ (values (second item) t))
+ (:gets
+ (values (second item) t (third item)))))
+ (values nil nil)))))
+
+(defun mem-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
+ (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))
+ (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))
+ (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
+
+
--- /dev/null
+;; -*- Mode: Common-Lisp -*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FILE IDENTIFICATION
+;;
+;; Name: package.lisp
+;; Purpose: Package definition for memstore package
+;; Date Started: July 2011
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package #:cl-user)
+
+(defpackage #:memstore
+ (:nicknames #:ms)
+ (:use #:common-lisp #:kmrcl)
+ (:documentation "This is the main memstore package.")
+ (:import-from #:memcache #:*memcache* #:*use-pool* #:mc-get #:mc-store
+ #:mc-del #:mc-incr #:mc-decr)
+ (:import-from #:flexi-streams #:make-in-memory-input-stream
+ #:make-in-memory-output-stream
+ #:get-output-stream-sequence #:octet)
+ (:export
+ #:*compression-threshold*
+ #:*compression-enabled*
+ #:*compression-savings*
+ #:*realm*
+ #:mem-store
+ #:mem-restore
+ #:mem-del
+ #:mem-incr
+ #:mem-decr))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: memstore-tests.lisp
+;;;; Purpose: memstore tests file
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: July 2011
+;;;;
+;;;; This file is Copyright (c) 2011 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:cl)
+(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
+ #:serialize-clstore #:deserialize-clstore
+ #:serialize-string #:deserialize-string
+ #:+flag-wstring+ #:+flag-clstore+
+ #:+flag-zlib+ #:*realm*)
+ (: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__:"))
+
+(unless *memcache*
+ (setq *memcache* (make-memcache-instance :name "Memcache test")))
+
+(rem-all-tests)
+
+(defun run-tests (&key (compiled *compile-tests*))
+ (let ((*compile-tests* compiled))
+ (rtest:do-tests)))
+
+(defmacro def-readably-value* (val)
+ `(progn
+ (deftest ,(intern (format nil "DS.~D" *test-cnt*) '#:keyword)
+ (let* ((ser (serialize (quote ,val)))
+ (flags (car ser)))
+ (cond
+ ((stringp (quote ,val))
+ (unless (and (zerop (logand flags +flag-wstring+))
+ (zerop (logand flags +flag-clstore+)))
+ (error "Should be stored as simple string.")))
+ (t
+ (unless (and (plusp (logand flags +flag-wstring+))
+ (zerop (logand flags +flag-clstore+)))
+ (error "Should be stored as wstring."))))
+ (deserialize ser))
+ ,val)
+ (deftest ,(intern (format nil "RS.~D" *test-cnt*) '#:keyword)
+ (deserialize-clstore (serialize-clstore (quote ,val)))
+ ,val)
+ (deftest ,(intern (format nil "SS.~D" *test-cnt*) '#:keyword)
+ (deserialize-string (serialize-string (quote ,val)))
+ ,val)
+ (deftest ,(intern (format nil "MC.~D" *test-cnt*) '#:keyword)
+ (let ((*realm* ,*test-realm*)
+ (key (format nil "~D" ,*test-cnt*)))
+ (mem-store key (quote ,val))
+ (multiple-value-bind (res found) (mem-restore key)
+ (mem-del key)
+ (values found (equalp res (quote ,val)))))
+ t t)
+ ,(incf *test-cnt*)))
+
+(defmacro def-readably-value (val)
+ `(progn
+ (let ((*use-pool* nil))
+ (def-readably-value* ,val))
+ (let ((*use-pool* t))
+ (def-readably-value* ,val))))
+
+(def-readably-value -1)
+(def-readably-value 10)
+(def-readably-value 1.5)
+(def-readably-value #C(1 2))
+(def-readably-value "")
+(def-readably-value "abc")
+(def-readably-value nil)
+(def-readably-value t)
+(def-readably-value a)
+(def-readably-value :a)
+(def-readably-value (a b))
+(def-readably-value (a . b))
+(def-readably-value (:a . "b"))
+(def-readably-value #(0 1 2))
+(def-readably-value \#k)
+(def-readably-value ((:a . 1) (:b . 2)))
+(def-readably-value #(((:a . 1) (:b . 2.5))
+ ((:c . "a") (:d . a))))
+
+(deftest :ht.1
+ (let ((h (make-hash-table :test 'equal)))
+ (setf (gethash "a" h) "A")
+ (setf (gethash "b" h) "B")
+ (let ((ds (deserialize (serialize h))))
+ (list (hash-table-count ds) (gethash "a" ds) (gethash "b" ds))))
+ (2 "A" "B"))
+(deftest :ht.2
+ (let ((h (make-hash-table :test 'equal)))
+ (setf (gethash "a" h) "A")
+ (setf (gethash "b" h) "B")
+ (let ((ds (deserialize-clstore (serialize-clstore h))))
+ (list (hash-table-count ds) (gethash "a" ds) (gethash "b" ds))))
+ (2 "A" "B"))
+
+#-sbcl
+(deftest :ht.3
+ (let ((h (make-hash-table :test 'equal)))
+ (setf (gethash "a" h) "A")
+ (setf (gethash "b" h) "B")
+ (serialize-string h)) ;; should be nil as hash tables can't be print-readably to string
+ nil)
+
+;; SBCL can print hash-tables readably
+#+sbcl
+(deftest :ht.3
+ (let ((h (make-hash-table :test 'equal)))
+ (setf (gethash "a" h) "A")
+ (setf (gethash "b" h) "B")
+ (let ((ds (deserialize-string (serialize-string h))))
+ (list (hash-table-count ds) (gethash "a" ds) (gethash "b" ds))))
+ (2 "A" "B"))
+
+
+(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*))
+ (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))))
+ t t t t t)
+
+(deftest :l.2
+ (let* ((ser (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))))
+ t t t t t)
+
+(deftest :incr.1
+ (let ((*realm* *test-realm*))
+ (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")))
+ "STORED" 0 1 6 9 7 6 "DELETED")
+
+(deftest :nf.1
+ (let ((*realm* *test-realm*))
+ (mem-restore "a"))
+ nil nil)