Update of /project/cl-xmpp/cvsroot/cl-xmpp In directory common-lisp.net:/tmp/cvs-serv29674

Modified Files: README cl-xmpp.lisp result.lisp utility.lisp Added Files: CREDITS Log Message: cleaning up the handling code

Date: Mon Oct 31 18:02:04 2005 Author: eenge

Index: cl-xmpp/README diff -u cl-xmpp/README:1.1.1.1 cl-xmpp/README:1.2 --- cl-xmpp/README:1.1.1.1 Fri Oct 28 15:16:02 2005 +++ cl-xmpp/README Mon Oct 31 18:02:03 2005 @@ -1,27 +1,44 @@ -This is a Common Lisp implementation of the XMPP RFCs. The -implementation is currently very immature and comments are -solicited. +This is a Common Lisp implementation of the XMPP RFCs. Please +see http://common-lisp.net/project/cl-xmpp for more information.

-Non-normative example: +Example:

-* (defparameter *c* (xmpp:connect :hostname "my-xmpp-server")) -#<CONNECTION open> + * (require :cl-xmpp)

-* (xmpp:begin-xml-stream *c*) -... output ... + * (defvar connection (xmpp:connect :hostname "jabber.org"))

-* (xmpp:auth *c* "username" "password" "resource") -... output ... +;; initiate XML stream with server + * (xmpp:begin-xml-stream connection)

-* (xmpp:receive-stanzas *c*) -... output ... +;; authenticate (or use xmpp:register to make an account) + * (xmpp:auth connection "username" "password" "resource")

-* (xmpp:message *c* "username" "message") -... output ... +;; let the server know you want to receive/send presence information +;; (this makes you "come online" if others have a subscription with you + * (xmpp:presence connection)

-; let's assume a user replies to you -* (xmpp:receive-stanzas *c*) -(#<MESSAGE>) +;; send someone a message + * (xmpp:message connection "username@hostname" "what's going on?") + +;; then sit back and watch the messages roll in: + * (xmpp:receive-stanza-loop connection) +<MESSAGE from=username@hostname to=me@myserver> +[....] + +;; That's it. Interrupt the loop to issue other commands, eg: + * (xmpp:get-roster connection) + +;; or any of the other ones you may find by looking through cl-xmpp.lisp +;; and package.lisp to see which ones are exported. + +;; If you wish to handle the incoming messages or other objects simply +;; specify an xmpp:handle method for the objects you are interested in +;; or (defmethod xmpp:handle (object) ...) to get them all. Or alternatively +;; specify :dom-repr t to receive-stanza-loop to get DOM-ish objects. + +;; For example, if you wanted to create an annoying reply bot: + + * (defmethod xmpp:handle ((connection xmpp:connection) (message xmpp:message)) + (xmpp:message connection (xmpp:from message) + (format nil "reply to: ~a~%" (xmpp:message object))))

-And so on and so forth. Check cl-xmpp.lisp and package.lisp for -symbols which are exported and might be of use. \ No newline at end of file

Index: cl-xmpp/cl-xmpp.lisp diff -u cl-xmpp/cl-xmpp.lisp:1.5 cl-xmpp/cl-xmpp.lisp:1.6 --- cl-xmpp/cl-xmpp.lisp:1.5 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/cl-xmpp.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cl-xmpp.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ +;;;; $Id: cl-xmpp.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -64,7 +64,8 @@ :socket socket :hostname hostname :port port)) - #+lispworks (let ((socket (comm:open-tcp-stream hostname port :element-type '(unsigned-byte 8)))) + #+lispworks (let ((socket (comm:open-tcp-stream hostname port + :element-type '(unsigned-byte 8)))) (make-instance 'connection :server-stream socket :socket socket @@ -101,14 +102,14 @@ (cond ((equal tagname "stream:stream") (when init-callback - (funcall init-callback stanza :dom-repr dom-repr))) + (funcall init-callback stanza connection :dom-repr dom-repr))) ((equal tagname "stream:error") (when stanza-callback - (funcall stanza-callback stanza :dom-repr dom-repr)) + (funcall stanza-callback stanza connection :dom-repr dom-repr)) (error "Received error.")) (t (when stanza-callback - (funcall stanza-callback stanza :dom-repr dom-repr))))))) + (funcall stanza-callback stanza connection :dom-repr dom-repr)))))))

(defun read-stanza (connection) (unless (server-xstream connection) @@ -245,8 +246,6 @@ (cxml:with-element "body" (cxml:text body)))) connection)

