From 7b1921a415c4670f36c2e3bdccbe859284fb7eee Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 1 Jul 2011 23:01:05 -0600 Subject: [PATCH] Initial commit --- LICENSE | 26 ++ README.md | 46 ++++ memcache.asd | 23 ++ memcache/LICENSE | 28 +++ memcache/README.md | 54 +++++ memcache/compat.lisp | 61 +++++ memcache/doc/cl-memcached.html | 423 +++++++++++++++++++++++++++++++++ memcache/memcache.lisp | 421 ++++++++++++++++++++++++++++++++ memcache/package.lisp | 53 +++++ memcache/specials.lisp | 176 ++++++++++++++ memcache/util.lisp | 108 +++++++++ memstore-tests.asd | 38 +++ memstore.asd | 32 +++ src/memstore.lisp | 194 +++++++++++++++ src/package.lisp | 31 +++ src/tests.lisp | 173 ++++++++++++++ 16 files changed, 1887 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 memcache.asd create mode 100644 memcache/LICENSE create mode 100644 memcache/README.md create mode 100644 memcache/compat.lisp create mode 100644 memcache/doc/cl-memcached.html create mode 100644 memcache/memcache.lisp create mode 100644 memcache/package.lisp create mode 100644 memcache/specials.lisp create mode 100644 memcache/util.lisp create mode 100644 memstore-tests.asd create mode 100644 memstore.asd create mode 100644 src/memstore.lisp create mode 100644 src/package.lisp create mode 100644 src/tests.lisp diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1dcd882 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..01143d1 --- /dev/null +++ b/README.md @@ -0,0 +1,46 @@ +MemStore +======== + +_A high-level interface for the memcached and membase servers_ + +Written by Kevin M. Rosenberg + +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. diff --git a/memcache.asd b/memcache.asd new file mode 100644 index 0000000..2603159 --- /dev/null +++ b/memcache.asd @@ -0,0 +1,23 @@ +;;; -*- 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 , quasi " + :depends-on (usocket kmrcl) + :components ((:module memcache + :serial t + :components + ((:file "package") + (:file "specials") + (:file "util") + (:file "compat") + (:file "memcache"))))) + diff --git a/memcache/LICENSE b/memcache/LICENSE new file mode 100644 index 0000000..606bec4 --- /dev/null +++ b/memcache/LICENSE @@ -0,0 +1,28 @@ +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. + diff --git a/memcache/README.md b/memcache/README.md new file mode 100644 index 0000000..cd45d3c --- /dev/null +++ b/memcache/README.md @@ -0,0 +1,54 @@ +Memcache +======== + +_Library for memcached protocol_ + +Author: Kevin Rosenberg , 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. diff --git a/memcache/compat.lisp b/memcache/compat.lisp new file mode 100644 index 0000000..f9fc8be --- /dev/null +++ b/memcache/compat.lisp @@ -0,0 +1,61 @@ +(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)) diff --git a/memcache/doc/cl-memcached.html b/memcache/doc/cl-memcached.html new file mode 100644 index 0000000..10725aa --- /dev/null +++ b/memcache/doc/cl-memcached.html @@ -0,0 +1,423 @@ + + + + + + CL-MEMCACHED + + + + + +
+

CL-MEMCACHED - Common Lisp interface to the memcached object caching system.

+
+ +
+ +
 

Abstract

+ +

CL-MEMCACHED is a library to interface with the memcached object caching system. +

What is Memcached?? According to the home page : +

+ +memcached 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. + +

+ +Danga Interactive developed memcached to enhance the speed of LiveJournal.com, 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. +
+ +

CL-MEMCACHED implements most of the memcached protocol. The code has been tested on Allegro CL and does not work on other Lisp's right now. See file compat.lisp to help. + +

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. + + + +

Here are some sample performance statistics of CL-MEMCACHED and other memcached clients : +
+ + + + + + +
clientlang implementation10,000 writes
1K data (in msec)		10,000 reads
1K data (in msec)		10,000 writes
10K data (in msec)		10,000 reads
10K data (in msec)
cl-memcachedAllegro 8.0 (AMD64)9508302,1301,330
memcached-client-1.2.0ruby 1.8.57278741,1291,296
python-memcached-1.36python 2.5.18929511,0921,259
php-memcached-2.1.2php 4.3.9507513400,000660
+ +
+

The code comes with a BSD-style license so you can basically do with it whatever you want. + +

Download shortcut: cl-memcached-latest.tar.gz. + + +

 

Lists

+ +
The devel mailing list is cl-memcached-devel. +
The announce mailing list is cl-memcached-announce. + +
 

Example Usage

+ +

quick start +

+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"))
+
+
+ + +
 

Contents

+
    +
  1. Download +
  2. The CL-MEMCACHED dictionary +
      +
    1. *memcache* +
    2. *use-pool* +
    3. *pool-get-trys?* +
    4. mc-decr +
    5. mc-del +
    6. mc-get +
    7. mc-get+ +
    8. mc-incr +
    9. mc-make-memcache-instance +
    10. mc-pool-init +
    11. mc-server-check +
    12. mc-stats +
    13. mc-store +
    14. memcache +
    +
  3. Acknowledgements +
