File Coverage

blib/lib/IRC/Formatting/HTML/Common.pm
Criterion Covered Total %
statement 43 51 84.3
branch 16 18 88.8
condition n/a
subroutine 7 8 87.5
pod 0 5 0.0
total 66 82 80.4


line stmt bran cond sub pod time code
1             package IRC::Formatting::HTML::Common;
2              
3 4     4   22 use warnings;
  4         7  
  4         104  
4 4     4   23 use strict;
  4         8  
  4         116  
5              
6 4     4   21 use Exporter 'import';
  4         13  
  4         4025  
7              
8             our @EXPORT = qw/$BOLD $COLOR $COLORM $RESET $INVERSE $UNDERLINE
9             $COLOR_SEQUENCE $FORMAT_SEQUENCE @COLORS/;
10              
11             our @EXPORT_OK = qw/html_color_to_irc color_distance hex_color_to_dec rgb_str_to_dec style_tag/;
12              
13             our $BOLD = "\002",
14             our $COLOR = "\003";
15             our $COLORM = qr/^$COLOR/;
16             our $RESET = "\017";
17             our $INVERSE = "\026";
18             our $UNDERLINE = "\037";
19              
20             our $COLOR_SEQUENCE = qr/([0-9]{1,2})(?:,([0-9]{1,2}))?/;
21             my $COLOR_SEQUENCE_NC = qr/[0-9]{1,2}(?:,[0-9]{1,2})?/;
22             our $FORMAT_SEQUENCE = qr/(
23             $BOLD
24             | $COLOR$COLOR_SEQUENCE_NC? | $RESET
25             | $INVERSE
26             | $UNDERLINE)
27             /x;
28              
29             our @COLORS = ( qw/fff 000 008 080 f00 800 808 f80
30             ff0 0f0 088 0ff 00f f0f 888 ccc/ );
31              
32             my @colors_dec = do { map {hex_color_to_dec($_)} @COLORS };
33              
34             sub html_color_to_irc {
35 12     12 0 29 my $color = shift;
36 12         17 my $rgb;
37 12 100       65 if ($color =~ /^#?[a-f0-9]+$/i) {
    100          
38 7         19 $rgb = hex_color_to_dec($color);
39             } elsif ($color =~ /^rgb/) {
40 4         11 $rgb = rgb_str_to_dec($color);
41             }
42              
43 12 100       34 return () unless $rgb;
44              
45 11         19 my ($closest, $dist) = (1, 500);
46 11         31 for my $i (0 .. @colors_dec - 1) {
47 118         161 my $_rgb = $colors_dec[$i];
48 118         210 my $_dist = color_distance($rgb, $_rgb);
49 118 100       276 if ($_dist < $dist) {
50 28         49 ($closest, $dist) = ($i, $_dist);
51             }
52 118 100       336 last if $dist == 0;
53             }
54 11         69 return sprintf "%02s", $closest;
55             }
56              
57             sub color_distance {
58 118     118 0 184 my ($a, $b) = @_;
59 118         143 my $distance = 0;
60 118         223 for (0 .. 2) {
61 354         477 my $_a = $a->[$_];
62 354         437 my $_b = $b->[$_];
63 354         762 $distance += ($_b - $_a) ** 2;
64             }
65 118         336 return (int (sqrt($distance) * 10)) / 10;
66             }
67              
68             sub rgb_str_to_dec {
69 4     4 0 6 my $color = shift;
70 4 50       28 if ($color =~ /^rgba? \s* \( \s* (\d+) \s* , \s* (\d+) \s* , \s* (\d+) \s* \)/xi) {
71 4         22 return [$1, $2, $3];
72             }
73 0         0 return ();
74             }
75              
76             sub hex_color_to_dec {
77 71     71 0 95 my $color = shift;
78              
79 71 100       187 if (substr($color, 0, 1) eq "#") {
80 7         18 $color = substr $color, 1;
81             }
82              
83 71 100       155 if (length $color == 3) {
84 67         148 $color = join "", map {$_ x 2} split "", $color;
  201         397  
85             }
86              
87 71         424 my @rgb = ($color =~ /([a-f0-9]{2})/gi);
88 71 50       174 if (@rgb == 3) {
89 71         96 return [ map {hex $_} @rgb ];
  213         11701  
90             }
91            
92 0           return ();
93             }
94              
95             sub style_tag {
96 0     0 0   my $style = "";
107              
108 0           return $style;
109             }
110              
111             1;