From b863ee040d4f399abb087df7304eafb0d5da4d1a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Jul 2011 10:50:25 -0600 Subject: [PATCH] Work around error with zlib library compressor --- memcache/README.md | 16 +++++-- memcache/memcache.lisp | 106 ++++++++++++++++++++++++++++------------- memcache/package.lisp | 3 ++ memcache/specials.lisp | 2 +- memstore.asd | 3 +- src/memstore.lisp | 58 +++++++++++++--------- src/package.lisp | 14 +++--- src/tests.lisp | 82 +++++++++++++++++++++---------- 8 files changed, 193 insertions(+), 91 deletions(-) diff --git a/memcache/README.md b/memcache/README.md index cd45d3c..c280b01 100644 --- a/memcache/README.md +++ b/memcache/README.md @@ -7,10 +7,12 @@ Author: Kevin Rosenberg , based on the `cl-memcached` library by Abhijit 'quasi' Rao and Chaitanya Gupta . +Date Started: July 1, 2011 + Overview -------- -This package is based on the cl-memcached library. +This package is based on the `cl-memcached` library. It is substantially modified for use with the memstore package. The primary areas of additional functionality are: @@ -50,5 +52,13 @@ are: package to provide those functions as well as utilitizing other `kmrcl` functions to simplify code. -* Nearly the entire code base has been reworked for improved - robustness and efficiency. +* Added functions to support all memcached API commands, + such as `flush_all` and `version`. + +* Support for the `moreply` command argument accepted by + many commands. + +* Support the `noreply` argument that many API commands accept. + +* Write nearly the entire code base for improved + clarity, robustness, and efficiency. diff --git a/memcache/memcache.lisp b/memcache/memcache.lisp index 1b8a244..c5593cb 100644 --- a/memcache/memcache.lisp +++ b/memcache/memcache.lisp @@ -85,21 +85,26 @@ around a body of actual action statements" (mc-put-in-pool ,us :memcache ,mc) (ignore-errors (usocket:socket-close ,mc))))))) +(defun write-string-bytes (string stream) + (loop for char across string + do (write-byte (char-code char) stream))) + (defun send-mc-command (s &rest args &aux started) - (flet ((write-string-bytes (str stream) - (loop for char across str - do (write-byte (char-code char) stream)))) - (dolist (arg args) - (unless (null arg) - (if started - (write-byte (char-code #\space) s) - (setq started t)) - (typecase arg - (string (write-string-bytes arg s)) - (character (write-byte (char-code arg) s)) - (t (write-string-bytes (princ-to-string arg) s))))) - (write-string-bytes +crlf+ s) - (force-output s))) + (dolist (arg args) + (unless (null arg) + (if started + (write-byte (char-code #\space) s) + (setq started t)) + (typecase arg + #+nil (keyword (if (eq :no-reply arg) + (write-string-bytes "noreply" s) + (write-string-bytes (string-downcase + (symbol-name arg)) s))) + (string (write-string-bytes arg s)) + (character (write-byte (char-code arg) s)) + (t (write-string-bytes (princ-to-string arg) s))))) + (write-string-bytes +crlf+ s) + (force-output s)) ;;; @@ -109,7 +114,8 @@ around a body of actual action statements" ;;; (defun mc-store (key data &key (memcache *memcache*) ((:command command) :set) ((:exptime exptime) 0) - ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0)) + ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0) + no-reply) "Stores data in the memcached server using the :command command. key => key by which the data is stored. this is of type SIMPLE-STRING data => data to be stored into the cache. data is a sequence of type (UNSIGNED-BYTE 8) @@ -131,10 +137,12 @@ exptime => The time in seconds when this data expires. 0 is never expire." (:append "append") (:prepend "prepend") (:cas "cas")) - key flags exptime len (when (eq command :cas) cas-unique)) + key flags exptime len (when (eq command :cas) cas-unique) (when no-reply "noreply")) (write-sequence data s) (send-mc-command s) - (read-crlf-line s)))) + (if no-reply + (values) + (read-crlf-line s))))) (defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*) (command :get)) @@ -170,32 +178,66 @@ value is of type (UNSIGNED-BYTE 8)" res (car res)))) -(defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*)) +(defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*) (no-reply)) "Deletes a particular 'key' and it's associated data from the memcached server" (declare (type fixnum time)) (with-pool-maybe (s memcache use-pool) - (send-mc-command s "delete" key time) - (read-crlf-line s))) + (send-mc-command s "delete" key time (when no-reply "noreply")) + (if no-reply + (values) + (read-crlf-line s)))) + -(defun incr-or-decr (cmd key delta memcache use-pool) +(defun incr-or-decr (cmd key delta memcache use-pool no-reply) (declare (type fixnum delta)) (let* ((res (with-pool-maybe (s memcache use-pool) - (send-mc-command s cmd key delta) - (read-crlf-line s))) - (int (ignore-errors (parse-integer res)))) + (send-mc-command s cmd key delta (if no-reply "noreply")) + (if no-reply + (values) + (read-crlf-line s)))) + (int (unless no-reply + (ignore-errors (parse-integer res))))) (or int res))) -(defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*)) +(defun mc-version (&key (memcache *memcache*) (use-pool *use-pool*)) + (let* ((raw (with-pool-maybe (s memcache use-pool) + (send-mc-command s "version") + (read-crlf-line s))) + (split (delimited-string-to-list raw))) + (when (string-equal (first split) "VERSION") + (second split)))) + +(defun mc-verbosity (v &key (memcache *memcache*) (use-pool *use-pool*) (no-reply)) + (declare (type integer v)) + (let ((res (with-pool-maybe (s memcache use-pool) + (send-mc-command s "verbosity" v (when no-reply "noreply")) + (if no-reply + (values) + (read-crlf-line s))))) + res)) + +(defun mc-flush-all (&key (time nil) (memcache *memcache*) (use-pool *use-pool*) (no-reply)) + (declare (type (or null integer) time)) + (let ((res (with-pool-maybe (s memcache use-pool) + (if time + (send-mc-command s "flush_all" time (when no-reply "noreply")) + (send-mc-command s "flush_all" (when no-reply "noreply"))) + (if no-reply + (values) + (read-crlf-line s))))) + res)) + +(defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply)) "Implements the INCR command. Increments the value of a key. Please read memcached documentation for more information. key is a string delta is an integer" - (incr-or-decr "incr" key delta memcache use-pool)) + (incr-or-decr "incr" key delta memcache use-pool no-reply)) -(defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*)) +(defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply)) "Implements the DECR command. Decrements the value of a key. Please read memcached documentation for more information." - (incr-or-decr "decr" key delta memcache use-pool)) + (incr-or-decr "decr" key delta memcache use-pool no-reply)) (defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args &aux results) @@ -262,13 +304,13 @@ information about each slot" ;;; Error Conditions (define-condition memcached-server-unreachable (error) - ()) + ((error :initarg :error))) (define-condition memcache-pool-empty (error) ()) (define-condition cannot-make-pool-object (error) - ()) + ((error :initarg :error))) (define-condition bad-pool-object (error) ()) @@ -373,8 +415,8 @@ information about each slot" (defun mc-make-pool-item (&key (memcache *memcache*)) (handler-case (usocket:socket-connect (ip memcache) (port memcache) :element-type '(unsigned-byte 8)) - (usocket:socket-error () (error 'memcached-server-unreachable)) - (error () (error 'cannot-make-pool-object)))) + (usocket:socket-error (e) (error 'memcached-server-unreachable :error e)) + (error (e) (error 'cannot-make-pool-object :error e)))) (defun mc-pool-grow (memcache) (let (grow-count pool-item-list) diff --git a/memcache/package.lisp b/memcache/package.lisp index 3584152..7ed1060 100644 --- a/memcache/package.lisp +++ b/memcache/package.lisp @@ -45,6 +45,9 @@ #:mc-decr #:mc-stats #:mc-get-stat + #:mc-version + #:mc-verbosity + #:mc-flush-all #:memcache-stats #:make-memcache-instance #:mc-server-check diff --git a/memcache/specials.lisp b/memcache/specials.lisp index f4431ac..2006f37 100644 --- a/memcache/specials.lisp +++ b/memcache/specials.lisp @@ -123,7 +123,7 @@ limit-maxbytes mc-stats-limit-maxbytes Number of bytes thi (:documentation "This class represents an instance of the Memcached server")) -(defconstant* *membase17-stat-names* +(defconstant* +membase17-stat-names+ '("accepting_conns" "auth_cmds" "auth_errors" "bucket_active_conns" "bucket_conns" "bytes_read" "bytes_written" "cas_badval" "cas_hits" "cas_misses" "cmd_flush" "cmd_get" "cmd_set" "conn_yields" "connection_structures" "curr_connections" diff --git a/memstore.asd b/memstore.asd index 45de2ed..35d4571 100644 --- a/memstore.asd +++ b/memstore.asd @@ -16,11 +16,12 @@ :author "Kevin M. Rosenberg " :version "1.0" :licence "BSD" - :depends-on (memcache cl-store flexi-streams zlib) + :depends-on (memcache cl-store flexi-streams zlib salza2 chipz) :components ((:module src :serial t :components ((:file "package") + (:file "compress") (:file "memstore"))))) (defmethod operation-done-p ((o test-op) (c (eql (find-system :memstore)))) diff --git a/src/memstore.lisp b/src/memstore.lisp index 776c83d..2443a26 100644 --- a/src/memstore.lisp +++ b/src/memstore.lisp @@ -2,8 +2,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; FILE IDENTIFICATION ;; -;; Name: main.lisp -;; Purpose: memstore main functions +;; Name: memstore.lisp +;; Purpose: Memstore primary functions ;; Date Started: July 2011 ;; ;; Copyright (c) 2011 Kevin M. Rosenberg @@ -49,17 +49,22 @@ "Determines if compression is enabled.") (defvar *compression-threshold* 5000 "Minimum size of object before attempting compression.") -(defvar *debug* nil) -(defvar *realm* "ms:") -(defvar *encoding* (flex:make-external-format :utf-8)) +(defvar *debug* nil + "Controls output of debugging messages.") +(defvar *namespace* "ms:" + "String to prepend to keys for memcache. Default is 'ms:'.") +(defvar *encoding* (flex:make-external-format :utf-8) + "Character encoding to use with converting strings to octets.") (defun serialize-clstore (obj) + "Converts a Lisp object into a vector of octets using CL-STORE." (let ((s (make-in-memory-output-stream :element-type 'octet))) (cl-store:store obj s) (get-output-stream-sequence s))) (defun deserialize-clstore (data) + "Restores a Lisp object from a vector of octets using CL-STORE." (let ((s (make-in-memory-input-stream data))) (cl-store:restore s))) @@ -78,7 +83,7 @@ Catches error while using *print-readably*. Returns nil if unable to (declare (ignore pos)) obj)) -(defun serialize (obj &key (compression-enabled *compression-enabled*) +(defun ms-serialize (obj &key (compression-enabled *compression-enabled*) (compression-threshold *compression-threshold*)) "Converts a lisp object into a vector of octets. Returns a cons of (flags . data)." @@ -102,7 +107,7 @@ Returns a cons of (flags . data)." compression-enabled compression-threshold dlen)) (when (and compression-enabled compression-threshold (> dlen compression-threshold)) - (multiple-value-bind (compressed clen) (zlib:compress data :fixed) + (multiple-value-bind (compressed clen) (compress data) (when *debug* (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*)))) (when (< clen (* dlen (- 1 *compression-savings*))) @@ -112,12 +117,12 @@ Returns a cons of (flags . data)." (format t "flags:~D dlen:~D data:~S~%" flags (length data) data)) (cons flags data))) -(defun deserialize (ser) +(defun ms-deserialize (ser) "Converts a cons of storage flags and vector of octets into a lisp object." (let ((flags (car ser)) (data (cdr ser))) (when (plusp (logand flags +flag-zlib+)) - (setq data (zlib:uncompress data))) + (setq data (uncompress data))) (cond ((plusp (logand flags +flag-clstore+)) (deserialize-clstore data)) @@ -128,19 +133,21 @@ Returns a cons of (flags . data)." (defun make-key (key) - (concatenate 'string *realm* key)) + "Prepends the *namespace* to a key." + (concatenate 'string *namespace* key)) -(defun remove-realm (key) - (subseq key (length *realm*))) +(defun remove-namespace (key) + "Strips the current *namespace* from beginning of key." + (subseq key (length *namespace*))) -(defun mem-store (key obj &key (memcache *memcache*) (command :set) +(defun ms-store (key obj &key (memcache *memcache*) (command :set) (exptime 0) (use-pool *use-pool*) (compression-enabled *compression-enabled*) (compression-threshold *compression-threshold*)) "Stores an object in cl-memcached. Tries to print-readably object to a string for storage. If unable to do so, uses cl-store to serialize object. Optionally compresses value if meets compression criteria." - (let ((ser (serialize obj :compression-enabled compression-enabled + (let ((ser (ms-serialize obj :compression-enabled compression-enabled :compression-threshold compression-threshold))) (mc-store (make-key key) (cdr ser) :memcache memcache @@ -148,7 +155,8 @@ object. Optionally compresses value if meets compression criteria." :use-pool use-pool :flags (car ser)))) (defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*) - (command :get)) + (command :get)) + "Retrieves a list of objects from memcache from the keys in KEYS-LIST." (let ((items (mc-get (mapcar 'make-key keys-list) :memcache memcache @@ -160,13 +168,16 @@ object. Optionally compresses value if meets compression criteria." (data (third item))) (ecase command (:get - (list (remove-realm key) (deserialize (cons flags data)))) + (list (remove-namespace key) (ms-deserialize (cons flags data)))) (:gets - (list (remove-realm key) (deserialize (cons flags data)) (fourth item)))))) + (list (remove-namespace key) (ms-deserialize (cons flags data)) (fourth item)))))) items))) -(defun mem-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*) - (command :get)) +(defun ms-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*) + (command :get)) + "Lisp objects are restored by memcache server. A key, or list of keys, +is used to identify objects. Command is either :get or :gets. The latter +is used to get memcached's unique object number for storage with :cas." (let* ((multp (listp key-or-keys)) (keys (if multp key-or-keys (list key-or-keys))) (items (get-objects keys :memcache memcache :use-pool use-pool @@ -182,13 +193,16 @@ object. Optionally compresses value if meets compression criteria." (values (second item) t (third item))))) (values nil nil))))) -(defun mem-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0)) +(defun ms-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0)) + "Deletes a keyed object from memcache. Key is prepended with *namespace*." (mc-del (make-key key) :memcache memcache :use-pool use-pool :time time)) -(defun mem-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1)) +(defun ms-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1)) + "Increments a keyed integer object. Key is prepended with *namespace*." (mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta)) -(defun mem-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1)) +(defun ms-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1)) + "Decrements a keyed integer object. Key is prepended with *namespace*." (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta)) diff --git a/src/package.lisp b/src/package.lisp index d255c6b..6cef27a 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -23,9 +23,11 @@ #:*compression-threshold* #:*compression-enabled* #:*compression-savings* - #:*realm* - #:mem-store - #:mem-restore - #:mem-del - #:mem-incr - #:mem-decr)) + #:*namespace* + #:ms-serialize + #:ms-deserialize + #:ms-store + #:ms-restore + #:ms-del + #:ms-incr + #:ms-decr)) diff --git a/src/tests.lisp b/src/tests.lisp index a36cd72..d787734 100644 --- a/src/tests.lisp +++ b/src/tests.lisp @@ -15,19 +15,20 @@ (defpackage #:memstore-tests (:import-from #:rtest #:*compile-tests* #:*expected-failures*) (:use #:memstore #:cl #:rtest) - (:import-from #:memstore #:mem-store #:mem-restore #:mem-del - #:serialize #:deserialize + (:import-from #:memstore #:ms-store #:ms-restore #:ms-del + #:ms-serialize #:ms-deserialize #:serialize-clstore #:deserialize-clstore #:serialize-string #:deserialize-string #:+flag-wstring+ #:+flag-clstore+ - #:+flag-zlib+ #:*realm*) + #:+flag-zlib+ #:*namespace* + #:compress #:uncompress) (:import-from #:memcache #:*memcache* #:*use-pool* #:make-memcache-instance)) (in-package #:memstore-tests) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *test-cnt* 0) - (defvar *test-realm* "__mctest__:")) + (defvar *test-namespace* "__mctest__:")) (unless *memcache* (setq *memcache* (make-memcache-instance :name "Memcache test"))) @@ -41,7 +42,7 @@ (defmacro def-readably-value* (val) `(progn (deftest ,(intern (format nil "DS.~D" *test-cnt*) '#:keyword) - (let* ((ser (serialize (quote ,val))) + (let* ((ser (ms-serialize (quote ,val))) (flags (car ser))) (cond ((stringp (quote ,val)) @@ -52,7 +53,7 @@ (unless (and (plusp (logand flags +flag-wstring+)) (zerop (logand flags +flag-clstore+))) (error "Should be stored as wstring.")))) - (deserialize ser)) + (ms-deserialize ser)) ,val) (deftest ,(intern (format nil "RS.~D" *test-cnt*) '#:keyword) (deserialize-clstore (serialize-clstore (quote ,val))) @@ -61,11 +62,11 @@ (deserialize-string (serialize-string (quote ,val))) ,val) (deftest ,(intern (format nil "MC.~D" *test-cnt*) '#:keyword) - (let ((*realm* ,*test-realm*) + (let ((*namespace* ,*test-namespace*) (key (format nil "~D" ,*test-cnt*))) - (mem-store key (quote ,val)) - (multiple-value-bind (res found) (mem-restore key) - (mem-del key) + (ms-store key (quote ,val)) + (multiple-value-bind (res found) (ms-restore key) + (ms-del key) (values found (equalp res (quote ,val))))) t t) ,(incf *test-cnt*))) @@ -100,7 +101,7 @@ (let ((h (make-hash-table :test 'equal))) (setf (gethash "a" h) "A") (setf (gethash "b" h) "B") - (let ((ds (deserialize (serialize h)))) + (let ((ds (ms-deserialize (ms-serialize h)))) (list (hash-table-count ds) (gethash "a" ds) (gethash "b" ds)))) (2 "A" "B")) (deftest :ht.2 @@ -133,41 +134,70 @@ (defvar *long-string* (make-string 10000 :initial-element #\space)) (defvar *long-array* (make-array '(10000) :initial-element 0)) (deftest :l.1 - (let* ((ser (serialize *long-string*)) + (let* ((ser (ms-serialize *long-string*)) (data (cdr ser)) (flags (car ser))) (values (< (length data) (length *long-string*)) (eql (logand flags +flag-zlib+) +flag-zlib+) (zerop (logand flags +flag-wstring+)) (zerop (logand flags +flag-clstore+)) - (string-equal *long-string* (deserialize ser)))) + (string-equal *long-string* (ms-deserialize ser)))) t t t t t) (deftest :l.2 - (let* ((ser (serialize *long-array*)) + (let* ((ser (ms-serialize *long-array*)) (data (cdr ser)) (flags (car ser))) (values (< (length data) (length *long-array*)) (eql (logand flags +flag-zlib+) +flag-zlib+) (eql (logand flags +flag-wstring+) +flag-wstring+) (zerop (logand flags +flag-clstore+)) - (equalp *long-array* (deserialize ser)))) + (equalp *long-array* (ms-deserialize ser)))) t t t t t) (deftest :incr.1 - (let ((*realm* *test-realm*)) + (let ((*namespace* *test-namespace*)) (values - (mem-store "i" 0) - (mem-restore "i") - (mem-incr "i") - (mem-incr "i" :delta 5) - (mem-incr "i" :delta 3) - (mem-decr "i" :delta 2) - (mem-decr "i") - (mem-del "i"))) + (ms-store "i" 0) + (ms-restore "i") + (ms-incr "i") + (ms-incr "i" :delta 5) + (ms-incr "i" :delta 3) + (ms-decr "i" :delta 2) + (ms-decr "i") + (ms-del "i"))) "STORED" 0 1 6 9 7 6 "DELETED") (deftest :nf.1 - (let ((*realm* *test-realm*)) - (mem-restore "a")) + (let ((*namespace* *test-namespace*)) + (ms-restore "a")) nil nil) + +(defmacro def-compress-test (length id) + (let ((len (gensym "LENGTH-"))) + `(deftest ,(intern (format nil "Z.~D" id) + (find-package '#:keyword)) + (block z + (let* ((,len ,length) + (a (make-array (list ,len) :element-type '(unsigned-byte 8)))) + (dotimes (j ,len) + (setf (aref a j) (random 256))) + (let* ((comp (compress a)) + (uncomp (uncompress comp))) + (unless (equalp a uncomp) + (throw 'z :error))))) + nil))) + +(def-compress-test (random 10000) 0) +(def-compress-test (random 10000) 1) +(def-compress-test (random 10000) 2) +(def-compress-test (random 10000) 3) +(def-compress-test (random 10000) 4) +(def-compress-test (random 10000) 5) +(def-compress-test (random 10000) 6) +(def-compress-test (random 10000) 7) +(def-compress-test (random 10000) 8) +(def-compress-test (random 10000) 9) +(def-compress-test (random 10000) 10) + + -- 2.34.1