emacs/xml-rpc.el

   1 ;;; xml-rpc.el --- An elisp implementation of clientside XML-RPC
   2
   3 ;; Copyright (C) 2002-2010 Mark A. Hershberger
   4 ;; Copyright (C) 2001 CodeFactory AB.
   5 ;; Copyright (C) 2001 Daniel Lundin.
   6 ;; Copyright (C) 2006 Shun-ichi Goto
   7 ;;   Modified for non-ASCII character handling.
   8
   9 ;; Author: Mark A. Hershberger <mah@everybody.org>
  10 ;; Original Author: Daniel Lundin <daniel@codefactory.se>
  11 ;; Version: 1.6.8
  12 ;; Created: May 13 2001
  13 ;; Keywords: xml rpc network
  14 ;; URL: http://launchpad.net/xml-rpc-el
  15 ;; Last Modified: <2010-02-27 07:02:36 mah>
  16
  17 (defconst xml-rpc-version "1.6.8"
  18   "Current version of xml-rpc.el")
  19
  20 ;; This file is NOT (yet) part of GNU Emacs.
  21
  22 ;; This program is free software: you can redistribute it and/or modify
  23 ;; it under the terms of the GNU General Public License as published by
  24 ;; the Free Software Foundation, either version 3 of the License, or
  25 ;; (at your option) any later version.
  26
  27 ;; This program is distributed in the hope that it will be useful,
  28 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  29 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  30 ;; GNU General Public License for more details.
  31
  32 ;; You should have received a copy of the GNU General Public License
  33 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  34
  35 ;;; Commentary:
  36
  37 ;; This is an XML-RPC client implementation in elisp, capable of both
  38 ;; synchronous and asynchronous method calls (using the url package's async
  39 ;; retrieval functionality).
  40 ;; XML-RPC is remote procedure calls over HTTP using XML to describe the
  41 ;; function call and return values.
  42
  43 ;; xml-rpc.el represents XML-RPC datatypes as lisp values, automatically
  44 ;; converting to and from the XML datastructures as needed, both for method
  45 ;; parameters and return values, making using XML-RPC methods fairly
  46 ;; transparent to the lisp code.
  47
  48 ;;; Installation:
  49
  50 ;; If you use ELPA (http://tromey.com/elpa), you can install via the
  51 ;; M-x package-list-packages interface. This is preferrable as you
  52 ;; will have access to updates automatically.
  53
  54 ;; Otherwise, just make sure this file in your load-path (usually
  55 ;; ~/.emacs.d is included) and put (require 'xml-rpc) in your
  56 ;; ~/.emacs or ~/.emacs.d/init.el file.
  57
  58 ;;; Requirements
  59
  60 ;; xml-rpc.el uses the url package for http handling and xml.el for
  61 ;; XML parsing. url is a part of the W3 browser package.  The url
  62 ;; package that is part of Emacs 22+ works great.
  63 ;;
  64 ;; xml.el is a part of GNU Emacs 21, but can also be downloaded from
  65 ;; here: <URL:ftp://ftp.codefactory.se/pub/people/daniel/elisp/xml.el>
  66
  67 ;;; Bug reports
  68
  69 ;; Please use M-x xml-rpc-submit-bug-report to report bugs.
  70
  71 ;;; XML-RPC datatypes are represented as follows
  72
  73 ;;          int:  42
  74 ;; float/double:  42.0
  75 ;;       string:  "foo"
  76 ;;        array:  '(1 2 3 4)   '(1 2 3 (4.1 4.2))
  77 ;;       struct:  '(("name" . "daniel") ("height" . 6.1))
  78 ;;    dateTime:   (:datetime (1234 124))
  79
  80
  81 ;;; Examples
  82
  83 ;; Here follows some examples demonstrating the use of xml-rpc.el
  84
  85 ;; Normal synchronous operation
  86 ;; ----------------------------
  87
  88 ;; (xml-rpc-method-call "http://localhost:80/RPC" 'foo-method foo bar zoo)
  89
  90 ;; Asynchronous example (cb-foo will be called when the methods returns)
  91 ;; ---------------------------------------------------------------------
  92
  93 ;; (defun cb-foo (foo)
  94 ;;   (print (format "%s" foo)))
  95
  96 ;; (xml-rpc-method-call-async 'cb-foo "http://localhost:80/RPC"
  97 ;;                            'foo-method foo bar zoo)
  98
  99
 100 ;; Some real world working examples for fun and play
 101 ;; -------------------------------------------------
 102
 103 ;; Check the temperature (celsius) outside jonas@codefactory.se's apartment
 104
 105 ;; (xml-rpc-method-call
 106 ;;      "http://flint.bengburken.net:80/xmlrpc/onewire_temp.php"
 107 ;;      'onewire.getTemp)
 108
 109
 110 ;; Fetch the latest NetBSD news the past 5 days from O'reillynet
 111
 112 ;; (xml-rpc-method-call "http://www.oreillynet.com/meerkat/xml-rpc/server.php"
 113 ;;                   'meerkat.getItems
 114 ;;                   '(("channel" . 1024)
 115 ;;                     ("search" . "/NetBSD/")
 116 ;;                     ("time_period" . "5DAY")
 117 ;;                     ("ids" . 0)
 118 ;;                     ("descriptions" . 200)
 119 ;;                     ("categories" . 0)
 120 ;;                     ("channels" . 0)
 121 ;;                     ("dates" . 0)
 122 ;;                     ("num_items" . 5)))
 123
 124
 125 ;;; History:
 126
 127 ;; 1.6.8   - Add a report-xml-rpc-bug function
 128
 129 ;; 1.6.7   - Skipped version
 130
 131 ;; 1.6.6   - Use the correct dateTime elements.  Fix bug in parsing null int.
 132
 133 ;; 1.6.5.1 - Fix compile time warnings.
 134
 135 ;; 1.6.5   - Made handling of dateTime elements more robust.
 136
 137 ;; 1.6.4.1 - Updated to work with both Emacs22 and Emacs23.
 138
 139 ;; 1.6.2.2 - Modified to allow non-ASCII string again.
 140 ;;           It can handle non-ASCII page name and comment
 141 ;;           on Emacs 21 also.
 142
 143 ;; 1.6.2.1 - Modified to allow non-ASCII string.
 144 ;;           If xml-rpc-allow-unicode-string is non-nil,
 145 ;;           make 'value' object instead of 'base64' object.
 146 ;;           This is good for WikiRPC.
 147
 148 ;; 1.6.2   - Fix whitespace issues to work better with new xml.el
 149 ;;           Fix bug in string handling.
 150 ;;           Add support for gzip-encoding when needed.
 151
 152 ;; 1.6.1   - base64 support added.
 153 ;;           url-insert-entities-in-string done on string types now.
 154
 155 ;; 1.6     - Fixed dependencies (remove w3, add cl).
 156 ;;           Move string-to-boolean and boolean-to-string into xml-rpc
 157 ;;           namespace.
 158 ;;           Fix bug in xml-rpc-xml-to-response where non-existent var was.
 159 ;;           More tweaking of "Connection: close" header.
 160 ;;           Fix bug in xml-rpc-request-process-buffer so that this works with
 161 ;;           different mixes of the url.el code.
 162
 163 ;; 1.5.1   - Added Andrew J Cosgriff's patch to make the
 164 ;;           xml-rpc-clean-string function work in XEmacs.
 165
 166 ;; 1.5     - Added headers to the outgoing url-retreive-synchronously
 167 ;;           so that it would close connections immediately on completion.
 168
 169 ;; 1.4     - Added conditional debugging code.  Added version tag.
 170
 171 ;; 1.2     - Better error handling.  The documentation didn't match
 172 ;;           the code.  That was changed so that an error was
 173 ;;           signaled.  Also, better handling of various and
 174 ;;           different combinations of xml.el and url.el.
 175
 176 ;; 1.1     - Added support for boolean types.  If the type of a
 177 ;;           returned value is not specified, string is assumed
 178
 179 ;; 1.0     - First version
 180
 181
 182 ;;; Code:
 183
 184 (require 'xml)
 185 (require 'url-http)
 186 (require 'timezone)
 187 (eval-when-compile
 188   (require 'cl))
 189
 190 (defconst xml-rpc-maintainer-address "mah@everybody.org"
 191   "The address where bug reports should be sent.")
 192
 193 (defcustom xml-rpc-load-hook nil
 194   "*Hook run after loading xml-rpc."
 195   :type 'hook :group 'xml-rpc)
 196
 197 (defcustom xml-rpc-use-coding-system
 198   (if (coding-system-p 'utf-8) 'utf-8 'iso-8859-1)
 199   "The coding system to use."
 200   :type 'symbol :group 'xml-rpc)
 201
 202 (defcustom xml-rpc-allow-unicode-string (coding-system-p 'utf-8)
 203   "If non-nil, non-ASCII data is composed as 'value' instead of 'base64'.
 204 And this option overrides `xml-rpc-base64-encode-unicode' and
 205 `xml-rpc-base64-decode-unicode' if set as non-nil."
 206   :type 'boolean :group 'xml-rpc)
 207
 208 (defcustom xml-rpc-base64-encode-unicode (coding-system-p 'utf-8)
 209   "If non-nil, then strings with non-ascii characters will be turned
 210 into Base64."
 211   :type 'boolean :group 'xml-rpc)
 212
 213 (defcustom xml-rpc-base64-decode-unicode (coding-system-p 'utf-8)
 214   "If non-nil, then base64 strings will be decoded using the
 215 utf-8 coding system."
 216   :type 'boolean :group 'xml-rpc)
 217
 218 (defcustom xml-rpc-debug 0
 219   "Set this to 1 or greater to avoid killing temporary buffers.
 220 Set it higher to get some info in the *Messages* buffer"
 221   :type 'integerp :group 'xml-rpc)
 222
 223 (defvar xml-rpc-fault-string nil
 224   "Contains the fault string if a fault is returned")
 225
 226 (defvar xml-rpc-fault-code nil
 227   "Contains the fault code if a fault is returned")
 228
 229 ;;
 230 ;; Value type handling functions
 231 ;;
 232
 233 (defsubst xml-rpc-value-intp (value)
 234   "Return t if VALUE is an integer."
 235   (integerp value))
 236
 237 (defsubst xml-rpc-value-doublep (value)
 238   "Return t if VALUE is a double precision number."
 239   (floatp value))
 240
 241 (defsubst xml-rpc-value-stringp (value)
 242   "Return t if VALUE is a string."
 243   (stringp value))
 244
 245 ;; An XML-RPC struct is a list where every car is cons or a list of
 246 ;; length 1 or 2 and has a string for car.
 247 (defsubst xml-rpc-value-structp (value)
 248   "Return t if VALUE is an XML-RPC struct."
 249   (and (listp value)
 250        (let ((vals value)
 251              (result t)
 252              curval)
 253          (while (and vals result)
 254            (setq result (and
 255                          (setq curval (car-safe vals))
 256                          (consp curval)
 257                          (stringp (car-safe curval))))
 258            (setq vals (cdr-safe vals)))
 259          result)))
 260
 261 ;; A somewhat lazy predicate for arrays
 262 (defsubst xml-rpc-value-arrayp (value)
 263   "Return t if VALUE is an XML-RPC struct."
 264   (and (listp value)
 265        (not (xml-rpc-value-datetimep value))
 266        (not (xml-rpc-value-structp value))))
 267
 268 (defun xml-rpc-submit-bug-report ()
 269  "Submit a bug report on xml-rpc."
 270  (interactive)
 271  (require 'reporter)
 272  (let ((xml-rpc-tz-pd-defined-in
 273         (if (fboundp 'find-lisp-object-file-name)
 274             (find-lisp-object-file-name
 275              'timezone-parse-date (symbol-function 'timezone-parse-date))
 276           (symbol-file 'timezone-parse-date)))
 277        (date-parses-as (timezone-parse-date "20091130T00:52:53")))
 278    (reporter-submit-bug-report
 279     xml-rpc-maintainer-address
 280     (concat "xml-rpc.el " xml-rpc-version)
 281     (list 'xml-rpc-tz-pd-defined-in
 282           'date-parses-as
 283           'xml-rpc-load-hook
 284           'xml-rpc-use-coding-system
 285           'xml-rpc-allow-unicode-string
 286           'xml-rpc-base64-encode-unicode
 287           'xml-rpc-base64-decode-unicode))))
 288
 289 (defun xml-rpc-value-booleanp (value)
 290   "Return t if VALUE is a boolean."
 291   (or (eq value nil)
 292       (eq value t)))
 293
 294 (defun xml-rpc-value-datetimep (value)
 295   "Return t if VALUE is a datetime.  For Emacs XML-RPC
 296 implementation, you must put time keyword :datetime before the
 297 time, or it will be confused for a list."
 298   (and (listp value)
 299        (eq (car value) :datetime)))
 300
 301 (defun xml-rpc-string-to-boolean (value)
 302   "Return t if VALUE is a boolean"
 303   (or (string-equal value "true") (string-equal value "1")))
 304
 305 (defun xml-rpc-caddar-safe (list)
 306   (car-safe (cdr-safe (cdr-safe (car-safe list)))))
 307
 308 (defun xml-rpc-xml-list-to-value (xml-list)
 309   "Convert an XML-RPC structure in an xml.el style XML-LIST to an elisp list, \
 310 interpreting and simplifying it while retaining its structure."
 311   (let (valtype valvalue)
 312     (cond
 313      ((and (xml-rpc-caddar-safe xml-list)
 314            (listp (car-safe (cdr-safe (cdr-safe (car-safe xml-list))))))
 315
 316       (setq valtype (car (caddar xml-list))
 317             valvalue (caddr (caddar xml-list)))
 318       (cond
 319        ;; Base64
 320        ((eq valtype 'base64)
 321         (if xml-rpc-base64-decode-unicode
 322             (decode-coding-string (base64-decode-string valvalue) 'utf-8)
 323           (base64-decode-string valvalue)))
 324        ;; Boolean
 325        ((eq valtype 'boolean)
 326         (xml-rpc-string-to-boolean valvalue))
 327        ;; String
 328        ((eq valtype 'string)
 329         valvalue)
 330        ;; Integer
 331        ((or (eq valtype 'int) (eq valtype 'i4))
 332         (string-to-number (or valvalue "0")))
 333        ;; Double/float
 334        ((eq valtype 'double)
 335         (string-to-number valvalue))
 336        ;; Struct
 337        ((eq valtype 'struct)
 338         (mapcar (lambda (member)
 339                   (let ((membername (cadr (cdaddr member)))
 340                         (membervalue (xml-rpc-xml-list-to-value
 341                                       (cdddr member))))
 342                     (cons membername membervalue)))
 343                 (cddr (caddar xml-list))))
 344        ;; Fault
 345        ((eq valtype 'fault)
 346         (let* ((struct (xml-rpc-xml-list-to-value (list valvalue)))
 347                (fault-string (cdr (assoc "faultString" struct)))
 348                (fault-code (cdr (assoc "faultCode" struct))))
 349           (list 'fault fault-code fault-string)))
 350        ;; DateTime
 351        ((or (eq valtype 'dateTime.iso8601)
 352             (eq valtype 'dateTime))
 353         (list :datetime (date-to-time valvalue)))
 354        ;; Array
 355        ((eq valtype 'array)
 356         (mapcar (lambda (arrval)
 357                   (xml-rpc-xml-list-to-value (list arrval)))
 358                 (cddr valvalue)))))
 359      ((xml-rpc-caddar-safe xml-list)))))
 360
 361 (defun xml-rpc-boolean-to-string (value)
 362   "Convert a boolean value to a string"
 363   (if value
 364       "1"
 365     "0"))
 366
 367 (defun xml-rpc-datetime-to-string (value)
 368   "Convert a date time to a valid XML-RPC date"
 369   (format-time-string "%Y%m%dT%H:%M:%S" (cadr value)))
 370
 371 (defun xml-rpc-value-to-xml-list (value)
 372   "Return XML representation of VALUE properly formatted for use with the  \
 373 functions in xml.el."
 374   (cond
 375    ;;   ((not value)
 376    ;;    nil)
 377    ((xml-rpc-value-booleanp value)
 378     `((value nil (boolean nil ,(xml-rpc-boolean-to-string value)))))
 379    ;; Date
 380    ((xml-rpc-value-datetimep value)
 381     `((value nil (dateTime.iso8601 nil ,(xml-rpc-datetime-to-string value)))))
 382    ;; list
 383    ((xml-rpc-value-arrayp value)
 384     (let ((result nil)
 385           (xmlval nil))
 386       (while (setq xmlval (xml-rpc-value-to-xml-list (car value))
 387                    result (if result (append result xmlval)
 388                             xmlval)
 389                    value (cdr value)))
 390       `((value nil (array nil ,(append '(data nil) result))))))
 391    ;; struct
 392    ((xml-rpc-value-structp value)
 393     (let ((result nil)
 394           (xmlval nil))
 395       (while (setq xmlval `((member nil (name nil ,(caar value))
 396                                     ,(car (xml-rpc-value-to-xml-list
 397                                            (cdar value)))))
 398                    result (append result xmlval)
 399                    value (cdr value)))
 400       `((value nil ,(append '(struct nil) result)))))
 401    ;; Value is a scalar
 402    ((xml-rpc-value-intp value)
 403     `((value nil (int nil ,(int-to-string value)))))
 404    ((xml-rpc-value-stringp value)
 405     (let ((charset-list (find-charset-string value)))
 406       (if (or xml-rpc-allow-unicode-string
 407               (and (eq 1 (length charset-list))
 408                    (eq 'ascii (car charset-list)))
 409               (not xml-rpc-base64-encode-unicode))
 410           `((value nil (string nil ,value)))
 411         `((value nil (base64 nil ,(if xml-rpc-base64-encode-unicode
 412                                       (base64-encode-string
 413                                        (encode-coding-string
 414                                         value xml-rpc-use-coding-system))
 415                                     (base64-encode-string value))))))))
 416    ((xml-rpc-value-doublep value)
 417     `((value nil (double nil ,(number-to-string value)))))
 418    (t
 419     `((value nil (base64 nil ,(base64-encode-string value)))))))
 420
 421 (defun xml-rpc-xml-to-string (xml)
 422   "Return a string representation of the XML tree as valid XML markup."
 423   (let ((tree (xml-node-children xml))
 424         (result (concat "<" (symbol-name (xml-node-name xml)) ">")))
 425     (while tree
 426       (cond
 427        ((listp (car tree))
 428         (setq result (concat result (xml-rpc-xml-to-string (car tree)))))
 429        ((stringp (car tree))
 430         (setq result (concat result (car tree))))
 431        (t
 432         (error "Invalid XML tree")))
 433       (setq tree (cdr tree)))
 434     (setq result (concat result "</" (symbol-name (xml-node-name xml)) ">"))
 435     result))
 436
 437 ;;
 438 ;; Response handling
 439 ;;
 440
 441 (defsubst xml-rpc-response-errorp (response)
 442   "An 'xml-rpc-method-call'  result value is always a list, where the first \
 443 element in RESPONSE is either nil or if an error occured, a cons pair \
 444 according to (errnum .  \"Error string\"),"
 445   (eq 'fault (car-safe (caddar response))))
 446
 447 (defsubst xml-rpc-response-error-code (response)
 448   "Return the error code from RESPONSE."
 449   (and (xml-rpc-response-errorp response)
 450        (nth 1 (xml-rpc-xml-list-to-value response))))
 451
 452 (defsubst xml-rpc-response-error-string (response)
 453   "Return the error code from RESPONSE."
 454   (and (xml-rpc-response-errorp response)
 455        (nth 2 (xml-rpc-xml-list-to-value response))))
 456
 457 (defun xml-rpc-xml-to-response (xml)
 458   "Convert an XML list to a method response list.  An error is
 459 signaled if there is a fault or if the response does not appear
 460 to be an XML-RPC response (i.e. no methodResponse).  Otherwise,
 461 the parsed XML response is returned."
 462   ;; Check if we have a methodResponse
 463   (cond
 464    ((not (eq (car-safe (car-safe xml)) 'methodResponse))
 465     (error "No methodResponse found"))
 466
 467    ;; Did we get a fault response
 468    ((xml-rpc-response-errorp xml)
 469     (let ((resp (xml-rpc-xml-list-to-value xml)))
 470       (setq xml-rpc-fault-string (nth 2 resp))
 471       (setq xml-rpc-fault-code   (nth 1 resp))
 472       (error "XML-RPC fault `%s'" xml-rpc-fault-string)))
 473
 474    ;; Interpret the XML list and produce a more useful data structure
 475    (t
 476     (let ((valpart (cdr (cdaddr (caddar xml)))))
 477       (xml-rpc-xml-list-to-value valpart)))))
 478
 479 ;;
 480 ;; Method handling
 481 ;;
 482
 483 (defun xml-rpc-request (server-url xml &optional async-callback-function)
 484   "Perform http post request to SERVER-URL using XML.
 485
 486 If ASYNC-CALLBACK-FUNCTION is non-nil, the request will be performed
 487 asynchronously and ASYNC-CALLBACK-FUNCTION should be a callback function to
 488 be called when the reuest is finished.  ASYNC-CALLBACK-FUNCTION is called with
 489 a single argument being an xml.el style XML list.
 490
 491 It returns an XML list containing the method response from the XML-RPC server,
 492 or nil if called with ASYNC-CALLBACK-FUNCTION."
 493   (declare (special url-current-callback-data
 494                     url-current-callback-func
 495                     url-http-response-status))
 496   (unwind-protect
 497       (save-excursion
 498         (let ((url-request-method "POST")
 499               (url-package-name "xml-rpc.el")
 500               (url-package-version xml-rpc-version)
 501               (url-request-data (concat "<?xml version=\"1.0\""
 502                                         " encoding=\"UTF-8\"?>\n"
 503                                         (with-temp-buffer
 504                                           (xml-print xml)
 505                                           (when xml-rpc-allow-unicode-string
 506                                             (encode-coding-region
 507                                              (point-min) (point-max) 'utf-8))
 508                                           (buffer-string))
 509                                         "\n"))
 510               (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
 511               (url-request-coding-system xml-rpc-use-coding-system)
 512               (url-http-attempt-keepalives t)
 513               (url-request-extra-headers (list
 514                                           (cons "Connection" "keep-alive")
 515                                           (cons "Content-Type"
 516                                                 "text/xml; charset=utf-8"))))
 517           (when (> xml-rpc-debug 1)
 518             (print url-request-data (create-file-buffer "request-data")))
 519
 520           (cond ((boundp 'url-be-asynchronous) ; Sniff for w3 lib capability
 521                  (if async-callback-function
 522                      (setq url-be-asynchronous t
 523                            url-current-callback-data (list
 524                                                       async-callback-function
 525                                                       (current-buffer))
 526                            url-current-callback-func
 527                            'xml-rpc-request-callback-handler)
 528                    (setq url-be-asynchronous nil))
 529                  (url-retrieve server-url t)
 530
 531                  (when (not url-be-asynchronous)
 532                    (let ((result (xml-rpc-request-process-buffer
 533                                   (current-buffer))))
 534                      (when (> xml-rpc-debug 1)
 535                        (with-current-buffer (create-file-buffer "result-data")
 536                          (insert result)))
 537                      result)))
 538                 (t                      ; Post emacs20 w3-el
 539                  (if async-callback-function
 540                      (url-retrieve server-url async-callback-function)
 541                    (let ((buffer (url-retrieve-synchronously server-url))
 542                          result)
 543                      (with-current-buffer buffer
 544                        (when (not (numberp url-http-response-status))
 545                          ;; this error may occur when keep-alive bug
 546                          ;; of url-http.el is not cleared.
 547                          (error "Why? url-http-response-status is %s"
 548                                 url-http-response-status))
 549                        (when (> url-http-response-status 299)
 550                          (error "Error during request: %s"
 551                                 url-http-response-status)))
 552                      (xml-rpc-request-process-buffer buffer)))))))))
 553
 554
 555 (defun xml-rpc-clean-string (s)
 556   (if (string-match "\\`[ \t\n\r]*\\'" s)
 557       ;;"^[ \t\n]*$" s)
 558       nil
 559     s))
 560
 561 (defun xml-rpc-clean (l)
 562   (cond
 563    ((listp l)
 564     (let ((remain l)
 565           elem
 566           (result nil))
 567       (while l
 568         ;; iterate
 569         (setq elem (car l)
 570               l (cdr l))
 571         ;; test the head
 572         (cond
 573          ;; a string, so clean it.
 574          ((stringp elem)
 575           (let ((tmp (xml-rpc-clean-string elem)))
 576             (when (and tmp xml-rpc-allow-unicode-string)
 577               (setq tmp (decode-coding-string tmp xml-rpc-use-coding-system)))
 578             (if tmp
 579                 (setq result (append result (list tmp)))
 580               result)))
 581          ;; a list, so recurse.
 582          ((listp elem)
 583           (setq result (append result (list (xml-rpc-clean elem)))))
 584
 585          ;; everthing else, as is.
 586          (t
 587           (setq result (append result (list elem))))))
 588       result))
 589
 590    ((stringp l)                   ; will returning nil be acceptable ?
 591     nil)
 592
 593    (t l)))
 594
 595 (defun xml-rpc-request-process-buffer (xml-buffer)
 596   "Process buffer XML-BUFFER."
 597   (unwind-protect
 598       (with-current-buffer xml-buffer
 599         (when (fboundp 'url-uncompress)
 600           (let ((url-working-buffer xml-buffer))
 601             (url-uncompress)))
 602         (goto-char (point-min))
 603         (search-forward-regexp "<\\?xml" nil t)
 604         (move-to-column 0)
 605         ;; Gather the results
 606         (let* ((status (if (boundp 'url-http-response-status)
 607                            ;; Old URL lib doesn't save the result.
 608                            url-http-response-status 200))
 609                (result (cond
 610                         ;; A probable XML response
 611                         ((looking-at "<\\?xml ")
 612                          (xml-rpc-clean (xml-parse-region (point-min)
 613                                                           (point-max))))
 614
 615                         ;; No HTTP status returned
 616                         ((not status)
 617                          (let ((errstart
 618                                 (search-forward "\n---- Error was: ----\n")))
 619                            (and errstart
 620                                 (buffer-substring errstart (point-max)))))
 621
 622                         ;; Maybe they just gave us an the XML w/o PI?
 623                         ((search-forward "<methodResponse>" nil t)
 624                          (xml-rpc-clean (xml-parse-region (match-beginning 0)
 625                                                           (point-max))))
 626
 627                         ;; Valid HTTP status
 628                         (t
 629                          (int-to-string status)))))
 630           (when (< xml-rpc-debug 3)
 631             (kill-buffer (current-buffer)))
 632           result))))
 633
 634
 635 (defun xml-rpc-request-callback-handler (callback-fun xml-buffer)
 636   "Marshall a callback function request to CALLBACK-FUN with the results \
 637 handled from XML-BUFFER."
 638   (let ((xml-response (xml-rpc-request-process-buffer xml-buffer)))
 639     (when (< xml-rpc-debug 1)
 640       (kill-buffer xml-buffer))
 641     (funcall callback-fun (xml-rpc-xml-to-response xml-response))))
 642
 643
 644 (defun xml-rpc-method-call-async (async-callback-func server-url method
 645                                                       &rest params)
 646   "Call an XML-RPC method asynchronously at SERVER-URL named METHOD with \
 647 PARAMS as parameters. When the method returns, ASYNC-CALLBACK-FUNC will be \
 648 called with the result as parameter."
 649   (let* ((m-name (if (stringp method)
 650                      method
 651                    (symbol-name method)))
 652          (m-params (mapcar '(lambda (p)
 653                               `(param nil ,(car (xml-rpc-value-to-xml-list
 654                                                  p))))
 655                            (if async-callback-func
 656                                params
 657                              (car-safe params))))
 658          (m-func-call `((methodCall nil (methodName nil ,m-name)
 659                                     ,(append '(params nil) m-params)))))
 660     (when (> xml-rpc-debug 1)
 661       (print m-func-call (create-file-buffer "func-call")))
 662     (xml-rpc-request server-url m-func-call async-callback-func)))
 663
 664 (defun xml-rpc-method-call (server-url method &rest params)
 665   "Call an XML-RPC method at SERVER-URL named METHOD with PARAMS as \
 666 parameters."
 667   (let ((response
 668          (xml-rpc-method-call-async nil server-url method params)))
 669     (cond ((stringp response)
 670            (list (cons nil (concat "URL/HTTP Error: " response))))
 671           (t
 672            (xml-rpc-xml-to-response response)))))
 673
 674 (unless (fboundp 'xml-escape-string)
 675   (defun xml-debug-print (xml &optional indent-string)
 676     "Outputs the XML in the current buffer.
 677 XML can be a tree or a list of nodes.
 678 The first line is indented with the optional INDENT-STRING."
 679     (setq indent-string (or indent-string ""))
 680     (dolist (node xml)
 681       (xml-debug-print-internal node indent-string)))
 682
 683   (defalias 'xml-print 'xml-debug-print)
 684
 685   (when (not (boundp 'xml-entity-alist))
 686     (defvar xml-entity-alist
 687       '(("lt" . "<")
 688         ("gt" . ">")
 689         ("apos" . "'")
 690         ("quot" . "\"")
 691         ("amp" . "&"))))
 692
 693   (defun xml-escape-string (string)
 694     "Return the string with entity substitutions made from
 695 xml-entity-alist."
 696     (mapconcat (lambda (byte)
 697                  (let ((char (char-to-string byte)))
 698                    (if (rassoc char xml-entity-alist)
 699                        (concat "&" (car (rassoc char xml-entity-alist)) ";")
 700                      char)))
 701                ;; This differs from the non-unicode branch.  Just
 702                ;; grabbing the string works here.
 703                string ""))
 704
 705   (defun xml-debug-print-internal (xml indent-string)
 706     "Outputs the XML tree in the current buffer.
 707 The first line is indented with INDENT-STRING."
 708     (let ((tree xml)
 709           attlist)
 710       (insert indent-string ?< (symbol-name (xml-node-name tree)))
 711
 712       ;;  output the attribute list
 713       (setq attlist (xml-node-attributes tree))
 714       (while attlist
 715         (insert ?\  (symbol-name (caar attlist)) "=\""
 716                 (xml-escape-string (cdar attlist)) ?\")
 717         (setq attlist (cdr attlist)))
 718
 719       (setq tree (xml-node-children tree))
 720
 721       (if (null tree)
 722           (insert ?/ ?>)
 723         (insert ?>)
 724
 725         ;;  output the children
 726         (dolist (node tree)
 727           (cond
 728            ((listp node)
 729             (insert ?\n)
 730             (xml-debug-print-internal node (concat indent-string "  ")))
 731            ((stringp node)
 732             (insert (xml-escape-string node)))
 733            (t
 734             (error "Invalid XML tree"))))
 735
 736         (when (not (and (null (cdr tree))
 737                         (stringp (car tree))))
 738           (insert ?\n indent-string))
 739         (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>)))))
 740
 741 (let ((tdate (timezone-parse-date "20090101T010101Z")))
 742   (when (not (string-equal (aref tdate 0) "2009"))
 743     (defun timezone-parse-date (date)
 744       "Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE].
 745 Two-digit dates are `windowed'.  Those <69 have 2000 added; otherwise 1900
 746 is added.  Three-digit dates have 1900 added.
 747 TIMEZONE is nil for DATEs without a zone field.
 748
 749 Understands the following styles:
 750  (1) 14 Apr 89 03:20[:12] [GMT]
 751  (2) Fri, 17 Mar 89 4:01[:33] [GMT]
 752  (3) Mon Jan 16 16:12[:37] [GMT] 1989
 753  (4) 6 May 1992 1641-JST (Wednesday)
 754  (5) 22-AUG-1993 10:59:12.82
 755  (6) Thu, 11 Apr 16:17:12 91 [MET]
 756  (7) Mon, 6  Jul 16:47:20 T 1992 [MET]
 757  (8) 1996-06-24 21:13:12 [GMT]
 758  (9) 1996-06-24 21:13-ZONE
 759  (10) 19960624T211312"
 760       ;; Get rid of any text properties.
 761       (and (stringp date)
 762            (or (text-properties-at 0 date)
 763                (next-property-change 0 date))
 764            (setq date (copy-sequence date))
 765            (set-text-properties 0 (length date) nil date))
 766       (let ((date (or date ""))
 767             (year nil)
 768             (month nil)
 769             (day nil)
 770             (time nil)
 771             (zone nil))                 ;This may be nil.
 772         (cond ((string-match
 773                 "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)" date)
 774                ;; Styles: (1) and (2) with timezone and buggy timezone
 775                ;; This is most common in mail and news,
 776                ;; so it is worth trying first.
 777                (setq year 3 month 2 day 1 time 4 zone 5))
 778               ((string-match
 779                 "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\'" date)
 780                ;; Styles: (1) and (2) without timezone
 781                (setq year 3 month 2 day 1 time 4 zone nil))
 782               ((string-match
 783                 "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\'" date)
 784                ;; Styles: (6) and (7) without timezone
 785                (setq year 6 month 3 day 2 time 4 zone nil))
 786               ((string-match
 787                 "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
 788                ;; Styles: (6) and (7) with timezone and buggy timezone
 789                (setq year 6 month 3 day 2 time 4 zone 7))
 790               ((string-match
 791                 "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([0-9]+\\)" date)
 792                ;; Styles: (3) without timezone
 793                (setq year 4 month 1 day 2 time 3 zone nil))
 794               ((string-match
 795                 "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)[ \t]+\\([0-9]+\\)" date)
 796                ;; Styles: (3) with timezone
 797                (setq year 5 month 1 day 2 time 3 zone 4))
 798               ((string-match
 799                 "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
 800                ;; Styles: (4) with timezone
 801                (setq year 3 month 2 day 1 time 4 zone 5))
 802               ((string-match
 803                 "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)?[ \t]+\\([-+a-zA-Z0-9]+\\)" date)
 804                ;; Styles: (5) with timezone.
 805                (setq year 3 month 2 day 1 time 4 zone 6))
 806               ((string-match
 807                 "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)?" date)
 808                ;; Styles: (5) without timezone.
 809                (setq year 3 month 2 day 1 time 4 zone nil))
 810               ((string-match
 811                 "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)" date)
 812                ;; Styles: (8) with timezone.
 813                (setq year 1 month 2 day 3 time 4 zone 5))
 814               ((string-match
 815                 "\\([0-9]\\{4\\}\\)-?\\([0-9]\\{0,2\\}\\)-?\\([0-9]\\{0,2\\}\\)[T \t]+\\([0-9]\\{0,2\\}:?[0-9]\\{0,2\\}:?[0-9]\\{0,2\\}\\)[ \t]*\\([-+a-zA-Z]+[0-9:]*\\)" date)
 816                ;; Styles: (8) with timezone with a colon in it.
 817                (setq year 1 month 2 day 3 time 4 zone 5))
 818               ((string-match
 819                 "\\([0-9]\\{4\\}\\)-?\\([0-9]\\{0,2\\}\\)-?\\([0-9]\\{0,2\\}\\)[T \t]+\\([0-9]+:?[0-9]+:?[0-9]+\\)" date)
 820                ;; Styles: (8) without timezone.
 821                (setq year 1 month 2 day 3 time 4 zone nil)))
 822
 823         (when year
 824           (setq year (match-string year date))
 825           ;; Guess ambiguous years.  Assume years < 69 don't predate the
 826           ;; Unix Epoch, so are 2000+.  Three-digit years are assumed to
 827           ;; be relative to 1900.
 828           (when (< (length year) 4)
 829             (let ((y (string-to-number year)))
 830               (when (< y 69)
 831                 (setq y (+ y 100)))
 832               (setq year (int-to-string (+ 1900 y)))))
 833           (setq month
 834                 (if (or (= (aref date (+ (match-beginning month) 2)) ?-)
 835                         (let ((n (string-to-number
 836                                   (char-to-string
 837                                    (aref date (+ (match-beginning month) 2))))))
 838                           (= (aref (number-to-string n) 0)
 839                              (aref date (+ (match-beginning month) 2)))))
 840                     ;; Handle numeric months, spanning exactly two digits.
 841                     (substring date
 842                                (match-beginning month)
 843                                (+ (match-beginning month) 2))
 844                   (let* ((string (substring date
 845                                             (match-beginning month)
 846                                             (+ (match-beginning month) 3)))
 847                          (monthnum
 848                           (cdr (assoc (upcase string) timezone-months-assoc))))
 849                     (when monthnum
 850                       (int-to-string monthnum)))))
 851           (setq day (match-string day date))
 852           (setq time (match-string time date)))
 853         (when zone (setq zone (match-string zone date)))
 854         ;; Return a vector.
 855         (if (and year month)
 856             (vector year month day time zone)
 857           (vector "0" "0" "0" "0" nil))))))
 858
 859 (provide 'xml-rpc)
 860
 861 ;; Local Variables:
 862 ;; time-stamp-pattern: "20/^;; Last Modified: <%%>$"
 863 ;; End:
 864
 865 ;;; xml-rpc.el ends here