mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-19 03:17:36 +00:00
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.
This commit is contained in:
Lars Magne Ingebrigtsen
Katsumi Yamaoka
parent
d363bffbed
commit
7304e4dd67
4 changed files with 105 additions and 61 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
130
lisp/gnus/shr.el
130
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:
|
||||
|
|
|
|||
Loading…
Reference in a new issue