[elpa] externals/compat 212f8c7c77 17/27: Add color-values-from-color-spec

[ELPA Syncer]

branch: externals/compat
commit 212f8c7c77a4e18917b6986ebc51a1f823c856c0
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>

    Add color-values-from-color-spec
---
 MANUAL          |  1 +
 compat-28.el    | 63 ++++++++++++++++++++++++++++++++++++++++++
 compat-tests.el | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 149 insertions(+)

diff --git a/MANUAL b/MANUAL
index e083237c4c..51009a7926 100644
--- a/MANUAL
+++ b/MANUAL
@@ -351,6 +351,7 @@ provided by compat by default:
   Environment]].
 - Function ~button-buttonize~ :: Defined in ~button.el~.
 - Function ~make-directory-autoloads~ :: See [[info:elisp#Autoload][(elisp) 
Autoload]].
+- Function ~color-values-from-color-spec~ :: Defined in ~xfaces.c~.
 
 These functions are prefixed with ~compat~ prefix, and are only loaded
 when ~compat-28~ is required:
diff --git a/compat-28.el b/compat-28.el
index c81eb04a5e..d60ef5c2f6 100644
--- a/compat-28.el
+++ b/compat-28.el
@@ -243,6 +243,69 @@ If COUNT is non-nil and a natural number, the function will
             (insert "]"))))
         (throw 'escape (elt (apply oldfun args) 0))))))
 
+;;;; xfaces.c
+
+(compat-defun color-values-from-color-spec (spec)
+  "Parse color SPEC as a numeric color and return (RED GREEN BLUE).
+This function recognises the following formats for SPEC:
+
+ #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each.
+ rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each.
+ rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1].
+
+If SPEC is not in one of the above forms, return nil.
+
+Each of the 3 integer members of the resulting list, RED, GREEN,
+and BLUE, is normalized to have its value in [0,65535]."
+  (save-match-data
+    (cond
+     ((string-match
+       ;; (rx bos "#"
+       ;;     (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 
1 hex)))
+       ;;         (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 
2 hex)))
+       ;;         (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 
3 hex)))
+       ;;         (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 
4 hex))))
+       ;;     eos)
+       
"\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'"
+       spec)
+      (let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))))
+        (list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max)
+              (/ (* (string-to-number (match-string 2 spec) 16) 65535) max)
+              (/ (* (string-to-number (match-string 3 spec) 16) 65535) max))))
+     ((string-match
+       ;; (rx bos "rgb:"
+       ;;     (group (** 1 4 hex)) "/"
+       ;;     (group (** 1 4 hex)) "/"
+       ;;     (group (** 1 4 hex))
+       ;;     eos)
+       
"\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'"
+       spec)
+      (list (/ (* (string-to-number (match-string 1 spec) 16) 65535)
+               (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))
+            (/ (* (string-to-number (match-string 2 spec) 16) 65535)
+               (1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4))))
+            (/ (* (string-to-number (match-string 3 spec) 16) 65535)
+               (1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4))))))
+     ((string-match
+       ;; (rx bos "rgbi:" (* space)
+       ;;     (group (or (: "0" (? "." (* digit)))
+       ;;                (: "." (+ digit))
+       ;;                (: "1" (? "." (* "0")))))
+       ;;     "/" (* space)
+       ;;     (group (or (: "0" (? "." (* digit)))
+       ;;                (: "." (+ digit))
+       ;;                (: "1" (? "." (* "0")))))
+       ;;     "/" (* space)
+       ;;     (group (or (: "0" (? "." (* digit)))
+       ;;                (: "." (+ digit))
+       ;;                (: "1" (? "." (* "0")))))
+       ;;     eos)
+       
"\\`rgbi:[[:space:]]*\\(0\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\|1\\(?:\\.0*\\)?\\)/[[:space:]]*\\(0\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\|1\\(?:\\.0*\\)?\\)/[[:space:]]*\\(0\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\|1\\(?:\\.0*\\)?\\)\\'"
+       spec)
+      (list (round (* (string-to-number (match-string 1 spec)) 65535))
+            (round (* (string-to-number (match-string 2 spec)) 65535))
+            (round (* (string-to-number (match-string 3 spec)) 65535)))))))
+
 ;;;; Defined in subr.el
 
 (compat-defun string-replace (fromstring tostring instring)
diff --git a/compat-tests.el b/compat-tests.el
index 5271d5d1e5..2ad7951ed6 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -1600,5 +1600,90 @@ the compatibility function."
     (compat--should '((0 . zero) a (0 . zero)) 0 (list (cons 0 'zero) (cons 1 
'one) 'a  (cons 0 'zero)) #'/=)
     (compat--should '(a (0 . zero) (0 . zero)) 0 (list 'a (cons 0 'zero) (cons 
1 'one) (cons 0 'zero)) #'/=)))
 
+(ert-deftest compat-color-values-from-color-spec ()
+  "Check if `compat--color-values-from-color-spec' was implemented properly."
+  (compat-test color-values-from-color-spec
+    ;; #RGB notation
+    (compat--should '(0 0 0) "#000")
+    (compat--should '(0 0 0) "#000000")
+    (compat--should '(0 0 0) "#000000000")
+    (compat--should '(0 0 0) "#000000000000")
+    (compat--should '(0 0 65535) "#00F")
+    (compat--should '(0 0 65535) "#0000FF")
+    (compat--should '(0 0 65535) "#000000FFF")
+    (compat--should '(0 0 65535) "#00000000FFFF")
+    (compat--should '(0 0 65535) "#00f")
+    (compat--should '(0 0 65535) "#0000ff")
+    (compat--should '(0 0 65535) "#000000fff")
+    (compat--should '(0 0 65535) "#00000000ffff")
+    (compat--should '(0 0 65535) "#00000000ffFF")
+    (compat--should nil "")
+    (compat--should nil "#")
+    (compat--should nil "#0")
+    (compat--should nil "#00")
+    (compat--should nil "#0000FG")
+    (compat--should nil "#0000FFF")
+    (compat--should nil "#0000FFFF")
+    (compat--should '(0 4080 65535) "#0000FFFFF")
+    (compat--should nil "#000FF")
+    (compat--should nil "#0000F")
+    (compat--should nil " #000000")
+    (compat--should nil "#000000 ")
+    (compat--should nil " #000000 ")
+    ;; rgb: notation
+    (compat--should '(0 0 0) "rgb:0/0/0")
+    (compat--should '(0 0 0) "rgb:0/0/00")
+    (compat--should '(0 0 0) "rgb:0/00/000")
+    (compat--should '(0 0 0) "rgb:0/000/0000")
+    (compat--should '(0 0 0) "rgb:000/0000/0")
+    (compat--should '(0 0 65535) "rgb:000/0000/F")
+    (compat--should '(65535 0 65535) "rgb:FFF/0000/F")
+    (compat--should '(65535 0 65535) "rgb:FFFF/0000/FFFF")
+    (compat--should '(0 255 65535) "rgb:0/00FF/FFFF")
+    (compat--should nil "rgb:/0000/FFFF")
+    (compat--should nil "rgb:0000/0000/FFFG")
+    (compat--should nil "rgb:0000/0000/FFFFF")
+    (compat--should nil "rgb:0000/0000")
+    (compat--should nil "rg:0000/0000/0000")
+    (compat--should nil "rgb: 0000/0000/0000")
+    (compat--should nil "rgbb:0000/0000/0000")
+    (compat--should nil "rgb:0000/0000/0000   ")
+    (compat--should nil " rgb:0000/0000/0000  ")
+    (compat--should nil "  rgb:0000/0000/0000")
+    (compat--should nil "rgb:0000/ 0000 /0000")
+    (compat--should nil "rgb: 0000 /0000 /0000")
+    ;; rgbi: notation
+    (compat--should '(0 0 0) "rgbi:0/0/0")
+    (compat--should '(0 0 0) "rgbi:0.0/0.0/0.0")
+    (compat--should '(0 0 0) "rgbi:0.0/0/0")
+    (compat--should '(0 0 0) "rgbi:0.0/0/0")
+    (compat--should '(0 0 0) "rgbi:0/0/0.")
+    (compat--should '(0 0 0) "rgbi:0/0/0.0000")
+    (compat--should '(0 0 0) "rgbi:0/0/.0")
+    (compat--should '(0 0 0) "rgbi:0/0/.0000")
+    (compat--should '(65535 0 0) "rgbi:1/0/0.0000")
+    (compat--should '(65535 0 0) "rgbi:1./0/0.0000")
+    (compat--should '(65535 0 0) "rgbi:1.0/0/0.0000")
+    (compat--should '(65535 32768 0) "rgbi:1.0/0.5/0.0000")
+    (compat--should '(6554 21843 65469) "rgbi:0.1/0.3333/0.999")
+    (compat--should nil "rgbi:1.0001/0/0")
+    (compat--should nil "rgbi:2/0/0")
+    (compat--should nil "rgbi:0.a/0/0")
+    (compat--should nil "rgbi:./0/0")
+    (compat--should nil "rgbi:./0/0")
+    (compat--should nil " rgbi:0/0/0")
+    (compat--should nil "rgbi:0/0/0 ")
+    (compat--should nil "      rgbi:0/0/0 ")
+    (compat--should nil "rgbi:0 /0/ 0")
+    (compat--should nil "rgbi:0/ 0 /0")
+    (compat--should nil "rgbii:0/0/0")
+    (compat--should nil "rgbi :0/0/0")
+    ;; strtod ignores leading whitespace, making these legal colour
+    ;; specifications:
+    ;;
+    ;; (compat--should nil "rgbi: 0/0/0")
+    ;; (compat--should nil "rgbi: 0/ 0/ 0")
+    (compat--should nil "rgbi : 0/0/0")))
+
 (provide 'compat-tests)
 ;;; compat-tests.el ends here