File Coverage

blib/lib/Parse/ANSIColor/Tiny.pm
Criterion Covered Total %
statement 114 115 99.1
branch 45 48 93.7
condition 7 7 100.0
subroutine 19 19 100.0
pod 13 13 100.0
total 198 202 98.0


line stmt bran cond sub pod time code
1             # vim: set ts=2 sts=2 sw=2 expandtab smarttab:
2             #
3             # This file is part of Parse-ANSIColor-Tiny
4             #
5             # This software is copyright (c) 2011 by Randy Stauner.
6             #
7             # This is free software; you can redistribute it and/or modify it under
8             # the same terms as the Perl 5 programming language system itself.
9             #
10 13     13   124104 use strict;
  13         19  
  13         373  
11 13     13   51 use warnings;
  13         15  
  13         19031  
12              
13             package Parse::ANSIColor::Tiny;
14             # git description: v0.501-13-g0dfbfe4
15              
16             our $AUTHORITY = 'cpan:RWSTAUNER';
17             # ABSTRACT: Determine attributes of ANSI-Colored string
18             $Parse::ANSIColor::Tiny::VERSION = '0.600';
19             our @COLORS = qw( black red green yellow blue magenta cyan white );
20             our %FOREGROUND = (
21             (map { ( $COLORS[$_] => 30 + $_ ) } 0 .. $#COLORS),
22             (map { ( 'bright_' . $COLORS[$_] => 90 + $_ ) } 0 .. $#COLORS),
23             );
24             our %BACKGROUND = (
25             (map { ( 'on_' . $COLORS[$_] => 40 + $_ ) } 0 .. $#COLORS),
26             (map { ('on_bright_' . $COLORS[$_] => 100 + $_ ) } 0 .. $#COLORS),
27             );
28             our %ATTRIBUTES = (
29             clear => 0,
30             reset => 0,
31             bold => 1,
32             dark => 2,
33             faint => 2,
34             underline => 4,
35             underscore => 4,
36             blink => 5,
37             reverse => 7,
38             concealed => 8,
39             reverse_off => 27,
40             reset_foreground => 39,
41             reset_background => 49,
42             %FOREGROUND,
43             %BACKGROUND,
44             );
45              
46             # Generating the 256-color codes involves a lot of codes and offsets that are
47             # not helped by turning them into constants.
48             ## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
49              
50             our @COLORS256;
51              
52             # The first 16 256-color codes are duplicates of the 16 ANSI colors,
53             # included for completeness.
54             for my $code (0 .. 15) {
55             my $name = "ansi$code";
56             $ATTRIBUTES{$name} = "38;5;$code";
57             $ATTRIBUTES{"on_$name"} = "48;5;$code";
58             push @COLORS256, $name;
59             }
60              
61             # 256-color RGB colors. Red, green, and blue can each be values 0 through 5,
62             # and the resulting 216 colors start with color 16.
63             for my $r (0 .. 5) {
64             for my $g (0 .. 5) {
65             for my $b (0 .. 5) {
66             my $code = 16 + (6 * 6 * $r) + (6 * $g) + $b;
67             my $name = "rgb$r$g$b";
68             $ATTRIBUTES{$name} = "38;5;$code";
69             $ATTRIBUTES{"on_$name"} = "48;5;$code";
70             push @COLORS256, $name;
71             }
72             }
73             }
74              
75             # The last 256-color codes are 24 shades of grey.
76             for my $n (0 .. 23) {
77             my $code = $n + 232;
78             my $name = "grey$n";
79             $ATTRIBUTES{$name} = "38;5;$code";
80             $ATTRIBUTES{"on_$name"} = "48;5;$code";
81             push @COLORS256, $name;
82             }
83              
84             # copied from Term::ANSIColor
85             our %ATTRIBUTES_R;
86             # Reverse lookup. Alphabetically first name for a sequence is preferred.
87             for (reverse sort keys %ATTRIBUTES) {
88             $ATTRIBUTES_R{$ATTRIBUTES{$_}} = $_;
89             }
90              
91              
92             sub new {
93 25     25 1 23481 my $class = shift;
94             my $self = {
95             remove_escapes => 1,
96 25 50       104 @_ == 1 ? %{ $_[0] } : @_,
  0         0  
97             };
98              
99             $self->{process} = 1
100 25 100       102 if $self->{auto_reverse};
101              
102             # fix incorrectly specified attributes
103 25   100     209 ($self->{background} ||= 'black') =~ s/^(on_)*/on_/;
104 25   100     157 ($self->{foreground} ||= 'white') =~ s/^(on_)*//;
105              
106 25         144 bless $self, $class;
107             }
108              
109              
110             sub colors {
111 1     1 1 1085 return (@COLORS, @COLORS256);
112             }
113             sub foreground_colors {
114             return (
115             @COLORS,
116 1     1 1 4 (map { "bright_$_" } @COLORS),
  8         47  
117             @COLORS256,
118             );
119             }
120             sub background_colors {
121             return (
122 8         14 (map { "on_$_" } @COLORS),
123 8         11 (map { "on_bright_$_" } @COLORS),
124 1     1 1 12280 (map { "on_$_" } @COLORS256),
  256         261  
125             );
126             }
127              
128              
129             sub __separate_and_normalize {
130 1293     1293   952 my ($codes) = @_;
131              
132             # Treat empty as "clear".
133 1293 100 100     3526 defined($codes) && length($codes)
134             or return 0;
135              
136             # Replace empty (clear) with zero to simplify parsing and return values.
137 1284         1072 $codes =~ s/^;/0;/;
138 1284         864 $codes =~ s/;$/;0/;
139             # Insert a zero between two semicolons (use look-ahead to get /g to find all).
140 1284         1152 $codes =~ s/;(?=;)/;0/g;
141              
142             # Remove any leading zeros from (sections of) codes.
143 1284         1532 $codes =~ s/\b0+(?=\d)//g;
144              
145             # Return all matches (of extended sequences or digits).
146 1284         3024 return $codes =~ m{ ( [34]8;5;\d+ | \d+) }xg;
147             }
148              
149             sub identify {
150 1286     1286 1 2037 my ($self, @codes) = @_;
151 1286         870 local $_;
152             return
153 1400         2749 grep { defined }
154 1400         1839 map { $ATTRIBUTES_R{ $_ } }
155 1286         1035 map { __separate_and_normalize($_) }
  1293         1165  
156             @codes;
157             }
158              
159              
160             sub normalize {
161 1265     1265 1 1645 my $self = shift;
162 1265         776 my @norm;
163 1265         1239 foreach my $attr ( @_ ){
164 2117 100       3668 if( $attr eq 'clear' ){
    100          
    100          
    100          
165 584         601 @norm = ();
166             }
167             elsif( $attr eq 'reverse_off' ){
168             # reverse_off cancels reverse
169 8         10 @norm = grep { $_ ne 'reverse' } @norm;
  21         38  
170             }
171             elsif( $attr eq 'reset_foreground' ){
172 4         4 @norm = grep { !exists $FOREGROUND{$_} } @norm;
  5         10  
173             }
174             elsif( $attr eq 'reset_background' ){
175 1         2 @norm = grep { !exists $BACKGROUND{$_} } @norm;
  1         3  
176             }
177             else {
178             # remove previous (duplicate) occurrences of this attribute
179 1520         1306 @norm = grep { $_ ne $attr } @norm;
  373         595  
180             # new fg color overwrites previous fg
181 1520 100       2030 @norm = grep { !exists $FOREGROUND{$_} } @norm if exists $FOREGROUND{$attr};
  120         198  
182             # new bg color overwrites previous bg
183 1520 100       1804 @norm = grep { !exists $BACKGROUND{$_} } @norm if exists $BACKGROUND{$attr};
  64         96  
184 1520         1626 push @norm, $attr;
185             }
186             }
187 1265         1588 return @norm;
188             }
189              
190              
191             sub parse {
192 32     32 1 12255 my ($self, $orig) = @_;
193              
194 32         89 my $last_pos = 0;
195 32         46 my $last_attr = [];
196 32         41 my $processed = [];
197 32         33 my $parsed = [];
198              
199             # Strip escape sequences that we aren't going to use
200             $orig = $self->remove_escape_sequences($orig)
201 32 100       145 if $self->{remove_escapes};
202              
203 32         153 while( $orig =~ m/(\e\[([0-9;]*)m)/mg ){
204 1247         1247 my $seq = $1;
205 1247         960 my $attrs = $2;
206              
207 1247         912 my $cur_pos = pos($orig);
208              
209 1247         943 my $len = ($cur_pos - length($seq)) - $last_pos;
210 1247 100       2847 push @$parsed, [
211             $processed,
212             substr($orig, $last_pos, $len)
213             ]
214             # don't bother with empty strings
215             if $len;
216              
217 1247         847 $last_pos = $cur_pos;
218 1247         1517 $last_attr = [$self->normalize(@$last_attr, $self->identify($attrs))];
219 1247 100       3951 $processed = $self->{process} ? [$self->process(@$last_attr)] : $last_attr;
220             }
221              
222 32 100       103 push @$parsed, [
223             $processed,
224             substr($orig, $last_pos)
225             ]
226             # if there's any string left
227             if $last_pos < length($orig);
228              
229 32         327 return $parsed;
230             }
231              
232              
233             sub process {
234 26     26 1 964 my ($self, @attr) = @_;
235 26 100       87 @attr = $self->process_reverse(@attr) if $self->{auto_reverse};
236 26         159 return @attr;
237             }
238              
239              
240             sub process_reverse {
241 37     37 1 1648 my $self = shift;
242 37         49 my ($rev, $fg, $bg, @attr);
243 37         36 my $i = 0;
244 37         63 foreach my $attr ( @_ ){
245 95 100       220 if( $attr eq 'reverse' ){
    100          
    100          
246 24         23 $rev = 1;
247 24         32 next;
248             }
249             elsif( $FOREGROUND{ $attr } ){
250 28         27 $fg = $i;
251             }
252             elsif( $BACKGROUND{ $attr } ){
253 10         10 $bg = $i;
254             }
255 71         79 push @attr, $attr;
256 71         67 $i++;
257             }
258             # maintain order for consistency with other methods
259 37 100       59 if( $rev ){
260             # if either color is missing then the default colors should be reversed
261             {
262 24 100       23 $attr[ $fg = $i++ ] = $self->{foreground} if !defined $fg;
  24         49  
263 24 100       61 $attr[ $bg = $i++ ] = $self->{background} if !defined $bg;
264             }
265 24 50       72 $attr[ $fg ] = 'on_' . $attr[ $fg ] if defined $fg;
266 24 50       56 $attr[ $bg ] = substr( $attr[ $bg ], 3 ) if defined $bg;
267             }
268 37         147 return @attr;
269             }
270              
271              
272             sub remove_escape_sequences {
273 31     31 1 33 my ($self, $string) = @_;
274              
275             # This is in no way comprehensive or accurate...
276             # it just seems like most of the sequences match this.
277             # We could certainly expand this if the need arises.
278 31         371 $string =~ s{
279             \e\[
280             [0-9;]*
281             [a-ln-zA-Z]
282             }{}gx;
283              
284 31         60 return $string;
285             }
286              
287              
288             our @EXPORT_OK;
289             BEGIN {
290 13     13   38 my @funcs = qw(identify normalize parse);
291 13         20 my $suffix = '_ansicolor';
292 13         21 local $_;
293             eval join '', ## no critic (StringyEval)
294 13     1 1 22 map { "sub ${_}$suffix { __PACKAGE__->new->$_(\@_) }" }
  39     1 1 2049  
  1     1 1 66  
  1         4  
  1         5  
295             @funcs;
296 13         996 @EXPORT_OK = map { $_ . $suffix } @funcs;
  39         574  
297             }
298              
299             sub import {
300 5     5   32 my $class = shift;
301 5 100       2464 return unless @_;
302              
303 2         16 my $caller = caller;
304 13     13   754 no strict 'refs'; ## no critic (NoStrict)
  13         17  
  13         1749  
305              
306 2         3 foreach my $arg ( @_ ){
307             die "'$arg' is not exported by $class"
308 4 100       5 unless grep { $arg eq $_ } @EXPORT_OK;
  12         38  
309 3         1 *{"${caller}::$arg"} = *{"${class}::$arg"}{CODE};
  3         1156  
  3         8  
310             }
311             }
312              
313             # TODO: option for blotting out 'concealed'? s/\S/ /g
314              
315             1;
316              
317             # NOTE: this synopsis is tested (eval'ed) in t/synopsis.t
318              
319             __END__