Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2 Modified Files: lisppaste.lisp package.lisp xml-paste.lisp Log Message: restructure xml-rpc interface Date: Tue Apr 27 17:03:21 2004 Author: bmastenbrook Index: lisppaste2/lisppaste.lisp diff -u lisppaste2/lisppaste.lisp:1.14 lisppaste2/lisppaste.lisp:1.15 --- lisppaste2/lisppaste.lisp:1.14 Mon Apr 26 12:46:55 2004 +++ lisppaste2/lisppaste.lisp Tue Apr 27 17:03:21 2004 @@ -1,4 +1,4 @@ -;;;; $Id: lisppaste.lisp,v 1.14 2004/04/26 16:46:55 bmastenbrook Exp $ +;;;; $Id: lisppaste.lisp,v 1.15 2004/04/27 21:03:21 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/lisppaste.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -63,3 +63,9 @@ (push ,paste-name ,paste-list)) `(push ,paste-name ,paste-list)) (serialize-transaction "pastes.lisp-expr" ,paste-name (if ,annotate ,real-number))))) + +(defun shut-up () + (setf (irc:client-stream *connection*) (make-broadcast-stream))) + +(defun un-shut-up () + (setf (irc:client-stream *connection*) *trace-output*)) \ No newline at end of file Index: lisppaste2/package.lisp diff -u lisppaste2/package.lisp:1.2 lisppaste2/package.lisp:1.3 --- lisppaste2/package.lisp:1.2 Tue Feb 3 21:41:12 2004 +++ lisppaste2/package.lisp Tue Apr 27 17:03:21 2004 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.2 2004/02/04 02:41:12 bmastenbrook Exp $ +;;;; $Id: package.lisp,v 1.3 2004/04/27 21:03:21 bmastenbrook Exp $ ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -8,6 +8,6 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :lisppaste (:use :cl :sb-bsd-sockets) - (:export :start-lisppaste))) + (:export :start-lisppaste :join-new-channel :shut-up :un-shut-up))) Index: lisppaste2/xml-paste.lisp diff -u lisppaste2/xml-paste.lisp:1.2 lisppaste2/xml-paste.lisp:1.3 --- lisppaste2/xml-paste.lisp:1.2 Sun Mar 7 01:39:56 2004 +++ lisppaste2/xml-paste.lisp Tue Apr 27 17:03:21 2004 @@ -1,5 +1,16 @@ (in-package :lisppaste) +(defun paste-xml-list (paste &optional contents) + (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) + (paste-channel paste) + (paste-title paste) + (length (paste-annotations paste)) + (if contents + (list (paste-contents paste))))) + (setf xml-rpc:*xml-rpc-call-hook* (lambda (method-name &rest args) (block hook @@ -40,24 +51,38 @@ :channel paste-channel) (format nil "Your paste has been announced to ~A and is available at ~A ." paste-channel url)))))))) - ((string-equal method-name "pasteheaders") + ((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)))) + ((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 #'(lambda (paste) - (list (paste-number paste) - (xml-rpc:xml-rpc-time (paste-universal-time paste)) - (paste-user paste) - (paste-channel paste) - (paste-title paste) - (length (paste-annotations paste)))) - (if args (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - *pastes*)))) - ((string-equal method-name "pastecontents") + (mapcar #'paste-xml-list + (if args + (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) + *pastes*)))) + ((string-equal method-name "pastedetails") (if (eql (length args) 1) - (paste-contents (find (car args) *pastes* :key #'paste-number :test #'eql)) - (if (eql (length args) 2) - (paste-contents - (find (second args) - (paste-annotations (find (car args) *pastes* :key #'paste-number :test #'eql)) - :key #'paste-number :test #'eql)) - "Error: Invalid number of arguments."))) + (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."))) (t (format nil "Error: unimplemented method ~S." method-name)))))))