From: Basil L. Contovounesios <contovob@tcd.ie>
Date: Thu, 7 May 2020 23:25:38 +0000 (+0100)
Subject: Propertize all shr fragment IDs as shr-target-id
X-Git-Tag: emacs-28.0.90~7147
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3dd6b23cdfa64bdff2bdc9e7fbf9844a2ed6cd8f;p=emacs.git

Propertize all shr fragment IDs as shr-target-id

* lisp/net/shr.el (shr-target-id): Add docstring.
(shr-descend, shr-tag-a): Display dummy anchor characters as the
empty string.  Give all relevant 'id' or 'name' fragment identifier
attributes the shr-target-id text property.  This ensures that
cached content, such as tables, retains the property across
renders.  (Bug#40532)

* lisp/net/eww.el: (eww-display-html): Adapt shr-target-id property
search accordingly.
---

diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index cf31d37f072..2f6528de948 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -25,13 +25,14 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'mm-url)
+(require 'puny)
 (require 'shr)
+(require 'text-property-search)
+(require 'thingatpt)
 (require 'url)
 (require 'url-queue)
-(require 'thingatpt)
-(require 'mm-url)
-(require 'puny)
-(eval-when-compile (require 'subr-x)) ;; for string-trim
+(eval-when-compile (require 'subr-x))
 
 (defgroup eww nil
   "Emacs Web Wowser"
@@ -542,10 +543,10 @@ Currently this means either text/html or application/xhtml+xml."
 	  (goto-char point))
 	 (shr-target-id
 	  (goto-char (point-min))
-	  (let ((point (next-single-property-change
-			(point-min) 'shr-target-id)))
-	    (when point
-	      (goto-char point))))
+          (let ((match (text-property-search-forward
+                        'shr-target-id shr-target-id t)))
+            (when match
+              (goto-char (prop-match-beginning match)))))
 	 (t
 	  (goto-char (point-min))
 	  ;; Don't leave point inside forms, because the normal eww
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 03260c9e70a..a3f04968a27 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -185,13 +185,15 @@ and other things:
 (defvar shr-depth 0)
 (defvar shr-warning nil)
 (defvar shr-ignore-cache nil)
-(defvar shr-target-id nil)
 (defvar shr-table-separator-length 1)
 (defvar shr-table-separator-pixel-width 0)
 (defvar shr-table-id nil)
 (defvar shr-current-font nil)
 (defvar shr-internal-bullet nil)
 
+(defvar shr-target-id nil
+  "Target fragment identifier anchor.")
+
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
     (define-key map "a" 'shr-show-alt-text)
@@ -526,13 +528,13 @@ size, and full-buffer size."
                (funcall function dom))
               (t
                (shr-generic dom)))
-	(when (and shr-target-id
-		   (equal (dom-attr dom 'id) shr-target-id))
+        (when-let* ((id (dom-attr dom 'id)))
 	  ;; If the element was empty, we don't have anything to put the
 	  ;; anchor on.  So just insert a dummy character.
 	  (when (= start (point))
-	    (insert "*"))
-	  (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+            (insert ?*)
+            (put-text-property (1- (point)) (point) 'display ""))
+          (put-text-property start (1+ start) 'shr-target-id id))
 	;; If style is set, then this node has set the color.
 	(when style
 	  (shr-colorize-region
@@ -1486,14 +1488,13 @@ ones, in case fg and bg are nil."
 	(start (point))
 	shr-start)
     (shr-generic dom)
-    (when (and shr-target-id
-	       (equal (dom-attr dom 'name) shr-target-id))
-      ;; We have a zero-length <a name="foo"> element, so just
-      ;; insert...  something.
+    (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'.
+                      (dom-attr dom 'name))))  ; Obsolete since HTML5.
+      ;; We have an empty element, so just insert... something.
       (when (= start (point))
-	(shr-ensure-newline)
-	(insert " "))
-      (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+        (insert ?\s)
+        (put-text-property (1- (point)) (point) 'display ""))
+      (put-text-property start (1+ start) 'shr-target-id id))
     (when url
       (shr-urlify (or shr-start start) (shr-expand-url url) title))))