shr-color: add HTML->hexadecimal converter

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

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index fee208a..2117227 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,11 @@
 2010-11-22  Julien Danjou  <julien@danjou.info>
 
+       * shr.el (shr-tag-color-check): Convert colors to hexadecimal with
+       shr-color->hexadecimal.
+
+       * shr-color.el (shr-color->hexadecimal): Add converting functions for
+       RGB() or HSL() color representation.
+
        * 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

diff --git a/lisp/shr-color.el b/lisp/shr-color.el
index 26778a7..127dc68 100644 (file)
--- a/lisp/shr-color.el
+++ b/lisp/shr-color.el
@@ -45,6 +45,55 @@ absolute value without any unit."
   :group 'shr
   :type 'integer)
 
+(defun shr-color-relative-to-absolute (number)
+  "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER.
+This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
+  (let ((string-length (- (length number) 1)))
+    ;; Is this a number with %?
+    (if (eq (elt number string-length) ?%)
+        (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
+      (string-to-number number))))
+
+(defun shr-color-hsl-to-rgb-fractions (h s l)
+  "Convert H S L to fractional RGB values."
+  (let (m1 m2)
+    (if (<= l 0.5)
+        (setq m2 (* l (+ s 1)))
+        (setq m2 (- (+ l s) (* l s))))
+    (setq m1 (- (* l 2) m2))
+    (list (rainbow-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
+         (rainbow-hue-to-rgb m1 m2 h)
+         (rainbow-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
+
+(defun shr-color->hexadecimal (color)
+  "Convert any color format to hexadecimal representation.
+Like rgb() or hsl()."
+  (when color
+    (cond ((or (string-match
+                "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
+                color)
+               (string-match
+                "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+                color))
+           (format "#%02X%02X%02X"
+                   (shr-color-relative-to-absolute (match-string-no-properties 1 color))
+                   (shr-color-relative-to-absolute (match-string-no-properties 2 color))
+                   (shr-color-relative-to-absolute (match-string-no-properties 3 color))))
+          ((or (string-match
+                "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
+                color)
+               (string-match
+                "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+                color))
+           (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
+                 (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
+                 (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
+             (destructuring-bind (r g b)
+                 (rainbow-hsl-to-rgb-fractions h s l)
+               (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255)))))
+          (t
+           color))))
+
 (defun set-minimum-interval (val1 val2 min max interval &optional fixed)
   "Set minimum interval between VAL1 and VAL2 to INTERVAL.
 The values are bound by MIN and MAX.

diff --git a/lisp/shr.el b/lisp/shr.el
index 1084505..60fa127 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -520,7 +520,9 @@ START, and END."
 (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)))
+  (shr-color-visible (or (shr-color->hexadecimal bg)
+                         (frame-parameter nil 'background-color))
+                     (shr-color->hexadecimal fg) (not bg)))
 
 (defun shr-tag-insert-color-overlay (color start end)
   (when color