File Coverage

blib/lib/IRC/Toolkit/Colors.pm
Criterion Covered Total %
statement 22 24 91.6
branch 2 4 50.0
condition 1 5 20.0
subroutine 6 6 100.0
pod 3 3 100.0
total 34 42 80.9


line stmt bran cond sub pod time code
1             package IRC::Toolkit::Colors;
2             $IRC::Toolkit::Colors::VERSION = '0.092001';
3 3     3   1236 use strictures 2;
  3         1273  
  3         140  
4 3     3   655 use Carp;
  3         6  
  3         216  
5              
6 3     3   438 use parent 'Exporter::Tiny';
  3         234  
  3         22  
7             our @EXPORT = qw/
8             color
9             has_color
10             strip_color
11             /;
12              
13             our %COLORS = (
14             NORMAL => "\x0f",
15              
16             BOLD => "\x02",
17             UNDERLINE => "\x1f",
18             REVERSE => "\x16",
19             ITALIC => "\x1d",
20              
21             WHITE => "\x0300",
22             BLACK => "\x0301",
23             BLUE => "\x0302",
24             GREEN => "\x0303",
25             RED => "\x0304",
26             BROWN => "\x0305",
27             PURPLE => "\x0306",
28             ORANGE => "\x0307",
29             YELLOW => "\x0308",
30             TEAL => "\x0310",
31             PINK => "\x0313",
32             GREY => "\x0314",
33             GRAY => "\x0314",
34              
35             LIGHT_BLUE => "\x0312",
36             LIGHT_CYAN => "\x0311",
37             CYAN => "\x0311",
38             LIGHT_GREEN => "\x0309",
39             LIGHT_GRAY => "\x0315",
40             LIGHT_GREY => "\x0315",
41             );
42              
43             sub color {
44 2     2 1 998 my ($fmt, $str) = @_;
45 2   50     6 $fmt = uc($fmt || 'normal');
46 2         3 my $slct = $COLORS{$fmt};
47 2 50       6 unless (defined $slct) {
48 0         0 carp "Invalid format $fmt passed to color()";
49             return $str || $COLORS{NORMAL}
50 0   0     0 }
51 2 50       10 $str ? join('', $slct, $str, $COLORS{NORMAL}) : $slct
52             }
53              
54             sub has_color {
55 2     2 1 383 !! ( $_[0] =~ /[\x02\x03\x04\x1B\x1f\x16\x1d\x11\x06]/ )
56             }
57              
58             sub strip_color {
59 1     1 1 2 my ($str) = @_;
60             # Borrowed from IRC::Utils;
61             # mIRC:
62 1         2 $str =~ s/\x03(?:,\d{1,2}|\d{1,2}(?:,\d{1,2})?)?//g;
63             # RGB:
64 1         2 $str =~ s/\x04[0-9a-fA-F]{0,6}//ig;
65             # ECMA-48:
66 1         1 $str =~ s/\x1B\[.*?[\x00-\x1F\x40-\x7E]//g;
67             # Formatting codes:
68 1         6 $str =~ s/[\x02\x1f\x16\x1d\x11\x06]//g;
69             # Cancellation code:
70 1         2 $str =~ s/\x0f//g;
71 1         3 $str
72             }
73              
74              
75             1;
76              
77             =pod
78              
79             =head1 NAME
80              
81             IRC::Toolkit::Colors - IRC color code utilities
82              
83             =head1 SYNOPSIS
84              
85             my $str = color('red', "red text") ." other text";
86              
87             if (has_color($str)) {
88             # ...
89             }
90              
91             my $stripped = strip_color($str);
92              
93             =head1 DESCRIPTION
94              
95             IRC utilities for adding color/formatting codes to a string.
96              
97             =head2 color
98              
99             my $code = color('red');
100             my $str = color('bold') . "bold text" . color() . "normal text";
101             my $str = color('bold', "bold text");
102              
103             Add mIRC formatting/color codes to a string.
104              
105             Valid formatting codes are:
106              
107             normal
108             bold
109             underline
110             reverse
111             italic
112              
113             Valid color codes are:
114              
115             white
116             black
117             blue
118             light_blue
119             cyan
120             green
121             light_green
122             red
123             brown
124             purple
125             orange
126             yellow
127             teal
128             pink
129             gray
130             light_gray
131              
132             =head2 has_color
133              
134             Returns true if the given string contains color or formatting codes.
135              
136             =head2 strip_color
137              
138             Strips all color and formatting codes from the string.
139              
140             =head1 AUTHOR
141              
142             Jon Portnoy
143              
144             Much of this code is primarily derived from L, authored by HINRIK &
145             BINGOS.
146              
147             Licensed under the same terms as Perl.
148              
149             =cut