Convert shr.el from using overlays into using text properties

* eww.el (eww-mode-map): Use `shr-next-link' (etc) instead of the
widget commands, since we're no longer using widgets for links.

* mm-decode.el (mm-convert-shr-links): New function to convert
new-style shr URL links into widgets.
(mm-shr): Use it.

* shr.el (shr-next-link): New command.
(shr-previous-link): New command.
(shr-urlify): Don't use `widget-convert', because that's slow.
(shr-put-color-1): Use `add-face-text-property' instead of overlays,
because collecting the overlays and reapplying them when generating
tables is slow.
(shr-insert-table): Ditto.

lisp/gnus/ChangeLog

+2013-06-17  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* mm-decode.el (mm-convert-shr-links): New function to convert
+	new-style shr URL links into widgets.
+	(mm-shr): Use it.
+
+	* eww.el (eww-mode-map): Use `shr-next-link' (etc) instead of the
+	widget commands, since we're no longer using widgets for links.
+
+	* shr.el (shr-next-link): New command.
+	(shr-previous-link): New command.
+	(shr-urlify): Don't use `widget-convert', because that's slow.
+	(shr-put-color-1): Use `add-face-text-property' instead of overlays,
+	because collecting the overlays and reapplying them when generating
+	tables is slow.
+	(shr-insert-table): Ditto.
+
 2013-06-17  Stefan Monnier  <monnier@iro.umontreal.ca>
 	* sieve.el (sieve-edit-script): Avoid beginning-of-buffer.

lisp/gnus/eww.el

@@ -206,8 +206,8 @@
     (suppress-keymap map)
     (define-key map "q" 'eww-quit)
     (define-key map "g" 'eww-reload)
-    (define-key map [tab] 'widget-forward)
-    (define-key map [backtab] 'widget-backward)
+    (define-key map [tab] 'shr-next-link)
+    (define-key map [backtab] 'shr-previous-link)
     (define-key map [delete] 'scroll-down-command)
     (define-key map "\177" 'scroll-down-command)
     (define-key map " " 'scroll-up-command)

lisp/gnus/mm-decode.el

@@ -1809,6 +1809,7 @@ If RECURSIVE, search recursively."
 	 (libxml-parse-html-region (point-min) (point-max))))
       (unless (bobp)
 	(insert "\n"))
+      (mm-convert-shr-links)
       (mm-handle-set-undisplayer
        handle
        `(lambda ()
@@ -1816,6 +1817,20 @@ If RECURSIVE, search recursively."
 	    (delete-region ,(point-min-marker)
 			   ,(point-max-marker))))))))
 
