File Coverage

blib/lib/Mail/Box/IMAP4.pm
Criterion Covered Total %
statement 33 180 18.3
branch 0 78 0.0
condition 0 40 0.0
subroutine 11 27 40.7
pod 14 16 87.5
total 58 341 17.0


line stmt bran cond sub pod time code
1             # Copyrights 2001-2019 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-IMAP4. 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::IMAP4;
10 2     2   218787 use vars '$VERSION';
  2         8  
  2         113  
11             $VERSION = '3.007';
12              
13 2     2   11 use base 'Mail::Box::Net';
  2         5  
  2         937  
14              
15 2     2   272160 use strict;
  2         5  
  2         38  
16 2     2   10 use warnings;
  2         6  
  2         48  
17              
18 2     2   897 use Mail::Box::IMAP4::Message;
  2         6  
  2         74  
19 2     2   840 use Mail::Box::IMAP4::Head;
  2         11  
  2         58  
20 2     2   998 use Mail::Transport::IMAP4;
  2         8  
  2         94  
21              
22 2     2   16 use Mail::Box::Parser::Perl;
  2         4  
  2         71  
23 2     2   11 use Mail::Message::Head::Complete;
  2         4  
  2         73  
24 2     2   13 use Mail::Message::Head::Delayed;
  2         4  
  2         51  
25              
26 2     2   25 use Scalar::Util 'weaken';
  2         6  
  2         4263  
