[cl-xmpp-cvs] CVS update: cl-xmpp/cl-xmpp.lisp cl-xmpp/cxml.lisp cl-xmpp/result.lisp
Erik Enge
eenge at common-lisp.net
Sat Dec 31 20:15:08 UTC 2005
Update of /project/cl-xmpp/cvsroot/cl-xmpp
In directory common-lisp.net:/tmp/cvs-serv23722
Modified Files:
cl-xmpp.lisp cxml.lisp result.lisp
Log Message:
Applying patches from
David Lichteblau
Adam Thorsen
Julian Stecklina
Date: Sat Dec 31 21:15:06 2005
Author: eenge
Index: cl-xmpp/cl-xmpp.lisp
diff -u cl-xmpp/cl-xmpp.lisp:1.23 cl-xmpp/cl-xmpp.lisp:1.24
--- cl-xmpp/cl-xmpp.lisp:1.23 Mon Nov 21 19:58:03 2005
+++ cl-xmpp/cl-xmpp.lisp Sat Dec 31 21:15:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cl-xmpp.lisp,v 1.23 2005/11/21 18:58:03 eenge Exp $
+;;;; $Id: cl-xmpp.lisp,v 1.24 2005/12/31 20:15:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -66,7 +66,8 @@
;;; or begin-xml-stream you must update that value in cl-xmpp-tls.lisp's
;;; connect-tls to be the same.
(defun connect (&key (hostname *default-hostname*) (port *default-port*)
- (receive-stanzas t) (begin-xml-stream t) jid-domain-part)
+ (receive-stanzas t) (begin-xml-stream t) jid-domain-part
+ (class 'connection))
"Open TCP connection to hostname.
By default this will set up the complete XML stream and receive the initial
@@ -85,7 +86,7 @@
after you've connected."
(let* ((stream (trivial-sockets:open-stream
hostname port :element-type '(unsigned-byte 8)))
- (connection (make-instance 'connection
+ (connection (make-instance class
:jid-domain-part jid-domain-part
:server-stream stream
:hostname hostname
@@ -158,14 +159,14 @@
(defmethod parse-result ((connection connection) (objects list))
(map 'list #'(lambda (x) (parse-result connection x)) objects))
-(defmethod parse-result ((connection connection) (document dom-impl::document))
+(defmethod parse-result ((connection connection) (document cxml-dom::document))
(let (objects)
(dom:map-node-list #'(lambda (node)
(push (parse-result connection node) objects))
(dom:child-nodes document))
objects))
-(defmethod parse-result ((connection connection) (attribute dom-impl::attribute))
+(defmethod parse-result ((connection connection) (attribute cxml-dom::attribute))
(let* ((name (ensure-keyword (dom:node-name attribute)))
(value (dom:value attribute))
(xml-attribute
@@ -173,41 +174,49 @@
:name name :value value :node attribute)))
xml-attribute))
-(defmethod parse-result ((connection connection) (node dom-impl::character-data))
+(defmethod parse-result ((connection connection) (node cxml-dom::character-data))
(let* ((name (ensure-keyword (dom:node-name node)))
(data (dom:data node))
(xml-element (make-instance 'xml-element
:name name :data data :node node)))
xml-element))
-(defmethod parse-result ((connection connection) (node dom-impl::node))
+(defmethod parse-result ((connection connection) (node cxml-dom::node))
(let* ((name (ensure-keyword (dom:node-name node)))
(xml-element (make-instance 'xml-element :name name :node node)))
- (dom:do-node-list (attribute (dom:attributes node))
- (push (parse-result connection attribute) (attributes xml-element)))
(dom:do-node-list (child (dom:child-nodes node))
(push (parse-result connection child) (elements xml-element)))
xml-element))
+(defmethod parse-result ((connection connection) (node cxml-dom::element))
+ (let ((xml-element (call-next-method)))
+ (dom:do-node-map (attribute (dom:attributes node))
+ (push (parse-result connection attribute) (attributes xml-element)))
+ xml-element))
(defmethod xml-element-to-event ((connection connection) (object xml-element) (name (eql :iq)))
- (let ((id (ensure-keyword (value (get-attribute object :id)))))
- (if (not (eq (ensure-keyword (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)
- (:bind_2 :bind-successful)
- (:session_1 :session-initiated)
- (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)))))))))
+ (let ((id (ensure-keyword (value (get-attribute object :id))))
+ (type (ensure-keyword (value (get-attribute object :type)))))
+ (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-successfully)
+ (:auth2 :authentication-successful)
+ (:bind_2 :bind-successful)
+ (:session_1 :session-initiated)
+ (t
+ (case type
+ (:get (warn "Don't know how to handle IQ get yet."))
+ (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)))
+ (t ;; Assuming an error
+ (make-error (get-element object :error))))))))))
(defmethod xml-element-to-event ((connection connection)
(object xml-element) (name (eql :error)))
@@ -270,6 +279,8 @@
:xml-element object
:from (value (get-attribute object :from))
:to (value (get-attribute object :to))
+ :id (value (get-attribute object :id))
+ :type (value (get-attribute object :type))
:body (data (get-element (get-element object :body) :\#text))))
;;
@@ -305,13 +316,13 @@
(defun read-stanza (connection)
(unless (server-xstream connection)
(setf (server-xstream connection)
- (cxml:make-xstream (server-stream connection))))
+ (cxml:make-xstream (make-slow-stream (server-stream connection)))))
(force-output (server-stream connection))
(catch 'stanza
- (let ((cxml::*default-namespace-bindings*
- (acons "stream"
- "http://etherx.jabber.org/streams"
- cxml::*default-namespace-bindings*)))
+ (let ((cxml::*namespace-bindings*
+ (acons #"stream"
+ #"http://etherx.jabber.org/streams"
+ cxml::*namespace-bindings*)))
(cxml::parse-xstream (server-xstream connection)
(make-instance 'stanza-handler))
(runes::write-xstream-buffer (server-xstream connection)))))
@@ -378,7 +389,7 @@
(defmacro with-iq-query ((connection &key xmlns id to node (type "get")) &body body)
"Macro to make it easier to write QUERYs."
- `(with-iq (connection :id ,id :type ,type :to ,to)
+ `(with-iq (,connection :id ,id :type ,type :to ,to)
(cxml:with-element "query"
(cxml:attribute "xmlns" ,xmlns)
(when ,node
@@ -476,10 +487,12 @@
(when to
(cxml:attribute "to" to)))))
-(defmethod message ((connection connection) to body)
+(defmethod message ((connection connection) to body &key id (type :chat))
(with-xml-output (connection)
(cxml:with-element "message"
(cxml:attribute "to" to)
+ (when id (cxml:attribute "id" id))
+ (when type (cxml:attribute "type" (string-downcase (string type))))
(cxml:with-element "body" (cxml:text body)))))
(defmethod bind ((connection connection) resource)
Index: cl-xmpp/cxml.lisp
diff -u cl-xmpp/cxml.lisp:1.9 cl-xmpp/cxml.lisp:1.10
--- cl-xmpp/cxml.lisp:1.9 Sat Nov 19 00:14:35 2005
+++ cl-xmpp/cxml.lisp Sat Dec 31 21:15:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: cxml.lisp,v 1.9 2005/11/18 23:14:35 eenge Exp $
+;;;; $Id: cxml.lisp,v 1.10 2005/12/31 20:15:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -11,7 +11,7 @@
:accessor depth)))
(defun start-sax-document (handler)
- (let ((dom-builder (dom:make-dom-builder)))
+ (let ((dom-builder (cxml-dom:make-dom-builder)))
(setf (cxml:proxy-chained-handler handler) dom-builder)
(sax:start-document dom-builder)
dom-builder))
@@ -22,7 +22,7 @@
(if (eq :stream\:stream (ensure-keyword qname))
;; Create an element for DOM-TO-EVENT so we don't have to have
;; any specialized code just to handle stream:stream.
- (let* ((document (dom:create-document))
+ (let* ((document (cxml-dom:create-document))
(element (dom:create-element document qname)))
(dom:append-child document element)
(dolist (attribute attrs)
@@ -45,37 +45,26 @@
(call-next-method)
(when (eql (depth handler) 0)
(throw 'stanza
- (dom-impl::document (cxml:proxy-chained-handler handler)))))
+ (cxml-dom::document (cxml:proxy-chained-handler handler)))))
-;;; The default implementation of this function in CXML does not
-;;; check whether or not the nodelist is NIL and dom:length et al
-;;; assumes it will be a vector. This will result in problems
-;;; because I wanted to use this with return value of DOM:ATTRIBUTES
-;;; which may be NIL. David Lichteblau said a specialized map
-;;; function for namednodelists (which is what the return value of
-;;; DOM:ATTRIBUTES) is could be added he just hadn't needed one
-;;; yet. So, if you want to you can write one and send him a
-;;; patch.
-(defun dom:map-node-list (fn nodelist)
- (when nodelist
- (dotimes (i (dom:length nodelist))
- (funcall fn (dom:item nodelist i)))))
-
-;;; XXX: because of READ-SEQUENCE's blocking on the stream
-;;; (in RUNES::READ-OCTETS) we do not call SET-TO-FULL-SPEED
-;;; so that we avoid the CXML buffering layer. I think perhaps
-;;; this would work if READ-N-BYTES worked properly but I
-;;; don't really know at this point.
-;;;
-;;; Should probably email the SBCL list about this.
-(defun cxml::set-full-speed (input)
- (declare (ignore input))
- nil)
+;;; Perform single-byte reads to avoid blocking on the socket.
+(defstruct (slow-stream (:constructor make-slow-stream (target)))
+ (target nil :type stream))
+
+(defmethod runes::figure-encoding ((stream slow-stream))
+ (runes::figure-encoding (slow-stream-target stream)))
+
+(defmethod runes::read-octets (seq (stream slow-stream) start end)
+ (when (< start end)
+ (let ((byte (read-byte (slow-stream-target stream) nil)))
+ (when byte
+ (setf (elt seq start) byte)
+ (incf start))))
+ start)
;; I'd like to see what CXML is reading from the stream
;; and this code helps us in that regard by printing it
;; to the *debug-stream*
-
(defun runes::write-xstream-buffer (xstream &optional (stream *debug-stream*))
(when stream
(write-string (map 'string
@@ -86,49 +75,5 @@
stream)
(force-output stream)))
-(defun runes::xstream-underflow (input)
- (declare (type runes::xstream input))
- ;; we are about to fill new data into the buffer, so we need to
- ;; adjust buffer-start.
- (runes::write-xstream-buffer input)
- (incf (runes::xstream-buffer-start input)
- (- (runes::xstream-fill-ptr input) 0))
- (let (n m)
- ;; when there is something left in the os-buffer, we move it to
- ;; the start of the buffer.
- (setf m (- (runes::xstream-os-left-end input) (runes::xstream-os-left-start input)))
- (unless (zerop m)
- (replace (runes::xstream-os-buffer input) (runes::xstream-os-buffer input)
- :start1 0 :end1 m
- :start2 (runes::xstream-os-left-start input)
- :end2 (runes::xstream-os-left-end input))
- ;; then we take care that the buffer is large enough to carry at
- ;; least 100 bytes (a random number)
- (unless (>= (length (runes::xstream-os-buffer input)) 100)
- (error "You lost")
- ;; todo: enlarge buffer
- ))
- (setf n
- (runes::read-octets (runes::xstream-os-buffer input) (runes::xstream-os-stream input)
- m (min (1- (length (runes::xstream-os-buffer input)))
- (+ m (runes::xstream-speed input)))))
- (cond ((runes::%= n 0)
- (setf (runes::xstream-read-ptr input) 0
- (runes::xstream-fill-ptr input) n)
- (setf (aref (runes::xstream-buffer input)
- (runes::xstream-fill-ptr input)) runes::+end+)
- :eof)
- (t
- (multiple-value-bind (fnw fnr)
- (encoding:decode-sequence
- (runes::xstream-encoding input)
- (runes::xstream-os-buffer input) 0 n
- (runes::xstream-buffer input) 0 (1- (length (runes::xstream-buffer input)))
- (= n m))
- (setf (runes::xstream-os-left-start input) fnr
- (runes::xstream-os-left-end input) n
- (runes::xstream-read-ptr input) 0
- (runes::xstream-fill-ptr input) fnw)
- (setf (aref (runes::xstream-buffer input)
- (runes::xstream-fill-ptr input)) runes::+end+)
- (runes:read-rune input))))))
+(defmethod runes::xstream-underflow :before ((input runes:xstream))
+ (runes::write-xstream-buffer input))
\ No newline at end of file
Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.12 cl-xmpp/result.lisp:1.13
--- cl-xmpp/result.lisp:1.12 Thu Nov 17 22:51:16 2005
+++ cl-xmpp/result.lisp Sat Dec 31 21:15:06 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.12 2005/11/17 21:51:16 eenge Exp $
+;;;; $Id: result.lisp,v 1.13 2005/12/31 20:15:06 eenge Exp $
;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -125,12 +125,24 @@
(body
:accessor body
:initarg :body
- :initform "")))
+ :initform "")
+ (id
+ :accessor id
+ :initarg :id
+ :initform nil)
+ (type
+ :accessor type-
+ :initarg :type
+ :initform nil)))
(defmethod print-object ((object message) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type t :identity t)
- (format stream "to:~a from:~a" (to object) (from object))))
+ (format stream "to:~a from:~a id:~a type:~a"
+ (to object)
+ (from object)
+ (id object)
+ (type- object))))
(defclass presence (event)
((to
More information about the Cl-xmpp-cvs
mailing list