File Coverage

blib/lib/Term/Chrome.pm
Criterion Covered Total %
statement 62 64 96.8
branch 31 44 70.4
condition 2 3 66.6
subroutine 18 18 100.0
pod 3 5 60.0
total 116 134 86.5


line stmt bran cond sub pod time code
1 4     4   63452 use strict;
  4         7  
  4         107  
2 4     4   20 use warnings;
  4         6  
  4         319  
3              
4             package Term::Chrome;
5             # ABSTRACT: DSL for colors and other terminal chrome
6             our $VERSION = '1.012';
7              
8             # Pre-declare packages
9             {
10             package # no index: private package
11             Term::Chrome::Color;
12             }
13              
14              
15 4     4   19 use Exporter 5.57 'import'; # perl 5.8.3
  4         116  
  4         130  
16             # @EXPORT is defined at the end
17              
18 4     4   24 use Carp ();
  4         6  
  4         977  
19             our @CARP_NOT = qw< Term::Chrome::Color >;
20              
21             # Private constructor for Term::Chrome objects. Lexical, so cross-packages.
22             # Arguments:
23             # - class name
24             # - foreground color
25             # - background color
26             # - flags list
27             my $new = sub
28             {
29             my ($class, @self) = @_;
30              
31             my $fg = $self[0];
32             Carp::croak "invalid fg color $fg"
33             if defined($fg) && ($fg < 0 || $fg > 255);
34             my $bg = $self[1];
35             Carp::croak "invalid bg color $bg"
36             if defined($bg) && ($bg < 0 || $bg > 255);
37             # TODO check flags
38              
39             bless \@self, $class
40             };
41              
42              
43             # Cache for color objects
44             my %COLOR_CACHE;
45              
46             sub color ($)
47             {
48 50     50 0 115 my $color = shift;
49 50 50       105 die "invalid color" if ref $color;
50 50         83 my $c = chr $color;
51             # We can not use '$COLOR_CACHE{$c} ||= ...' because this requires overloading
52             # We can not use 'no overloading' because this requires perl 5.10
53             exists $COLOR_CACHE{$c}
54             ? $COLOR_CACHE{$c}
55 50 100       176 : ($COLOR_CACHE{$c} = Term::Chrome::Color->$new($color, undef))
56             }
57              
58              
59             use overload
60 4         25 '""' => 'term',
61             '+' => '_plus',
62             '${}' => '_deref',
63             '&{}' => '_chromizer',
64             '.' => '_concat',
65             fallback => 0,
66 4     4   4728 ;
  4         3379  
