File Coverage

blib/lib/Dezi/Aggregator/Mail.pm
Criterion Covered Total %
statement 15 89 16.8
branch 0 26 0.0
condition 0 8 0.0
subroutine 5 12 41.6
pod n/a
total 20 135 14.8


line stmt bran cond sub pod time code
1             package Dezi::Aggregator::Mail;
2 2     2   140611 use Moose;
  2         5  
  2         18  
3             extends 'Dezi::Aggregator';
4             with 'Dezi::Role';
5              
6 2     2   12721 use Carp;
  2         6  
  2         135  
7 2     2   868 use Data::Dump qw( dump );
  2         5775  
  2         106  
8 2     2   1891 use Search::Tools::XML;
  2         189994  
  2         109  
9 2     2   1769 use Mail::Box::Manager;
  2         7670  
  2         2151  
10              
11             our $VERSION = '0.014';
12              
13             my $XMLer = Search::Tools::XML->new();
14              
15             =pod
16              
17             =head1 NAME
18              
19             Dezi::Aggregator::Mail - crawl a mail box
20              
21             =head1 SYNOPSIS
22            
23             use Dezi::Aggregator::Mail;
24            
25             my $aggregator =
26             Dezi::Aggregator::Mail->new(
27             indexer => Dezi::Indexer::Native->new()
28             );
29            
30             $aggregator->indexer->start;
31             $aggregator->crawl('path/to/my/maildir');
32             $aggregator->indexer->finish;
33              
34              
35             =head1 DESCRIPTION
36              
37             Dezi::Aggregator::Mail is a Dezi::Aggregator
38             subclass designed for providing full-text search for your email.
39              
40             Dezi::Aggregator::Mail uses Mail::Box, available from CPAN.
41              
42             =head1 METHODS
43              
44             Since Dezi::Aggregator::Mail inherits from Dezi::Aggregator,
45             read the Dezi::Aggregator docs first.
46             Any overridden methods are documented here.
47              
48             =head2 BUILD
49              
50             Internal method only.
51              
52             Adds the special C<mail> MetaName to the Config object before
53             opening indexer.
54              
55             =cut
56              
57             sub BUILD {
58 0     0     my $self = shift;
59              
60 0 0         if ( $self->indexer ) {
61              
62             # add top-level metaname
63 0           $self->config->MetaNameAlias('swishdefault mail');
64              
65 0           my @meta = qw(
66             url
67             id
68             subject
69             date
70             size
71             from
72             to
73             cc
74             bcc
75             type
76             part
77             );
78              
79 0           $self->config->MetaNames(@meta);
80 0           $self->config->PropertyNames(@meta);
81              
82             # save all body text in the swishdescription property for excerpts
83 0           $self->config->StoreDescription('XML* <body>');
84              
85             }
86              
87             }
88              
89             # basic flow:
90             # recurse through maildir, get all messages,
91             # convert each message to xml, create Doc object and call index()
92              
93             =head2 crawl( I<path_to_maildir> )
94              
95             Create index.
96              
97             Returns number of emails indexed.
98              
99             =cut
100              
101             sub crawl {
102 0     0     my $self = shift;
103 0 0         my $maildir = shift or croak "maildir required";
104 0           my $manager = Mail::Box::Manager->new;
105              
106 0           $self->{count} = 0;
107              
108 0 0         my $folder = $manager->open(
109             folderdir => $maildir,
110             folder => '=',
111             extract => 'ALWAYS'
112             ) or croak "can't open $maildir";
113              
114 0           $self->_process_folder($folder);
115              
116 0           $folder->close( write => 'NEVER' );
117              
118 0           return $self->{count};
119             }
120              
121             sub _addresses {
122 0 0   0     return join( ', ', map { ref($_) ? $_->format : $_ } @_ );
  0            
123             }
124              
125             sub _process_folder {
126 0     0     my $self = shift;
127 0 0         my $folder = shift or croak "folder required";
128              
129 0           my @subs = sort $folder->listSubFolders;
130 0           my $indexer = $self->indexer;
131              
132 0           for my $sub (@subs) {
133 0           my $subf = $folder->openSubFolder($sub);
134              
135 0 0         warn "searching $sub\n" if $self->verbose;
136              
137 0           foreach my $message ( $subf->messages ) {
138 0           my $doc = $self->get_doc( $sub, $message );
139 0           $indexer->process($doc);
140 0           $self->_increment_count;
141             }
142              
143 0           $self->_process_folder($subf);
144              
145 0           $subf->close( write => 'NEVER' );
146             }
147              
148             }
149              
150             sub _filter_attachment {
151 0     0     my $self = shift;
152 0 0         my $msg_url = shift or croak "message url required";
153 0 0         my $attm = shift or croak "attachment object required";
154              
155 0           my $type = $attm->body->mimeType->type;
156 0           my $filename = $attm->body->dispositionFilename;
157 0           my $content = $attm->decoded . ''; # force stringify
158              
159 0 0         if ( $self->swish_filter_obj->can_filter($type) ) {
160              
161 0           my $f = $self->swish_filter_obj->convert(
162             document => \$content,
163             content_type => $type,
164             name => $filename,
165             );
166              
167 0 0 0       if ( !$f
      0        
168             || !$f->was_filtered
169             || $f->is_binary ) # is is_binary necessary?
170             {
171 0           warn "skipping $filename in message $msg_url - filtering error\n";
172 0           return '';
173             }
174              
175 0           $content = ${ $f->fetch_doc };
  0            
176             }
177              
178 0           return join( '',
179             '<title>', $XMLer->escape($filename),
180             '</title>', $XMLer->escape($content) );
181              
182             }
183              
184             =head2 get_doc( I<folder>, I<Mail::Message> )
185              
186             Extract data and content from I<Mail::Message> in I<folder> and return
187             doc_class() object.
188              
189             =cut
190              
191             sub get_doc {
192 0     0     my $self = shift;
193 0 0         my $folder = shift or croak "folder required";
194 0 0         my $message = shift or croak "mail meta required";
195              
196             # >head->createFromLine;
197 0   0       my %meta = (
198             url => join( '.', $folder, $message->messageId ),
199             id => $message->messageId,
200             subject => $message->subject || '[ no subject ]',
201             date => $message->timestamp,
202             size => $message->size,
203             from => _addresses( $message->from ),
204             to => _addresses( $message->to ),
205             cc => _addresses( $message->cc ),
206             bcc => _addresses( $message->bcc ),
207             type => $message->contentType,
208             );
209              
210 0           my @parts = $message->parts;
211              
212 0           for my $part (@parts) {
213             push(
214 0           @{ $meta{parts} },
215 0           $self->_filter_attachment( $meta{url}, $part )
216             );
217             }
218              
219 0           my $title = $meta{subject};
220              
221 0           my $xml = $self->_mail2xml( $title, \%meta );
222              
223             my $doc = $self->doc_class->new(
224             content => $xml,
225             url => $meta{url},
226             modtime => $meta{date},
227 0           parser => 'XML*',
228             type => 'application/xml',
229             data => \%meta
230             );
231              
232 0           return $doc;
233             }
234              
235             sub _mail2xml {
236 0     0     my $self = shift;
237 0           my $title = shift;
238 0           my $meta = shift;
239              
240 0           my $xml
241             = "<mail>"
242             . "<swishtitle>"
243             . $XMLer->utf8_safe($title)
244             . "</swishtitle>"
245             . "<head>";
246              
247 0           for my $m ( sort keys %$meta ) {
248              
249 0 0         if ( $m eq 'parts' ) {
250              
251 0           $xml .= '<body>';
252 0           for my $part ( @{ $meta->{$m} } ) {
  0            
253 0           $xml .= '<part>';
254 0           $xml .= $part;
255 0           $xml .= '</part>';
256             }
257 0           $xml .= '</body>';
258             }
259             else {
260 0           $xml .= $XMLer->start_tag($m);
261 0           $xml .= $XMLer->escape( $meta->{$m} );
262 0           $xml .= $XMLer->end_tag($m);
263             }
264             }
265              
266 0           $xml .= "</head></mail>";
267              
268 0           return $xml;
269             }
270              
271             __PACKAGE__->meta->make_immutable;
272              
273             1;
274              
275             __END__
276              
277             =head1 AUTHOR
278              
279             Peter Karman, E<lt>karpet@dezi.orgE<gt>
280              
281             =head1 BUGS
282              
283             Please report any bugs or feature requests to C<bug-dezi-app at rt.cpan.org>, or through
284             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Dezi-App>.
285             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
286              
287             =head1 SUPPORT
288              
289             You can find documentation for this module with the perldoc command.
290              
291             perldoc Dezi::App
292              
293             You can also look for information at:
294              
295             =over 4
296              
297             =item * Website
298              
299             L<http://dezi.org/>
300              
301             =item * IRC
302              
303             #dezisearch at freenode
304              
305             =item * Mailing list
306              
307             L<https://groups.google.com/forum/#!forum/dezi-search>
308              
309             =item * RT: CPAN's request tracker
310              
311             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dezi-App>
312              
313             =item * AnnoCPAN: Annotated CPAN documentation
314              
315             L<http://annocpan.org/dist/Dezi-App>
316              
317             =item * CPAN Ratings
318              
319             L<http://cpanratings.perl.org/d/Dezi-App>
320              
321             =item * Search CPAN
322              
323             L<https://metacpan.org/dist/Dezi-App/>
324              
325             =back
326              
327             =head1 COPYRIGHT AND LICENSE
328              
329             Copyright 2014 by Peter Karman
330              
331             This library is free software; you can redistribute it and/or modify
332             it under the terms of the GPL v2 or later.
333              
334             =head1 SEE ALSO
335              
336             L<http://dezi.org/>, L<http://swish-e.org/>, L<http://lucy.apache.org/>
337