/emacsweblogs

;;; xml-rpc.el --- An elisp implementation of clientside XML-RPC

;; Copyright (C) 2002-2010 Mark A. Hershberger

;; Copyright (C) 2001 CodeFactory AB.

;; Copyright (C) 2001 Daniel Lundin.

;; Copyright (C) 2006 Shun-ichi Goto

;;   Modified for non-ASCII character handling.

;; Author: Mark A. Hershberger <mah@everybody.org>

;; Original Author: Daniel Lundin <daniel@codefactory.se>

;; Version: 1.6.8

;; Created: May 13 2001

;; Keywords: xml rpc network

;; URL: http://emacswiki.org/emacs/xml-rpc.el

;; Maintained-at: http://savannah.nongnu.org/bzr/?group=emacsweblogs

;; Last Modified: <2010-02-25 17:07:43 mah>

(defconst xml-rpc-version "1.6.8"

  "Current version of xml-rpc.el")

;; This file is NOT (yet) part of GNU Emacs.

;; This program is free software: you can redistribute it and/or modify

;; it under the terms of the GNU General Public License as published by

;; the Free Software Foundation, either version 3 of the License, or

;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,

;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License

;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is an XML-RPC client implementation in elisp, capable of both

;; synchronous and asynchronous method calls (using the url package's async

;; retrieval functionality).

;; XML-RPC is remote procedure calls over HTTP using XML to describe the

;; function call and return values.

;; xml-rpc.el represents XML-RPC datatypes as lisp values, automatically

;; converting to and from the XML datastructures as needed, both for method

;; parameters and return values, making using XML-RPC methods fairly

;; transparent to the lisp code.

;;; Installation:

