[Lisppaste-cvs] CVS update: lisppaste2/lisppaste.lisp lisppaste2/package.lisp lisppaste2/xml-paste.lisp

[Brian Mastenbrook]

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)))))))