[nongnu] elpa/xml-rpc 47007ef094 54/64: Merge pull request #14 from skangas/libxml-parse-xml-region

[Stefan Kangas]

branch: elpa/xml-rpc
commit 47007ef094ea741eef4414fee5fc335e9b310e67
Merge: 4efc188b7f bd359a86b1
Author: Mark A. Hershberger <mah@everybody.org>
Commit: GitHub <noreply@github.com>

    Merge pull request #14 from skangas/libxml-parse-xml-region
    
    Use libxml when available to significantly improve performance
---
 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 fa55525a12..fc2ddee211 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")
 
@@ -687,9 +694,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)
@@ -700,15 +709,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)