-;;; XXX: this one doesn't seem to work with Jabberd 1.4 -;;; (not insinuating that I've tested it with anything else). (defmethod bind ((connection connection) jid resource) (with-iq (connection :id "bind_2" :type "set") (cxml:with-element "bind" @@ -277,7 +276,7 @@ (defmethod get-roster ((connection connection)) (with-iq-query (connection :id "roster_1" :xmlns "jabber:iq:roster")))

-;;; XXX: Adding and removing from the roster is not the same as +;;; Note: Adding and removing from the roster is not the same as ;;; adding and removing subscriptions. I have not yet decided ;;; if the library should provide convenience methods for doing ;;; both actions at once.

Index: cl-xmpp/result.lisp diff -u cl-xmpp/result.lisp:1.5 cl-xmpp/result.lisp:1.6 --- cl-xmpp/result.lisp:1.5 Sat Oct 29 19:25:04 2005 +++ cl-xmpp/result.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: result.lisp,v 1.5 2005/10/29 17:25:04 eenge Exp $ +;;;; $Id: result.lisp,v 1.6 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -257,6 +257,10 @@ (items roster)))) roster))

+;; +;; Discovery +;; + (defclass identity- (event) ((category :accessor category @@ -275,8 +279,6 @@ :type- (value (get-attribute object :type-)) :name (value (get-attribute object :name))))

-;;; XXX: must think about this for another few days and then I will -;;; decide how to represent the disco#info and disco#items data. (defclass disco (event) ((identities :accessor identities @@ -371,46 +373,22 @@ (class (map-error-type-to-class type))) (make-instance class :code code :name name :xml-element object)))

-;;; XXX: this is a mess with all the IFs... fix. (defmethod xml-element-to-event ((object xml-element) (name (eql :iq))) (let ((id (intern (string-upcase (value (get-attribute object :id))) :keyword))) - (case id - (:roster_1 (make-roster object)) - (:reg2 (if (string-equal (value (get-attribute object :type)) "result") - :registration-successful - (make-error (get-element object :error)))) - (:unreg_1 (if (string-equal (value (get-attribute object :type)) "result") - :registration-cancellation-successful - (make-error (get-element object :error)))) - (:change1 (if (string-equal (value (get-attribute object :type)) "result") - :password-changed-succesfully - (make-error (get-element object :error)))) - (:error (make-error (get-element object :error))) - (:auth2 (if (string-equal (value (get-attribute object :type)) "result") - :authentication-successful - (make-error (get-element object :error)))) - (:info1 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:info2 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:info3 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-info (get-element object :query)) - (make-error (get-element object :error)))) - (:items1 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items2 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items3 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (:items4 (if (string-equal (value (get-attribute object :type)) "result") - (make-disco-items (get-element object :query)) - (make-error (get-element object :error)))) - (t object)))) + (if (not (string-equal (value (get-attribute object :type)) "result")) + (make-error (get-element object :error)) + (case id + (:error (make-error (get-element object :error))) + (:roster_1 (make-roster object)) + (:reg2 :registration-successful) + (:unreg_1 :registration-cancellation-successful) + (:change1 :password-changed-succesfully) + (:auth2 :authentication-successful) + (t (cond + ((member id '(info1 info2 info3)) + (make-disco-info (get-element object :query))) + ((member id '(items1 items2 items3 items4)) + (make-disco-items (get-element object :query)))))))))

(defmethod xml-element-to-event ((object xml-element) (name (eql :error))) (make-error object)) @@ -433,8 +411,9 @@ ;; Handle ;;

-(defmethod handle ((object list)) - (mapc #'handle object)) +(defmethod handle ((connection connection) (object list)) + (dolist (object list) + (handle connection object)))

-(defmethod handle (object) +(defmethod handle ((connection connection) object) (format t "~&Received: ~a~%" object))

Index: cl-xmpp/utility.lisp diff -u cl-xmpp/utility.lisp:1.3 cl-xmpp/utility.lisp:1.4 --- cl-xmpp/utility.lisp:1.3 Sat Oct 29 05:58:04 2005 +++ cl-xmpp/utility.lisp Mon Oct 31 18:02:04 2005 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.3 2005/10/29 03:58:04 eenge Exp $ +;;;; $Id: utility.lisp,v 1.4 2005/10/31 17:02:04 eenge Exp $ ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/utility.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -18,18 +18,18 @@ (setf (aref array position) (char-code (aref string position)))) array))

-(defun default-stanza-callback (stanza &key dom-repr) +(defun default-stanza-callback (stanza connection &key dom-repr) (let ((result (parse-result stanza))) (if dom-repr - (handle result) - (handle (dom-to-event result))))) + (handle connection result) + (handle connection (dom-to-event result)))))

;; um, refactor? -(defun default-init-callback (stanza &key dom-repr) +(defun default-init-callback (stanza connection &key dom-repr) (let ((result (parse-result stanza))) (if dom-repr - (handle result) - (handle (dom-to-event result))))) + (handle connection result) + (handle connection (dom-to-event result)))))

(defmacro fmt (string &rest args) `(format nil ,string ,@args))