File Coverage

blib/lib/App/Tailor.pm
Criterion Covered Total %
statement 62 74 83.7
branch 17 26 65.3
condition 2 14 14.2
subroutine 15 17 88.2
pod 6 8 75.0
total 102 139 73.3


line stmt bran cond sub pod time code
1             package App::Tailor;
2             # ABSTRACT: easily tailor terminal output to meet your needs
3             $App::Tailor::VERSION = '0.02';
4              
5              
6 4     4   957700 use strict;
  4         30  
  4         123  
7 4     4   20 use warnings;
  4         8  
  4         119  
8              
9 4     4   21 use Term::ANSIColor qw(color RESET);
  4         7  
  4         240  
10              
11 4     4   1967 use parent 'Exporter';
  4         1265  
  4         20  
12              
13             our @EXPORT = qw(
14             ignore
15             modify
16             colorize
17             tail
18             itail
19             reset_rules
20             );
21              
22 4     4   300 use constant IGNORE => 1;
  4         8  
  4         284  
23 4     4   21 use constant MODIFY => 2;
  4         7  
  4         166  
24 4     4   20 use constant COLORIZE => 3;
  4         8  
  4         3471  
25              
26             our @RULES;
27             our $RESET = RESET;
28             our $DEBUG;
29              
30             sub debug (&) {
31 69 50 33 69 0 259 if ($DEBUG || $ENV{APP_TAILOR_DEBUG}) {
32 0   0     0 my $msg = $_[0]->() || return;
33 0         0 warn __PACKAGE__.": $msg\n";
34             }
35             }
36              
37             sub reset_rules () {
38 6     6 1 13676 undef @RULES;
39             }
40              
41             sub itail (;$) {
42 6   33 6 1 36 my $fh = shift || *STDIN;
43 6         11 my $closed;
44              
45             return sub{
46 22 50   22   15358 return if $closed;
47              
48 22         60 LINE: until ($closed) {
49 24         95 my $line = <$fh>;
50              
51 24 100       61 unless (defined $line) {
52 4         10 $closed = 1;
53 4         23 return;
54             }
55              
56 20         49 chomp $line;
57              
58 20         124 debug{ "Input=[[$line]]" };
  0         0  
59              
60 20         82 for (@RULES) {
61 49         89 $line = apply_rule($line, $_);
62              
63 49 100       120 unless (defined $line) {
64 2         7 next LINE;
65             }
66             }
67              
68 18         111 return $line."\n";
69             }
70              
71 0         0 debug{ 'end of input' };
  0         0  
72 6         39 };
73             }
74              
75             sub tail (;$$) {
76 0   0 0 1 0 my $in = shift || *STDIN;
77 0   0     0 my $out = shift || *STDOUT;
78 0         0 my $iter = itail $in;
79 0         0 while ( defined( my $line = $iter->() ) ) {
80 0         0 print $out $line;
81             }
82             }
83              
84             sub apply_rule {
85 49     49 0 91 my ($line, $rule) = @_;
86 49         99 my ($type, @rule) = @$rule;
87              
88             debug{
89 0 0   0   0 my $label = $type == IGNORE ? 'ignore'
    0          
    0          
90             : $type == MODIFY ? 'modify'
91             : $type == COLORIZE ? 'colorize'
92             : $type;
93              
94 0         0 "applying rule <$label>: [@rule]";
95 49         175 };
96              
97 49 100       187 if ($type == IGNORE) {
    100          
    50          
98 7         13 my ($regex) = @rule;
99 7 100       36 return if $line =~ /$regex/;
100             }
101             elsif ($type == MODIFY) {
102 17         35 my ($regex, $replace) = @rule;
103              
104 17 100       82 if ($line =~ /$regex/) {
105 7 100       16 if (ref $replace eq 'CODE') {
106 3         17 $line =~ s/$regex/
107 3         5 local $_ = $line;
108 3         9 $replace->($line);
109             /xe;
110             }
111             else {
112 4         375 eval "\$line =~ s/$regex/$replace/";
113             }
114             }
115             }
116             elsif ($type == COLORIZE) {
117 25         49 my ($regex, $color) = @rule;
118 25         280 $line =~ s/($regex)/$color$1$RESET/;
119             }
120              
121 47         182 return $line;
122             }
123              
124             sub ignore ($) {
125 2     2 1 15 my ($regex) = @_;
126 2         8 push @RULES, [IGNORE, $regex];
127             }
128              
129             sub modify ($$) {
130 7     7 1 50 my ($regex, $replacement) = @_;
131 7         18 push @RULES, [MODIFY, $regex, $replacement];
132             }
133              
134             sub colorize ($@) {
135 5     5 1 25 my ($regex, @colors) = @_;
136 5         13 my $color = color @colors;
137 5         111 push @RULES, [COLORIZE, $regex, $color];
138             }
139              
140             1;
141              
142             __END__