+(defun mm-convert-shr-links ()
+  (let ((start (point-min))
+	end)
+    (while (and start
+		(< start (point-max)))
+      (when (setq start (text-property-not-all start (point-max) 'shr-url nil))
+	(setq end (next-single-property-change start 'shr-url nil (point-max)))
+	(widget-convert-button
+	 'url-link start end
+	 :help-echo (get-text-property start 'help-echo)
+	 :keymap shr-map
+	 (get-text-property start 'shr-url))
+	(setq start end)))))
+
 (defun mm-handle-filename (handle)
   "Return filename of HANDLE if any."
   (or (mail-content-type-get (mm-handle-type handle)

lisp/gnus/shr.el

@@ -131,6 +131,8 @@ cid: URL as the argument.")
     (define-key map "a" 'shr-show-alt-text)
     (define-key map "i" 'shr-browse-image)
     (define-key map "z" 'shr-zoom-image)
+    (define-key map [tab] 'shr-next-link)
+    (define-key map [backtab] 'shr-previous-link)
     (define-key map "I" 'shr-insert-image)
     (define-key map "u" 'shr-copy-url)
     (define-key map "v" 'shr-browse-url)
@@ -217,6 +219,40 @@ redirects somewhere else."
 	(copy-region-as-kill (point-min) (point-max))
 	(message "Copied %s" url))))))
 
+(defun shr-next-link ()
+  "Skip to the next link."
+  (interactive)
+  (let ((skip (text-property-any (point) (point-max) 'shr-url nil)))
+    (if (not (setq skip (text-property-not-all skip (point-max)
+					       'shr-url nil)))
+	(message "No next link")
+      (goto-char skip)
+      (message "%s" (get-text-property (point) 'help-echo)))))
+
+(defun shr-previous-link ()
+  "Skip to the previous link."
+  (interactive)
+  (let ((start (point))
+	(found nil))
+    ;; Skip past the current link.
+    (while (and (not (bobp))
+		(get-text-property (point) 'shr-url))
+      (forward-char -1))
+    ;; Find the previous link.
+    (while (and (not (bobp))
+		(not (setq found (get-text-property (point) 'shr-url))))
+      (forward-char -1))
+    (if (not found)
+	(progn
+	  (message "No previous link")
+	  (goto-char start))
+      ;; Put point at the start of the link.
+      (while (and (not (bobp))
+		  (get-text-property (point) 'shr-url))
+	(forward-char -1))
+      (forward-char 1)
+      (message "%s" (get-text-property (point) 'help-echo)))))
+
 (defun shr-show-alt-text ()
   "Show the ALT text of the image under point."
   (interactive)
@@ -578,17 +614,16 @@ size, and full-buffer size."
     (overlay-put overlay 'evaporate t)
     overlay))
 
-;; Add an overlay in the region, but avoid putting the font properties
-;; on blank text at the start of the line, and the newline at the end,
-;; to avoid ugliness.
+;; Add face to the region, but avoid putting the font properties on
+;; blank text at the start of the line, and the newline at the end, to
+;; avoid ugliness.
 (defun shr-add-font (start end type)
   (save-excursion
     (goto-char start)
     (while (< (point) end)
       (when (bolp)
 	(skip-chars-forward " "))
-      (let ((overlay (shr-make-overlay (point) (min (line-end-position) end))))
-	(overlay-put overlay 'face type))
+      (add-face-text-property (point) (min (line-end-position) end) type)
       (if (< (line-end-position) end)
 	  (forward-line 1)
 	(goto-char end)))))
@@ -678,10 +713,7 @@ size, and full-buffer size."
 		     (> (car (image-size image t)) 400))
 	    (insert "\n"))
 	  (if (eq size 'original)
-	      (let ((overlays (overlays-at (point))))
 	      (insert-sliced-image image (or alt "*") nil 20 1)
-		(dolist (overlay overlays)
-		  (overlay-put overlay 'face 'default)))
 	    (insert-image image (or alt "*")))
 	  (put-text-property start (point) 'image-size size)
 	  (when (cond ((fboundp 'image-multi-frame-p)
@@ -769,16 +801,13 @@ START, and END.  Note that START and END should be markers."
   (apply #'shr-fontize-cont cont types)
   (shr-ensure-paragraph))
 
-(autoload 'widget-convert-button "wid-edit")
-
 (defun shr-urlify (start url &optional title)
-  (widget-convert-button
-   'url-link start (point)
-   :help-echo (if title (format "%s (%s)" url title) url)
-   :keymap shr-map
-   url)
   (shr-add-font start (point) 'shr-link)
-  (put-text-property start (point) 'shr-url url))
+  (add-text-properties
+   start (point)
+   (list 'shr-url url
+	 'local-map shr-map
+	 'help-echo (if title (format "%s (%s)" url title) url))))
 
 (defun shr-encode-url (url)
   "Encode URL."
@@ -860,7 +889,7 @@ ones, in case fg and bg are nil."
 	(when (and (< (setq column (current-column)) width)
 		   (< (setq column (shr-previous-newline-padding-width column))
 		      width))
-	  (let ((overlay (shr-make-overlay (point) (1+ (point)))))
+	  (let ((overlay (make-overlay (point) (1+ (point)))))
 	    (overlay-put overlay 'before-string
 			 (concat
 			  (mapconcat
@@ -898,8 +927,7 @@ ones, in case fg and bg are nil."
     (while (< start end)
       (setq change (next-single-property-change start 'face nil end))
       (when do-put
-	(put-text-property start change 'face
-			   (nconc (list type color) old-props)))
+	(add-face-text-property start change (list type color)))
       (setq old-props (get-text-property change 'face))
       (setq do-put (and (listp old-props)
                         (not (memq type old-props))))
@@ -1172,10 +1200,9 @@ ones, in case fg and bg are nil."
 (defun shr-tag-span (cont)
   (let ((title (cdr (assq :title cont))))
     (shr-generic cont)
-    (when title
-      (when shr-start
-        (let ((overlay (shr-make-overlay shr-start (point))))
-          (overlay-put overlay 'help-echo title))))))
+    (when (and title
+	       shr-start)
+      (put-text-property shr-start (point) 'help-echo title))))
 
 (defun shr-tag-h1 (cont)
   (shr-heading cont 'bold 'underline))
@@ -1341,19 +1368,10 @@ ones, in case fg and bg are nil."
 	(insert shr-table-vertical-line "\n"))
       (dolist (column row)
 	(goto-char start)
-	(let ((lines (nth 2 column))
-	      (overlay-lines (nth 3 column))
-	      overlay overlay-line)
+	(let ((lines (nth 2 column)))
 	  (dolist (line lines)
-	    (setq overlay-line (pop overlay-lines))
 	    (end-of-line)
 	    (insert line shr-table-vertical-line)
-	    (dolist (overlay overlay-line)
-	      (let ((o (shr-make-overlay (- (point) (nth 0 overlay) 1)
-					 (- (point) (nth 1 overlay) 1)))
-		    (properties (nth 2 overlay)))
-		(while properties
-		  (overlay-put o (pop properties) (pop properties)))))
 	    (forward-line 1))
 	  ;; Add blank lines at padding at the bottom of the TD,
 	  ;; possibly.
@@ -1441,7 +1459,7 @@ ones, in case fg and bg are nil."
 	  (fgcolor (cdr (assq :fgcolor cont)))
 	  (style (cdr (assq :style cont)))
 	  (shr-stylesheet shr-stylesheet)
-	  overlays actual-colors)
+	  actual-colors)
       (when style
 	(setq style (and (string-match "color" style)
 			 (shr-parse-style style))))
@@ -1489,7 +1507,7 @@ ones, in case fg and bg are nil."
 	    (list max
 		  (count-lines (point-min) (point-max))
 		  (split-string (buffer-string) "\n")
-		  (shr-collect-overlays)
+		  nil
 		  (car actual-colors))
 	  max)))))
 
@@ -1502,29 +1520,6 @@ ones, in case fg and bg are nil."
       (forward-line 1))
     max))
 
-(defun shr-collect-overlays ()
-  (save-excursion
-    (goto-char (point-min))
-    (let ((overlays nil))
-      (while (not (eobp))
-	(push (shr-overlays-in-region (point) (line-end-position))
-	      overlays)
-	(forward-line 1))
-      (nreverse overlays))))
-
-(defun shr-overlays-in-region (start end)
-  (let (result)
-    (dolist (overlay (overlays-in start end))
-      (push (list (if (> start (overlay-start overlay))
-		      (- end start)
-		    (- end (overlay-start overlay)))
-		  (if (< end (overlay-end overlay))
-		      0
-		    (- end (overlay-end overlay)))
-		  (overlay-properties overlay))
-	    result))
-    (nreverse result)))
-
 (defun shr-pro-rate-columns (columns)
   (let ((total-percentage 0)
 	(widths (make-vector (length columns) 0)))
@@ -1570,6 +1565,23 @@ ones, in case fg and bg are nil."
 			      (shr-count (cdr row) 'th))))))
     max))
 
+;; Emacs less than 24.3
+(unless (fboundp 'add-face-text-property)
+  (defun add-face-text-property (beg end face)
+    "Combine FACE BEG and END."
+    (let ((b beg))
+      (while (< b end)
+	(let ((oldval (get-text-property b 'face)))
+	  (put-text-property
+	   b (setq b (next-single-property-change b 'face nil end))
+	   'face (cond ((null oldval)
+			face)
+		       ((and (consp oldval)
+			     (not (keywordp (car oldval))))
+			(cons face oldval))
+		       (t
+			(list face oldval)))))))))
+
 (provide 'shr)
 
 ;; Local Variables: