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__ |