;; If you use ELPA (http://tromey.com/elpa), you can install via the

;; M-x package-list-packages interface. This is preferrable as you

;; will have access to updates automatically.

;; Otherwise, just make sure this file in your load-path (usually

;; ~/.emacs.d is included) and put (require 'xml-rpc) in your

;; ~/.emacs or ~/.emacs.d/init.el file.

;;; Requirements

;; xml-rpc.el uses the url package for http handling and xml.el for

;; XML parsing. url is a part of the W3 browser package.  The url

;; package that is part of Emacs 22+ works great.

;;

;; xml.el is a part of GNU Emacs 21, but can also be downloaded from

;; here: <URL:ftp://ftp.codefactory.se/pub/people/daniel/elisp/xml.el>

;;; Bug reports

;; Please use M-x xml-rpc-submit-bug-report to report bugs.

;;; XML-RPC datatypes are represented as follows

;;          int:  42

;; float/double:  42.0

;;       string:  "foo"

;;        array:  '(1 2 3 4)   '(1 2 3 (4.1 4.2))

;;       struct:  '(("name" . "daniel") ("height" . 6.1))

;;    dateTime:   (:datetime (1234 124))

;;; Examples

;; Here follows some examples demonstrating the use of xml-rpc.el

;; Normal synchronous operation

;; ----------------------------

;; (xml-rpc-method-call "http://localhost:80/RPC" 'foo-method foo bar zoo)

;; Asynchronous example (cb-foo will be called when the methods returns)

;; ---------------------------------------------------------------------

;; (defun cb-foo (foo)

;;   (print (format "%s" foo)))

;; (xml-rpc-method-call-async 'cb-foo "http://localhost:80/RPC"

;;                            'foo-method foo bar zoo)

;; Some real world working examples for fun and play

;; -------------------------------------------------

;; Check the temperature (celsius) outside jonas@codefactory.se's apartment

;; (xml-rpc-method-call

;;      "http://flint.bengburken.net:80/xmlrpc/onewire_temp.php"

;;      'onewire.getTemp)

;; Fetch the latest NetBSD news the past 5 days from O'reillynet

;; (xml-rpc-method-call "http://www.oreillynet.com/meerkat/xml-rpc/server.php"

;;                   'meerkat.getItems

;;                   '(("channel" . 1024)

;;                     ("search" . "/NetBSD/")

;;                     ("time_period" . "5DAY")

;;                     ("ids" . 0)

;;                     ("descriptions" . 200)

;;                     ("categories" . 0)

;;                     ("channels" . 0)

;;                     ("dates" . 0)

;;                     ("num_items" . 5)))

;;; History:

;; 1.6.8   - Add a report-xml-rpc-bug function

;; 1.6.7   - Skipped version

;; 1.6.6   - Use the correct dateTime elements.  Fix bug in parsing null int.

;; 1.6.5.1 - Fix compile time warnings.

;; 1.6.5   - Made handling of dateTime elements more robust.

;; 1.6.4.1 - Updated to work with both Emacs22 and Emacs23.

;; 1.6.2.2 - Modified to allow non-ASCII string again.

;;           It can handle non-ASCII page name and comment

;;           on Emacs 21 also.

;; 1.6.2.1 - Modified to allow non-ASCII string.

;;           If xml-rpc-allow-unicode-string is non-nil,

;;           make 'value' object instead of 'base64' object.

;;           This is good for WikiRPC.

;; 1.6.2   - Fix whitespace issues to work better with new xml.el

;;           Fix bug in string handling.

;;           Add support for gzip-encoding when needed.

;; 1.6.1   - base64 support added.

;;           url-insert-entities-in-string done on string types now.

;; 1.6     - Fixed dependencies (remove w3, add cl).

;;           Move string-to-boolean and boolean-to-string into xml-rpc

;;           namespace.

;;           Fix bug in xml-rpc-xml-to-response where non-existent var was.

;;           More tweaking of "Connection: close" header.

;;           Fix bug in xml-rpc-request-process-buffer so that this works with

;;           different mixes of the url.el code.

;; 1.5.1   - Added Andrew J Cosgriff's patch to make the

;;           xml-rpc-clean-string function work in XEmacs.

;; 1.5     - Added headers to the outgoing url-retreive-synchronously

;;           so that it would close connections immediately on completion.

;; 1.4     - Added conditional debugging code.  Added version tag.

;; 1.2     - Better error handling.  The documentation didn't match

;;           the code.  That was changed so that an error was

;;           signaled.  Also, better handling of various and

;;           different combinations of xml.el and url.el.

;; 1.1     - Added support for boolean types.  If the type of a

;;           returned value is not specified, string is assumed

;; 1.0     - First version

;;; Code:

(require 'xml)

(require 'url-http)

(require 'timezone)

(eval-when-compile

  (require 'cl))

(defconst xml-rpc-maintainer-address "mah@everybody.org"

  "The address where bug reports should be sent.")

(defcustom xml-rpc-load-hook nil

  "*Hook run after loading xml-rpc."

  :type 'hook :group 'xml-rpc)

(defcustom xml-rpc-use-coding-system

  (if (coding-system-p 'utf-8) 'utf-8 'iso-8859-1)

  "The coding system to use."

  :type 'symbol :group 'xml-rpc)

(defcustom xml-rpc-allow-unicode-string (coding-system-p 'utf-8)

  "If non-nil, non-ASCII data is composed as 'value' instead of 'base64'.

And this option overrides `xml-rpc-base64-encode-unicode' and

`xml-rpc-base64-decode-unicode' if set as non-nil."

  :type 'boolean :group 'xml-rpc)

(defcustom xml-rpc-base64-encode-unicode (coding-system-p 'utf-8)

  "If non-nil, then strings with non-ascii characters will be turned

into Base64."

  :type 'boolean :group 'xml-rpc)

(defcustom xml-rpc-base64-decode-unicode (coding-system-p 'utf-8)

  "If non-nil, then base64 strings will be decoded using the

utf-8 coding system."

  :type 'boolean :group 'xml-rpc)

(defcustom xml-rpc-debug 0

  "Set this to 1 or greater to avoid killing temporary buffers.

Set it higher to get some info in the *Messages* buffer"

  :type 'integerp :group 'xml-rpc)

(defvar xml-rpc-fault-string nil

  "Contains the fault string if a fault is returned")

(defvar xml-rpc-fault-code nil

  "Contains the fault code if a fault is returned")

;;

;; Value type handling functions

;;

(defsubst xml-rpc-value-intp (value)

  "Return t if VALUE is an integer."

  (integerp value))

(defsubst xml-rpc-value-doublep (value)

  "Return t if VALUE is a double precision number."

  (floatp value))

(defsubst xml-rpc-value-stringp (value)

  "Return t if VALUE is a string."

  (stringp value))

;; An XML-RPC struct is a list where every car is cons or a list of

;; length 1 or 2 and has a string for car.

(defsubst xml-rpc-value-structp (value)

  "Return t if VALUE is an XML-RPC struct."

  (and (listp value)

       (let ((vals value)

             (result t)

             curval)

         (while (and vals result)

           (setq result (and

                         (setq curval (car-safe vals))

                         (consp curval)

                         (stringp (car-safe curval))))

           (setq vals (cdr-safe vals)))

         result)))

;; A somewhat lazy predicate for arrays

(defsubst xml-rpc-value-arrayp (value)

  "Return t if VALUE is an XML-RPC struct."

  (and (listp value)

       (not (xml-rpc-value-datetimep value))

       (not (xml-rpc-value-structp value))))

(defun xml-rpc-submit-bug-report ()

 "Submit a bug report on xml-rpc."

 (interactive)

 (require 'reporter)

 (let ((xml-rpc-tz-pd-defined-in

        (if (fboundp 'find-lisp-object-file-name)

            (find-lisp-object-file-name

             'timezone-parse-date (symbol-function 'timezone-parse-date))

          (symbol-file 'timezone-parse-date)))

       (date-parses-as (timezone-parse-date "20091130T00:52:53")))

   (reporter-submit-bug-report

    xml-rpc-maintainer-address

    (concat "xml-rpc.el " xml-rpc-version)

    (list 'xml-rpc-tz-pd-defined-in

          'date-parses-as

          'xml-rpc-load-hook

          'xml-rpc-use-coding-system

          'xml-rpc-allow-unicode-string

          'xml-rpc-base64-encode-unicode

          'xml-rpc-base64-decode-unicode))))

(defun xml-rpc-value-booleanp (value)

  "Return t if VALUE is a boolean."

  (or (eq value nil)

      (eq value t)))

(defun xml-rpc-value-datetimep (value)

  "Return t if VALUE is a datetime.  For Emacs XML-RPC

implementation, you must put time keyword :datetime before the

time, or it will be confused for a list."

  (and (listp value)

       (eq (car value) :datetime)))

(defun xml-rpc-string-to-boolean (value)

  "Return t if VALUE is a boolean"

  (or (string-equal value "true") (string-equal value "1")))

(defun xml-rpc-caddar-safe (list)

  (car-safe (cdr-safe (cdr-safe (car-safe list)))))

(defun xml-rpc-xml-list-to-value (xml-list)

  "Convert an XML-RPC structure in an xml.el style XML-LIST to an elisp list, \

interpreting and simplifying it while retaining its structure."

  (let (valtype valvalue)

    (cond

     ((and (xml-rpc-caddar-safe xml-list)

           (listp (car-safe (cdr-safe (cdr-safe (car-safe xml-list))))))

      (setq valtype (car (caddar xml-list))

            valvalue (caddr (caddar xml-list)))

      (cond

       ;; Base64

       ((eq valtype 'base64)

        (if xml-rpc-base64-decode-unicode

            (decode-coding-string (base64-decode-string valvalue) 'utf-8)

          (base64-decode-string valvalue)))

       ;; Boolean

       ((eq valtype 'boolean)

        (xml-rpc-string-to-boolean valvalue))

       ;; String

       ((eq valtype 'string)

        valvalue)

       ;; Integer

       ((or (eq valtype 'int) (eq valtype 'i4))

        (string-to-number (or valvalue "0")))

       ;; Double/float

       ((eq valtype 'double)

        (string-to-number valvalue))

       ;; Struct

       ((eq valtype 'struct)

        (mapcar (lambda (member)

                  (let ((membername (cadr (cdaddr member)))

                        (membervalue (xml-rpc-xml-list-to-value

                                      (cdddr member))))

                    (cons membername membervalue)))

                (cddr (caddar xml-list))))

       ;; Fault

       ((eq valtype 'fault)

        (let* ((struct (xml-rpc-xml-list-to-value (list valvalue)))

               (fault-string (cdr (assoc "faultString" struct)))

               (fault-code (cdr (assoc "faultCode" struct))))

          (list 'fault fault-code fault-string)))

       ;; DateTime

       ((or (eq valtype 'dateTime.iso8601)

            (eq valtype 'dateTime))

        (list :datetime (date-to-time valvalue)))

       ;; Array

       ((eq valtype 'array)

        (mapcar (lambda (arrval)

                  (xml-rpc-xml-list-to-value (list arrval)))

                (cddr valvalue)))))

     ((xml-rpc-caddar-safe xml-list)))))

(defun xml-rpc-boolean-to-string (value)

  "Convert a boolean value to a string"

  (if value

      "1"

    "0"))

(defun xml-rpc-datetime-to-string (value)

  "Convert a date time to a valid XML-RPC date"

  (format-time-string "%Y%m%dT%H:%M:%S" (cadr value)))

(defun xml-rpc-value-to-xml-list (value)

  "Return XML representation of VALUE properly formatted for use with the  \

functions in xml.el."

  (cond

   ;;   ((not value)

   ;;    nil)

   ((xml-rpc-value-booleanp value)

    `((value nil (boolean nil ,(xml-rpc-boolean-to-string value)))))

   ;; Date

   ((xml-rpc-value-datetimep value)

    `((value nil (dateTime.iso8601 nil ,(xml-rpc-datetime-to-string value)))))

   ;; list

   ((xml-rpc-value-arrayp value)

    (let ((result nil)

          (xmlval nil))

      (while (setq xmlval (xml-rpc-value-to-xml-list (car value))

                   result (if result (append result xmlval)

                            xmlval)

                   value (cdr value)))

      `((value nil (array nil ,(append '(data nil) result))))))

   ;; struct

   ((xml-rpc-value-structp value)

    (let ((result nil)

          (xmlval nil))

      (while (setq xmlval `((member nil (name nil ,(caar value))

                                    ,(car (xml-rpc-value-to-xml-list

                                           (cdar value)))))

                   result (append result xmlval)

                   value (cdr value)))

      `((value nil ,(append '(struct nil) result)))))

   ;; Value is a scalar

   ((xml-rpc-value-intp value)

    `((value nil (int nil ,(int-to-string value)))))

   ((xml-rpc-value-stringp value)

    (let ((charset-list (find-charset-string value)))

      (if (or xml-rpc-allow-unicode-string

              (and (eq 1 (length charset-list))

                   (eq 'ascii (car charset-list)))

              (not xml-rpc-base64-encode-unicode))

          `((value nil (string nil ,value)))

        `((value nil (base64 nil ,(if xml-rpc-base64-encode-unicode

                                      (base64-encode-string

                                       (encode-coding-string

                                        value xml-rpc-use-coding-system))

                                    (base64-encode-string value))))))))

   ((xml-rpc-value-doublep value)

    `((value nil (double nil ,(number-to-string value)))))

   (t

    `((value nil (base64 nil ,(base64-encode-string value)))))))

(defun xml-rpc-xml-to-string (xml)

  "Return a string representation of the XML tree as valid XML markup."

  (let ((tree (xml-node-children xml))

        (result (concat "<" (symbol-name (xml-node-name xml)) ">")))

    (while tree

      (cond

       ((listp (car tree))

        (setq result (concat result (xml-rpc-xml-to-string (car tree)))))

       ((stringp (car tree))

        (setq result (concat result (car tree))))

       (t

        (error "Invalid XML tree")))

      (setq tree (cdr tree)))

    (setq result (concat result "</" (symbol-name (xml-node-name xml)) ">"))

    result))

;;

;; Response handling

;;

(defsubst xml-rpc-response-errorp (response)

  "An 'xml-rpc-method-call'  result value is always a list, where the first \

element in RESPONSE is either nil or if an error occured, a cons pair \

according to (errnum .  \"Error string\"),"

  (eq 'fault (car-safe (caddar response))))

(defsubst xml-rpc-response-error-code (response)

  "Return the error code from RESPONSE."

  (and (xml-rpc-response-errorp response)

       (nth 1 (xml-rpc-xml-list-to-value response))))

(defsubst xml-rpc-response-error-string (response)

  "Return the error code from RESPONSE."

  (and (xml-rpc-response-errorp response)

       (nth 2 (xml-rpc-xml-list-to-value response))))

(defun xml-rpc-xml-to-response (xml)

  "Convert an XML list to a method response list.  An error is

signaled if there is a fault or if the response does not appear

to be an XML-RPC response (i.e. no methodResponse).  Otherwise,

the parsed XML response is returned."

  ;; Check if we have a methodResponse

  (cond

   ((not (eq (car-safe (car-safe xml)) 'methodResponse))

    (error "No methodResponse found"))

   ;; Did we get a fault response

   ((xml-rpc-response-errorp xml)

    (let ((resp (xml-rpc-xml-list-to-value xml)))

      (setq xml-rpc-fault-string (nth 2 resp))

      (setq xml-rpc-fault-code   (nth 1 resp))

      (error "XML-RPC fault `%s'" xml-rpc-fault-string)))

   ;; Interpret the XML list and produce a more useful data structure

   (t

    (let ((valpart (cdr (cdaddr (caddar xml)))))

      (xml-rpc-xml-list-to-value valpart)))))

;;

;; Method handling

;;

(defun xml-rpc-request (server-url xml &optional async-callback-function)

  "Perform http post request to SERVER-URL using XML.

If ASYNC-CALLBACK-FUNCTION is non-nil, the request will be performed

asynchronously and ASYNC-CALLBACK-FUNCTION should be a callback function to

be called when the reuest is finished.  ASYNC-CALLBACK-FUNCTION is called with

a single argument being an xml.el style XML list.

It returns an XML list containing the method response from the XML-RPC server,

or nil if called with ASYNC-CALLBACK-FUNCTION."

  (declare (special url-current-callback-data

                    url-current-callback-func

                    url-http-response-status))

  (unwind-protect

      (save-excursion

        (let ((url-request-method "POST")

              (url-package-name "xml-rpc.el")

              (url-package-version xml-rpc-version)

              (url-request-data (concat "<?xml version=\"1.0\""

                                        " encoding=\"UTF-8\"?>\n"

                                        (with-temp-buffer

                                          (xml-print xml)

                                          (when xml-rpc-allow-unicode-string

                                            (encode-coding-region

                                             (point-min) (point-max) 'utf-8))

                                          (buffer-string))

                                        "\n"))

              (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")

              (url-request-coding-system xml-rpc-use-coding-system)

              (url-http-attempt-keepalives t)

              (url-request-extra-headers (list

                                          (cons "Connection" "keep-alive")

                                          (cons "Content-Type"

                                                "text/xml; charset=utf-8"))))

          (when (> xml-rpc-debug 1)

            (print url-request-data (create-file-buffer "request-data")))

          (cond ((boundp 'url-be-asynchronous) ; Sniff for w3 lib capability

                 (if async-callback-function

                     (setq url-be-asynchronous t

                           url-current-callback-data (list

                                                      async-callback-function

                                                      (current-buffer))

                           url-current-callback-func

                           'xml-rpc-request-callback-handler)

                   (setq url-be-asynchronous nil))

                 (url-retrieve server-url t)

                 (when (not url-be-asynchronous)

                   (let ((result (xml-rpc-request-process-buffer

                                  (current-buffer))))

                     (when (> xml-rpc-debug 1)

                       (with-current-buffer (create-file-buffer "result-data")

                         (insert result)))

                     result)))

                (t                      ; Post emacs20 w3-el

                 (if async-callback-function

                     (url-retrieve server-url async-callback-function)

                   (let ((buffer (url-retrieve-synchronously server-url))

                         result)

                     (with-current-buffer buffer

                       (when (not (numberp url-http-response-status))

                         ;; this error may occur when keep-alive bug

                         ;; of url-http.el is not cleared.

                         (error "Why? url-http-response-status is %s"

                                url-http-response-status))

                       (when (> url-http-response-status 299)

                         (error "Error during request: %s"

                                url-http-response-status)))

                     (xml-rpc-request-process-buffer buffer)))))))))

(defun xml-rpc-clean-string (s)

  (if (string-match "\\`[ \t\n\r]*\\'" s)

      ;;"^[ \t\n]*$" s)

      nil

    s))

(defun xml-rpc-clean (l)

  (cond

   ((listp l)

    (let ((remain l)

          elem

          (result nil))

      (while l

        ;; iterate

        (setq elem (car l)

              l (cdr l))

        ;; test the head

        (cond

         ;; a string, so clean it.

         ((stringp elem)

          (let ((tmp (xml-rpc-clean-string elem)))

            (when (and tmp xml-rpc-allow-unicode-string)

              (setq tmp (decode-coding-string tmp xml-rpc-use-coding-system)))

            (if tmp

                (setq result (append result (list tmp)))

              result)))

         ;; a list, so recurse.

         ((listp elem)

          (setq result (append result (list (xml-rpc-clean elem)))))

         ;; everthing else, as is.

         (t

          (setq result (append result (list elem))))))

      result))

   ((stringp l)                   ; will returning nil be acceptable ?

    nil)

   (t l)))

(defun xml-rpc-request-process-buffer (xml-buffer)

  "Process buffer XML-BUFFER."

  (unwind-protect

      (with-current-buffer xml-buffer

        (when (fboundp 'url-uncompress)

          (let ((url-working-buffer xml-buffer))

            (url-uncompress)))

        (goto-char (point-min))

        (search-forward-regexp "<\\?xml" nil t)

        (move-to-column 0)

        ;; Gather the results

        (let* ((status (if (boundp 'url-http-response-status)

                           ;; Old URL lib doesn't save the result.

                           url-http-response-status 200))

               (result (cond

                        ;; A probable XML response

                        ((looking-at "<\\?xml ")

                         (xml-rpc-clean (xml-parse-region (point-min)

                                                          (point-max))))

                        ;; No HTTP status returned

                        ((not status)

                         (let ((errstart

                                (search-forward "\n---- Error was: ----\n")))

                           (and errstart

                                (buffer-substring errstart (point-max)))))

                        ;; Maybe they just gave us an the XML w/o PI?

                        ((search-forward "<methodResponse>" nil t)

                         (xml-rpc-clean (xml-parse-region (match-beginning 0)

                                                          (point-max))))

                        ;; Valid HTTP status

                        (t

                         (int-to-string status)))))

          (when (< xml-rpc-debug 3)

            (kill-buffer (current-buffer)))

          result))))

(defun xml-rpc-request-callback-handler (callback-fun xml-buffer)

  "Marshall a callback function request to CALLBACK-FUN with the results \

handled from XML-BUFFER."

  (let ((xml-response (xml-rpc-request-process-buffer xml-buffer)))

    (when (< xml-rpc-debug 1)

      (kill-buffer xml-buffer))

    (funcall callback-fun (xml-rpc-xml-to-response xml-response))))

(defun xml-rpc-method-call-async (async-callback-func server-url method

                                                      &rest params)

  "Call an XML-RPC method asynchronously at SERVER-URL named METHOD with \

PARAMS as parameters. When the method returns, ASYNC-CALLBACK-FUNC will be \

called with the result as parameter."

  (let* ((m-name (if (stringp method)

                     method

                   (symbol-name method)))

         (m-params (mapcar '(lambda (p)

                              `(param nil ,(car (xml-rpc-value-to-xml-list

                                                 p))))

                           (if async-callback-func

                               params

                             (car-safe params))))

         (m-func-call `((methodCall nil (methodName nil ,m-name)

                                    ,(append '(params nil) m-params)))))

    (when (> xml-rpc-debug 1)

      (print m-func-call (create-file-buffer "func-call")))

    (xml-rpc-request server-url m-func-call async-callback-func)))

(defun xml-rpc-method-call (server-url method &rest params)

  "Call an XML-RPC method at SERVER-URL named METHOD with PARAMS as \

parameters."

  (let ((response

         (xml-rpc-method-call-async nil server-url method params)))

    (cond ((stringp response)

           (list (cons nil (concat "URL/HTTP Error: " response))))

          (t

           (xml-rpc-xml-to-response response)))))

(unless (fboundp 'xml-escape-string)

  (defun xml-debug-print (xml &optional indent-string)

    "Outputs the XML in the current buffer.

XML can be a tree or a list of nodes.

The first line is indented with the optional INDENT-STRING."

    (setq indent-string (or indent-string ""))

    (dolist (node xml)

      (xml-debug-print-internal node indent-string)))

  (defalias 'xml-print 'xml-debug-print)

  (when (not (boundp 'xml-entity-alist))

    (defvar xml-entity-alist

      '(("lt" . "<")

        ("gt" . ">")

        ("apos" . "'")

        ("quot" . "\"")

        ("amp" . "&"))))

  (defun xml-escape-string (string)

    "Return the string with entity substitutions made from

xml-entity-alist."

    (mapconcat (lambda (byte)

                 (let ((char (char-to-string byte)))

                   (if (rassoc char xml-entity-alist)

                       (concat "&" (car (rassoc char xml-entity-alist)) ";")

                     char)))

               ;; This differs from the non-unicode branch.  Just

               ;; grabbing the string works here.

               string ""))

  (defun xml-debug-print-internal (xml indent-string)

    "Outputs the XML tree in the current buffer.

The first line is indented with INDENT-STRING."

    (let ((tree xml)

          attlist)

      (insert indent-string ?< (symbol-name (xml-node-name tree)))

      ;;  output the attribute list

      (setq attlist (xml-node-attributes tree))

      (while attlist

        (insert ?\  (symbol-name (caar attlist)) "=\""

                (xml-escape-string (cdar attlist)) ?\")

        (setq attlist (cdr attlist)))

      (setq tree (xml-node-children tree))

      (if (null tree)

          (insert ?/ ?>)

        (insert ?>)

        ;;  output the children

        (dolist (node tree)

          (cond

           ((listp node)

            (insert ?\n)

            (xml-debug-print-internal node (concat indent-string "  ")))

           ((stringp node)

            (insert (xml-escape-string node)))

           (t

            (error "Invalid XML tree"))))

        (when (not (and (null (cdr tree))

                        (stringp (car tree))))

          (insert ?\n indent-string))

        (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>)))))

(let ((tdate (timezone-parse-date "20090101T010101Z")))

  (when (not (string-equal (aref tdate 0) "2009"))

    (defun timezone-parse-date (date)

      "Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE].

Two-digit dates are `windowed'.  Those <69 have 2000 added; otherwise 1900

is added.  Three-digit dates have 1900 added.

TIMEZONE is nil for DATEs without a zone field.

Understands the following styles:

 (1) 14 Apr 89 03:20[:12] [GMT]

 (2) Fri, 17 Mar 89 4:01[:33] [GMT]

 (3) Mon Jan 16 16:12[:37] [GMT] 1989

 (4) 6 May 1992 1641-JST (Wednesday)

 (5) 22-AUG-1993 10:59:12.82

 (6) Thu, 11 Apr 16:17:12 91 [MET]

 (7) Mon, 6  Jul 16:47:20 T 1992 [MET]

 (8) 1996-06-24 21:13:12 [GMT]

 (9) 1996-06-24 21:13-ZONE

 (10) 19960624T211312"