[nongnu] elpa/xml-rpc bd359a86b1 47/64: Use libxml-parse-xml-region when available

[Stefan Kangas]

branch: elpa/xml-rpc
commit bd359a86b1cd59f99732c91a6fbd1f4a6a32ba9f
Author: Stefan Kangas <stefankangas@gmail.com>
Commit: Stefan Kangas <stefankangas@gmail.com>

    Use libxml-parse-xml-region when available
---
 xml-rpc-test.el | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 xml-rpc.el      | 28 ++++++++++++++++++++++------
 2 files changed, 72 insertions(+), 6 deletions(-)

diff --git a/xml-rpc-test.el b/xml-rpc-test.el
index c84c47a728..1d6f1cf7d2 100644
--- a/xml-rpc-test.el
+++ b/xml-rpc-test.el
@@ -8,3 +8,53 @@
   (should (eq (xml-rpc-value-structp '(("foo"))) t))
   (should (eq (xml-rpc-value-structp '(("foo" . "bar"))) t))
   (should (eq (xml-rpc-value-structp '(("foo" :datetime (12345 12345)))) t)))
+
+(defconst xml-rpc-test-http-data
+  "HTTP/1.1 200 OK
+Date: Sun, 06 Sep 2020 00:48:09 GMT
+Server: Apache/2.4.46 (Debian)
+Vary: Accept-Encoding
+Content-Length: 123
+Connection: close
+Content-Type: text/xml
+
+<?xml version=\"1.0\" encoding=\"UTF-8\"?>
+<methodResponse>
+<params>
+<param><value><string>0.9.8</string></value></param>
+</params>
+</methodResponse>")
+
+(defconst xml-rpc-test-scgi-data
+  "Status: 200 OK
+Content-Type: text/xml
+Content-Length: 152
+
+<?xml version=\"1.0\" encoding=\"UTF-8\"?>
+<methodResponse>
+<params>
+<param><value><string>0.9.8</string></value></param>
+</params>
+</methodResponse>
")
+
+(defconst xml-rpc-test-result
+  '((methodResponse nil (params nil (param nil (value nil (string nil 
"0.9.8")))))))
+
+(ert-deftest test-xml-rpc-request-process-buffer/xml.el ()
+  (let ((xml-rpc-parse-region-function #'xml-parse-region))
+    (dolist (data (list xml-rpc-test-http-data
+                        xml-rpc-test-scgi-data))
+      (with-temp-buffer
+        (insert data)
+        (should (equal (xml-rpc-request-process-buffer (current-buffer))
+                       xml-rpc-test-result))))))
+
+(ert-deftest test-xml-rpc-request-process-buffer/libxml ()
+  (skip-unless (fboundp 'libxml-available-p))
+  (let ((xml-rpc-parse-region-function #'libxml-parse-xml-region))
+    (dolist (data (list xml-rpc-test-http-data
+                        xml-rpc-test-scgi-data))
+      (with-temp-buffer
+        (insert data)
+        (should (equal (xml-rpc-request-process-buffer (current-buffer))
+                       xml-rpc-test-result))))))
diff --git a/xml-rpc.el b/xml-rpc.el
index 6d3334db46..f58c1dad32 100644
--- a/xml-rpc.el
+++ b/xml-rpc.el
@@ -244,6 +244,13 @@ utf-8 coding system."
 Set it higher to get some info in the *Messages* buffer"
   :type 'integer :group 'xml-rpc)
 
+(defvar xml-rpc-parse-region-function
+  (if (and (fboundp 'libxml-available-p)
+           (libxml-available-p))
+      #'libxml-parse-xml-region
+    #'xml-parse-region)
+  "Function to use for parsing XML data.")
+
 (defvar xml-rpc-fault-string nil
   "Contains the fault string if a fault is returned")
 
@@ -682,9 +689,11 @@ or nil if called with ASYNC-CALLBACK-FUNCTION."
                            url-http-response-status 200))
                (result (cond
                         ;; A probable XML response
-                        ((looking-at "<\\?xml ")
-                         (xml-rpc-clean (xml-parse-region (point-min)
-                                                          (point-max))))
+                        ((search-forward "<?xml " nil t)
+                         (xml-rpc-clean
+                          (funcall xml-rpc-parse-region-function
+                                   (match-beginning 0)
+                                   (point-max))))
 
                         ;; No HTTP status returned
                         ((not status)
@@ -695,15 +704,22 @@ or nil if called with ASYNC-CALLBACK-FUNCTION."
 
                         ;; 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))))
+                         (xml-rpc-clean
+                          (funcall xml-rpc-parse-region-function
+                                   (match-beginning 0)
+                                   (point-max))))
 
                         ;; Valid HTTP status
                         (t
                          (int-to-string status)))))
           (when (< xml-rpc-debug 3)
             (kill-buffer (current-buffer)))
-          result))))
+          ;; Normalize result: `libxml-parse-xml-region' gives response like
+          ;; `(methodResponse ...)' but `xml-parse-region' gives
+          ;; `((methodResponse ...))'.
+          (if (eq xml-rpc-parse-region-function 'libxml-parse-xml-region)
+              (list result)
+            result)))))
 
 
 (defun xml-rpc-request-callback-handler (callback-fun xml-buffer)