[gnus git] branch master updated: m0-7-100-ge64fc4c =1= Convert shr.el from using overlays into using text properties
Lars Magne Ingebrigtsen <[email protected]>
| Newsgroups | gmane.emacs.gnus.cvs |
|---|---|
| Message-ID | <[email protected]> |
via e64fc4c264019ff9818b7a9a09678a4a34858228 (commit)
from 44cf7e926ddf058f8b88de93f33c9921d291897f (commit)
- Log -----------------------------------------------------------------
commit e64fc4c264019ff9818b7a9a09678a4a34858228
Author: Lars Magne Ingebrigtsen <[email protected]>
Date: Mon Jun 17 11:04:25 2013 +0200
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.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d7f1d1b..fc9cfa3 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,20 @@
+2013-06-17 Lars Magne Ingebrigtsen <[email protected]>
+
+ * 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-16 Lars Magne Ingebrigtsen <[email protected]>
* eww.el (eww-display-html): Default to using the entire window width.
diff --git a/lisp/eww.el b/lisp/eww.el
index 868450c..e13393c 100644
--- a/lisp/eww.el
+++ b/lisp/eww.el
@@ -205,8 +205,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/mm-decode.el b/lisp/mm-decode.el
index b025f7c..948b2a2 100644
--- a/lisp/mm-decode.el
+++ b/lisp/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/shr.el b/lisp/shr.el
index 339b969..0e63095 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -130,6 +130,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)
@@ -216,6 +218,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)
@@ -577,17 +613,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)))))
@@ -677,10 +712,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)
@@ -768,16 +800,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."
@@ -859,7 +888,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
@@ -897,8 +926,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))))
@@ -1171,10 +1199,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))
@@ -1340,19 +1367,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.
@@ -1440,7 +1458,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))))
@@ -1488,7 +1506,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)))))
@@ -1501,29 +1519,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)))
@@ -1569,6 +1564,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:
-----------------------------------------------------------------------
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we listed those
revisions in full, above.
Summary of changes:
lisp/ChangeLog | 17 +++++++
lisp/eww.el | 4 +-
lisp/mm-decode.el | 15 ++++++
lisp/shr.el | 130 +++++++++++++++++++++++++++++------------------------
4 files changed, 105 insertions(+), 61 deletions(-)
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Gnus Project".
The branch, master has been updated
hooks/post-receive
--
Gnus Project