File Coverage

blib/lib/Mail/Box/Maildir.pm
Criterion Covered Total %
statement 123 200 61.5
branch 22 82 26.8
condition 17 77 22.0
subroutine 18 25 72.0
pod 13 14 92.8
total 193 398 48.4


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. 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::Maildir;
10 6     6   2692 use vars '$VERSION';
  6         10  
  6         303  
11             $VERSION = '3.008';
12              
13 6     6   30 use base 'Mail::Box::Dir';
  6         23  
  6         1328  
14              
15 6     6   34 use strict;
  6         20  
  6         102  
16 6     6   24 use warnings;
  6         10  
  6         140  
17 6     6   28 use filetest 'access';
  6         10  
  6         31  
18              
19 6     6   2017 use Mail::Box::Maildir::Message;
  6         12  
  6         156  
20              
21 6     6   29 use Carp;
  6         11  
  6         273  
22 6     6   29 use File::Copy 'move';
  6         10  
  6         189  
23 6     6   29 use File::Basename 'basename';
  6         9  
  6         228  
24 6     6   30 use Sys::Hostname 'hostname';
  6         11  
  6         214  
25 6     6   2463 use File::Remove 'remove';
  6         10399  
  6         13363  
26              
27             # Maildir is only supported on UNIX, because the filenames probably
28             # do not work on other platforms. Since MailBox 2.052, the use of
29             # File::Spec to create filenames has been removed: benchmarks showed
30             # that catfile() consumed 20% of the time of a folder open(). And
31             # '/' file separators work on Windows too!
32              
33              
34             my $default_folder_dir = exists $ENV{HOME} ? "$ENV{HOME}/.maildir" : '.';
35              
36             sub init($)
37 7     7 0 82 { my ($self, $args) = @_;
38              
39             croak "No locking possible for maildir folders."
40             if exists $args->{locker}
41 7 50 66     56 || (defined $args->{lock_type} && $args->{lock_type} ne 'NONE');
      33        
42              
43 7         18 $args->{lock_type} = 'NONE';
44 7   66     40 $args->{folderdir} ||= $default_folder_dir;
45              
46             return undef
47 7 50       38 unless $self->SUPER::init($args);
48              
49 7 50       34 $self->acceptMessages if $args->{accept_new};
50 7         21 $self;
51             }
52              
53              
54             sub create($@)
55 0     0 1 0 { my ($thingy, $name, %args) = @_;
56 0   0     0 my $class = ref $thingy || $thingy;
57 0   0     0 my $folderdir = $args{folderdir} || $default_folder_dir;
58 0         0 my $directory = $class->folderToDirectory($name, $folderdir);
59              
60 0 0       0 if($class->createDirs($directory))
61 0         0 { $class->log(PROGRESS => "Created folder Maildir $name.");
62 0         0 return $class;
63             }
64             else
65 0         0 { $class->log(ERROR => "Cannot create Maildir folder $name.");
66 0         0 return undef;
67             }
68             }
69              
70             sub foundIn($@)
71 5     5 1 41 { my $class = shift;
72 5 50       26 my $name = @_ % 2 ? shift : undef;
73 5         19 my %args = @_;
74 5   66     28 my $folderdir = $args{folderdir} || $default_folder_dir;
75 5         69 my $directory = $class->folderToDirectory($name, $folderdir);
76              
77 5         107 -d "$directory/cur";
78             }
79              
80             sub type() {'maildir'}
81              
82             sub listSubFolders(@)
83 0     0 1 0 { my ($class, %args) = @_;
84 0         0 my $dir;
85              
86 0 0       0 if(ref $class)
87 0         0 { $dir = $class->directory;
88 0         0 $class = ref $class;
89             }
90             else
91 0   0     0 { my $folder = $args{folder} || '=';
92 0   0     0 my $folderdir = $args{folderdir} || $default_folder_dir;
93 0         0 $dir = $class->folderToDirectory($folder, $folderdir);
94             }
95              
96 0   0     0 $args{skip_empty} ||= 0;
97 0   0     0 $args{check} ||= 0;
98              
99             # Read the directories from the directory, to find all folders
100             # stored here. Some directories have to be removed because they
101             # are created by all kinds of programs, but are no folders.
102              
103 0 0 0     0 return () unless -d $dir && opendir DIR, $dir;
104              
105 0         0 my @dirs;
106 0         0 while(my $d = readdir DIR)
107 0 0       0 { next if $d =~ m/^(new|tmp|cur|\.\.?)$/;
108              
109 0         0 my $dir = "$dir/$d";
110 0 0 0     0 push @dirs, $d if -d $dir && -r _;
111             }
112              
113 0         0 closedir DIR;
114              
115             # Skip empty folders.
116              
117 0         0 @dirs = grep {!$class->folderIsEmpty("$dir/$_")} @dirs
118 0 0       0 if $args{skip_empty};
119              
120             # Check if the files we want to return are really folders.
121              
122 0 0       0 @dirs = map { m/(.*)/ && $1 } @dirs; # untaint
  0         0  
123 0 0       0 return @dirs unless $args{check};
124              
125 0         0 grep { $class->foundIn("$dir/$_") } @dirs;
  0         0  
126             }
127              
128             sub openSubFolder($@)
129 0     0 1 0 { my ($self, $name) = (shift, shift);
130 0         0 $self->createDirs($self->nameOfSubFolder($name));
131 0         0 $self->SUPER::openSubFolder($name, @_);
132             }
133              
134             sub topFolderWithMessages() { 1 }
135              
136             my $uniq = rand 1000;
137              
138              
139             sub coerce($)
140 2     2 1 6 { my ($self, $message) = (shift, shift);
141              
142 2         11 my $is_native = $message->isa('Mail::Box::Maildir::Message');
143 2         12 my $coerced = $self->SUPER::coerce($message, @_);
144              
145 2 50 33     85 my $basename = $is_native ? basename($message->filename)
146             : ($message->timestamp || time) .'.'. hostname .'.'. $uniq++;
147              
148 2         1095 my $dir = $self->directory;
149 2         6 my $tmp = "$dir/tmp/$basename";
150 2         4 my $new = "$dir/new/$basename";
151              
152 2 50 33     13 if($coerced->create($tmp) && $coerced->create($new))
153 2         20 {$self->log(PROGRESS => "Added Maildir message in $new") }
154 0         0 else {$self->log(ERROR => "Cannot create Maildir message file $new.") }
155              
156 2 50       47 $coerced->labelsToFilename unless $is_native;
157 2         6 $coerced;
158             }
159              
160             #-------------------------------------------
161              
162              
163             sub createDirs($)
164 0     0 1 0 { my ($thing, $dir) = @_;
165              
166 0 0 0     0 $thing->log(ERROR => "Cannot create Maildir folder directory $dir: $!"), return
167             unless -d $dir || mkdir $dir;
168              
169 0         0 my $tmp = "$dir/tmp";
170 0 0 0     0 $thing->log(ERROR => "Cannot create Maildir folder subdir $tmp: $!"), return
171             unless -d $tmp || mkdir $tmp;
172              
173 0         0 my $new = "$dir/new";
174 0 0 0     0 $thing->log(ERROR => "Cannot create Maildir folder subdir $new: $!"), return
175             unless -d $new || mkdir $new;
176              
177 0         0 my $cur = "$dir/cur";
178 0 0 0     0 $thing->log(ERROR => "Cannot create Maildir folder subdir $cur: $!"), return
179             unless -d $cur || mkdir $cur;
180              
181 0         0 $thing;
182             }
183              
184              
185             sub folderIsEmpty($)
186 0     0 1 0 { my ($self, $dir) = @_;
187 0 0       0 return 1 unless -d $dir;
188              
189 0         0 foreach (qw/tmp new cur/)
190 0         0 { my $subdir = "$dir/$_";
191 0 0       0 next unless -d $subdir;
192              
193 0 0       0 opendir DIR, $subdir or return 0;
194 0         0 my $first = readdir DIR;
195 0         0 closedir DIR;
196              
197 0 0       0 return 0 if defined $first;
198             }
199              
200 0 0       0 opendir DIR, $dir or return 1;
201 0         0 while(my $entry = readdir DIR)
202 0 0       0 { next if $entry =~
203             m/^(?:tmp|cur|new|bulletin(?:time|lock)|seriallock|\..?)$/;
204              
205 0         0 closedir DIR;
206 0         0 return 0;
207             }
208              
209 0         0 closedir DIR;
210 0         0 1;
211             }
212              
213             sub delete(@)
214 0     0 1 0 { my $self = shift;
215              
216             # Subfolders are not nested in the directory structure
217 0         0 remove \1, $self->directory;
218             }
219              
220             sub readMessageFilenames
221 14     14 1 28 { my ($self, $dirname) = @_;
222              
223 14 50       362 opendir DIR, $dirname or return ();
224              
225 14         32 my @files;
226 14 50       49 if(${^TAINT})
227             { # unsorted list of untainted filenames.
228 0 0 0     0 @files = map { m/^([0-9][\w.:,=\-]+)$/ && -f "$dirname/$1" ? $1 : () }
  0         0  
229             readdir DIR;
230             }
231             else
232             { # not running tainted
233 14   66     3934 @files = grep /^([0-9][\w.:,=\-]+)$/ && -f "$dirname/$1", readdir DIR;
234             }
235 14         191 closedir DIR;
236              
237             # Sort the names. Solve the Y2K (actually the 1 billion seconds
238             # since 1970 bug) which hunts Maildir. The timestamp, which is
239             # the start of the filename will have some 0's in front, so each
240             # timestamp has the same length.
241              
242 14         32 my %unified;
243             m/^(\d+)/ and $unified{ ('0' x (10-length($1))).$_ } = $_
244 14   33     676 for @files;
245              
246 14         477 map "$dirname/$unified{$_}",
247             sort keys %unified;
248             }
249              
250             sub readMessages(@)
251 7     7 1 42 { my ($self, %args) = @_;
252              
253 7         21 my $directory = $self->directory;
254 7 50       94 return unless -d $directory;
255              
256             #
257             # Read all messages
258             #
259              
260 7         26 my $curdir = "$directory/cur";
261 7         28 my @cur = map +[$_, 1], $self->readMessageFilenames($curdir);
262              
263 7         42 my $newdir = "$directory/new";
264 7         25 my @new = map +[$_, 0], $self->readMessageFilenames($newdir);
265 7         33 my @log = $self->logSettings;
266              
267 7         53 foreach (@cur, @new)
268 303         527 { my ($filename, $accepted) = @$_;
269             my $message = $args{message_type}->new
270             ( head => $args{head_delayed_type}->new(@log)
271             , filename => $filename
272             , folder => $self
273             , fix_header=> $self->{MB_fix_headers}
274 303         877 , labels => [ accepted => $accepted ]
275             );
276              
277 303         1011 my $body = $args{body_delayed_type}->new(@log, message => $message);
278 303 50       723 $message->storeBody($body) if $body;
279 303         965 $self->storeMessage($message);
280             }
281              
282 7         84 $self;
283             }
284            
285              
286             sub acceptMessages($)
287 0     0 1 0 { my ($self, %args) = @_;
288 0         0 my @accept = $self->messages('!accepted');
289 0         0 $_->accept foreach @accept;
290 0         0 @accept;
291             }
292              
293             sub writeMessages($)
294 5     5 1 14 { my ($self, $args) = @_;
295              
296             # Write each message. Two things complicate life:
297             # 1 - we may have a huge folder, which should not be on disk twice
298             # 2 - we may have to replace a message, but it is unacceptable
299             # to remove the original before we are sure that the new version
300             # is on disk.
301              
302 5         9 my $writer = 0;
303              
304 5         22 my $directory = $self->directory;
305 5         10 my @messages = @{$args->{messages}};
  5         20  
306              
307 5         12 my $tmpdir = "$directory/tmp";
308 5 50 33     137 die "Cannot create directory $tmpdir: $!"
309             unless -d $tmpdir || mkdir $tmpdir;
310              
311 5         17 foreach my $message (@messages)
312 192 100       278 { next unless $message->isModified;
313              
314 1         6 my $filename = $message->filename;
315 1         50 my $basename = basename $filename;
316              
317 1         4 my $newtmp = "$directory/tmp/$basename";
318 1 50       60 open my $new, '>', $newtmp
319             or croak "Cannot create file $newtmp: $!";
320              
321 1         7 $message->write($new);
322 1         140 close $new;
323              
324 1         38 unlink $filename;
325 1 50       7 move $newtmp, $filename
326             or warn "Cannot move $newtmp to $filename: $!\n";
327             }
328              
329             # Remove an empty folder. This is done last, because the code before
330             # in this method will have cleared the contents of the directory.
331              
332 5 0 33     85 if(!@messages && $self->{MB_remove_empty})
333             { # If something is still in the directory, this will fail, but I
334             # don't mind.
335 0         0 rmdir "$directory/cur";
336 0         0 rmdir "$directory/tmp";
337 0         0 rmdir "$directory/new";
338 0         0 rmdir $directory;
339             }
340              
341 5         24 $self;
342             }
343              
344              
345             sub appendMessages(@)
346 1     1 1 3 { my $class = shift;
347 1         5 my %args = @_;
348              
349             my @messages = exists $args{message} ? $args{message}
350 1 50       5 : exists $args{messages} ? @{$args{messages}}
  1 50       3  
351             : return ();
352              
353 1         9 my $self = $class->new(@_, access => 'a');
354 1         5 my $directory= $self->directory;
355 1 50       23 return unless -d $directory;
356              
357 1         4 my $tmpdir = "$directory/tmp";
358 1 50 33     13 croak "Cannot create directory $tmpdir: $!", return
359             unless -d $tmpdir || mkdir $tmpdir;
360              
361 1   50     8 my $msgtype = $args{message_type} || 'Mail::Box::Maildir::Message';
362              
363 1         4 foreach my $message (@messages)
364 1         6 { my $is_native = $message->isa($msgtype);
365 1         2 my ($basename, $coerced);
366              
367 1 50       4 if($is_native)
368 1         2 { $coerced = $message;
369 1         4 $basename = basename $message->filename;
370             }
371             else
372 0         0 { $coerced = $self->SUPER::coerce($message);
373 0   0     0 $basename = ($message->timestamp||time).'.'. hostname.'.'.$uniq++;
374             }
375              
376 1         5 my $dir = $self->directory;
377 1         4 my $tmp = "$dir/tmp/$basename";
378 1         2 my $new = "$dir/new/$basename";
379              
380 1 50 33     5 if($coerced->create($tmp) && $coerced->create($new))
381 1         6 {$self->log(PROGRESS => "Appended Maildir message in $new") }
382 0         0 else {$self->log(ERROR =>
383             "Cannot append Maildir message in $new to folder $self.") }
384             }
385            
386 1         27 $self->close;
387              
388 1         11 @messages;
389             }
390              
391             #-------------------------------------------
392              
393              
394             1;