+ +
 

Download

+ +CL-MEMCACHED together with this documentation can be downloaded from cl-memcached-latest.tar.gz. The +current version is 0.4.1. (I will be setting up a SVN repo soon) + +
 

The CL-MEMCACHED dictionary

+ + + + + +


[Special variable]
*memcache* +


+ +We can set the current memcache instance to this if there is only one in use. + +
+ + + + + + +


[Special variable]
*use-pool* +


+
+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 nil, which means a new connection is make every request.
+
+
+ + + + + +


[Special variable]
*pool-get-trys?* +


+
+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.
+
+
+ + + + + + +


[Function]
mc-store key data &key memcache command timeout use-pool => result +


+ +Stores data in the memcached server. + +
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.
+timeout - The time in seconds when this data expires.  0 is never expire.
+
+
+ + + + + + +


[Function]
mc-get keys-list &key memcache use-pool is-string => result +


+ +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 two elements key and value
+key - is of type SIMPLE-STRING
+value is of type (UNSIGNED-BYTE 8)
+
+
+ + + + + + +


[Function]
mc-get+ key-or-list-of-keys &key memcache use-pool => result +


+ +To be used for non-binary data only. If one key is given +returns the response in string format + +
+ + + + + + + +


[Function]
mc-decr key &key memcache value use-pool => result +


+ +Implements the DECR command. Decrements the value of a key. Please read memcached documentation for more information + +
+ + + + + + +


[Function]
mc-del key &key memcache time use-pool => result +


+ +Deletes a particular 'key' and it's associated data from the memcached server + +
+ + + + + + + +


[Function]
mc-incr key &key memcache value use-pool => result +


+ +Implements the INCR command. Increments the value of a key. Please read memcached documentation for more information + +
+ + + + + + +


[Function]
mc-make-memcache-instance &key ip port name pool-size => result +


+ +Creates an instance of class MEMCACHE which represents a memcached server + +
+ + + + + + +


[Function]
mc-pool-init &key memcache => result +


+ +Cleans up the pool for this particular instance of memcache +& reinits it with POOL-SIZE number of objects required by this pool + +
+ + + + + + +


[Function]
mc-server-check &key memcache => result +


+ +Performs some basic tests on the Memcache instance and outputs a status string + +
+ + + + + + +


[Function]
mc-stats &key memcache use-pool => result +


+ +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. + +
+ + + + + +


[Structure]
memcache-stats +


+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
+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.
+
+
+ + + + + + + +


[Standard class]
memcache +


+ +This class represents an instance of 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"))
+
+ +
+ + + + +
 

Known Issues

+ +The pooling functionality is still experimental. This is mainly because strategies to deal with network errors are not in place. + +
 

TODO

+ +
- Add facility to created a replicated memcached pair. +
- Support for a memcached cluster (distributedness) + + +

People

+

Abhijit 'quasi' Rao +

Chaitanya Gupta + + +
 

Acknowledgements

+ +

Thanks to Mr. Hrush Bhatt of Cleartrip for allowing us to make this library available under a BSD licence. + + +

This documentation was prepared with the help of DOCUMENTATION-TEMPLATE. +

+
+ + diff --git a/memcache/memcache.lisp b/memcache/memcache.lisp new file mode 100644 index 0000000..1b8a244 --- /dev/null +++ b/memcache/memcache.lisp @@ -0,0 +1,421 @@ +;;; -*- 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)))) diff --git a/memcache/package.lisp b/memcache/package.lisp new file mode 100644 index 0000000..3584152 --- /dev/null +++ b/memcache/package.lisp @@ -0,0 +1,53 @@ +;;; -*- 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*)) + diff --git a/memcache/specials.lisp b/memcache/specials.lisp new file mode 100644 index 0000000..f4431ac --- /dev/null +++ b/memcache/specials.lisp @@ -0,0 +1,176 @@ +;;; -*- 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")) diff --git a/memcache/util.lisp b/memcache/util.lisp new file mode 100644 index 0000000..50286a3 --- /dev/null +++ b/memcache/util.lisp @@ -0,0 +1,108 @@ +(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)))))) + diff --git a/memstore-tests.asd b/memstore-tests.asd new file mode 100644 index 0000000..e82f033 --- /dev/null +++ b/memstore-tests.asd @@ -0,0 +1,38 @@ +;;;; -*- 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))) diff --git a/memstore.asd b/memstore.asd new file mode 100644 index 0000000..45de2ed --- /dev/null +++ b/memstore.asd @@ -0,0 +1,32 @@ +;;;; -*- 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 " + :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)) diff --git a/src/memstore.lisp b/src/memstore.lisp new file mode 100644 index 0000000..776c83d --- /dev/null +++ b/src/memstore.lisp @@ -0,0 +1,194 @@ +;; -*- 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)) + + diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..d255c6b --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,31 @@ +;; -*- 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)) diff --git a/src/tests.lisp b/src/tests.lisp new file mode 100644 index 0000000..a36cd72 --- /dev/null +++ b/src/tests.lisp @@ -0,0 +1,173 @@ +;;;; -*- 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) -- 2.34.1