[Emacs-diffs] trunk r113014: Convert shr.el from using overlays into using text properties

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 113014
revision-id: address@hidden
parent: address@hidden
author: Lars Magne Ingebrigtsen <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Mon 2013-06-17 09:19:50 +0000
message:
  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.
modified:
  lisp/gnus/ChangeLog            changelog-20091113204419-o5vbwnq5f7feedwu-1433
  lisp/gnus/eww.el               eww.el-20130610114603-80ap3gwnw4x4m5ix-1
  lisp/gnus/mm-decode.el         
mmdecode.el-20091113204419-o5vbwnq5f7feedwu-1971
  lisp/gnus/shr.el               shr.el-20101002102929-yfzewk55rsg0mn93-1

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2013-06-17 00:49:49 +0000
+++ b/lisp/gnus/ChangeLog       2013-06-17 09:19:50 +0000
@@ -1,3 +1,20 @@
+2013-06-17  Lars Magne Ingebrigtsen  <address@hidden>
+
+       * 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  <address@hidden>
 
        * sieve.el (sieve-edit-script): Avoid beginning-of-buffer.

=== modified file 'lisp/gnus/eww.el'
--- a/lisp/gnus/eww.el  2013-06-17 00:49:49 +0000
+++ b/lisp/gnus/eww.el  2013-06-17 09:19:50 +0000
@@ -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)

=== modified file 'lisp/gnus/mm-decode.el'
--- a/lisp/gnus/mm-decode.el    2013-05-23 05:05:27 +0000
+++ b/lisp/gnus/mm-decode.el    2013-06-17 09:19:50 +0000
@@ -1809,6 +1809,7 @@
         (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 @@
            (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)

=== modified file 'lisp/gnus/shr.el'
--- a/lisp/gnus/shr.el  2013-06-17 00:49:49 +0000
+++ b/lisp/gnus/shr.el  2013-06-17 09:19:50 +0000
@@ -131,6 +131,8 @@
     (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 @@
        (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 @@
     (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 @@
                     (> (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 @@
   (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 @@
        (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 @@
     (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 @@
 (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 @@
        (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 @@
          (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 @@
            (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 @@
       (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 @@
                              (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: