Commit 544d4594 authored by Lars Magne Ingebrigtsen's avatar Lars Magne Ingebrigtsen Committed by Katsumi Yamaoka

lisp/gnus/mm-decode.el (mm-convert-shr-links): Override the shr local map, so...

lisp/gnus/mm-decode.el (mm-convert-shr-links): Override the shr local map, so that Gnus commands work

lisp/gnus/shr.el (shr-render-td): Support horizontal alignment

Make eww use `add-face-text-property', too
lisp/gnus/shr.el (shr-make-overlay): Obsolete function
lisp/gnus/eww.el (eww-put-color): Removed
(eww-colorize-region): Use `add-face-text-property'

Get correct presedence for font data
lisp/gnus/shr.el (shr-add-font): Append face data, so that we get the correct presedence: The innermost value (which is applied first) wins
parent 372c83ba
2013-06-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
* mm-decode.el (mm-convert-shr-links): Override the shr local map, so
that Gnus commands work.
* shr.el (shr-render-td): Support horizontal alignment.
* eww.el (eww-put-color): Removed.
(eww-colorize-region): Use `add-face-text-property'.
* shr.el (shr-add-font): Append face data, so that we get the correct
presedence: The innermost value (which is applied first) wins.
(shr-make-overlay): Obsolete function.
* mm-decode.el (mm-convert-shr-links): New function to convert
new-style shr URL links into widgets.
(mm-shr): Use it.
......
......@@ -172,12 +172,11 @@
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
(when fg
(eww-put-color start end :foreground (cadr new-colors)))
(add-face-text-property start end
(list :foreground (cadr new-colors))))
(when bg
(eww-put-color start end :background (car new-colors)))))))
(defun eww-put-color (start end type color)
(shr-put-color-1 start end type color))
(add-face-text-property start end
(list :background (car new-colors))))))))
(defun eww-display-raw (charset)
(let ((data (buffer-substring (point) (point-max))))
......
......@@ -1831,6 +1831,7 @@ If RECURSIVE, search recursively."
:help-echo (get-text-property start 'help-echo)
:keymap shr-map
(get-text-property start 'shr-url))
(put-text-property start end 'local-map nil)
(setq start end)))))
(defun mm-handle-filename (handle)
......
......@@ -609,11 +609,6 @@ size, and full-buffer size."
(dolist (type types)
(shr-add-font (or shr-start (point)) (point) type))))
(defun shr-make-overlay (beg end &optional buffer front-advance rear-advance)
(let ((overlay (make-overlay beg end buffer front-advance rear-advance)))
(overlay-put overlay 'evaporate t)
overlay))
;; 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.
......@@ -623,7 +618,7 @@ size, and full-buffer size."
(while (< (point) end)
(when (bolp)
(skip-chars-forward " "))
(add-face-text-property (point) (min (line-end-position) end) type)
(add-face-text-property (point) (min (line-end-position) end) type t)
(if (< (line-end-position) end)
(forward-line 1)
(goto-char end)))))
......@@ -843,32 +838,11 @@ ones, in case fg and bg are nil."
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
(when fg
(shr-put-color start end :foreground (cadr new-colors)))
(shr-add-font start end (list :foreground (cadr new-colors))))
(when bg
(shr-put-color start end :background (car new-colors))))
(shr-add-font start end (list :background (car new-colors)))))
new-colors)))
;; Put a color in the region, but avoid putting colors on blank
;; text at the start of the line, and the newline at the end, to avoid
;; ugliness. Also, don't overwrite any existing color information,
;; since this can be called recursively, and we want the "inner" color
;; to win.
(defun shr-put-color (start end type color)
(save-excursion
(goto-char start)
(while (< (point) end)
(when (and (bolp)
(not (eq type :background)))
(skip-chars-forward " "))
(when (> (line-end-position) (point))
(shr-put-color-1 (point) (min (line-end-position) end) type color))
(if (< (line-end-position) end)
(forward-line 1)
(goto-char end)))
(when (and (eq type :background)
(= shr-table-depth 0))
(shr-expand-newlines start end color))))
(defun shr-expand-newlines (start end color)
(save-restriction
;; Skip past all white space at the start and ends.
......@@ -919,24 +893,6 @@ ones, in case fg and bg are nil."
'before-string)))))
(+ width previous-width))))
(defun shr-put-color-1 (start end type color)
(let* ((old-props (get-text-property start 'face))
(do-put (and (listp old-props)
(not (memq type old-props))))
change)
(while (< start end)
(setq change (next-single-property-change start 'face nil end))
(when do-put
(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))))
(setq start change))
(when (and do-put
(> end start))
(put-text-property start end 'face
(nconc (list type color old-props))))))
;;; Tag-specific rendering rules.
(defun shr-tag-body (cont)
......@@ -1381,7 +1337,8 @@ ones, in case fg and bg are nil."
(insert (make-string (string-width (car lines)) ? )
shr-table-vertical-line)
(when (nth 4 column)
(shr-put-color start (1- (point)) :background (nth 4 column))))
(shr-add-font start (1- (point))
(list :background (nth 4 column)))))
(forward-line 1)))))
(shr-insert-table-ruler widths)))
......@@ -1492,11 +1449,23 @@ ones, in case fg and bg are nil."
(if (zerop (buffer-size))
(insert (make-string width ? ))
;; Otherwise, fill the buffer.
(while (not (eobp))
(end-of-line)
(when (> (- width (current-column)) 0)
(insert (make-string (- width (current-column)) ? )))
(forward-line 1)))
(let ((align (cdr (assq :align cont)))
length)
(while (not (eobp))
(end-of-line)
(setq length (- width (current-column)))
(when (> length 0)
(cond
((equal align "right")
(beginning-of-line)
(insert (make-string length ? )))
((equal align "center")
(insert (make-string (/ length 2) ? ))
(beginning-of-line)
(insert (make-string (- length (/ length 2)) ? )))
(t
(insert (make-string length ? )))))
(forward-line 1))))
(when style
(setq actual-colors
(shr-colorize-region
......@@ -1567,7 +1536,7 @@ ones, in case fg and bg are nil."
;; Emacs less than 24.3
(unless (fboundp 'add-face-text-property)
(defun add-face-text-property (beg end face)
(defun add-face-text-property (beg end face &optional appendp object)
"Combine FACE BEG and END."
(let ((b beg))
(while (< b end)
......@@ -1578,9 +1547,13 @@ ones, in case fg and bg are nil."
face)
((and (consp oldval)
(not (keywordp (car oldval))))
(cons face oldval))
(if appendp
(nconc oldval (list face))
(cons face oldval)))
(t
(list face oldval)))))))))
(if appendp
(list oldval face)
(list face oldval))))))))))
(provide 'shr)
......
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