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.

4 files changed, 105 insertions, 61 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 8b0741bec6e..9552078ddb8 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,20 @@
+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.
diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el
index a79738a283f..6460ee79604 100644
--- a/lisp/gnus/eww.el
+++ b/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)
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index b025f7cc601..948b2a2fd1c 100644
--- a/lisp/gnus/mm-decode.el
+++ b/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)
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index be8ffb02581..b394607dbff 100644
--- a/lisp/gnus/shr.el
+++ b/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-sliced-image image (or alt "*") nil 20 1)
             (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: