Add color check support with shr-color

Signed-off-by: Julien Danjou <julien@danjou.info>

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ffce470..fee208a 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,6 +1,9 @@
 2010-11-22  Julien Danjou  <julien@danjou.info>
 
        * shr.el (shr-tag-font): Add.
+       (shr-tag-color-check): New function to get better colors.
+       (shr-tag-insert-color-overlay): Factorize code between tag-font and
+       tag-span.
 
        * shr-color.el: New file.
 

diff --git a/lisp/shr.el b/lisp/shr.el
index 0b3e1a9..1084505 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -517,21 +517,28 @@ START, and END."
 (defun shr-tag-s (cont)
   (shr-fontize-cont cont 'strike-through))
 
+(autoload 'shr-color-visible "shr-color")
+(defun shr-tag-color-check (fg &optional bg)
+  "Check that FG is visible on BG."
+  (shr-color-visible (or bg (frame-parameter nil 'background-color)) fg (not bg)))
+
+(defun shr-tag-insert-color-overlay (color start end)
+  (when color
+    (let ((overlay (make-overlay start end)))
+      (overlay-put overlay 'face (cons 'foreground-color
+                                       (cadr (shr-tag-color-check color)))))))
+
 (defun shr-tag-span (cont)
   (let ((start (point))
        (color (cdr (assq 'color (shr-parse-style (cdr (assq :style cont)))))))
     (shr-generic cont)
-    (when color
-      (let ((overlay (make-overlay start (point))))
-       (overlay-put overlay 'face (cons 'foreground-color color))))))
+    (shr-tag-insert-color-overlay color start (point))))
 
 (defun shr-tag-font (cont)
   (let ((start (point))
         (color (cdr (assq :color cont))))
     (shr-generic cont)
-    (when color
-      (let ((overlay (make-overlay start (point))))
-       (overlay-put overlay 'face (cons 'foreground-color color))))))
+    (shr-tag-insert-color-overlay color start (point))))
 
 (defun shr-parse-style (style)
   (when style