shr: colorize only in one place

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 43a1411..8ee1e99 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -195,16 +195,19 @@ redirects somewhere else."
        (shr-stylesheet shr-stylesheet)
        (start (point)))
     (when (and style
+               ;; HACK: we only parse if there's color information, since
+               ;; that's the only thing we are rendering.
               (string-match "color" style))
       (setq shr-stylesheet (nconc (shr-parse-style style)
                                  shr-stylesheet)))
+    ;; Render content
     (if (fboundp function)
        (funcall function (cdr dom))
       (shr-generic (cdr dom)))
-    (when shr-stylesheet
-      (shr-colorize-region start (point)
-                          (cdr (assq 'color shr-stylesheet))
-                          (cdr (assq 'background-color shr-stylesheet))))))
+    ;; Apply style
+    (shr-colorize-region start (point)
+                         (cdr (assq 'color shr-stylesheet))
+                         (cdr (assq 'background-color shr-stylesheet)))))
 
 (defun shr-generic (cont)
   (dolist (sub cont)
@@ -299,12 +302,12 @@ redirects somewhere else."
                    (eq (following-char) ? )
                    (shr-char-breakable-p (preceding-char))
                    (shr-char-breakable-p (following-char))
-                   (and (eq (preceding-char) ?')
-                        (not (memq (char-after (- (point) 2))
-                                   (list nil ?\n ? ))))
-                   ;; There're some kinsoku CJK chars that aren't breakable.
-                   (and (shr-char-kinsoku-bol-p (preceding-char))
-                        (not (shr-char-kinsoku-bol-p (following-char))))
+                   (if (eq (preceding-char) ?')
+                       (not (memq (char-after (- (point) 2))
+                                  (list nil ?\n ? )))
+                     ;; There're some kinsoku CJK chars that aren't breakable.
+                     (and (shr-char-kinsoku-bol-p (preceding-char))
+                          (not (shr-char-kinsoku-bol-p (following-char)))))
                    (shr-char-kinsoku-eol-p (following-char))))
       (backward-char 1))
     (if (and (not (or failed (eolp)))
@@ -584,23 +587,65 @@ ones, in case fg and bg are nil."
                (shr-color-visible bg fg)))))))
 
 (defun shr-colorize-region (start end fg &optional bg)
-  (when fg
-    (let ((new-colors
-          (shr-color-check fg (or bg
-                                  (frame-parameter nil 'background-color)))))
+  "Colorize region from START to END.
+Use foreground color FG and background color BG.
+Apply color check via `shr-color-check'."
+  (when (or fg bg)
+    (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
-       (overlay-put (make-overlay start end) 'face
-                    (list :foreground (cadr new-colors)
-                          :background (and bg (car new-colors))))))))
+       (shr-put-color start end :foreground (cadr new-colors))
+       (when bg
+         (shr-put-color start end :background (car new-colors)))))))
+
+;; Put a color in the region, but avoid putting colors on 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 (bolp)
+       (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)))))
+
+(defun shr-put-color-1 (start end type color)
+  (let* ((old-props (get-text-property start 'face))
+        (do-put (not (memq type old-props)))
+        change)
+    (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)))
+      (setq old-props (get-text-property change 'face))
+      (setq do-put (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)
-  (let ((start (point))
-        (fgcolor (cdr (assq :fgcolor cont)))
-        (bgcolor (cdr (assq :bgcolor cont))))
-    (shr-generic cont)
-    (shr-colorize-region start (point) fgcolor bgcolor)))
+  (let* ((start (point))
+        (fgcolor (cdr (assq :fgcolor cont)))
+        (bgcolor (cdr (assq :bgcolor cont)))
+         (shr-stylesheet (if fgcolor
+                             (if bgcolor
+                                 `((color . ,fgcolor)
+                                   (background-color . ,bgcolor) ,@shr-stylesheet)
+                               `((color . ,fgcolor) ,@shr-stylesheet))
+                           (if bgcolor
+                               `((background-color . ,bgcolor) ,@shr-stylesheet)
+                             shr-stylesheet))))
+    (shr-generic cont)))
 
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
@@ -801,10 +846,12 @@ ones, in case fg and bg are nil."
   (shr-heading cont 'bold 'underline))
 
 (defun shr-tag-font (cont)
-  (let ((start (point))
-        (color (cdr (assq :color cont))))
-    (shr-generic cont)
-    (shr-colorize-region start (point) color)))
+  (let* ((start (point))
+         (color (cdr (assq :color cont)))
+         (shr-stylesheet (if color
+                             `((color . ,fgcolor) ,@shr-stylesheet)
+                           shr-stylesheet)))
+    (shr-generic cont)))
 
 ;;; Table rendering algorithm.
 
@@ -1004,7 +1051,7 @@ ones, in case fg and bg are nil."
          (insert cache)
        (let ((shr-width width)
              (shr-indentation 0))
-         (shr-generic cont))
+         (shr-descend (cons 'td cont)))
        (delete-region
         (point)
         (+ (point)