File Coverage

blib/lib/Mail/Box/Search/Grep.pm
Criterion Covered Total %
statement 86 90 95.5
branch 27 46 58.7
condition 9 13 69.2
subroutine 18 20 90.0
pod 6 7 85.7
total 146 176 82.9


line stmt bran cond sub pod time code
1             # Copyrights 2001-2020 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Mail-Box. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Box::Search::Grep;
10 2     2   1892 use vars '$VERSION';
  2         5  
  2         118  
11             $VERSION = '3.009';
12              
13 2     2   12 use base 'Mail::Box::Search';
  2         4  
  2         969  
14              
15 2     2   27 use strict;
  2         5  
  2         40  
16 2     2   10 use warnings;
  2         5  
  2         43  
17              
18 2     2   9 use Carp;
  2         4  
  2         700  
19              
20             #-------------------------------------------
21              
22              
23             sub init($)
24 12     12 0 7559 { my ($self, $args) = @_;
25              
26 12 0 33     58 $args->{in} ||= ($args->{field} ? 'HEAD' : 'BODY');
27              
28 12   66     53 my $deliver = $args->{deliver} || $args->{details}; # details is old name
29             $args->{deliver}
30             = !defined $deliver ? $deliver
31             : ref $deliver eq 'CODE' ? $deliver
32 14     14   41 : $deliver eq 'PRINT' ? sub { $_[0]->printMatch($_[1]) }
33 504     504   1027 : ref $deliver eq 'ARRAY' ? sub { push @$deliver, $_[1] }
34 12 50       124 : $deliver;
    100          
    50          
    100          
35              
36 12         66 $self->SUPER::init($args);
37              
38 12         26 my $take = $args->{field};
39             $self->{MBSG_field_check}
40 3865     3865   17398 = !defined $take ? sub {1}
41 0     0   0 : !ref $take ? do {$take = lc $take; sub { $_[1] eq $take }}
  0         0  
  0         0  
42 0     0   0 : ref $take eq 'Regexp' ? sub { $_[1] =~ $take }
43 12 0       59 : ref $take eq 'CODE' ? $take
    0          
    0          
    50          
44             : croak "Illegal field selector $take.";
45              
46             my $match = $args->{match}
47 12 50       38 or croak "No match pattern specified.\n";
48             $self->{MBSG_match_check}
49 2     2   1126 = !ref $match ? sub { index("$_[1]", $match) >= $[ }
  2     2245   754  
  2         1811  
  2245         6849  
50 14921     14921   52422 : ref $match eq 'Regexp' ? sub { "$_[1]" =~ $match }
51 12 0       89 : ref $match eq 'CODE' ? $match
    50          
    100          
52             : croak "Illegal match pattern $match.";
53              
54 12         45 $self;
55             }
56              
57             sub search(@)
58 14     14 1 1866 { my ($self, $object, %args) = @_;
59 14         39 delete $self->{MBSG_last_printed};
60 14         71 $self->SUPER::search($object, %args);
61             }
62              
63             sub inHead(@)
64 231     231 1 1414 { my ($self, $part, $head, $args) = @_;
65              
66 231         537 my @details = (message => $part->toplevel, part => $part);
67             my ($field_check, $match_check, $deliver)
68 231         1454 = @$self{ qw/MBSG_field_check MBSG_match_check MBS_deliver/ };
69              
70 231         331 my $matched = 0;
71             LINES:
72 231         616 foreach my $field ($head->orderedFields)
73 3865 100 66     92867 { next unless $field_check->($head, $field->name)
74             && $match_check->($head, $field);
75              
76 122         3161 $matched++;
77 122 50       246 last LINES unless $deliver; # no deliver: only one match needed
78 122         421 $deliver->( {@details, field => $field} );
79             }
80              
81 231         5787 $matched;
82             }
83              
84             sub inBody(@)
85 302     302 1 788 { my ($self, $part, $body, $args) = @_;
86              
87 302         1074 my @details = (message => $part->toplevel, part => $part);
88             my ($field_check, $match_check, $deliver)
89 302         1812 = @$self{ qw/MBSG_field_check MBSG_match_check MBS_deliver/ };
90              
91 302         506 my $matched = 0;
92 302         407 my $linenr = 0;
93              
94             LINES:
95 302         816 foreach my $line ($body->lines)
96 13301         21093 { $linenr++;
97 13301 100       18890 next unless $match_check->($body, $line);
98              
99 397         695 $matched++;
100 397 100       738 last LINES unless $deliver; # no deliver: only one match needed
101 396         1587 $deliver->( {@details, linenr => $linenr, line => $line} );
102             }
103              
104 302         1458 $matched;
105             }
106              
107             #-------------------------------------------
108              
109              
110             sub printMatch($;$)
111 14     14 1 25 { my $self = shift;
112 14 50       54 my ($out, $match) = @_==2 ? @_ : (select, shift);
113              
114             $match->{field}
115 14 100       49 ? $self->printMatchedHead($out, $match)
116             : $self->printMatchedBody($out, $match)
117             }
118              
119              
120             sub printMatchedHead($$)
121 5     5 1 33 { my ($self, $out, $match) = @_;
122 5         9 my $message = $match->{message};
123 5         16 my $msgnr = $message->seqnr;
124 5         17 my $folder = $message->folder->name;
125 5   100     19 my $lp = $self->{MBSG_last_printed} || '';
126              
127 5 100       17 unless($lp eq "$folder $msgnr") # match in new message
128 4         11 { my $subject = $message->subject;
129 4         227 $out->print("$folder, message $msgnr: $subject\n");
130 4         81 $self->{MBSG_last_printed} = "$folder $msgnr";
131             }
132              
133 5         24 my @lines = $match->{field}->string;
134 5 50       128 my $inpart = $match->{part}->isPart ? 'p ' : ' ';
135 5         20 $out->print($inpart, join $inpart, @lines);
136 5         94 $self;
137             }
138              
139              
140             sub printMatchedBody($$)
141 9     9 1 24 { my ($self, $out, $match) = @_;
142 9         17 my $message = $match->{message};
143 9         40 my $msgnr = $message->seqnr;
144 9         27 my $folder = $message->folder->name;
145 9   100     39 my $lp = $self->{MBSG_last_printed} || '';
146              
147 9 50       31 unless($lp eq "$folder $msgnr") # match in new message
148 9         30 { my $subject = $message->subject;
149 9         537 $out->print("$folder, message $msgnr: $subject\n");
150 9         246 $self->{MBSG_last_printed} = "$folder $msgnr";
151             }
152              
153 9 100       40 my $inpart = $match->{part}->isPart ? 'p ' : ' ';
154 9         62 $out->print(sprintf "$inpart %2d: %s", $match->{linenr}, $match->{line});
155 9         209 $self;
156             }
157              
158             1;