27              
28              
29             sub init($)
30 0     0 0   { my ($self, $args) = @_;
31              
32 0           my $folder = $args->{folder};
33              
34             # MailBox names top folder directory '=', but IMAP needs '/'
35 0 0 0       $folder = '/'
36             if ! defined $folder || $folder eq '=';
37              
38             # There's a disconnect between the URL parser and this code.
39             # The URL parser always produces a full path (beginning with /)
40             # while this code expects to NOT get a full path. So, we'll
41             # trim the / from the front of the path.
42             # Also, this code can't handle a trailing slash and there's
43             # no reason to ever offer one. Strip that too.
44 0 0         if($folder ne '/')
45 0           { $folder =~ s,^/+,,g;
46 0           $folder =~ s,/+$,,g;
47             }
48              
49 0           $args->{folder} = $folder;
50              
51 0   0       my $access = $args->{access} ||= 'r';
52 0           my $writeable = $access =~ m/w|a/;
53             my $ch = $self->{MBI_c_head}
54 0   0       = $args->{cache_head} || ($writeable ? 'NO' : 'DELAY');
55              
56 0 0 0       $args->{head_type} ||= 'Mail::Box::IMAP4::Head'
      0        
57             if $ch eq 'NO' || $ch eq 'PARTIAL';
58              
59 0   0       $args->{body_type} ||= 'Mail::Message::Body::Lines';
60 0   0       $args->{message_type} ||= 'Mail::Box::IMAP4::Message';
61              
62 0           $self->SUPER::init($args);
63              
64 0           $self->{MBI_domain} = $args->{domain};
65             $self->{MBI_c_labels}
66 0   0       = $args->{cache_labels} || ($writeable ? 'NO' : 'DELAY');
67             $self->{MBI_c_body}
68 0   0       = $args->{cache_body} || ($writeable ? 'NO' : 'DELAY');
69              
70              
71 0   0       my $transport = $args->{transporter} || 'Mail::Transport::IMAP4';
72 0 0         $transport = $self->createTransporter($transport, %$args)
73             unless ref $transport;
74              
75 0           $self->transporter($transport);
76              
77 0 0         defined $transport
78             or return;
79              
80             $args->{create}
81 0 0         ? $self->create($transport, $args)
82             : $self;
83             }
84              
85             sub create($@)
86 0     0 1   { my($self, $name, $args) = @_;
87              
88 0 0         if($args->{access} !~ /w|a/)
89 0           { $self->log(ERROR =>
90             "You must have write access to create folder $name.");
91 0           return undef;
92             }
93              
94 0           $self->transporter->createFolder($name);
95             }
96              
97             sub foundIn(@)
98 0     0 1   { my $self = shift;
99 0 0         unshift @_, 'folder' if @_ % 2;
100 0           my %options = @_;
101              
102             (exists $options{type} && $options{type} =~ m/^imap/i)
103 0 0 0       || (exists $options{folder} && $options{folder} =~ m/^imap/);
      0        
104             }
105              
106             sub type() {'imap4'}
107              
108              
109              
110             sub close(@)
111 0     0 1   { my $self = shift;
112 0 0         $self->SUPER::close(@_) or return ();
113 0           $self->transporter(undef);
114 0           $self;
115             }
116              
117             sub listSubFolders(@)
118 0     0 1   { my ($thing, %args) = @_;
119 0           my $self = $thing;
120              
121 0 0 0       $self = $thing->new(%args) or return () # list toplevel
122             unless ref $thing;
123              
124 0           my $imap = $self->transporter;
125 0 0         defined $imap ? $imap->folders($self) : ();
126             }
127              
128 0     0 0   sub nameOfSubfolder($;$) { $_[1] }
129              
130             #-------------------------------------------
131              
132             sub readMessages(@)
133 0     0 1   { my ($self, %args) = @_;
134              
135 0           my $name = $self->name;
136 0 0         return $self if $name eq '/';
137              
138 0           my $imap = $self->transporter;
139 0 0         defined $imap or return ();
140              
141 0           my @log = $self->logSettings;
142 0           my $seqnr = 0;
143              
144 0           my $cl = $self->{MBI_c_labels} ne 'NO';
145 0           my $wl = $self->{MBI_c_labels} ne 'DELAY';
146              
147 0           my $ch = $self->{MBI_c_head};
148 0 0         my $ht = $ch eq 'DELAY' ? $args{head_delayed_type} : $args{head_type};
149 0 0         my @ho = $ch eq 'PARTIAL' ? (cache_fields => 1) : ();
150              
151             $self->{MBI_selectable}
152 0 0         or return $self;
153              
154 0           foreach my $id ($imap->ids)
155 0           { my $head = $ht->new(@log, @ho);
156             my $message = $args{message_type}->new
157 0           ( head => $head
158             , unique => $id
159             , folder => $self
160             , seqnr => $seqnr++
161              
162             , cache_labels => $cl
163             , write_labels => $wl
164             , cache_head => ($ch eq 'DELAY')
165             , cache_body => ($ch ne 'NO')
166             );
167              
168             my $body = $args{body_delayed_type}
169 0           ->new(@log, message => $message);
170              
171 0           $message->storeBody($body);
172              
173 0           $self->storeMessage($message);
174             }
175              
176 0           $self;
177             }
178            
179              
180              
181             sub getHead($)
182 0     0 1   { my ($self, $message) = @_;
183 0 0         my $imap = $self->transporter or return;
184              
185 0           my $uidl = $message->unique;
186 0           my @fields = $imap->getFields($uidl, 'ALL');
187              
188 0 0         unless(@fields)
189 0           { $self->log(WARNING => "Message $uidl disappeared from $self.");
190 0           return;
191             }
192              
193 0           my $head = $self->{MB_head_type}->new;
194 0           $head->addNoRealize($_) for @fields;
195              
196 0           $self->log(PROGRESS => "Loaded head of $uidl.");
197 0           $head;
198             }
199              
200              
201              
202             sub getHeadAndBody($)
203 0     0 1   { my ($self, $message) = @_;
204 0 0         my $imap = $self->transporter or return;
205 0           my $uid = $message->unique;
206 0           my $lines = $imap->getMessageAsString($uid);
207              
208 0 0         unless(defined $lines)
209 0           { $self->log(WARNING => "Message $uid disappeared from $self.");
210 0           return ();
211             }
212              
213 0           my $parser = Mail::Box::Parser::Perl->new # not parseable by C parser
214             ( filename => "$imap"
215             , file => Mail::Box::FastScalar->new(\$lines)
216             );
217              
218 0           my $head = $message->readHead($parser);
219 0 0         unless(defined $head)
220 0           { $self->log(WARNING => "Cannot find head back for $uid in $self.");
221 0           $parser->stop;
222 0           return ();
223             }
224              
225 0           my $body = $message->readBody($parser, $head);
226 0 0         unless(defined $body)
227 0           { $self->log(WARNING => "Cannot read body for $uid in $self.");
228 0           $parser->stop;
229 0           return ();
230             }
231              
232 0           $parser->stop;
233              
234 0           $self->log(PROGRESS => "Loaded message $uid.");
235 0           ($head, $body->contentInfoFrom($head));
236             }
237              
238              
239              
240             sub body(;$)
241 0     0 1   { my $self = shift;
242 0 0         unless(@_)
243 0 0         { my $body = $self->{MBI_cache_body} ? $self->SUPER::body : undef;
244             }
245              
246 0           $self->unique();
247 0           $self->SUPER::body(@_);
248             }
249              
250              
251              
252             sub write(@)
253 0     0 1   { my ($self, %args) = @_;
254 0 0         my $imap = $self->transporter or return;
255              
256 0 0         $self->SUPER::write(%args, transporter => $imap) or return;
257              
258 0 0         if($args{save_deleted})
259 0           { $self->log(NOTICE => "Impossible to keep deleted messages in IMAP");
260             }
261 0           else { $imap->destroyDeleted($self->name) }
262              
263 0           $self;
264             }
265              
266             sub delete(@)
267 0     0 1   { my $self = shift;
268 0           my $transp = $self->transporter;
269 0           $self->SUPER::delete(@_); # subfolders
270 0           $transp->deleteFolder($self->name);
271             }
272              
273              
274              
275             sub writeMessages($@)
276 0     0 1   { my ($self, $args) = @_;
277              
278 0           my $imap = $args->{transporter};
279 0           my $fn = $self->name;
280              
281 0           $_->writeDelayed($fn, $imap) for @{$args->{messages}};
  0            
282              
283 0           $self;
284             }
285              
286              
287              
288             my %transporters;
289             sub createTransporter($@)
290 0     0 1   { my ($self, $class, %args) = @_;
291              
292 0   0       my $hostname = $self->{MBN_hostname} || 'localhost';
293 0   0       my $port = $self->{MBN_port} || '143';
294 0   0       my $username = $self->{MBN_username} || $ENV{USER};
295              
296 0 0         my $join = exists $args{join_connection} ? $args{join_connection} : 1;
297              
298 0           my $linkid;
299 0 0         if($join)
300 0           { $linkid = "$hostname:$port:$username";
301 0 0         return $transporters{$linkid} if defined $transporters{$linkid};
302             }
303              
304             my $transporter = $class->new
305             ( %args,
306             , hostname => $hostname, port => $port
307             , username => $username, password => $self->{MBN_password}
308             , domain => $self->{MBI_domain}
309 0 0         ) or return undef;
310              
311 0 0         if(defined $linkid)
312 0           { $transporters{$linkid} = $transporter;
313 0           weaken($transporters{$linkid});
314             }
315              
316 0           $transporter;
317             }
318              
319              
320              
321             sub transporter(;$)
322 0     0 1   { my $self = shift;
323              
324 0           my $imap;
325 0 0         if(@_)
326 0           { $imap = $self->{MBI_transport} = shift;
327 0 0         defined $imap or return;
328             }
329             else
330 0           { $imap = $self->{MBI_transport};
331             }
332              
333 0 0         unless(defined $imap)
334 0           { $self->log(ERROR => "No IMAP4 transporter configured");
335 0           return undef;
336             }
337              
338 0           my $name = $self->name;
339              
340 0           $self->{MBI_selectable} = $imap->currentFolder($name);
341             return $imap
342 0 0         if defined $self->{MBI_selectable};
343              
344 0           $self->log(ERROR => "Couldn't select IMAP4 folder $name");
345 0           undef;
346             }
347              
348              
349              
350             sub fetch($@)
351 0     0 1   { my ($self, $what, @info) = @_;
352 0 0         my $imap = $self->transporter or return [];
353 0 0         $what = $self->messages($what) unless ref $what eq 'ARRAY';
354 0           $imap->fetch($what, @info);
355             }
356              
357              
358             #-------------------------------------------
359              
360             1;