[cl-xmpp-devel] upgrade to cxml cvs
David Lichteblau
david at lichteblau.com
Fri Dec 30 14:47:41 UTC 2005
Hi,
attached changes for cxml cvs.
This should make cl-xmpp work on non-Unicode-capable Lisps.
Tested briefly on SBCL with and without sb-unicode.
I've also changed cxml a little so that cxml.lisp can be a somewhat less
intrusive.
d.
-------------- next part --------------
Index: cl-xmpp.lisp
===================================================================
RCS file: /project/cl-xmpp/cvsroot/cl-xmpp/cl-xmpp.lisp,v
retrieving revision 1.23
diff -u -u -r1.23 cl-xmpp.lisp
--- cl-xmpp.lisp 21 Nov 2005 18:58:03 -0000 1.23
+++ cl-xmpp.lisp 30 Dec 2005 14:19:22 -0000
@@ -158,14 +158,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,22 +173,26 @@
: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)))))
@@ -305,13 +309,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)))))
Index: cxml.lisp
===================================================================
RCS file: /project/cl-xmpp/cvsroot/cl-xmpp/cxml.lisp,v
retrieving revision 1.9
diff -u -u -r1.9 cxml.lisp
--- cxml.lisp 18 Nov 2005 23:14:35 -0000 1.9
+++ cxml.lisp 30 Dec 2005 14:19:22 -0000
@@ -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,7 +45,7 @@
(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
@@ -56,21 +56,36 @@
;;; 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)
+
+;;; Commented this out, because it's bogus.
+;;; * Attributes are a NamedNodeMap, *not* a NodeList. Both have similar
+;;; slots, but are entirely separate interfaces.
+;;; * NIL is neither, so it is *meant* to be an error to treat it as such.
+;;; * cl-xmpp was accessing the attributes slot of a node, not of an element.
+;;; That's legal, but NIL is the right return value there, because
+;;; non-element nodes do not have attributes. (On Elements without
+;;; attributes, the result will be an empty but non-NIL node map.)
+;;; --David
+
+;;;(defun dom:map-node-list (fn nodelist)
+;;; (when nodelist
+;;; (dotimes (i (dom:length nodelist))
+;;; (funcall fn (dom:item nodelist i)))))
+
+;;; 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
@@ -86,49 +101,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))
More information about the cl-xmpp-devel
mailing list