2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Purpose: memstore main functions
7 ;; Date Started: July 2011
9 ;; Copyright (c) 2011 Kevin M. Rosenberg
10 ;; All rights reserved.
12 ;; Redistribution and use in source and binary forms, with or without
13 ;; modification, are permitted provided that the following conditions
15 ;; 1. Redistributions of source code must retain the above copyright
16 ;; notice, this list of conditions and the following disclaimer.
17 ;; 2. Redistributions in binary form must reproduce the above copyright
18 ;; notice, this list of conditions and the following disclaimer in the
19 ;; documentation and/or other materials provided with the distribution.
20 ;; 3. Neither the name of the author nor the names of the contributors
21 ;; may be used to endorse or promote products derived from this software
22 ;; without specific prior written permission.
24 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
25 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
26 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
27 ;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
28 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 ;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30 ;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31 ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 ;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
33 ;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 (in-package #:memstore)
39 (defconstant +flag-wstring+ (ash 1 0)
40 "Bit set if stored with write-to-string.")
41 (defconstant +flag-clstore+ (ash 1 1)
42 "Bit set if stored with cl-store.")
43 (defconstant +flag-zlib+ (ash 1 2)
44 "Bit set if data compressed with zlib.")
46 (defvar *compression-savings* 0.20
47 "Compression required before saving compressed value.")
48 (defvar *compression-enabled* t
49 "Determines if compression is enabled.")
50 (defvar *compression-threshold* 5000
51 "Minimum size of object before attempting compression.")
53 (defvar *realm* "ms:")
54 (defvar *encoding* (flex:make-external-format :utf-8))
57 (defun serialize-clstore (obj)
58 (let ((s (make-in-memory-output-stream :element-type 'octet)))
59 (cl-store:store obj s)
60 (get-output-stream-sequence s)))
62 (defun deserialize-clstore (data)
63 (let ((s (make-in-memory-input-stream data)))
64 (cl-store:restore s)))
66 (defun serialize-string (obj)
67 "Tries to write object to string, then convert to vector of octets
68 Catches error while using *print-readably*. Returns nil if unable to
70 (let* ((*print-readably* t)
71 (str (ignore-errors (write-to-string obj))))
73 (flex:string-to-octets str :external-format *encoding*))))
75 (defun deserialize-string (str)
76 (multiple-value-bind (obj pos)
77 (read-from-string (flex:octets-to-string str :external-format *encoding*))
78 (declare (ignore pos))
81 (defun serialize (obj &key (compression-enabled *compression-enabled*)
82 (compression-threshold *compression-threshold*))
83 "Converts a lisp object into a vector of octets.
84 Returns a cons of (flags . data)."
89 (flex:string-to-octets obj :external-format :utf8))
91 (let ((ser (serialize-string obj)))
94 (setq flags (logior flags +flag-wstring+))
97 (setq flags (logior flags +flag-clstore+))
98 (serialize-clstore obj)))))))
101 (format t "Compression enabled:~A compression-threshold:~A dlen:~D~%"
102 compression-enabled compression-threshold dlen))
103 (when (and compression-enabled compression-threshold
104 (> dlen compression-threshold))
105 (multiple-value-bind (compressed clen) (zlib:compress data :fixed)
107 (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
108 (when (< clen (* dlen (- 1 *compression-savings*)))
109 (setq data compressed)
110 (setq flags (logior flags +flag-zlib+)))))
112 (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
115 (defun deserialize (ser)
116 "Converts a cons of storage flags and vector of octets into a lisp object."
117 (let ((flags (car ser))
119 (when (plusp (logand flags +flag-zlib+))
120 (setq data (zlib:uncompress data)))
122 ((plusp (logand flags +flag-clstore+))
123 (deserialize-clstore data))
124 ((plusp (logand flags +flag-wstring+))
125 (deserialize-string data))
127 (flex:octets-to-string data :external-format :utf8)))))
130 (defun make-key (key)
131 (concatenate 'string *realm* key))
133 (defun remove-realm (key)
134 (subseq key (length *realm*)))
136 (defun mem-store (key obj &key (memcache *memcache*) (command :set)
137 (exptime 0) (use-pool *use-pool*)
138 (compression-enabled *compression-enabled*)
139 (compression-threshold *compression-threshold*))
140 "Stores an object in cl-memcached. Tries to print-readably object
141 to a string for storage. If unable to do so, uses cl-store to serialize
142 object. Optionally compresses value if meets compression criteria."
143 (let ((ser (serialize obj :compression-enabled compression-enabled
144 :compression-threshold compression-threshold)))
145 (mc-store (make-key key) (cdr ser)
147 :command command :exptime exptime
148 :use-pool use-pool :flags (car ser))))
150 (defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
153 (mapcar 'make-key keys-list)
157 (mapcar (lambda (item)
158 (let ((key (first item))
159 (flags (second item))
163 (list (remove-realm key) (deserialize (cons flags data))))
165 (list (remove-realm key) (deserialize (cons flags data)) (fourth item))))))
168 (defun mem-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
170 (let* ((multp (listp key-or-keys))
171 (keys (if multp key-or-keys (list key-or-keys)))
172 (items (get-objects keys :memcache memcache :use-pool use-pool
177 (let ((item (car items)))
180 (values (second item) t))
182 (values (second item) t (third item)))))
185 (defun mem-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
186 (mc-del (make-key key) :memcache memcache :use-pool use-pool :time time))
188 (defun mem-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
189 (mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
191 (defun mem-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
192 (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))