1package Email::Sender::Transport::Maildir;
2# ABSTRACT: deliver mail to a maildir on disk
3$Email::Sender::Transport::Maildir::VERSION = '1.300031';
4use Moo;
5with 'Email::Sender::Transport';
6
7use Errno ();
8use Fcntl;
9use File::Path 2.06;
10use File::Spec;
11
12use Sys::Hostname;
13
14use MooX::Types::MooseLike::Base qw(Bool);
15
16#pod =head1 DESCRIPTION
17#pod
18#pod This transport delivers into a maildir.  The maildir's location may be given as
19#pod the F<dir> argument to the constructor, and defaults to F<Maildir> in the
20#pod current directory (at the time of transport initialization).
21#pod
22#pod If the directory does not exist, it will be created.
23#pod
24#pod By default, three headers will be added:
25#pod
26#pod  * X-Email-Sender-From - the envelope sender
27#pod  * X-Email-Sender-To   - the envelope recipients (one header per rcpt)
28#pod  * Lines               - the number of lines in the body
29#pod
30#pod These can be controlled with the C<add_lines_header> and
31#pod C<add_envelope_headers> constructor arguments.
32#pod
33#pod The L<Email::Sender::Success> object returned on success has a C<filename>
34#pod method that returns the filename to which the message was delivered.
35#pod
36#pod =cut
37
38{
39  package
40    Email::Sender::Success::MaildirSuccess;
41  use Moo;
42  use MooX::Types::MooseLike::Base qw(Str);
43  extends 'Email::Sender::Success';
44  has filename => (
45    is  => 'ro',
46    isa => Str,
47    required => 1,
48  );
49  no Moo;
50}
51
52
53my $HOSTNAME;
54BEGIN { ($HOSTNAME = hostname) =~ s/\..*//; }
55sub _hostname { $HOSTNAME }
56
57my $MAILDIR_TIME    = 0;
58my $MAILDIR_COUNTER = 0;
59
60has [ qw(add_lines_header add_envelope_headers) ] => (
61  is  => 'ro',
62  isa => Bool,
63  default => sub { 1 },
64);
65
66has dir => (
67  is  => 'ro',
68  required => 1,
69  default  => sub { File::Spec->catdir(File::Spec->curdir, 'Maildir') },
70);
71
72sub send_email {
73  my ($self, $email, $env) = @_;
74
75  my $dupe = Email::Abstract->new(\do { $email->as_string });
76
77  if ($self->add_envelope_headers) {
78    $dupe->set_header('X-Email-Sender-From' =>
79      (defined $env->{from} ? $env->{from} : '-'),
80    );
81
82    my @to = grep {; defined } @{ $env->{to} };
83    $dupe->set_header('X-Email-Sender-To'   => (@to ? @to : '-'));
84  }
85
86  $self->_ensure_maildir_exists;
87
88  $self->_add_lines_header($dupe) if $self->add_lines_header;
89  $self->_update_time;
90
91  my $fn = $self->_deliver_email($dupe);
92
93  return Email::Sender::Success::MaildirSuccess->new({
94    filename => $fn,
95  });
96}
97
98sub _ensure_maildir_exists {
99  my ($self) = @_;
100
101  for my $dir (qw(cur tmp new)) {
102    my $subdir = File::Spec->catdir($self->dir, $dir);
103    next if -d $subdir;
104
105    Email::Sender::Failure->throw("couldn't create $subdir: $!")
106      unless File::Path::make_path($subdir) || -d $subdir;
107  }
108}
109
110sub _add_lines_header {
111  my ($class, $email) = @_;
112  return if $email->get_header("Lines");
113  my $lines = $email->get_body =~ tr/\n/\n/;
114  $email->set_header("Lines", $lines);
115}
116
117sub _update_time {
118  my $time = time;
119  if ($MAILDIR_TIME != $time) {
120    $MAILDIR_TIME    = $time;
121    $MAILDIR_COUNTER = 0;
122  } else {
123    $MAILDIR_COUNTER++;
124  }
125}
126
127sub _deliver_email {
128  my ($self, $email) = @_;
129
130  my ($tmp_filename, $tmp_fh) = $self->_delivery_fh;
131
132  # if (eval { $email->can('stream_to') }) {
133  #  eval { $mail->stream_to($fh); 1 } or return;
134  #} else {
135  my $string = $email->as_string;
136  $string =~ s/\x0D\x0A/\x0A/g unless $^O eq 'MSWin32';
137  print $tmp_fh $string
138    or Email::Sender::Failure->throw("could not write to $tmp_filename: $!");
139
140  close $tmp_fh
141    or Email::Sender::Failure->throw("error closing $tmp_filename: $!");
142
143  my $target_name = File::Spec->catfile($self->dir, 'new', $tmp_filename);
144
145  my $ok = rename(
146    File::Spec->catfile($self->dir, 'tmp', $tmp_filename),
147    $target_name,
148  );
149
150  Email::Sender::Failure->throw("could not move $tmp_filename from tmp to new")
151    unless $ok;
152
153  return $target_name;
154}
155
156sub _delivery_fh {
157  my ($self) = @_;
158
159  my $hostname = $self->_hostname;
160
161  my ($filename, $fh);
162  until ($fh) {
163    $filename = join q{.}, $MAILDIR_TIME, $$, ++$MAILDIR_COUNTER, $hostname;
164    my $filespec = File::Spec->catfile($self->dir, 'tmp', $filename);
165    sysopen $fh, $filespec, O_CREAT|O_EXCL|O_WRONLY;
166    binmode $fh;
167    Email::Sender::Failure->throw("cannot create $filespec for delivery: $!")
168      unless $fh or $!{EEXIST};
169  }
170
171  return ($filename, $fh);
172}
173
174no Moo;
1751;
176
177__END__
178
179=pod
180
181=encoding UTF-8
182
183=head1 NAME
184
185Email::Sender::Transport::Maildir - deliver mail to a maildir on disk
186
187=head1 VERSION
188
189version 1.300031
190
191=head1 DESCRIPTION
192
193This transport delivers into a maildir.  The maildir's location may be given as
194the F<dir> argument to the constructor, and defaults to F<Maildir> in the
195current directory (at the time of transport initialization).
196
197If the directory does not exist, it will be created.
198
199By default, three headers will be added:
200
201 * X-Email-Sender-From - the envelope sender
202 * X-Email-Sender-To   - the envelope recipients (one header per rcpt)
203 * Lines               - the number of lines in the body
204
205These can be controlled with the C<add_lines_header> and
206C<add_envelope_headers> constructor arguments.
207
208The L<Email::Sender::Success> object returned on success has a C<filename>
209method that returns the filename to which the message was delivered.
210
211=head1 AUTHOR
212
213Ricardo Signes <rjbs@cpan.org>
214
215=head1 COPYRIGHT AND LICENSE
216
217This software is copyright (c) 2017 by Ricardo Signes.
218
219This is free software; you can redistribute it and/or modify it under
220the same terms as the Perl 5 programming language system itself.
221
222=cut
223