From: Lars Magne Ingebrigtsen Date: Mon, 17 Jun 2013 10:51:54 +0000 (+0000) Subject: lisp/gnus/mm-decode.el (mm-convert-shr-links): Override the shr local map, so that... X-Git-Tag: emacs-24.3.90~173^2^2~42^2~45^2~387^2~2016^2~77 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=544d4594cb3e9945dc3a512e619d3cf2759fc86a;p=emacs.git 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 --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 9552078ddb8..7ceaac31e7e 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,5 +1,17 @@ 2013-06-17 Lars Magne Ingebrigtsen + * 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. diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el index 6460ee79604..fc0e413248a 100644 --- a/lisp/gnus/eww.el +++ b/lisp/gnus/eww.el @@ -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)))) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 521251845da..971c26e200a 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -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) diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index b394607dbff..d3b9a362a0b 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -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)