line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Color screen output using ANSI escape sequences. |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# This module provides utility functions (in two different forms) for coloring |
4
|
|
|
|
|
|
|
# output with ANSI escape sequences. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# This module is sometimes used in low-memory environments, so avoid use of |
7
|
|
|
|
|
|
|
# \d, \w, [:upper:], and similar constructs in the most important functions |
8
|
|
|
|
|
|
|
# (color, colored, AUTOLOAD, and the generated constant functions) since |
9
|
|
|
|
|
|
|
# loading the Unicode attribute files consumes a lot of memory. |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
# Ah, September, when the sysadmins turn colors and fall off the trees.... |
12
|
|
|
|
|
|
|
# -- Dave Van Domelen |
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
############################################################################## |
17
|
|
|
|
|
|
|
# Modules and declarations |
18
|
|
|
|
|
|
|
############################################################################## |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
package Term::ANSIColor; |
21
|
|
|
|
|
|
|
|
22
|
7
|
|
|
7
|
|
381249
|
use 5.008; |
|
7
|
|
|
|
|
73
|
|
23
|
7
|
|
|
7
|
|
30
|
use strict; |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
127
|
|
24
|
7
|
|
|
7
|
|
26
|
use warnings; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
182
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# Also uses Carp but loads it on demand to reduce memory usage. |
27
|
|
|
|
|
|
|
|
28
|
7
|
|
|
7
|
|
30
|
use Exporter; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
2363
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# use Exporter plus @ISA instead of use base to reduce memory usage. |
31
|
|
|
|
|
|
|
## no critic (ClassHierarchies::ProhibitExplicitISA) |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Declare variables that should be set in BEGIN for robustness. |
34
|
|
|
|
|
|
|
## no critic (Modules::ProhibitAutomaticExportation) |
35
|
|
|
|
|
|
|
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS, @ISA, $VERSION); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# We use autoloading, which sets this variable to the name of the called sub. |
38
|
|
|
|
|
|
|
our $AUTOLOAD; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Set $VERSION and everything export-related in a BEGIN block for robustness |
41
|
|
|
|
|
|
|
# against circular module loading (not that we load any modules, but |
42
|
|
|
|
|
|
|
# consistency is good). |
43
|
|
|
|
|
|
|
BEGIN { |
44
|
7
|
|
|
7
|
|
25
|
$VERSION = '5.00'; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# All of the basic supported constants, used in %EXPORT_TAGS. |
47
|
7
|
|
|
|
|
61
|
my @colorlist = qw( |
48
|
|
|
|
|
|
|
CLEAR RESET BOLD DARK |
49
|
|
|
|
|
|
|
FAINT ITALIC UNDERLINE UNDERSCORE |
50
|
|
|
|
|
|
|
BLINK REVERSE CONCEALED |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
BLACK RED GREEN YELLOW |
53
|
|
|
|
|
|
|
BLUE MAGENTA CYAN WHITE |
54
|
|
|
|
|
|
|
ON_BLACK ON_RED ON_GREEN ON_YELLOW |
55
|
|
|
|
|
|
|
ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW |
58
|
|
|
|
|
|
|
BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE |
59
|
|
|
|
|
|
|
ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW |
60
|
|
|
|
|
|
|
ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_WHITE |
61
|
|
|
|
|
|
|
); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# 256-color constants, used in %EXPORT_TAGS. |
64
|
|
|
|
|
|
|
my @colorlist256 = ( |
65
|
1792
|
|
|
|
|
3354
|
(map { ("ANSI$_", "ON_ANSI$_") } 0 .. 255), |
66
|
7
|
|
|
|
|
44
|
(map { ("GREY$_", "ON_GREY$_") } 0 .. 23), |
|
168
|
|
|
|
|
478
|
|
67
|
|
|
|
|
|
|
); |
68
|
7
|
|
|
|
|
43
|
for my $r (0 .. 5) { |
69
|
42
|
|
|
|
|
60
|
for my $g (0 .. 5) { |
70
|
252
|
|
|
|
|
336
|
push(@colorlist256, map { ("RGB$r$g$_", "ON_RGB$r$g$_") } 0 .. 5); |
|
1512
|
|
|
|
|
3490
|
|
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Exported symbol configuration. |
75
|
7
|
|
|
|
|
94
|
@ISA = qw(Exporter); |
76
|
7
|
|
|
|
|
21
|
@EXPORT = qw(color colored); |
77
|
7
|
|
|
|
|
14
|
@EXPORT_OK = qw(uncolor colorstrip colorvalid coloralias); |
78
|
7
|
|
|
|
|
52
|
%EXPORT_TAGS = ( |
79
|
|
|
|
|
|
|
constants => \@colorlist, |
80
|
|
|
|
|
|
|
constants256 => \@colorlist256, |
81
|
|
|
|
|
|
|
pushpop => [@colorlist, qw(PUSHCOLOR POPCOLOR LOCALCOLOR)], |
82
|
|
|
|
|
|
|
); |
83
|
7
|
|
|
|
|
18677
|
Exporter::export_ok_tags('pushpop', 'constants256'); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
############################################################################## |
87
|
|
|
|
|
|
|
# Package variables |
88
|
|
|
|
|
|
|
############################################################################## |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# If this is set, any color changes will implicitly push the current color |
91
|
|
|
|
|
|
|
# onto the stack and then pop it at the end of the constant sequence, just as |
92
|
|
|
|
|
|
|
# if LOCALCOLOR were used. |
93
|
|
|
|
|
|
|
our $AUTOLOCAL; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# Caller sets this to force a reset at the end of each constant sequence. |
96
|
|
|
|
|
|
|
our $AUTORESET; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# Caller sets this to force colors to be reset at the end of each line. |
99
|
|
|
|
|
|
|
our $EACHLINE; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
############################################################################## |
102
|
|
|
|
|
|
|
# Internal data structures |
103
|
|
|
|
|
|
|
############################################################################## |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# This module does quite a bit of initialization at the time it is first |
106
|
|
|
|
|
|
|
# loaded, primarily to set up the package-global %ATTRIBUTES hash. The |
107
|
|
|
|
|
|
|
# entries for 256-color names are easier to handle programmatically, and |
108
|
|
|
|
|
|
|
# custom colors are also imported from the environment if any are set. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# All basic supported attributes, including aliases. |
111
|
|
|
|
|
|
|
#<<< |
112
|
|
|
|
|
|
|
our %ATTRIBUTES = ( |
113
|
|
|
|
|
|
|
'clear' => 0, |
114
|
|
|
|
|
|
|
'reset' => 0, |
115
|
|
|
|
|
|
|
'bold' => 1, |
116
|
|
|
|
|
|
|
'dark' => 2, |
117
|
|
|
|
|
|
|
'faint' => 2, |
118
|
|
|
|
|
|
|
'italic' => 3, |
119
|
|
|
|
|
|
|
'underline' => 4, |
120
|
|
|
|
|
|
|
'underscore' => 4, |
121
|
|
|
|
|
|
|
'blink' => 5, |
122
|
|
|
|
|
|
|
'reverse' => 7, |
123
|
|
|
|
|
|
|
'concealed' => 8, |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
'black' => 30, 'on_black' => 40, |
126
|
|
|
|
|
|
|
'red' => 31, 'on_red' => 41, |
127
|
|
|
|
|
|
|
'green' => 32, 'on_green' => 42, |
128
|
|
|
|
|
|
|
'yellow' => 33, 'on_yellow' => 43, |
129
|
|
|
|
|
|
|
'blue' => 34, 'on_blue' => 44, |
130
|
|
|
|
|
|
|
'magenta' => 35, 'on_magenta' => 45, |
131
|
|
|
|
|
|
|
'cyan' => 36, 'on_cyan' => 46, |
132
|
|
|
|
|
|
|
'white' => 37, 'on_white' => 47, |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
'bright_black' => 90, 'on_bright_black' => 100, |
135
|
|
|
|
|
|
|
'bright_red' => 91, 'on_bright_red' => 101, |
136
|
|
|
|
|
|
|
'bright_green' => 92, 'on_bright_green' => 102, |
137
|
|
|
|
|
|
|
'bright_yellow' => 93, 'on_bright_yellow' => 103, |
138
|
|
|
|
|
|
|
'bright_blue' => 94, 'on_bright_blue' => 104, |
139
|
|
|
|
|
|
|
'bright_magenta' => 95, 'on_bright_magenta' => 105, |
140
|
|
|
|
|
|
|
'bright_cyan' => 96, 'on_bright_cyan' => 106, |
141
|
|
|
|
|
|
|
'bright_white' => 97, 'on_bright_white' => 107, |
142
|
|
|
|
|
|
|
); |
143
|
|
|
|
|
|
|
#>>> |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# Generating the 256-color codes involves a lot of codes and offsets that are |
146
|
|
|
|
|
|
|
# not helped by turning them into constants. |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# The first 16 256-color codes are duplicates of the 16 ANSI colors. The rest |
149
|
|
|
|
|
|
|
# are RBG and greyscale values. |
150
|
|
|
|
|
|
|
for my $code (0 .. 15) { |
151
|
|
|
|
|
|
|
$ATTRIBUTES{"ansi$code"} = "38;5;$code"; |
152
|
|
|
|
|
|
|
$ATTRIBUTES{"on_ansi$code"} = "48;5;$code"; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# 256-color RGB colors. Red, green, and blue can each be values 0 through 5, |
156
|
|
|
|
|
|
|
# and the resulting 216 colors start with color 16. |
157
|
|
|
|
|
|
|
for my $r (0 .. 5) { |
158
|
|
|
|
|
|
|
for my $g (0 .. 5) { |
159
|
|
|
|
|
|
|
for my $b (0 .. 5) { |
160
|
|
|
|
|
|
|
my $code = 16 + (6 * 6 * $r) + (6 * $g) + $b; |
161
|
|
|
|
|
|
|
$ATTRIBUTES{"rgb$r$g$b"} = "38;5;$code"; |
162
|
|
|
|
|
|
|
$ATTRIBUTES{"on_rgb$r$g$b"} = "48;5;$code"; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# The last 256-color codes are 24 shades of grey. |
168
|
|
|
|
|
|
|
for my $n (0 .. 23) { |
169
|
|
|
|
|
|
|
my $code = $n + 232; |
170
|
|
|
|
|
|
|
$ATTRIBUTES{"grey$n"} = "38;5;$code"; |
171
|
|
|
|
|
|
|
$ATTRIBUTES{"on_grey$n"} = "48;5;$code"; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# Reverse lookup. Alphabetically first name for a sequence is preferred. |
175
|
|
|
|
|
|
|
our %ATTRIBUTES_R; |
176
|
|
|
|
|
|
|
for my $attr (reverse(sort(keys(%ATTRIBUTES)))) { |
177
|
|
|
|
|
|
|
$ATTRIBUTES_R{ $ATTRIBUTES{$attr} } = $attr; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# Provide ansiN names for all 256 characters to provide a convenient flat |
181
|
|
|
|
|
|
|
# namespace if one doesn't want to mess with the RGB and greyscale naming. Do |
182
|
|
|
|
|
|
|
# this after creating %ATTRIBUTES_R since we want to use the canonical names |
183
|
|
|
|
|
|
|
# when reversing a color. |
184
|
|
|
|
|
|
|
for my $code (16 .. 255) { |
185
|
|
|
|
|
|
|
$ATTRIBUTES{"ansi$code"} = "38;5;$code"; |
186
|
|
|
|
|
|
|
$ATTRIBUTES{"on_ansi$code"} = "48;5;$code"; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# Import any custom colors set in the environment. |
190
|
|
|
|
|
|
|
our %ALIASES; |
191
|
|
|
|
|
|
|
if (exists($ENV{ANSI_COLORS_ALIASES})) { |
192
|
|
|
|
|
|
|
my $spec = $ENV{ANSI_COLORS_ALIASES}; |
193
|
|
|
|
|
|
|
$spec =~ s{ \A \s+ }{}xms; |
194
|
|
|
|
|
|
|
$spec =~ s{ \s+ \z }{}xms; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# Error reporting here is an interesting question. Use warn rather than |
197
|
|
|
|
|
|
|
# carp because carp would report the line of the use or require, which |
198
|
|
|
|
|
|
|
# doesn't help anyone understand what's going on, whereas seeing this code |
199
|
|
|
|
|
|
|
# will be more helpful. |
200
|
|
|
|
|
|
|
## no critic (ErrorHandling::RequireCarping) |
201
|
|
|
|
|
|
|
for my $definition (split(m{\s*,\s*}xms, $spec)) { |
202
|
|
|
|
|
|
|
my ($new, $old) = split(m{\s*=\s*}xms, $definition, 2); |
203
|
|
|
|
|
|
|
if (!$new || !$old) { |
204
|
|
|
|
|
|
|
warn qq{Bad color mapping "$definition"}; |
205
|
|
|
|
|
|
|
} else { |
206
|
|
|
|
|
|
|
my $result = eval { coloralias($new, $old) }; |
207
|
|
|
|
|
|
|
if (!$result) { |
208
|
|
|
|
|
|
|
my $error = $@; |
209
|
|
|
|
|
|
|
$error =~ s{ [ ] at [ ] .* }{}xms; |
210
|
|
|
|
|
|
|
warn qq{$error in "$definition"}; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# Stores the current color stack maintained by PUSHCOLOR and POPCOLOR. This |
217
|
|
|
|
|
|
|
# is global and therefore not threadsafe. |
218
|
|
|
|
|
|
|
our @COLORSTACK; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
############################################################################## |
221
|
|
|
|
|
|
|
# Helper functions |
222
|
|
|
|
|
|
|
############################################################################## |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Stub to load the Carp module on demand. |
225
|
|
|
|
|
|
|
sub croak { |
226
|
51
|
|
|
51
|
0
|
82
|
my (@args) = @_; |
227
|
51
|
|
|
|
|
231
|
require Carp; |
228
|
51
|
|
|
|
|
4565
|
Carp::croak(@args); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
############################################################################## |
232
|
|
|
|
|
|
|
# Implementation (constant form) |
233
|
|
|
|
|
|
|
############################################################################## |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# Time to have fun! We now want to define the constant subs, which are named |
236
|
|
|
|
|
|
|
# the same as the attributes above but in all caps. Each constant sub needs |
237
|
|
|
|
|
|
|
# to act differently depending on whether $AUTORESET is set. Without |
238
|
|
|
|
|
|
|
# autoreset: |
239
|
|
|
|
|
|
|
# |
240
|
|
|
|
|
|
|
# BLUE "text\n" ==> "\e[34mtext\n" |
241
|
|
|
|
|
|
|
# |
242
|
|
|
|
|
|
|
# If $AUTORESET is set, we should instead get: |
243
|
|
|
|
|
|
|
# |
244
|
|
|
|
|
|
|
# BLUE "text\n" ==> "\e[34mtext\n\e[0m" |
245
|
|
|
|
|
|
|
# |
246
|
|
|
|
|
|
|
# The sub also needs to handle the case where it has no arguments correctly. |
247
|
|
|
|
|
|
|
# Maintaining all of this as separate subs would be a major nightmare, as well |
248
|
|
|
|
|
|
|
# as duplicate the %ATTRIBUTES hash, so instead we define an AUTOLOAD sub to |
249
|
|
|
|
|
|
|
# define the constant subs on demand. To do that, we check the name of the |
250
|
|
|
|
|
|
|
# called sub against the list of attributes, and if it's an all-caps version |
251
|
|
|
|
|
|
|
# of one of them, we define the sub on the fly and then run it. |
252
|
|
|
|
|
|
|
# |
253
|
|
|
|
|
|
|
# If the environment variable ANSI_COLORS_DISABLED is set to a true value, |
254
|
|
|
|
|
|
|
# just return the arguments without adding any escape sequences. This is to |
255
|
|
|
|
|
|
|
# make it easier to write scripts that also work on systems without any ANSI |
256
|
|
|
|
|
|
|
# support, like Windows consoles. |
257
|
|
|
|
|
|
|
# |
258
|
|
|
|
|
|
|
# Avoid using character classes like [:upper:] and \w here, since they load |
259
|
|
|
|
|
|
|
# Unicode character tables and consume a ton of memory. All of our constants |
260
|
|
|
|
|
|
|
# only use ASCII characters. |
261
|
|
|
|
|
|
|
# |
262
|
|
|
|
|
|
|
## no critic (ClassHierarchies::ProhibitAutoloading) |
263
|
|
|
|
|
|
|
## no critic (Subroutines::RequireArgUnpacking) |
264
|
|
|
|
|
|
|
## no critic (RegularExpressions::ProhibitEnumeratedClasses) |
265
|
|
|
|
|
|
|
sub AUTOLOAD { |
266
|
29
|
|
|
29
|
|
1786
|
my ($sub, $attr) = $AUTOLOAD =~ m{ |
267
|
|
|
|
|
|
|
\A ( [a-zA-Z0-9:]* :: ([A-Z0-9_]+) ) \z |
268
|
|
|
|
|
|
|
}xms; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# Check if we were called with something that doesn't look like an |
271
|
|
|
|
|
|
|
# attribute. |
272
|
29
|
100
|
100
|
|
|
156
|
if (!($attr && defined($ATTRIBUTES{ lc $attr }))) { |
273
|
3
|
|
|
|
|
9
|
croak("undefined subroutine &$AUTOLOAD called"); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# If colors are disabled, just return the input. Do this without |
277
|
|
|
|
|
|
|
# installing a sub for (marginal, unbenchmarked) speed. |
278
|
26
|
100
|
|
|
|
70
|
if ($ENV{ANSI_COLORS_DISABLED}) { |
279
|
1
|
|
|
|
|
5
|
return join(q{}, @_); |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
# We've untainted the name of the sub. |
283
|
25
|
|
|
|
|
36
|
$AUTOLOAD = $sub; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# Figure out the ANSI string to set the desired attribute. |
286
|
25
|
|
|
|
|
55
|
my $escape = "\e[" . $ATTRIBUTES{ lc $attr } . 'm'; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# Save the current value of $@. We can't just use local since we want to |
289
|
|
|
|
|
|
|
# restore it before dispatching to the newly-created sub. (The caller may |
290
|
|
|
|
|
|
|
# be colorizing output that includes $@.) |
291
|
25
|
|
|
|
|
33
|
my $eval_err = $@; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# Generate the constant sub, which should still recognize some of our |
294
|
|
|
|
|
|
|
# package variables. Use string eval to avoid a dependency on |
295
|
|
|
|
|
|
|
# Sub::Install, even though it makes it somewhat less readable. |
296
|
|
|
|
|
|
|
## no critic (BuiltinFunctions::ProhibitStringyEval) |
297
|
|
|
|
|
|
|
## no critic (ValuesAndExpressions::ProhibitImplicitNewlines) |
298
|
25
|
100
|
100
|
32
|
0
|
3710
|
my $eval_result = eval qq{ |
|
32
|
100
|
100
|
27
|
0
|
170
|
|
|
4
|
100
|
100
|
8
|
0
|
17
|
|
|
6
|
100
|
100
|
13
|
0
|
16
|
|
|
6
|
100
|
100
|
13
|
0
|
29
|
|
|
16
|
100
|
100
|
9
|
0
|
91
|
|
|
27
|
100
|
100
|
7
|
0
|
614
|
|
|
3
|
100
|
100
|
8
|
0
|
13
|
|
|
3
|
100
|
100
|
7
|
0
|
9
|
|
|
4
|
100
|
100
|
10
|
0
|
34
|
|
|
17
|
100
|
100
|
10
|
0
|
96
|
|
|
8
|
100
|
100
|
32
|
0
|
49
|
|
|
1
|
100
|
100
|
6
|
0
|
5
|
|
|
1
|
100
|
100
|
6
|
0
|
3
|
|
|
1
|
100
|
100
|
|
|
6
|
|
|
5
|
100
|
100
|
|
|
25
|
|
|
13
|
100
|
100
|
|
|
77
|
|
|
2
|
100
|
100
|
|
|
8
|
|
|
2
|
100
|
100
|
|
|
7
|
|
|
2
|
100
|
100
|
|
|
11
|
|
|
7
|
100
|
100
|
|
|
37
|
|
|
13
|
100
|
100
|
|
|
86
|
|
|
2
|
100
|
100
|
|
|
9
|
|
|
2
|
100
|
100
|
|
|
8
|
|
|
2
|
100
|
100
|
|
|
11
|
|
|
7
|
100
|
100
|
|
|
48
|
|
|
9
|
100
|
100
|
|
|
50
|
|
|
1
|
100
|
100
|
|
|
5
|
|
|
1
|
100
|
|
|
|
3
|
|
|
1
|
100
|
|
|
|
5
|
|
|
6
|
100
|
|
|
|
40
|
|
|
7
|
100
|
|
|
|
41
|
|
|
1
|
100
|
|
|
|
4
|
|
|
1
|
100
|
|
|
|
3
|
|
|
1
|
100
|
|
|
|
5
|
|
|
4
|
100
|
|
|
|
19
|
|
|
8
|
100
|
|
|
|
42
|
|
|
1
|
100
|
|
|
|
5
|
|
|
1
|
100
|
|
|
|
3
|
|
|
1
|
100
|
|
|
|
6
|
|
|
5
|
100
|
|
|
|
24
|
|
|
7
|
100
|
|
|
|
41
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
53
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
6
|
|
|
7
|
|
|
|
|
57
|
|
|
10
|
|
|
|
|
51
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
6
|
|
|
7
|
|
|
|
|
43
|
|
|
32
|
|
|
|
|
158
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
10
|
|
|
28
|
|
|
|
|
180
|
|
|
6
|
|
|
|
|
37
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
37
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
16
|
|
299
|
|
|
|
|
|
|
sub $AUTOLOAD { |
300
|
|
|
|
|
|
|
if (\$ENV{ANSI_COLORS_DISABLED}) { |
301
|
|
|
|
|
|
|
return join(q{}, \@_); |
302
|
|
|
|
|
|
|
} elsif (\$AUTOLOCAL && \@_) { |
303
|
|
|
|
|
|
|
return PUSHCOLOR('$escape') . join(q{}, \@_) . POPCOLOR; |
304
|
|
|
|
|
|
|
} elsif (\$AUTORESET && \@_) { |
305
|
|
|
|
|
|
|
return '$escape' . join(q{}, \@_) . "\e[0m"; |
306
|
|
|
|
|
|
|
} else { |
307
|
|
|
|
|
|
|
return '$escape' . join(q{}, \@_); |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
1; |
311
|
|
|
|
|
|
|
}; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# Failure is an internal error, not a problem with the caller. |
314
|
|
|
|
|
|
|
## no critic (ErrorHandling::RequireCarping) |
315
|
25
|
100
|
|
|
|
111
|
if (!$eval_result) { |
316
|
1
|
|
|
|
|
7
|
die "failed to generate constant $attr: $@"; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# Restore $@. |
320
|
|
|
|
|
|
|
## no critic (Variables::RequireLocalizedPunctuationVars) |
321
|
24
|
|
|
|
|
33
|
$@ = $eval_err; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
# Dispatch to the newly-created sub. |
324
|
24
|
|
|
|
|
413
|
goto &$AUTOLOAD; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
## use critic |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
# Append a new color to the top of the color stack and return the top of |
329
|
|
|
|
|
|
|
# the stack. |
330
|
|
|
|
|
|
|
# |
331
|
|
|
|
|
|
|
# $text - Any text we're applying colors to, with color escapes prepended |
332
|
|
|
|
|
|
|
# |
333
|
|
|
|
|
|
|
# Returns: The text passed in |
334
|
|
|
|
|
|
|
sub PUSHCOLOR { |
335
|
32
|
|
|
32
|
0
|
58
|
my (@text) = @_; |
336
|
32
|
|
|
|
|
69
|
my $text = join(q{}, @text); |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# Extract any number of color-setting escape sequences from the start of |
339
|
|
|
|
|
|
|
# the string. |
340
|
32
|
|
|
|
|
131
|
my ($color) = $text =~ m{ \A ( (?:\e\[ [\d;]+ m)+ ) }xms; |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# If we already have a stack, append these escapes to the set from the top |
343
|
|
|
|
|
|
|
# of the stack. This way, each position in the stack stores the complete |
344
|
|
|
|
|
|
|
# enabled colors for that stage, at the cost of some potential |
345
|
|
|
|
|
|
|
# inefficiency. |
346
|
32
|
100
|
|
|
|
68
|
if (@COLORSTACK) { |
347
|
8
|
|
|
|
|
16
|
$color = $COLORSTACK[-1] . $color; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# Push the color onto the stack. |
351
|
32
|
|
|
|
|
57
|
push(@COLORSTACK, $color); |
352
|
32
|
|
|
|
|
99
|
return $text; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
# Pop the color stack and return the new top of the stack (or reset, if |
356
|
|
|
|
|
|
|
# the stack is empty). |
357
|
|
|
|
|
|
|
# |
358
|
|
|
|
|
|
|
# @text - Any text we're applying colors to |
359
|
|
|
|
|
|
|
# |
360
|
|
|
|
|
|
|
# Returns: The concatenation of @text prepended with the new stack color |
361
|
|
|
|
|
|
|
sub POPCOLOR { |
362
|
32
|
|
|
32
|
0
|
55
|
my (@text) = @_; |
363
|
32
|
|
|
|
|
40
|
pop(@COLORSTACK); |
364
|
32
|
100
|
|
|
|
58
|
if (@COLORSTACK) { |
365
|
8
|
|
|
|
|
42
|
return $COLORSTACK[-1] . join(q{}, @text); |
366
|
|
|
|
|
|
|
} else { |
367
|
24
|
|
|
|
|
364
|
return RESET(@text); |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# Surround arguments with a push and a pop. The effect will be to reset the |
372
|
|
|
|
|
|
|
# colors to whatever was on the color stack before this sequence of colors was |
373
|
|
|
|
|
|
|
# applied. |
374
|
|
|
|
|
|
|
# |
375
|
|
|
|
|
|
|
# @text - Any text we're applying colors to |
376
|
|
|
|
|
|
|
# |
377
|
|
|
|
|
|
|
# Returns: The concatenation of the text and the proper color reset sequence. |
378
|
|
|
|
|
|
|
sub LOCALCOLOR { |
379
|
3
|
|
|
3
|
0
|
6
|
my (@text) = @_; |
380
|
3
|
|
|
|
|
8
|
return PUSHCOLOR(join(q{}, @text)) . POPCOLOR(); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
############################################################################## |
384
|
|
|
|
|
|
|
# Implementation (attribute string form) |
385
|
|
|
|
|
|
|
############################################################################## |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# Return the escape code for a given set of color attributes. |
388
|
|
|
|
|
|
|
# |
389
|
|
|
|
|
|
|
# @codes - A list of possibly space-separated color attributes |
390
|
|
|
|
|
|
|
# |
391
|
|
|
|
|
|
|
# Returns: The escape sequence setting those color attributes |
392
|
|
|
|
|
|
|
# undef if no escape sequences were given |
393
|
|
|
|
|
|
|
# Throws: Text exception for any invalid attribute |
394
|
|
|
|
|
|
|
sub color { |
395
|
76
|
|
|
76
|
1
|
4029
|
my (@codes) = @_; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
# Return the empty string if colors are disabled. |
398
|
76
|
100
|
|
|
|
162
|
if ($ENV{ANSI_COLORS_DISABLED}) { |
399
|
1
|
|
|
|
|
4
|
return q{}; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# Split on whitespace and expand aliases. |
403
|
75
|
|
|
|
|
124
|
@codes = map { split } @codes; |
|
83
|
|
|
|
|
227
|
|
404
|
75
|
100
|
|
|
|
96
|
@codes = map { defined($ALIASES{$_}) ? @{ $ALIASES{$_} } : $_ } @codes; |
|
94
|
|
|
|
|
219
|
|
|
8
|
|
|
|
|
21
|
|
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Build the attribute string from semicolon-separated numbers. |
407
|
|
|
|
|
|
|
## no critic (RegularExpressions::ProhibitEnumeratedClasses) |
408
|
75
|
|
|
|
|
104
|
my $attribute = q{}; |
409
|
75
|
|
|
|
|
103
|
for my $code (@codes) { |
410
|
100
|
|
|
|
|
159
|
$code = lc($code); |
411
|
100
|
100
|
|
|
|
290
|
if (defined($ATTRIBUTES{$code})) { |
|
|
100
|
|
|
|
|
|
412
|
66
|
|
|
|
|
107
|
$attribute .= $ATTRIBUTES{$code} . q{;}; |
413
|
|
|
|
|
|
|
} elsif ($code =~ m{ \A (on_)? r([0-9]+) g([0-9]+) b([0-9]+) \z }xms) { |
414
|
18
|
|
|
|
|
71
|
my ($r, $g, $b) = ($2 + 0, $3 + 0, $4 + 0); |
415
|
18
|
100
|
100
|
|
|
80
|
if ($r > 255 || $g > 255 || $b > 255) { |
|
|
|
100
|
|
|
|
|
416
|
4
|
|
|
|
|
9
|
croak("Invalid attribute name $code"); |
417
|
|
|
|
|
|
|
} |
418
|
14
|
100
|
|
|
|
28
|
my $prefix = $1 ? '48' : '38'; |
419
|
14
|
|
|
|
|
42
|
$attribute .= "$prefix;2;$r;$g;$b;"; |
420
|
|
|
|
|
|
|
} else { |
421
|
16
|
|
|
|
|
40
|
croak("Invalid attribute name $code"); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
## use critic |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
# We added one too many semicolons for simplicity. Remove the last one. |
427
|
55
|
|
|
|
|
72
|
chop($attribute); |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# Return undef if there were no attributes. |
430
|
55
|
100
|
|
|
|
207
|
return ($attribute ne q{}) ? "\e[${attribute}m" : undef; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# Return a list of named color attributes for a given set of escape codes. |
434
|
|
|
|
|
|
|
# Escape sequences can be given with or without enclosing "\e[" and "m". The |
435
|
|
|
|
|
|
|
# empty escape sequence '' or "\e[m" gives an empty list of attrs. |
436
|
|
|
|
|
|
|
# |
437
|
|
|
|
|
|
|
# There is one special case. 256-color codes start with 38 or 48, followed by |
438
|
|
|
|
|
|
|
# a 5 and then the 256-color code. |
439
|
|
|
|
|
|
|
# |
440
|
|
|
|
|
|
|
# @escapes - A list of escape sequences or escape sequence numbers |
441
|
|
|
|
|
|
|
# |
442
|
|
|
|
|
|
|
# Returns: An array of attribute names corresponding to those sequences |
443
|
|
|
|
|
|
|
# Throws: Text exceptions on invalid escape sequences or unknown colors |
444
|
|
|
|
|
|
|
sub uncolor { |
445
|
39
|
|
|
39
|
1
|
16977
|
my (@escapes) = @_; |
446
|
39
|
|
|
|
|
54
|
my (@nums, @result); |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
# Walk the list of escapes and build a list of attribute numbers. |
449
|
39
|
|
|
|
|
64
|
for my $escape (@escapes) { |
450
|
42
|
|
|
|
|
148
|
$escape =~ s{ \A \e\[ }{}xms; |
451
|
42
|
|
|
|
|
114
|
$escape =~ s{ m \z } {}xms; |
452
|
42
|
|
|
|
|
191
|
my ($attrs) = $escape =~ m{ \A ((?:\d+;)* \d*) \z }xms; |
453
|
42
|
100
|
|
|
|
91
|
if (!defined($attrs)) { |
454
|
1
|
|
|
|
|
4
|
croak("Bad escape sequence $escape"); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# Pull off 256-color codes (38;5;n or 48;5;n) and true color codes |
458
|
|
|
|
|
|
|
# (38;2;n;n;n or 48;2;n;n;n) as a unit. |
459
|
41
|
|
|
|
|
106
|
my $regex = qr{ |
460
|
|
|
|
|
|
|
( |
461
|
|
|
|
|
|
|
0*[34]8 ; 0*2 ; \d+ ; \d+ ; \d+ |
462
|
|
|
|
|
|
|
| 0*[34]8 ; 0*5 ; \d+ |
463
|
|
|
|
|
|
|
| \d+ |
464
|
|
|
|
|
|
|
) |
465
|
|
|
|
|
|
|
(?: ; | \z ) |
466
|
|
|
|
|
|
|
}xms; |
467
|
41
|
|
|
|
|
280
|
push(@nums, $attrs =~ m{$regex}xmsg); |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# Now, walk the list of numbers and convert them to attribute names. |
471
|
|
|
|
|
|
|
# Strip leading zeroes from any of the numbers. (xterm, at least, allows |
472
|
|
|
|
|
|
|
# leading zeroes to be added to any number in an escape sequence.) |
473
|
38
|
|
|
|
|
65
|
for my $num (@nums) { |
474
|
44
|
100
|
|
|
|
102
|
if ($num =~ m{ \A 0*([34])8 ; 0*2 ; (\d+) ; (\d+) ; (\d+) \z }xms) { |
475
|
15
|
|
|
|
|
55
|
my ($r, $g, $b) = ($2 + 0, $3 + 0, $4 + 0); |
476
|
15
|
100
|
100
|
|
|
55
|
if ($r > 255 || $g > 255 || $b > 255) { |
|
|
|
100
|
|
|
|
|
477
|
8
|
|
|
|
|
21
|
croak("No name for escape sequence $num"); |
478
|
|
|
|
|
|
|
} |
479
|
7
|
100
|
|
|
|
15
|
my $prefix = ($1 == 4) ? 'on_' : q{}; |
480
|
7
|
|
|
|
|
21
|
push(@result, "${prefix}r${r}g${g}b${b}"); |
481
|
|
|
|
|
|
|
} else { |
482
|
29
|
|
|
|
|
55
|
$num =~ s{ ( \A | ; ) 0+ (\d) }{$1$2}xmsg; |
483
|
29
|
|
|
|
|
56
|
my $name = $ATTRIBUTES_R{$num}; |
484
|
29
|
100
|
|
|
|
56
|
if (!defined($name)) { |
485
|
15
|
|
|
|
|
38
|
croak("No name for escape sequence $num"); |
486
|
|
|
|
|
|
|
} |
487
|
14
|
|
|
|
|
20
|
push(@result, $name); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# Return the attribute names. |
492
|
15
|
|
|
|
|
77
|
return @result; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# Given a string and a set of attributes, returns the string surrounded by |
496
|
|
|
|
|
|
|
# escape codes to set those attributes and then clear them at the end of the |
497
|
|
|
|
|
|
|
# string. The attributes can be given either as an array ref as the first |
498
|
|
|
|
|
|
|
# argument or as a list as the second and subsequent arguments. |
499
|
|
|
|
|
|
|
# |
500
|
|
|
|
|
|
|
# If $EACHLINE is set, insert a reset before each occurrence of the string |
501
|
|
|
|
|
|
|
# $EACHLINE and the starting attribute code after the string $EACHLINE, so |
502
|
|
|
|
|
|
|
# that no attribute crosses line delimiters (this is often desirable if the |
503
|
|
|
|
|
|
|
# output is to be piped to a pager or some other program). |
504
|
|
|
|
|
|
|
# |
505
|
|
|
|
|
|
|
# $first - An anonymous array of attributes or the text to color |
506
|
|
|
|
|
|
|
# @rest - The text to color or the list of attributes |
507
|
|
|
|
|
|
|
# |
508
|
|
|
|
|
|
|
# Returns: The text, concatenated if necessary, surrounded by escapes to set |
509
|
|
|
|
|
|
|
# the desired colors and reset them afterwards |
510
|
|
|
|
|
|
|
# Throws: Text exception on invalid attributes |
511
|
|
|
|
|
|
|
sub colored { |
512
|
17
|
|
|
17
|
1
|
2836
|
my ($first, @rest) = @_; |
513
|
17
|
|
|
|
|
25
|
my ($string, @codes); |
514
|
17
|
100
|
100
|
|
|
59
|
if (ref($first) && ref($first) eq 'ARRAY') { |
515
|
2
|
|
|
|
|
3
|
@codes = @{$first}; |
|
2
|
|
|
|
|
5
|
|
516
|
2
|
|
|
|
|
6
|
$string = join(q{}, @rest); |
517
|
|
|
|
|
|
|
} else { |
518
|
15
|
|
|
|
|
17
|
$string = $first; |
519
|
15
|
|
|
|
|
27
|
@codes = @rest; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# Return the string unmolested if colors are disabled. |
523
|
17
|
100
|
|
|
|
37
|
if ($ENV{ANSI_COLORS_DISABLED}) { |
524
|
1
|
|
|
|
|
4
|
return $string; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# Find the attribute string for our colors. |
528
|
16
|
|
|
|
|
29
|
my $attr = color(@codes); |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# If $EACHLINE is defined, split the string on line boundaries, suppress |
531
|
|
|
|
|
|
|
# empty segments, and then colorize each of the line sections. |
532
|
15
|
100
|
|
|
|
26
|
if (defined($EACHLINE)) { |
533
|
18
|
100
|
|
|
|
39
|
my @text = map { ($_ ne $EACHLINE) ? $attr . $_ . "\e[0m" : $_ } |
534
|
7
|
|
|
|
|
63
|
grep { length > 0 } |
|
22
|
|
|
|
|
35
|
|
535
|
|
|
|
|
|
|
split(m{ (\Q$EACHLINE\E) }xms, $string); |
536
|
7
|
|
|
|
|
37
|
return join(q{}, @text); |
537
|
|
|
|
|
|
|
} else { |
538
|
8
|
|
|
|
|
31
|
return $attr . $string . "\e[0m"; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# Define a new color alias, or return the value of an existing alias. |
543
|
|
|
|
|
|
|
# |
544
|
|
|
|
|
|
|
# $alias - The color alias to define |
545
|
|
|
|
|
|
|
# @color - The color attributes the alias will correspond to (optional) |
546
|
|
|
|
|
|
|
# |
547
|
|
|
|
|
|
|
# Returns: The standard color value of the alias as a string (may be multiple |
548
|
|
|
|
|
|
|
# attributes separated by spaces) |
549
|
|
|
|
|
|
|
# undef if one argument was given and the alias was not recognized |
550
|
|
|
|
|
|
|
# Throws: Text exceptions for invalid alias names, attempts to use a |
551
|
|
|
|
|
|
|
# standard color name as an alias, or an unknown standard color name |
552
|
|
|
|
|
|
|
sub coloralias { |
553
|
12
|
|
|
12
|
1
|
2906
|
my ($alias, @color) = @_; |
554
|
12
|
100
|
|
|
|
27
|
if (!@color) { |
555
|
3
|
100
|
|
|
|
7
|
if (exists($ALIASES{$alias})) { |
556
|
2
|
|
|
|
|
3
|
return join(q{ }, @{ $ALIASES{$alias} }); |
|
2
|
|
|
|
|
10
|
|
557
|
|
|
|
|
|
|
} else { |
558
|
1
|
|
|
|
|
3
|
return; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# Avoid \w here to not load Unicode character tables, which increases the |
563
|
|
|
|
|
|
|
# memory footprint of this module considerably. |
564
|
|
|
|
|
|
|
# |
565
|
|
|
|
|
|
|
## no critic (RegularExpressions::ProhibitEnumeratedClasses) |
566
|
9
|
100
|
|
|
|
51
|
if ($alias !~ m{ \A [a-zA-Z0-9._-]+ \z }xms) { |
|
|
100
|
|
|
|
|
|
567
|
2
|
|
|
|
|
7
|
croak(qq{Invalid alias name "$alias"}); |
568
|
|
|
|
|
|
|
} elsif ($ATTRIBUTES{$alias}) { |
569
|
1
|
|
|
|
|
5
|
croak(qq{Cannot alias standard color "$alias"}); |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
## use critic |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
# Split on whitespace and expand aliases. |
574
|
6
|
|
|
|
|
10
|
@color = map { split } @color; |
|
7
|
|
|
|
|
22
|
|
575
|
6
|
100
|
|
|
|
7
|
@color = map { defined($ALIASES{$_}) ? @{ $ALIASES{$_} } : $_ } @color; |
|
10
|
|
|
|
|
21
|
|
|
2
|
|
|
|
|
5
|
|
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
# Check that all of the attributes are valid. |
578
|
6
|
|
|
|
|
11
|
for my $attribute (@color) { |
579
|
10
|
100
|
|
|
|
20
|
if (!exists($ATTRIBUTES{$attribute})) { |
580
|
1
|
|
|
|
|
4
|
croak(qq{Invalid attribute name "$attribute"}); |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# Set the alias and return. |
585
|
5
|
|
|
|
|
13
|
$ALIASES{$alias} = [@color]; |
586
|
5
|
|
|
|
|
26
|
return join(q{ }, @color); |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
# Given a string, strip the ANSI color codes out of that string and return the |
590
|
|
|
|
|
|
|
# result. This removes only ANSI color codes, not movement codes and other |
591
|
|
|
|
|
|
|
# escape sequences. |
592
|
|
|
|
|
|
|
# |
593
|
|
|
|
|
|
|
# @string - The list of strings to sanitize |
594
|
|
|
|
|
|
|
# |
595
|
|
|
|
|
|
|
# Returns: (array) The strings stripped of ANSI color escape sequences |
596
|
|
|
|
|
|
|
# (scalar) The same, concatenated |
597
|
|
|
|
|
|
|
sub colorstrip { |
598
|
5
|
|
|
5
|
1
|
12
|
my (@string) = @_; |
599
|
5
|
|
|
|
|
9
|
for my $string (@string) { |
600
|
11
|
|
|
|
|
38
|
$string =~ s{ \e\[ [\d;]* m }{}xmsg; |
601
|
|
|
|
|
|
|
} |
602
|
5
|
100
|
|
|
|
28
|
return wantarray ? @string : join(q{}, @string); |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# Given a list of color attributes (arguments for color, for instance), return |
606
|
|
|
|
|
|
|
# true if they're all valid or false if any of them are invalid. |
607
|
|
|
|
|
|
|
# |
608
|
|
|
|
|
|
|
# @codes - A list of color attributes, possibly space-separated |
609
|
|
|
|
|
|
|
# |
610
|
|
|
|
|
|
|
# Returns: True if all the attributes are valid, false otherwise. |
611
|
|
|
|
|
|
|
sub colorvalid { |
612
|
33
|
|
|
33
|
1
|
15307
|
my (@codes) = @_; |
613
|
33
|
|
|
|
|
64
|
@codes = map { split(q{ }, lc) } @codes; |
|
34
|
|
|
|
|
110
|
|
614
|
33
|
|
|
|
|
56
|
for my $code (@codes) { |
615
|
38
|
100
|
|
|
|
90
|
next if defined($ATTRIBUTES{$code}); |
616
|
26
|
100
|
|
|
|
45
|
next if defined($ALIASES{$code}); |
617
|
24
|
100
|
|
|
|
110
|
if ($code =~ m{ \A (?: on_ )? r (\d+) g (\d+) b (\d+) \z }xms) { |
618
|
10
|
100
|
100
|
|
|
57
|
next if ($1 <= 255 && $2 <= 255 && $3 <= 255); |
|
|
|
100
|
|
|
|
|
619
|
|
|
|
|
|
|
} |
620
|
18
|
|
|
|
|
56
|
return; |
621
|
|
|
|
|
|
|
} |
622
|
15
|
|
|
|
|
51
|
return 1; |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
############################################################################## |
626
|
|
|
|
|
|
|
# Module return value and documentation |
627
|
|
|
|
|
|
|
############################################################################## |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# Ensure we evaluate to true. |
630
|
|
|
|
|
|
|
1; |
631
|
|
|
|
|
|
|
__END__ |