X-Git-Url: http://git.kpe.io/?p=memstore.git;a=blobdiff_plain;f=memcache%2Fmemcache.lisp;h=c5593cbc7ee712a69529275104b20544a7ea4aa2;hp=1b8a24469b8318286232ff02198078033b89571b;hb=b863ee040d4f399abb087df7304eafb0d5da4d1a;hpb=7dd62ee1de6fc014941ae83d7e09bac2f44b6a5b 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)