File Coverage

blib/lib/Email/Sender/Transport/Maildir.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	14	26	53.8
condition	2	6	33.3
subroutine	19	19	100.0
pod	0	1	0.0
total	118	135	87.4

package Email::Sender::Transport::Maildir 1.500;
# ABSTRACT: deliver mail to a maildir on disk

use Moo;
with 'Email::Sender::Transport';

use Errno ();
use Fcntl;
use File::Path 2.06;
use File::Spec;

use Sys::Hostname;

use MooX::Types::MooseLike::Base qw(Bool);

#pod =head1 DESCRIPTION
#pod
#pod This transport delivers into a maildir.  The maildir's location may be given as
#pod the F argument to the constructor, and defaults to F in the
#pod current directory (at the time of transport initialization).
#pod
#pod If the directory does not exist, it will be created.
#pod
#pod By default, three headers will be added:
#pod
#pod  * X-Email-Sender-From - the envelope sender
#pod  * X-Email-Sender-To   - the envelope recipients (one header per rcpt)
#pod  * Lines               - the number of lines in the body
#pod
#pod These can be controlled with the C and
#pod C constructor arguments.
#pod
#pod The L object returned on success has a C
#pod method that returns the filename to which the message was delivered.
#pod
#pod =cut

{
  package
    Email::Sender::Success::MaildirSuccess;
  use Moo;
  use MooX::Types::MooseLike::Base qw(Str);
  extends 'Email::Sender::Success';
  has filename => (
    is  => 'ro',
    isa => Str,
    required => 1,
  );
  no Moo;
}


my $HOSTNAME;
BEGIN { ($HOSTNAME = hostname) =~ s/\..*//; }
sub _hostname { $HOSTNAME }

my $MAILDIR_TIME    = 0;
my $MAILDIR_COUNTER = 0;

has [ qw(add_lines_header add_envelope_headers) ] => (
  is  => 'ro',
  isa => Bool,
  default => sub { 1 },
);

has dir => (
  is  => 'ro',
  required => 1,
  default  => sub { File::Spec->catdir(File::Spec->curdir, 'Maildir') },
);

sub send_email {
  my ($self, $email, $env) = @_;

  my $dupe = Email::Abstract->new(\do { $email->as_string });

  if ($self->add_envelope_headers) {
    $dupe->set_header('X-Email-Sender-From' =>
      (defined $env->{from} ? $env->{from} : '-'),
    );

    my @to = grep {; defined } @{ $env->{to} };
    $dupe->set_header('X-Email-Sender-To'   => (@to ? @to : '-'));
  }

  $self->_ensure_maildir_exists;

  $self->_add_lines_header($dupe) if $self->add_lines_header;
  $self->_update_time;

  my $fn = $self->_deliver_email($dupe);

  return Email::Sender::Success::MaildirSuccess->new({
    filename => $fn,
  });
}

sub _ensure_maildir_exists {
  my ($self) = @_;

  for my $dir (qw(cur tmp new)) {
    my $subdir = File::Spec->catdir($self->dir, $dir);
    next if -d $subdir;

    Email::Sender::Failure->throw("couldn't create $subdir: $!")
      unless File::Path::make_path($subdir) || -d $subdir;
  }
}

sub _add_lines_header {
  my ($class, $email) = @_;
  return if $email->get_header("Lines");
  my $lines = $email->get_body =~ tr/\n/\n/;
  $email->set_header("Lines", $lines);
}

sub _update_time {
  my $time = time;
  if ($MAILDIR_TIME != $time) {
    $MAILDIR_TIME    = $time;
    $MAILDIR_COUNTER = 0;
  } else {
    $MAILDIR_COUNTER++;
  }
}

sub _deliver_email {
  my ($self, $email) = @_;

  my ($tmp_filename, $tmp_fh) = $self->_delivery_fh;

  # if (eval { $email->can('stream_to') }) {
  #  eval { $mail->stream_to($fh); 1 } or return;
  #} else {
  my $string = $email->as_string;
  $string =~ s/\x0D\x0A/\x0A/g unless $^O eq 'MSWin32';
  print $tmp_fh $string
    or Email::Sender::Failure->throw("could not write to $tmp_filename: $!");

  close $tmp_fh
    or Email::Sender::Failure->throw("error closing $tmp_filename: $!");

  my $target_name = File::Spec->catfile($self->dir, 'new', $tmp_filename);

  my $ok = rename(
    File::Spec->catfile($self->dir, 'tmp', $tmp_filename),
    $target_name,
  );

  Email::Sender::Failure->throw("could not move $tmp_filename from tmp to new")
    unless $ok;

  return $target_name;
}

sub _delivery_fh {
  my ($self) = @_;

  my $hostname = $self->_hostname;

  my ($filename, $fh);
  until ($fh) {
    $filename = join q{.}, $MAILDIR_TIME, $$, ++$MAILDIR_COUNTER, $hostname;
    my $filespec = File::Spec->catfile($self->dir, 'tmp', $filename);
    sysopen $fh, $filespec, O_CREAT|O_EXCL|O_WRONLY;
    binmode $fh;
    Email::Sender::Failure->throw("cannot create $filespec for delivery: $!")
      unless $fh or $!{EEXIST};
  }

  return ($filename, $fh);
}

no Moo;
1;

__END__