From e60185223a83c93fabb33b749e042d2be1ab5cbd Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sat, 14 Jan 2012 14:08:21 -0500 Subject: [PATCH] Support processed results from bulk object deletion. --- interface.lisp | 36 ++++++++++++++++++++++------ xml-binding.lisp | 73 ++++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 76 insertions(+), 33 deletions(-) diff --git a/interface.lisp b/interface.lisp index 062c60d..59f2ed2 100644 --- a/interface.lisp +++ b/interface.lisp @@ -467,17 +467,39 @@ constraint." (cxml:with-element "Key" (cxml:text key))))))) +(defparameter *delete-objects-binder* + (make-binder '("DeleteResult" + (sequence :results + (alternate + ("Deleted" + ("Key" (bind :deleted-key))) + ("Error" + ("Key" (bind :error-key)) + ("Code" (bind :error-code)) + ("Message" (bind :error-message)))))))) + (defun delete-objects (bucket keys &key ((:credentials *credentials*) *credentials*)) - "Delete the objects in BUCKET identified by KEYS." + "Delete the objects in BUCKET identified by the sequence KEYS." + (unless (<= (length keys) 1000) + (error "Can only delete 1000 objects per request.")) (let* ((content (bulk-delete-document keys)) (md5 (vector-md5/b64 content))) - (submit-request (make-instance 'request - :method :post - :sub-resource "delete" - :bucket bucket - :content content - :content-md5 md5)))) + (let* ((response + (submit-request (make-instance 'request + :method :post + :sub-resource "delete" + :bucket bucket + :content content + :content-md5 md5))) + (bindings (xml-bind *delete-objects-binder* (body response))) + (results (bvalue :results bindings)) + (deleted 0) + (failed '())) + (dolist (result results (values deleted failed)) + (if (bvalue :deleted-key result) + (incf deleted) + (push result failed)))))) (defun delete-all-objects (bucket &key ((:credentials *credentials*) *credentials*)) diff --git a/xml-binding.lisp b/xml-binding.lisp index 8767e07..919b746 100644 --- a/xml-binding.lisp +++ b/xml-binding.lisp @@ -164,25 +164,31 @@ effectively ending matching." (declare (ignore source k)) (nreverse bindings))) +(defmacro catching-xml-errors (&body body) + `(handler-case + (progn ,@body) + (xml-binding-error (c) + (values nil c)))) + (defun create-sequence-binder (key forms kk) "Return a function that creates a list of sub-bindings based on a sub-matcher, with KEY as the key." - (let ((binder (create-binder forms (create-bindings-returner))) - (element-name (first forms))) + (let ((binder (create-binder forms (create-bindings-returner)))) (lambda (source bindings k) (let ((sub-bindings '())) (loop - (skip-characters source) - (multiple-value-bind (type uri lname) - (klacks:peek source) - (declare (ignore uri)) - (unless (and (eql type :start-element) - (string= lname element-name)) - (return (funcall kk source (acons key - (nreverse sub-bindings) - bindings) - k)))) - (push (funcall binder source nil k) sub-bindings)))))) + (skip-characters source) + (multiple-value-bind (sub-binding failure) + (catching-xml-errors + (funcall binder source nil k)) + (if failure + (return (funcall kk + source + (acons key + (nreverse sub-bindings) + bindings) + k)) + (push sub-binding sub-bindings)))))))) (defun create-alist-binder (key kk) "Return a function that returns the rest of SOURCE as an alist of @@ -193,26 +199,32 @@ element-name/element-content data." k))) (defun create-optional-binder (subforms kk) - (let ((binder (create-binder subforms kk)) - (element-name (first subforms))) + (let ((binder (create-binder subforms kk))) (lambda (source bindings k) (skip-characters source) - (multiple-value-bind (type uri lname) - (klacks:peek source) - (declare (ignore uri)) - (cond ((and (eql type :start-element) - (string= element-name lname)) - (funcall binder - source - bindings - k)) - (t (funcall kk source bindings k))))))) - + (multiple-value-bind (optional-bindings failure) + (catching-xml-errors (funcall binder source bindings k)) + (if failure + (funcall kk source bindings k) + optional-bindings))))) + +(defun create-alternate-binder (subforms kk) + (let ((binders (mapcar (lambda (form) (create-binder form kk)) subforms))) + (lambda (source bindings k) + ;; FIXME: This xml-binding-error needs :expected and :action + ;; ooptions. Can get actual with peeking and expected by getting + ;; the cl:cars of subforms...maybe. + (dolist (binder binders (error 'xml-binding-error)) + (multiple-value-bind (alt-bindings failure) + (catching-xml-errors (funcall binder source bindings k)) + (unless failure + (return alt-bindings))))))) (defun create-special-processor (operator form k) "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE, etc." (ecase operator + (alternate (create-alternate-binder (rest form) k)) (bind (create-bindings-extender (second form) k)) (optional (create-optional-binder (second form) k)) (skip-rest (create-skipper *current-element-name* k)) @@ -258,6 +270,15 @@ process an XML source." (defun xml-bind (binder source) (funcall binder source)) +(defun try-to-xml-bind (binder source) + "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors + are caught, NIL is the primary value and the error object is the + secondary value." + (handler-case + (xml-bind binder source) + (xml-binding-error (c) + (values nil c)))) + (defun xml-document-element (source) (nth-value 2 (klacks:find-event (xml-source source) :start-element))) -- 2.11.4.GIT