File Coverage

blib/lib/Term/ANSIColor.pm
Criterion Covered Total %
statement 219 219 100.0
branch 148 148 100.0
condition 108 108 100.0
subroutine 30 30 100.0
pod 6 24 25.0
total 511 529 96.6


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__