Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: xml-paste.lisp persistent-pastes.lisp Log Message: Remove evil ^Ms Date: Tue Apr 27 17:47:33 2004 Author: bmastenbrook Index: lisppaste2/xml-paste.lisp diff -u lisppaste2/xml-paste.lisp:1.3 lisppaste2/xml-paste.lisp:1.4 --- lisppaste2/xml-paste.lisp:1.3 Tue Apr 27 17:03:21 2004 +++ lisppaste2/xml-paste.lisp Tue Apr 27 17:47:32 2004 @@ -1,7 +1,7 @@ (in-package :lisppaste) (defun paste-xml-list (paste &optional contents) - (format t "collecting paste number ~A~%" (paste-number paste)) +; (format t "collecting paste number ~A~%" (paste-number paste)) (list* (paste-number paste) (xml-rpc:xml-rpc-time (paste-universal-time paste)) (paste-user paste) @@ -9,10 +9,11 @@ (paste-title paste) (length (paste-annotations paste)) (if contents - (list (paste-contents paste))))) + (list (remove #\return (paste-contents paste)))))) (setf xml-rpc:*xml-rpc-call-hook* (lambda (method-name &rest args) + (format t "Handling XML-RPC request for ~S ~{~S~^ ~}~%" method-name args) (block hook (handler-bind ((condition #'(lambda (c) (return-from hook @@ -24,7 +25,8 @@ "Error: all arguments must be strings." (if (not (every (lambda (s) (> (length s) 0)) (list paste-channel paste-user paste-title paste-contents))) "Error: all arguments must be non-empty strings." - (let ((annotate-this (if annotate (find annotate *pastes* :key #'paste-number)))) + (let ((annotate-this (if annotate (find annotate *pastes* :key #'paste-number))) + (paste-contents (remove #\return paste-contents))) (if (if annotate (not (string-equal paste-channel (paste-channel annotate-this))) (not (member paste-channel *channels* :test #'string-equal))) @@ -53,36 +55,34 @@ paste-channel url)))))))) ((string-equal method-name "pasteheaders") (destructuring-bind - (length &optional (start (paste-number (car *pastes*)))) args - (format t "args is ~A~%" args) - (mapcar #'paste-xml-list - (loop for i from 1 to length - for j in (member start *pastes* :key #'paste-number) - collect j)))) + (length &optional supplied-start) args + (let ((start (or supplied-start (paste-number (car *pastes*))))) + (mapcar #'paste-xml-list + (loop for i from 1 to length + for j in (member start *pastes* :key #'paste-number) + collect j))))) ((string-equal method-name "pasteheadersbychannel") (destructuring-bind (channel length &optional supplied-start) args (let* ((*pastes* (remove channel *pastes* :test-not #'string-equal :key #'paste-channel)) (start (or supplied-start (paste-number (car *pastes*))))) - (format t "args is ~A~%" args) (mapcar #'paste-xml-list (loop for i from 1 to length for j in (member start *pastes* :key #'paste-number) collect j))))) ((string-equal method-name "pasteannotationheaders") - (format t "args is ~A~%" args) (nreverse (mapcar #'paste-xml-list - (if args - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - *pastes*)))) + (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql))))) ((string-equal method-name "pastedetails") - (if (eql (length args) 1) - (paste-xml-list (find (car args) *pastes* :key #'paste-number :test #'eql) t) - (if (eql (length args) 2) - (paste-xml-list - (find (second args) - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - :key #'paste-number :test #'eql) t) - "Error: Invalid number of arguments."))) + (destructuring-bind + (paste &optional annotation) args + (if (not annotation) + (paste-xml-list (find paste *pastes* :key #'paste-number :test #'eql) t) + (paste-xml-list + (find annotation + (paste-annotations (find paste *pastes* :key #'paste-number :test #'eql)) + :key #'paste-number :test #'eql) t)))) + ((string-equal method-name "listchannels") + *channels*) (t (format nil "Error: unimplemented method ~S." method-name))))))) Index: lisppaste2/persistent-pastes.lisp diff -u lisppaste2/persistent-pastes.lisp:1.7 lisppaste2/persistent-pastes.lisp:1.8 --- lisppaste2/persistent-pastes.lisp:1.7 Sun Mar 7 13:16:27 2004 +++ lisppaste2/persistent-pastes.lisp Tue Apr 27 17:47:32 2004 @@ -48,7 +48,7 @@ (make-paste :number number :user user :title title - :contents contents + :contents (remove #\return contents) :universal-time universal-time :channel channel :annotations nil)))