Fix DOM printing

Fix DOM printing when an attribute value is not a string, which is
often the case in SVG DOM.  Don't print attributes without a
value.  Refresh the list of HTML boolean attributes.
* lisp/dom.el (dom--html-boolean-attribute-p): New function.
(dom-print): Use it.  Convert attribute value to string before to
call `url-insert-entities-in-string'.  Don't print attribute
without a value.  Compute indentation column outside of loop and
call `indent-line-to' to indent line.  (Bug#5928)

* test/lisp/dom-tests.el (dom-tests-print-svg)
(dom-tests-print-html-boolean): New tests.

(cherry picked from commit 7ad139d72108df78763b570b376fbe4aad952f72)

diff --git a/lisp/dom.el b/lisp/dom.el
index 46b6e6c755d1e61972c85407a5b9b0b97515234b..919f5397c3979b54783d3053d95e2af489c9cf2b 100644 (file)
--- a/lisp/dom.el
+++ b/lisp/dom.el
@@ -258,31 +258,41 @@ white-space."
              (insert ")")
            (insert "\n" (make-string (1+ column) ?\s))))))))
 
+(define-inline dom--html-boolean-attribute-p (attr)
+  "Return non-nil if ATTR is an HTML boolean attribute."
+  (inline-quote
+   (memq ,attr
+         ;; Extracted from the HTML Living Standard list of attributes
+         ;; at <https://html.spec.whatwg.org/#attributes-3>.
+         '( allowfullscreen alpha async autofocus autoplay checked
+            controls default defer disabled formnovalidate inert ismap
+            itemscope loop multiple muted nomodule novalidate open
+            playsinline readonly required reversed selected
+            shadowrootclonable shadowrootdelegatesfocus
+            shadowrootserializable))))
+
 (defun dom-print (dom &optional pretty xml)
   "Print DOM at point as HTML/XML.
 If PRETTY, indent the HTML/XML logically.
 If XML, generate XML instead of HTML."
-  (let ((column (current-column)))
+  (let ((column (current-column))
+        (indent-tabs-mode nil)) ;; Indent with spaces
     (insert (format "<%s" (dom-tag dom)))
-    (let ((attr (dom-attributes dom)))
-      (dolist (elem attr)
-       ;; In HTML, these are boolean attributes that should not have
-       ;; an = value.
-       (insert (if (and (memq (car elem)
-                              '(async autofocus autoplay checked
-                                contenteditable controls default
-                                defer disabled formNoValidate frameborder
-                                hidden ismap itemscope loop
-                                multiple muted nomodule novalidate open
-                                readonly required reversed
-                                scoped selected typemustmatch))
-                        (cdr elem)
-                        (not xml))
-                   (format " %s" (car elem))
-                 (format " %s=\"%s\"" (car elem)
-                         (url-insert-entities-in-string (cdr elem)))))))
+    (pcase-dolist (`(,attr . ,value) (dom-attributes dom))
+      ;; Don't print attributes without a value.
+      (when value
+        (insert
+         ;; HTML boolean attributes should not have an = value.  The
+         ;; presence of a boolean attribute on an element represents
+         ;; the true value, and the absence of the attribute
+         ;; represents the false value.
+         (if (and (not xml) (dom--html-boolean-attribute-p attr))
+             (format " %s" attr)
+           (format " %s=%S" attr (url-insert-entities-in-string
+                                  (format "%s" value)))))))
     (let* ((children (dom-children dom))
-          (non-text nil))
+          (non-text nil)
+           (indent (+ column 2)))
       (if (null children)
          (insert " />")
        (insert ">")
@@ -291,16 +301,14 @@ If XML, generate XML instead of HTML."
              (insert (url-insert-entities-in-string child))
            (setq non-text t)
            (when pretty
-              (insert "\n" (make-string (+ column 2) ?\s)))
+              (insert "\n")
+              (indent-line-to indent))
            (dom-print child pretty xml)))
        ;; If we inserted non-text child nodes, or a text node that
        ;; ends with a newline, then we indent the end tag.
-        (when (and pretty
-                  (or (bolp)
-                      non-text))
-         (unless (bolp)
-            (insert "\n"))
-         (insert (make-string column ?\s)))
+        (when (and pretty (or (bolp) non-text))
+         (or (bolp) (insert "\n"))
+         (indent-line-to column))
         (insert (format "</%s>" (dom-tag dom)))))))
 
 (provide 'dom)

diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el
index 47c2a7bb569d061bf6986a90d01dac4afaeba359..eecc4f398087c91a6ed2dc90bf36f5acabc9ce65 100644 (file)
--- a/test/lisp/dom-tests.el
+++ b/test/lisp/dom-tests.el
@@ -27,6 +27,7 @@
 ;;; Code:
 
 (require 'dom)
+(require 'svg)
 (require 'ert)
 
 ;; `defsubst's are not inlined inside `ert-deftest' (see Bug#24402),
@@ -219,6 +220,59 @@ child results in an error."
                      "<div class="default"> </div>"
                      "</samp>")))))
 
+(ert-deftest dom-tests-print-svg ()
+  "Test that `dom-print' correctly print a SVG DOM."
+  (let ((svg (svg-create 100 100)))
+    (svg-rectangle svg 0 0 "100%" "100%" :fill "blue")
+    (svg-text svg "A text" :x 0 :y 55 :stroke "yellow" :fill "yellow")
+    (with-temp-buffer
+      (dom-print svg t t)
+      (should
+       (equal
+        (buffer-string)
+        (concat
+         "<svg width=\"100\" height=\"100\" version=\"1.1\" "
+         "xmlns=\"http://www.w3.org/2000/svg\" "
+         "xmlns:xlink=\"http://www.w3.org/1999/xlink\">\n"
+         "  <rect width=\"100%\" height=\"100%\" x=\"0\" y=\"0\" fill=\"blue\" />\n"
+         "  <text fill=\"yellow\" stroke=\"yellow\" y=\"55\" x=\"0\">A text</text>\n"
+         "</svg>"))))))
+
+(ert-deftest dom-tests-print-html-boolean ()
+  "Test that `dom-print' correctly print HTML boolean attributes."
+  (let ((dom (dom-node
+              "html" nil
+              (dom-node "head" nil
+                        (dom-node "title" nil
+                                  "Test boolean attributes"))
+              (dom-node "body" nil
+                        ;; The following checkboxes are checked
+                        (dom-node "input" '((type . "checkbox")
+                                            (checked . "")))
+                        (dom-node "input" '((type . "checkbox")
+                                            (checked . "checked")))
+                        (dom-node "input" '((type . "checkbox")
+                                            (checked . "true")))
+                        (dom-node "input" '((type . "checkbox")
+                                            (checked . "false")))
+                        ;; The following checkbox is not checked
+                        (dom-node "input" '((type . "checkbox")
+                                            (checked)))
+                        ))))
+    (with-temp-buffer
+      (dom-print dom)
+      (should
+       (equal
+        (buffer-string)
+        (concat
+         "<html><head><title>Test boolean attributes</title></head><body>"
+         "<input type=\"checkbox\" checked />"
+         "<input type=\"checkbox\" checked />"
+         "<input type=\"checkbox\" checked />"
+         "<input type=\"checkbox\" checked />"
+         "<input type=\"checkbox\" />"
+         "</body></html>"))))))
+
 (ert-deftest dom-test-search ()
   (let ((dom '(a nil (b nil (c nil)))))
     (should (equal (dom-search dom (lambda (d) (eq (dom-tag d) 'a)))