[cl-xmpp-cvs] CVS update: cl-xmpp/result.lisp

[Erik Enge]

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

Modified Files:
	result.lisp 
Log Message:
now producing the same error instance for old-style and new-style error messages

Date: Tue Nov 15 16:19:08 2005
Author: eenge

Index: cl-xmpp/result.lisp
diff -u cl-xmpp/result.lisp:1.9 cl-xmpp/result.lisp:1.10
--- cl-xmpp/result.lisp:1.9	Mon Nov 14 21:07:36 2005
+++ cl-xmpp/result.lisp	Tue Nov 15 16:19:08 2005
@@ -1,4 +1,4 @@
-;;;; $Id: result.lisp,v 1.9 2005/11/14 20:07:36 eenge Exp $
+;;;; $Id: result.lisp,v 1.10 2005/11/15 15:19:08 eenge Exp $
 ;;;; $Source: /project/cl-xmpp/cvsroot/cl-xmpp/result.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
@@ -296,9 +296,12 @@
 (defclass xmpp-protocol-error-wait (xmpp-protocol-error) ())
 (defclass xmpp-protocol-error-auth (xmpp-protocol-error) ())
 
-(defun get-error-data (name)
+(defun get-error-data-name (name)
   (assoc name *errors*))
 
+(defun get-error-data-code (code)
+  (rassoc code *errors* :key #'second))
+
 (defun map-error-type-to-class (type)
   (case type
     (modify (find-class 'xmpp-protocol-error-modify))
@@ -308,9 +311,22 @@
     (t (find-class 'xmpp-protocol-error))))
 
 (defmethod make-error ((object xml-element))
-  (let* ((name (intern (string-upcase (name (car (elements object)))) :keyword))
-	 (data (get-error-data name))
-	 (type (second data))
-	 (code (third data))
-	 (class (map-error-type-to-class type)))
+  (let* ((first-element (car (elements object)))
+	 (name)
+	 (type)
+	 (code)
+	 (class))
+    (if (eq (name first-element) :\#text) ; old-style error
+	(progn
+	  (setq code (parse-integer (value (get-attribute object :code))))
+	  (let ((data (get-error-data-code code)))
+	    (setq name (first data))
+	    (setq type (second data))
+	    (setq class (map-error-type-to-class type))))
+      (progn
+	(setq name (name first-element))
+	(let ((data (get-error-data-name name)))
+	  (setq type (second data))
+	  (setq code (third data))
+	  (setq class (map-error-type-to-class type)))))
     (make-instance class :code code :name name :xml-element object)))