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