[cl-xmpp-cvs] CVS update: cl-xmpp/CREDITS cl-xmpp/README cl-xmpp/cl-xmpp.lisp cl-xmpp/result.lisp cl-xmpp/utility.lisp
Erik Enge
eenge at common-lisp.net
Mon Oct 31 17:02:06 UTC 2005
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 at hostname" "what's going on?")
+
+;; then sit back and watch the messages roll in:
+ * (xmpp:receive-stanza-loop connection)
+<MESSAGE from=username at hostname to=me at 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 , at args))
More information about the Cl-xmpp-cvs
mailing list