Commit 7304e4dd authored by Lars Magne Ingebrigtsen's avatar Lars Magne Ingebrigtsen Committed by Katsumi Yamaoka
Browse files

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.
parent d363bffb
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> 2013-06-17 Stefan Monnier <monnier@iro.umontreal.ca>
   
* sieve.el (sieve-edit-script): Avoid beginning-of-buffer. * sieve.el (sieve-edit-script): Avoid beginning-of-buffer.
......
...@@ -206,8 +206,8 @@ ...@@ -206,8 +206,8 @@
(suppress-keymap map) (suppress-keymap map)
(define-key map "q" 'eww-quit) (define-key map "q" 'eww-quit)
(define-key map "g" 'eww-reload) (define-key map "g" 'eww-reload)
(define-key map [tab] 'widget-forward) (define-key map [tab] 'shr-next-link)
(define-key map [backtab] 'widget-backward) (define-key map [backtab] 'shr-previous-link)
(define-key map [delete] 'scroll-down-command) (define-key map [delete] 'scroll-down-command)
(define-key map "\177" 'scroll-down-command) (define-key map "\177" 'scroll-down-command)
(define-key map " " 'scroll-up-command) (define-key map " " 'scroll-up-command)
......
...@@ -1809,6 +1809,7 @@ If RECURSIVE, search recursively." ...@@ -1809,6 +1809,7 @@ If RECURSIVE, search recursively."
(libxml-parse-html-region (point-min) (point-max)))) (libxml-parse-html-region (point-min) (point-max))))
(unless (bobp) (unless (bobp)
(insert "\n")) (insert "\n"))
(mm-convert-shr-links)
(mm-handle-set-undisplayer (mm-handle-set-undisplayer
handle handle
`(lambda () `(lambda ()
...@@ -1816,6 +1817,20 @@ If RECURSIVE, search recursively." ...@@ -1816,6 +1817,20 @@ If RECURSIVE, search recursively."
(delete-region ,(point-min-marker) (delete-region ,(point-min-marker)
,(point-max-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) (defun mm-handle-filename (handle)
"Return filename of HANDLE if any." "Return filename of HANDLE if any."
(or (mail-content-type-get (mm-handle-type handle) (or (mail-content-type-get (mm-handle-type handle)
......
...@@ -131,6 +131,8 @@ cid: URL as the argument.") ...@@ -131,6 +131,8 @@ cid: URL as the argument.")
(define-key map "a" 'shr-show-alt-text) (define-key map "a" 'shr-show-alt-text)
(define-key map "i" 'shr-browse-image) (define-key map "i" 'shr-browse-image)
(define-key map "z" 'shr-zoom-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 "I" 'shr-insert-image)
(define-key map "u" 'shr-copy-url) (define-key map "u" 'shr-copy-url)
(define-key map "v" 'shr-browse-url) (define-key map "v" 'shr-browse-url)
...@@ -217,6 +219,40 @@ redirects somewhere else." ...@@ -217,6 +219,40 @@ redirects somewhere else."
(copy-region-as-kill (point-min) (point-max)) (copy-region-as-kill (point-min) (point-max))
(message "Copied %s" url)))))) (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 () (defun shr-show-alt-text ()
"Show the ALT text of the image under point." "Show the ALT text of the image under point."
(interactive) (interactive)
...@@ -578,17 +614,16 @@ size, and full-buffer size." ...@@ -578,17 +614,16 @@ size, and full-buffer size."
(overlay-put overlay 'evaporate t) (overlay-put overlay 'evaporate t)
overlay)) overlay))
;; Add an overlay in the region, but avoid putting the font properties ;; Add face to the region, but avoid putting the font properties on
;; on blank text at the start of the line, and the newline at the end, ;; blank text at the start of the line, and the newline at the end, to
;; to avoid ugliness. ;; avoid ugliness.
(defun shr-add-font (start end type) (defun shr-add-font (start end type)
(save-excursion (save-excursion
(goto-char start) (goto-char start)
(while (< (point) end) (while (< (point) end)
(when (bolp) (when (bolp)
(skip-chars-forward " ")) (skip-chars-forward " "))
(let ((overlay (shr-make-overlay (point) (min (line-end-position) end)))) (add-face-text-property (point) (min (line-end-position) end) type)
(overlay-put overlay 'face type))
(if (< (line-end-position) end) (if (< (line-end-position) end)
(forward-line 1) (forward-line 1)
(goto-char end))))) (goto-char end)))))
...@@ -678,10 +713,7 @@ size, and full-buffer size." ...@@ -678,10 +713,7 @@ size, and full-buffer size."
(> (car (image-size image t)) 400)) (> (car (image-size image t)) 400))
(insert "\n")) (insert "\n"))
(if (eq size 'original) (if (eq size 'original)
(let ((overlays (overlays-at (point)))) (insert-sliced-image image (or alt "*") nil 20 1)
(insert-sliced-image image (or alt "*") nil 20 1)
(dolist (overlay overlays)
(overlay-put overlay 'face 'default)))
(insert-image image (or alt "*"))) (insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size) (put-text-property start (point) 'image-size size)
(when (cond ((fboundp 'image-multi-frame-p) (when (cond ((fboundp 'image-multi-frame-p)
...@@ -769,16 +801,13 @@ START, and END. Note that START and END should be markers." ...@@ -769,16 +801,13 @@ START, and END. Note that START and END should be markers."
(apply #'shr-fontize-cont cont types) (apply #'shr-fontize-cont cont types)
(shr-ensure-paragraph)) (shr-ensure-paragraph))
(autoload 'widget-convert-button "wid-edit")
(defun shr-urlify (start url &optional title) (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) (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) (defun shr-encode-url (url)
"Encode URL." "Encode URL."
...@@ -860,7 +889,7 @@ ones, in case fg and bg are nil." ...@@ -860,7 +889,7 @@ ones, in case fg and bg are nil."
(when (and (< (setq column (current-column)) width) (when (and (< (setq column (current-column)) width)
(< (setq column (shr-previous-newline-padding-width column)) (< (setq column (shr-previous-newline-padding-width column))
width)) width))
(let ((overlay (shr-make-overlay (point) (1+ (point))))) (let ((overlay (make-overlay (point) (1+ (point)))))
(overlay-put overlay 'before-string (overlay-put overlay 'before-string
(concat (concat
(mapconcat (mapconcat
...@@ -898,8 +927,7 @@ ones, in case fg and bg are nil." ...@@ -898,8 +927,7 @@ ones, in case fg and bg are nil."
(while (< start end) (while (< start end)
(setq change (next-single-property-change start 'face nil end)) (setq change (next-single-property-change start 'face nil end))
(when do-put (when do-put
(put-text-property start change 'face (add-face-text-property start change (list type color)))
(nconc (list type color) old-props)))
(setq old-props (get-text-property change 'face)) (setq old-props (get-text-property change 'face))
(setq do-put (and (listp old-props) (setq do-put (and (listp old-props)
(not (memq type old-props)))) (not (memq type old-props))))
...@@ -1172,10 +1200,9 @@ ones, in case fg and bg are nil." ...@@ -1172,10 +1200,9 @@ ones, in case fg and bg are nil."
(defun shr-tag-span (cont) (defun shr-tag-span (cont)
(let ((title (cdr (assq :title cont)))) (let ((title (cdr (assq :title cont))))
(shr-generic cont) (shr-generic cont)
(when title (when (and title
(when shr-start shr-start)
(let ((overlay (shr-make-overlay shr-start (point)))) (put-text-property shr-start (point) 'help-echo title))))
(overlay-put overlay 'help-echo title))))))
(defun shr-tag-h1 (cont) (defun shr-tag-h1 (cont)
(shr-heading cont 'bold 'underline)) (shr-heading cont 'bold 'underline))
...@@ -1341,19 +1368,10 @@ ones, in case fg and bg are nil." ...@@ -1341,19 +1368,10 @@ ones, in case fg and bg are nil."
(insert shr-table-vertical-line "\n")) (insert shr-table-vertical-line "\n"))
(dolist (column row) (dolist (column row)
(goto-char start) (goto-char start)
(let ((lines (nth 2 column)) (let ((lines (nth 2 column)))
(overlay-lines (nth 3 column))
overlay overlay-line)
(dolist (line lines) (dolist (line lines)
(setq overlay-line (pop overlay-lines))
(end-of-line) (end-of-line)
(insert line shr-table-vertical-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)) (forward-line 1))
;; Add blank lines at padding at the bottom of the TD, ;; Add blank lines at padding at the bottom of the TD,
;; possibly. ;; possibly.
...@@ -1441,7 +1459,7 @@ ones, in case fg and bg are nil." ...@@ -1441,7 +1459,7 @@ ones, in case fg and bg are nil."
(fgcolor (cdr (assq :fgcolor cont))) (fgcolor (cdr (assq :fgcolor cont)))
(style (cdr (assq :style cont))) (style (cdr (assq :style cont)))
(shr-stylesheet shr-stylesheet) (shr-stylesheet shr-stylesheet)
overlays actual-colors) actual-colors)
(when style (when style
(setq style (and (string-match "color" style) (setq style (and (string-match "color" style)
(shr-parse-style style)))) (shr-parse-style style))))
...@@ -1489,7 +1507,7 @@ ones, in case fg and bg are nil." ...@@ -1489,7 +1507,7 @@ ones, in case fg and bg are nil."
(list max (list max
(count-lines (point-min) (point-max)) (count-lines (point-min) (point-max))
(split-string (buffer-string) "\n") (split-string (buffer-string) "\n")
(shr-collect-overlays) nil
(car actual-colors)) (car actual-colors))
max))))) max)))))
...@@ -1502,29 +1520,6 @@ ones, in case fg and bg are nil." ...@@ -1502,29 +1520,6 @@ ones, in case fg and bg are nil."
(forward-line 1)) (forward-line 1))
max)) 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) (defun shr-pro-rate-columns (columns)
(let ((total-percentage 0) (let ((total-percentage 0)
(widths (make-vector (length columns) 0))) (widths (make-vector (length columns) 0)))
...@@ -1570,6 +1565,23 @@ ones, in case fg and bg are nil." ...@@ -1570,6 +1565,23 @@ ones, in case fg and bg are nil."
(shr-count (cdr row) 'th)))))) (shr-count (cdr row) 'th))))))
max)) 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) (provide 'shr)
;; Local Variables: ;; Local Variables:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment