File Coverage

blib/lib/Mail/Box/Search.pm
Criterion Covered Total %
statement 82 89 92.1
branch 57 80 71.2
condition 31 46 67.3
subroutine 9 13 69.2
pod 5 6 83.3
total 184 234 78.6


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;
10 2     2   18 use vars '$VERSION';
  2         5  
  2         119  
11             $VERSION = '3.009';
12              
13 2     2   13 use base 'Mail::Reporter';
  2         4  
  2         193  
14              
15 2     2   13 use strict;
  2         4  
  2         39  
16 2     2   9 use warnings;
  2         3  
  2         70  
17              
18 2     2   46 use Carp;
  2         5  
  2         2453  
19              
20              
21             sub init($)
22 12     12 0 30 { my ($self, $args) = @_;
23              
24 12         48 $self->SUPER::init($args);
25              
26 12   50     125 my $in = $args->{in} || 'BODY';
27 12 50       77 @$self{ qw/MBS_check_head MBS_check_body/ }
    100          
    100          
28             = $in eq 'BODY' ? (0,1)
29             : $in eq 'HEAD' ? (1,0)
30             : $in eq 'MESSAGE' ? (1,1)
31             : ($self->log(ERROR => "Search in BODY, HEAD or MESSAGE not $in."), return);
32              
33             $self->log(ERROR => "Cannot search in header."), return
34 12 50 66     80 if $self->{MBS_check_head} && !$self->can('inHead');
35              
36             $self->log(ERROR => "Cannot search in body."), return
37 12 50 66     82 if $self->{MBS_check_body} && !$self->can('inBody');
38              
39 12         27 my $deliver = $args->{deliver};
40             $self->{MBS_deliver}
41 518     518   1096 = ref $deliver eq 'CODE' ? sub { $deliver->($self, $_[0]) }
42             : !defined $deliver ? undef
43             : $deliver eq 'DELETE'
44 0     0   0 ? sub {$_[0]->{part}->toplevel->label(deleted => 1)}
45 12 0       76 : $self->log(ERROR => "Don't know how to deliver results in $deliver.");
    50          
    100          
46              
47 12   50     56 my $logic = $args->{logical} || 'REPLACE';
48 12         48 $self->{MBS_negative} = $logic =~ s/\s*NOT\s*$//;
49 12         29 $self->{MBS_logical} = $logic;
50              
51 12         41 $self->{MBS_label} = $args->{label};
52 12   100     50 $self->{MBS_binaries} = $args->{binaries} || 0;
53 12   100     43 $self->{MBS_limit} = $args->{limit} || 0;
54 12   50     47 $self->{MBS_decode} = $args->{decode} || 1;
55 12         39 $self->{MBS_no_deleted} = not $args->{deleted};
56 12 50       36 $self->{MBS_delayed} = defined $args->{delayed} ? $args->{delayed} : 1;
57             $self->{MBS_multiparts}
58 12 100       37 = defined $args->{multiparts} ? $args->{multiparts} : 1;
59              
60 12         27 $self;
61             }
62              
63             #-------------------------------------------
64              
65              
66             sub search(@)
67 14     14 1 33 { my ($self, $object) = @_;
68              
69 14         30 my $label = $self->{MBS_label};
70 14         23 my $limit = $self->{MBS_limit};
71              
72             my @messages
73 14 50       159 = ref $object eq 'ARRAY' ? @$object
    100          
    100          
    100          
74             : $object->isa('Mail::Box') ? $object->messages
75             : $object->isa('Mail::Message') ? ($object)
76             : $object->isa('Mail::Box::Thread::Node') ? $object->threadMessages
77             : croak "Expect messages to search, not $object.";
78              
79 14         28 my $take = 0;
80 14 100 100     100 if($limit < 0) { $take = -$limit; @messages = reverse @messages }
  1 50       4  
  1 100       3  
81 0         0 elsif($limit > 0) { $take = $limit }
82 1         2 elsif(!defined $label && !wantarray && !$self->{MBS_deliver}) {$take = 1 }
83              
84 14         33 my $logic = $self->{MBS_logical};
85 14         23 my @selected;
86 14         23 my $count = 0;
87              
88 14         39 foreach my $message (@messages)
89 376 100 100     1474 { next if $self->{MBS_no_deleted} && $message->isDeleted;
90 343 50 33     837 next unless $self->{MBS_delayed} || !$message->isDelayed;
91              
92 343 50       677 my $set = defined $label ? $message->label($label) : 0;
93              
94             my $selected
95             = $set && $logic eq 'OR' ? 1
96             : !$set && $logic eq 'AND' ? 0
97 343 50 33     1750 : $self->{MBS_negative} ? ! $self->searchPart($message)
    50 33        
    50          
98             : $self->searchPart($message);
99              
100 343 50       796 $message->label($label => $selected) if defined $label;
101 343 100       698 if($selected)
102 167         305 { push @selected, $message;
103 167         216 $count++;
104 167 100 100     499 last if $take && $count == $take;
105             }
106             }
107              
108 14 100       168 $limit < 0 ? reverse @selected : @selected;
109             }
110              
111              
112             #-------------------------------------------
113              
114              
115             sub searchPart($)
116 376     376 1 805 { my ($self, $part) = @_;
117              
118 376         538 my $matched = 0;
119             $matched = $self->inHead($part, $part->head)
120 376 100       1079 if $self->{MBS_check_head};
121              
122 376 100       851 return $matched unless $self->{MBS_check_body};
123 335 50 66     760 return $matched if $matched && !$self->{MBS_deliver};
124              
125 335         893 my $body = $part->body;
126 335         1702 my @bodies;
127              
128             # Handle multipart parts.
129              
130 335 100       1303 if($body->isMultipart)
    50          
131 25 100       70 { return $matched unless $self->{MBS_multiparts};
132 24         51 my $no_delayed = not $self->{MBS_delayed};
133 24         87 @bodies = ($body->preamble, $body->epilogue);
134              
135 24         249 foreach my $piece ($body->parts)
136 33 50       242 { next unless defined $piece;
137 33 50 33     84 next if $no_delayed && $piece->isDelayed;
138              
139 33         79 $matched += $self->searchPart($piece);
140 33 50 66     152 return $matched if $matched && !$self->{MBS_deliver};
141             }
142             }
143             elsif($body->isNested)
144 0 0       0 { return $matched unless $self->{MBS_multiparts};
145 0         0 $matched += $self->searchPart($body->nested);
146             }
147             else
148 310         674 { @bodies = ($body);
149             }
150              
151             # Handle normal bodies.
152              
153 334         564 foreach (@bodies)
154 358 100       719 { next unless defined $_;
155 325 100 100     1213 next if !$self->{MBS_binaries} && $_->isBinary;
156 302 50       93270 my $body = $self->{MBS_decode} ? $_->decoded : $_;
157 302         284182 my $inbody = $self->inBody($part, $body);
158 302         941 $matched += $inbody;
159             }
160              
161 334         6923 $matched;
162             }
163              
164             #-------------------------------------------
165              
166              
167 0     0 1   sub inHead(@) {shift->notImplemented}
168              
169             #-------------------------------------------
170              
171              
172 0     0 1   sub inBody(@) {shift->notImplemented}
173              
174             #-------------------------------------------
175              
176              
177 0     0 1   sub printMatch($) {shift->notImplemented}
178              
179             #-------------------------------------------
180              
181              
182             1;