File Coverage

blib/lib/Data/Printer/Theme.pm
Criterion Covered Total %
statement 102 104 98.0
branch 39 44 88.6
condition 13 16 81.2
subroutine 16 16 100.0
pod 0 6 0.0
total 170 186 91.4


line stmt bran cond sub pod time code
1             package Data::Printer::Theme;
2 33     33   57151 use strict;
  33         64  
  33         855  
3 33     33   165 use warnings;
  33         55  
  33         822  
4 33     33   543 use Data::Printer::Common;
  33         71  
  33         18655  
5              
6             # the theme name
7             sub name {
8 8     8 0 39 my ($self) = @_;
9 8         38 return $self->{name};
10             }
11              
12             # true if the theme has at least one color override
13             sub customized {
14 2     2 0 5 my ($self) = @_;
15 2 100       10 return exists $self->{is_custom} ? 1 : 0;
16             }
17              
18             # displays the color as-is
19             sub color_for {
20 5     5 0 12 my ($self, $color_type) = @_;
21 5   50     25 return $self->{colors}{$color_type} || '';
22             }
23              
24             # prints the SGR (terminal) color modifier
25             sub sgr_color_for {
26 12     12 0 2056 my ($self, $color_type) = @_;
27 12 100       40 return unless exists $self->{sgr_colors}{$color_type};
28 9   100     34 return $self->{sgr_colors}{$color_type} || ''
29             }
30              
31             # prints the SGR (terminal) color reset modifier
32 1     1 0 4 sub color_reset { return "\e[0m" }
33              
34             sub new {
35 263     263 0 5441 my ($class, %params) = @_;
36              
37 263         546 my $color_level = $params{color_level};
38 263         445 my $colors_to_override = $params{color_overrides};
39 263         439 my $theme_name = $params{name};
40              
41             # before we put user info on string eval, make sure
42             # it's just a module name:
43 263         888 $theme_name =~ s/[^a-zA-Z0-9:]+//gsm;
44              
45 263         1052 my $theme = bless {
46             name => $theme_name,
47             color_level => $color_level,
48             colors => {},
49             sgr_colors => {},
50             }, $class;
51 263 100       886 $theme->_load_theme($params{ddp}) or delete $theme->{name};
52 263         950 $theme->_maybe_override_theme_colors($colors_to_override, $params{ddp});
53 263         1015 return $theme;
54             }
55              
56             sub _maybe_override_theme_colors {
57 263     263   601 my ($self, $colors_to_override, $ddp) = @_;
58              
59 263 50 66     834 return unless $colors_to_override
      66        
60             && ref $colors_to_override eq 'HASH'
61             && keys %$colors_to_override;
62              
63             my $error = Data::Printer::Common::_tryme(sub {
64 13     13   30 foreach my $kind (keys %$colors_to_override ) {
65 17         26 my $override = $colors_to_override->{$kind};
66 17 100       37 die "invalid color for '$kind': must be scalar not ref" if ref $override;
67 16         30 my $parsed = $self->_parse_color($override, $ddp);
68 16 100       46 if (defined $parsed) {
69 6         10 $self->{colors}{$kind} = $override;
70 6         9 $self->{sgr_colors}{$kind} = $parsed;
71 6         13 $self->{is_custom}{$kind} = 1;
72             }
73             }
74 13         56 });
75 13 100       60 if ($error) {
76 1         5 Data::Printer::Common::_warn($ddp, "error overriding color: $error. Skipping!");
77             }
78 13         562 return;
79             }
80              
81             sub _load_theme {
82 263     263   602 my ($self, $ddp) = @_;
83 263         584 my $theme_name = $self->{name};
84              
85 263         735 my $class = 'Data::Printer::Theme::' . $theme_name;
86 263         958 my $error = Data::Printer::Common::_tryme("use $class; 1;");
87 263 100       653 if ($error) {
88 1         5 Data::Printer::Common::_warn($ddp, "error loading theme '$theme_name': $error.");
89 1         5 return;
90             }
91 262         519 my $loaded_colors = {};
92 262         436 my $loaded_colors_sgr = {};
93             $error = Data::Printer::Common::_tryme(sub {
94 262     262   373 my $class_colors;
95 33     33   237 { no strict 'refs'; $class_colors = &{ $class . '::colors'}(); }
  33         62  
  33         24940  
  262         364  
  262         365  
  262         1655  
96 262 100       876 die "${class}::colors() did not return a hash reference"
97             unless ref $class_colors eq 'HASH';
98              
99 261         1298 foreach my $kind (keys %$class_colors) {
100 6003         7572 my $loaded_color = $class_colors->{$kind};
101 6003 50       8866 die "color for '$kind' must be a scalar in theme '$theme_name'"
102             if ref $loaded_color;
103 6003         9051 my $parsed_color = $self->_parse_color($loaded_color, $ddp);
104 6003 50       9430 if (defined $parsed_color) {
105 6003         9248 $loaded_colors->{$kind} = $loaded_color;
106 6003         10656 $loaded_colors_sgr->{$kind} = $parsed_color;
107             }
108             }
109 262         1744 });
110 262 100       1844 if ($error) {
111 1         6 Data::Printer::Common::_warn($ddp, "error loading theme '$theme_name': $error. Output will have no colors");
112 1         5 return;
113             }
114 261         542 $self->{colors} = $loaded_colors;
115 261         457 $self->{sgr_colors} = $loaded_colors_sgr;
116 261         755 return 1;
117             }
118              
119             sub _parse_color {
120 6020     6020   9057 my ($self, $color_label, $ddp) = @_;
121 6020 50       8797 return unless defined $color_label;
122 6020 100       8429 return '' unless $color_label;
123              
124 6006         6333 my $color_code;
125 6006 100       17119 if ($color_label =~ /\Argb\((\d+),(\d+),(\d+)\)\z/) {
    100          
    100          
    100          
126 4         11 my ($r, $g, $b) = ($1, $2, $3);
127 4 100 100     33 if ($r < 256 && $g < 256 && $b < 256) {
      100        
128 1 50       4 if ($self->{color_level} == 3) {
129 1         4 $color_code = "\e[0;38;2;$r;$g;${b}m";
130             }
131             else {
132 0         0 my $reduced = _rgb2short($r,$g,$b);
133 0         0 $color_code = "\e[0;38;5;${reduced}m";
134             }
135             }
136             else {
137 3         11 Data::Printer::Common::_warn($ddp, "invalid color '$color_label': all colors must be between 0 and 255");
138             }
139             }
140             elsif ($color_label =~ /\A#([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\z/i) {
141 5975         17414 my ($r, $g, $b) = map hex($_), ($1, $2, $3);
142 5975 100       10408 if ($self->{color_level} == 3) {
143 344         586 $color_code = "\e[0;38;2;$r;$g;${b}m";
144             }
145             else {
146 5631         8319 my $reduced = _rgb2short($r,$g,$b);
147 5631         10991 $color_code = "\e[0;38;5;${reduced}m";
148             }
149             }
150             elsif ($color_label =~ /\A\e\[\d+(:?;\d+)*m\z/) {
151 2         5 $color_code = $color_label;
152             }
153             elsif ($color_label =~ /\A
154             (?:
155             \s*
156             (?:on_)?
157             (?:bright_)?
158             (?:black|red|green|yellow|blue|magenta|cyan|white)
159             )+
160             \s*\z/x
161             ) {
162 18         134 my %ansi_colors = (
163             'black' => 30, 'on_black' => 40,
164             'red' => 31, 'on_red' => 41,
165             'green' => 32, 'on_green' => 42,
166             'yellow' => 33, 'on_yellow' => 43,
167             'blue' => 34, 'on_blue' => 44,
168             'magenta' => 35, 'on_magenta' => 45,
169             'cyan' => 36, 'on_cyan' => 46,
170             'white' => 37, 'on_white' => 47,
171             'bright_black' => 90, 'on_bright_black' => 100,
172             'bright_red' => 91, 'on_bright_red' => 101,
173             'bright_green' => 92, 'on_bright_green' => 102,
174             'bright_yellow' => 93, 'on_bright_yellow' => 103,
175             'bright_blue' => 94, 'on_bright_blue' => 104,
176             'bright_magenta' => 95, 'on_bright_magenta' => 105,
177             'bright_cyan' => 96, 'on_bright_cyan' => 106,
178             'bright_white' => 97, 'on_bright_white' => 107,
179             );
180             $color_code = "\e["
181 18         106 . join(';' => map $ansi_colors{$_}, split(/\s+/, $color_label))
182             . 'm'
183             ;
184             }
185             else {
186 7         21 Data::Printer::Common::_warn($ddp, "invalid color '$color_label'");
187             }
188 6006         14504 return $color_code;
189             }
190              
191             sub _rgb2short {
192 5632     5632   7512 my ($r,$g,$b) = @_;
193 5632         7928 my @snaps = (47, 115, 155, 195, 235);
194 5632         6028 my @new;
195 5632         8000 foreach my $color ($r,$g,$b) {
196 16896         18106 my $big = 0;
197 16896         19573 foreach my $s (@snaps) {
198 84480 100       123538 $big++ if $s < $color;
199             }
200 16896         22615 push @new, $big
201             }
202 5632         10356 return $new[0]*36 + $new[1]*6 + $new[2] + 16
203             }
204              
205             1;
206             __END__