67              
68             sub term
69             {
70 74     74 0 186 my $self = shift;
71 74         93 my ($fg, $bg) = @{$self}[0, 1];
  74         380  
72 74         147 my $r = join(';', @{$self}[2 .. $#$self]);
  74         164  
73 74 100 66     280 if (defined($fg) || defined($bg)) {
74 41 100       109 $r .= ';' if @$self > 2;
75 41 50       86 if (defined $fg) {
76             # LeoNerd says that this should be ----------> "38:5:$fg"
77             # according to the spec but gnome-terminal doesn't support that
78 41 50       98 $r .= $fg < 8 ? (30+$fg) : $fg < 16 ? "9$fg" : "38;5;$fg";
    100          
79 41 100       93 $r .= ';' if defined $bg;
80             }
81             # -------> "48:5:$bg"
82 41 50       104 $r .= $bg < 8 ? (40+$bg) : $bg < 16 ? "10$bg" : "48;5;$bg" if defined $bg;
    100          
    100          
83             }
84             "\e[${r}m"
85 74         337 }
86              
87              
88             sub _plus
89             {
90 35     35   345 my ($self, $other, $swap) = @_;
91              
92 35 50       80 return $self unless defined $other;
93              
94 35 50       134 die 'invalid value for +' unless $other->isa(__PACKAGE__);
95              
96 35         82 my @new = @$self;
97 35 50       88 $new[0] = $other->[0] if defined $other->[0];
98 35 50       77 $new[1] = $other->[1] if defined $other->[1];
99 35         61 push @new, @{$other}[2 .. $#$other];
  35         71  
100              
101 35         5981 bless \@new
102             }
103              
104             sub _deref
105             {
106 29     29   79 \("$_[0]")
107             }
108              
109             sub _concat
110             {
111 22 100   22   530 $_[2] ? $_[1].$_[0]->term
112             : $_[0]->term.$_[1]
113             }
114              
115              
116             # Stringified Reset constant for use in chomizers
117             # (the value is set at the end of this source)
118             my $Reset_str;
119              
120             sub _chromizer
121             {
122 6     6   62 my $chrome_str = shift->term;
123             sub {
124 7 50   7   22 unless (defined $_[0]) {
125 0         0 Carp::carp "missing argument in Term::Chrome chromizer";
126             return
127 0         0 }
128 7         33 $chrome_str . $_[0] . $Reset_str
129             }
130 6         29 }
131              
132             sub fg
133             {
134 4     4 1 9 my $c = $_[0]->[0];
135 4 50       14 defined($c) ? color($c) : undef
136             }
137              
138             sub bg
139             {
140 3     3 1 9 my $c = $_[0]->[1];
141 3 100       13 defined($c) ? color($c) : undef
142             }
143              
144             sub flags
145             {
146 3     3 1 5 my $self = shift;
147 3 50       11 return undef unless @$self > 2;
148 3         8 __PACKAGE__->$new(undef, undef, @{$self}[2..$#$self])
  3         9  
149             }
150              
151             package # no index: private package
152             Term::Chrome::Color;
153              
154             our @ISA = qw< Term::Chrome >;
155              
156             use overload
157 4 50       67 '/' => '_over',
158             # Even if overloading is set in the super class, we have to repeat it for old perls
159             (
160             $^V ge v5.18.0
161             ? ()
162             : (
163             '""' => \&Term::Chrome::term,
164             '+' => \&Term::Chrome::_plus,
165             '${}' => \&Term::Chrome::_deref,
166             '.' => \&Term::Chrome::_concat,
167             )
168             ),
169             fallback => 0,
170 4     4   3088 ;
  4         8  
171              
172             sub _over
173             {
174 18 50   18   486 die 'invalid bg color for /' unless ref($_[1]) eq __PACKAGE__;
175 18         47 Term::Chrome->$new($_[0]->[0], $_[1]->[0])
176             }
177              
178             package
179             Term::Chrome;
180              
181             # Build the constants and the @EXPORT list
182             #
183             # This block must be after "use overload" (for both Term::Chrome
184             # and Term::Chrome::Color) because overload must be set before blessing
185             # due to a bug in perl < 5.18
186             # (according to a comment in Types::Serialiser source)
187              
188             my $mk_flag = sub { __PACKAGE__->$new(undef, undef, $_[0]) };
189              
190             my %const = (
191             Reset => $mk_flag->(''),
192             ResetFg => $mk_flag->(39),
193             ResetBg => $mk_flag->(49),
194             ResetFlags => $mk_flag->(22),
195             Standout => $mk_flag->(7),
196             Underline => $mk_flag->(4),
197             Reverse => $mk_flag->(7),
198             Blink => $mk_flag->(5),
199             Bold => $mk_flag->(1),
200              
201             Black => color 0,
202             Red => color 1,
203             Green => color 2,
204             Yellow => color 3,
205             Blue => color 4,
206             Magenta => color 5,
207             Cyan => color 6,
208             White => color 7,
209              
210             # Larry Wall's favorite color
211             # The true 'chartreuse' color from X11 colors is #7fff00
212             # The xterm-256 color #118 is near: #87ff00
213             Chartreuse => color 118,
214             );
215              
216             our @EXPORT = ('color', keys %const);
217              
218             if ($^V lt v5.16.0) {
219 4     4   1093 no strict 'refs';
  4         10  
  4         609  
220             while (my ($name, $value) = each %const) {
221             *{__PACKAGE__."::$name"} = sub () { $value };
222             }
223             } else {
224             require constant;
225             constant->import(\%const);
226             }
227              
228             # See $Reset_str declaration above
229             $Reset_str = $const{Reset}->term;
230              
231             1;
232             # vim:set et ts=8 sw=4 sts=4: