File Coverage

blib/lib/Mail/Dir.pm
Criterion Covered Total %
statement 24 153 15.6
branch 0 90 0.0
condition 0 3 0.0
subroutine 8 23 34.7
pod 8 14 57.1
total 40 283 14.1


line stmt bran cond sub pod time code
1             # Copyright (c) 2014 cPanel, Inc.
2             # All rights reserved.
3             # http://cpanel.net/
4             #
5             # Distributed under the terms of the MIT license. See the LICENSE file for
6             # further details.
7              
8             package Mail::Dir;
9              
10 1     1   24753 use strict;
  1         3  
  1         74  
11 1     1   6 use warnings;
  1         1  
  1         58  
12              
13 1     1   4 use Errno;
  1         6  
  1         32  
14 1     1   4 use IO::Handle;
  1         1  
  1         62  
15              
16 1     1   4 use Cwd ();
  1         1  
  1         11  
17 1     1   4 use Fcntl ();
  1         1  
  1         10  
18 1     1   516 use Sys::Hostname ();
  1         1051  
  1         26  
19              
20 1     1   855 use Mail::Dir::Message ();
  1         2  
  1         1598  
21              
22             =head1 NAME
23              
24             Mail::Dir - Compliant Maildir and Maildir++ delivery mechanism
25              
26             =head1 SYNOPSIS
27              
28             use Mail::Dir;
29              
30             my $maildir = Mail::Dir->open("$ENV{'HOME'}/Maildir");
31              
32             $maildir->deliver('somefile.msg');
33              
34             #
35             # Create a new Maildir++ mailbox with sub-mailboxes
36             #
37             my $maildirPP = Mail::Dir->open("$ENV{'HOME'}/newmaildir",
38             'maildir++' => 1,
39             'create' => 1
40             );
41              
42             $maildirPP->create_mailbox('INBOX.foo');
43             $maildirPP->create_mailbox('INBOX.foo.bar');
44             $maildirPP->select_mailbox('INBOX.foo.bar');
45              
46             $maildirPP->deliver(\*STDIN);
47              
48             =head1 DESCRIPTION
49              
50             C provides a straightforward mechanism for delivering mail messages
51             to a Maildir or Maildir++ mailbox.
52              
53             =cut
54              
55             our $VERSION = '0.02';
56              
57             my $MAX_BUFFER_LEN = 4096;
58             my $MAX_TMP_LAST_ACCESS = 129600;
59             my $DEFAULT_MAILBOX = 'INBOX';
60              
61             sub dirs {
62 0     0 0   my ($dir) = @_;
63              
64             return (
65 0           'dir' => $dir,
66             'tmp' => "$dir/tmp",
67             'new' => "$dir/new",
68             'cur' => "$dir/cur"
69             );
70             }
71              
72             =head1 OPENING OR CREATING A MAILBOX
73              
74             =over
75              
76             =item Copen(I<$dir>, I<%opts>)>
77              
78             Open or create a mailbox, in a manner dependent on the flags specified in
79             I<%opts>, and returns an object representing the Maildir structure.
80              
81             Recognized option flags are:
82              
83             =over
84              
85             =item * C
86              
87             When specified, create a Maildir inbox at I<$dir> if one does not already
88             exist.
89              
90             =item * C
91              
92             When specified, enable management and usage of Maildir++ sub-mailboxes.
93              
94             =back
95              
96             =back
97              
98             =cut
99              
100             sub open {
101 0     0 1   my ( $class, $dir, %opts ) = @_;
102              
103 0 0         die('No Maildir path specified') unless $dir;
104              
105 0           my %dirs = dirs($dir);
106              
107 0           foreach my $key (qw(dir tmp new cur)) {
108 0           my $dir = $dirs{$key};
109              
110 0 0         if ( $opts{'create'} ) {
111 0 0         unless ( -d $dir ) {
112 0 0         mkdir($dir) or die("Unable to mkdir() $dir: $!");
113             }
114             }
115             else {
116 0 0         die("$dir: Not a directory") unless -d $dir;
117             }
118             }
119              
120 0           my $hostname = Sys::Hostname::hostname();
121              
122 0 0         return bless {
123             'dir' => $dir,
124             'maildir++' => $opts{'maildir++'} ? 1 : 0,
125             'hostname' => $hostname,
126             'mailbox' => $DEFAULT_MAILBOX,
127             'deliveries' => 0
128             }, $class;
129             }
130              
131             sub validate_mailbox_name {
132 0     0 0   my ($mailbox) = @_;
133              
134 0 0         my @components = split( /\./, $mailbox ) or die("Invalid mailbox name $mailbox");
135              
136 0           my $first = $components[0];
137              
138 0 0         if ( $first =~ /^\~/ ) {
139 0           die("Invalid mailbox name $mailbox: Name cannot start with a tilde");
140             }
141              
142 0           foreach my $component (@components) {
143 0 0         die("Invalid mailbox name $mailbox: Name cannot contain '..'") if $component eq '';
144 0 0         die("Invalid mailbox name $mailbox: Name cannot contain '/'") if $component =~ /\//;
145             }
146              
147 0           return;
148             }
149              
150             sub mailbox_dir {
151 0     0 0   my ( $self, $mailbox ) = @_;
152              
153 0   0       $mailbox ||= $self->mailbox;
154              
155 0           validate_mailbox_name($mailbox);
156              
157 0 0         if ( $mailbox eq $DEFAULT_MAILBOX ) {
158 0           return $self->{'dir'};
159             }
160              
161 0           my @components = split /\./, $mailbox;
162              
163 0           my $subdir = join( '.', @components );
164              
165 0           return "$self->{'dir'}/.$subdir";
166             }
167              
168             =head1 MANIPULATING MAILBOXES
169              
170             The following methods require Maildir++ extensions to be enabled.
171              
172             =over
173              
174             =item C<$maildir-Eselect_mailbox(I<$mailbox>)>
175              
176             Change the current mailbox to which mail is delivered, to I<$mailbox>.
177              
178             =cut
179              
180             sub select_mailbox {
181 0     0 1   my ( $self, $mailbox ) = @_;
182              
183 0 0         die('Maildir++ extensions not enabled') unless $self->{'maildir++'};
184              
185 0           validate_mailbox_name($mailbox);
186              
187 0 0         die('Mailbox does not exist') unless -d $self->mailbox_dir($mailbox);
188              
189 0           return $self->{'mailbox'} = $mailbox;
190             }
191              
192             =item C<$maildir-Emailbox()>
193              
194             Returns the name of the currently selected mailbox.
195              
196             =cut
197              
198             sub mailbox {
199 0     0 1   my ($self) = @_;
200              
201 0           return $self->{'mailbox'};
202             }
203              
204             =item C<$maildir-Emailbox_exists(I<$mailbox>)>
205              
206             Returns true if I<$mailbox> exists.
207              
208             =cut
209              
210             sub mailbox_exists {
211 0     0 1   my ( $self, $mailbox ) = @_;
212              
213 0           return -d $self->mailbox_dir($mailbox);
214             }
215              
216             sub parent_mailbox {
217 0     0 0   my ($mailbox) = @_;
218              
219 0           my @components = split /\./, $mailbox;
220 0 0         pop @components if @components;
221              
222 0           return join( '.', @components );
223             }
224              
225             =item C<$maildir-Ecreate_mailbox(I<$mailbox>)>
226              
227             Create the new I<$mailbox> if it does not already exist. Will throw an error
228             if the parent mailbox does not already exist.
229              
230             =back
231              
232             =cut
233              
234             sub create_mailbox {
235 0     0 1   my ( $self, $mailbox ) = @_;
236              
237 0 0         die('Maildir++ extensions not enabled') unless $self->{'maildir++'};
238 0 0         die('Parent mailbox does not exist') unless $self->mailbox_exists( parent_mailbox($mailbox) );
239              
240 0           my %dirs = dirs( $self->mailbox_dir($mailbox) );
241              
242 0           foreach my $key (qw(dir tmp new cur)) {
243 0           my $dir = $dirs{$key};
244              
245 0 0         mkdir($dir) or die("Unable to mkdir() $dir: $!");
246             }
247              
248 0           return 1;
249             }
250              
251             sub name {
252 0     0 0   my ( $self, %args ) = @_;
253              
254 0 0         my $from = $args{'from'} or die('No message file, handle or source subroutine specified');
255 0 0         my $time = $args{'time'} ? $args{'time'} : time();
256              
257 0           my $name = sprintf( "%d.P%dQ%d.%s", $time, $$, $self->{'deliveries'}, $self->{'hostname'} );
258              
259 0 0         if ( $self->{'maildir++'} ) {
260 0           my $size;
261              
262 0 0         if ( defined $args{'size'} ) {
    0          
263 0           $size = $args{'size'};
264             }
265             elsif ( !ref($from) ) {
266 0 0         my @st = stat($from) or die("Unable to stat() $from: $!");
267 0           $size = $st[7];
268             }
269              
270 0 0         if ( defined $size ) {
271 0           $name .= sprintf( ",S=%d", $size );
272             }
273             }
274              
275 0           return $name;
276             }
277              
278             sub spool {
279 0     0 0   my ( $self, %args ) = @_;
280              
281 0           my $size = 0;
282              
283 0           my $from = $args{'from'};
284 0           my $to = $args{'to'};
285              
286 0 0         sysopen( my $fh_to, $to, &Fcntl::O_CREAT | &Fcntl::O_WRONLY ) or die("Unable to open $to for writing: $!");
287              
288 0 0         if ( ref($from) eq 'CODE' ) {
289 0           $from->($fh_to);
290              
291 0           $fh_to->flush;
292 0           $fh_to->sync;
293              
294 0           $size = tell $fh_to;
295             }
296             else {
297 0           my $fh_from;
298              
299 0 0         if ( ref($from) eq 'GLOB' ) {
    0          
300 0           $fh_from = $from;
301             }
302             elsif ( ref($from) eq '' ) {
303 0 0         sysopen( $fh_from, $from, &Fcntl::O_RDONLY ) or die("Unable to open $from for reading: $!");
304             }
305              
306 0           while ( my $len = $fh_from->read( my $buf, $MAX_BUFFER_LEN ) ) {
307 0           $size += syswrite( $fh_to, $buf, $len );
308              
309 0           $fh_to->flush;
310 0           $fh_to->sync;
311             }
312              
313 0 0         close $fh_from unless ref($from) eq 'GLOB';
314             }
315              
316 0           close $fh_to;
317              
318 0           return $size;
319             }
320              
321             =head1 DELIVERING MESSAGES
322              
323             =over
324              
325             =item C<$maildir-Edeliver(I<$from>)>
326              
327             Deliver a piece of mail from the source indicated by I<$from>. The following
328             types of values can be specified in I<$from>:
329              
330             =over
331              
332             =item * A C reference
333              
334             When passed a C reference, the subroutine specified in I<$from> is called,
335             with a file handle passed that the subroutine may write mail data to.
336              
337             =item * A file handle
338              
339             The file handle passed in I<$from> is read until end-of-file condition is
340             reached, and spooled to a new message in the current mailbox.
341              
342             =item * A filename
343              
344             The message at the filename indicated by I<$from> is spooled into the current
345             mailbox.
346              
347             =back
348              
349             =cut
350              
351             sub deliver {
352 0     0 1   my ( $self, $from ) = @_;
353              
354 0 0         die('No message source provided') unless defined $from;
355              
356 0 0         my $oldcwd = Cwd::getcwd() or die("Unable to getcwd(): $!");
357 0           my $dir = $self->mailbox_dir;
358 0           my $time = time();
359              
360 0           my $name = $self->name(
361             'from' => $from,
362             'time' => $time
363             );
364              
365 0 0         chdir($dir) or die("Unable to chdir() to $dir: $!");
366              
367 0           my $file_tmp = "tmp/$name";
368              
369 0 0         return if -e $file_tmp;
370              
371 0           my $size = $self->spool(
372             'from' => $from,
373             'to' => $file_tmp
374             );
375              
376 0           my $name_new = $self->name(
377             'from' => $file_tmp,
378             'time' => $time,
379             'size' => $size
380             );
381              
382 0           my $file_new = "new/$name_new";
383              
384 0 0         unless ( rename( $file_tmp => $file_new ) ) {
385 0           die("Unable to deliver incoming message to $file_new: $!");
386             }
387              
388 0 0         my @st = stat($file_new) or die("Unable to stat() $file_new: $!");
389              
390 0 0         chdir($oldcwd) or die("Unable to chdir() to $oldcwd: $!");
391              
392 0           $self->{'deliveries'}++;
393              
394 0           return Mail::Dir::Message->from_file(
395             'maildir' => $self,
396             'mailbox' => $self->{'mailbox'},
397             'dir' => 'new',
398             'file' => "$dir/$file_new",
399             'name' => $name_new,
400             'st' => \@st
401             );
402             }
403              
404             =back
405              
406             =head1 RETRIEVING MESSAGES
407              
408             =over
409              
410             =item C<$maildir-Emessages(I<%opts>)>
411              
412             Return a list of L references containing mail messages as
413             selected by the criteria specified in I<%opts>. Options include:
414              
415             =over
416              
417             =item * C, C, C
418              
419             When any of these are set to 1, messages in those queues are processed.
420              
421             =item * C
422              
423             A subroutine can be passed via C reference which filters for messages
424             that are desired. Each L object is passed to the
425             subroutine as its sole argument, and is kept if the subroutine returns 1.
426              
427             =back
428              
429             =back
430              
431             =cut
432              
433             sub messages {
434 0     0 1   my ( $self, %opts ) = @_;
435 0           my $dir = $self->mailbox_dir;
436              
437 0           my @ret;
438              
439 0           foreach my $key (qw(tmp new cur)) {
440 0 0         next unless $opts{$key};
441              
442 0           my $path = "$dir/$key";
443              
444 0 0         opendir( my $dh, $path ) or die("Unable to opendir() $path: $!");
445              
446 0           while ( my $item = readdir($dh) ) {
447 0 0         next if $item =~ /^\./;
448              
449 0           my $file = "$path/$item";
450 0 0         my @st = stat($file) or die("Unable to stat() $file: $!");
451              
452 0           my $message = Mail::Dir::Message->from_file(
453             'maildir' => $self,
454             'mailbox' => $self->{'mailbox'},
455             'dir' => $key,
456             'file' => $file,
457             'name' => $item,
458             'st' => \@st
459             );
460              
461 0 0         if ( defined $opts{'filter'} ) {
462 0 0         next unless $opts{'filter'}->($message);
463             }
464              
465 0           push @ret, $message;
466             }
467              
468 0           closedir $dh;
469             }
470              
471 0           return \@ret;
472             }
473              
474             =head1 PURGING EXPIRED MESSAGES
475              
476             =over
477              
478             =item C<$maildir-Epurge()>
479              
480             Purge all messages in the C queue that have not been accessed for the past
481             36 hours.
482              
483             =back
484              
485             =cut
486              
487             sub purge {
488 0     0 1   my ($self) = @_;
489 0           my $time = time();
490              
491             my $messages = $self->messages(
492             'tmp' => 1,
493             'filter' => sub {
494 0     0     my ($message) = @_;
495              
496 0 0         return ( $time - $message->{'atime'} > $MAX_TMP_LAST_ACCESS ) ? 1 : 0;
497             }
498 0           );
499              
500 0           foreach my $message ( @{$messages} ) {
  0            
501 0 0         unlink( $message->{'file'} ) or die("Unable to unlink() $message->{'file'}: $!");
502             }
503              
504 0           return $messages;
505             }
506              
507             1;
508              
509             __END__