File Coverage

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

Criterion	Covered	Total	%
statement	62	64	96.8
branch	11	20	55.0
condition	1	6	16.6
subroutine	15	15	100.0
pod	0	1	0.0
total	89	106	83.9

package Email::Sender::Transport::Mbox 2.600;
# ABSTRACT: deliver mail to an mbox on disk

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

use Carp;
use File::Path;
use File::Basename;
use IO::File 1.11; # binmode
use Email::Simple 1.998;  # needed for ->header_obj
use Fcntl ':flock';

#pod =head1 DESCRIPTION
#pod
#pod This transport delivers into an mbox.  The mbox file may be given by the
#pod F argument to the constructor, and defaults to F.
#pod
#pod The transport I assumes that the mbox is in F format, but
#pod this may change or be configurable in the future.
#pod
#pod =cut

has 'filename' => (is => 'ro', default => sub { 'mbox' }, required => 1);

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

  my $filename = $self->filename;
  my $fh       = $self->_open_fh($filename);

  my $ok = eval {
    if ($fh->tell > 0) {
      $fh->print("\n") or Carp::confess("couldn't write to $filename: $!");
    }

    $fh->print($self->_from_line($email, $env))
      or Carp::confess("couldn't write to $filename: $!");

    $fh->print($self->_escape_from_body($email))
      or Carp::confess("couldn't write to $filename: $!");

    # This will make streaming a bit more annoying. -- rjbs, 2007-05-25
    $fh->print("\n")
      or Carp::confess("couldn't write to $filename: $!")
      unless $email->as_string =~ /\n$/;

    $self->_close_fh($fh)
      or Carp::confess "couldn't close file $filename: $!";

     1;
  };

  die unless $ok;
  # Email::Sender::Failure->throw($@ || 'unknown error') unless $ok;

  return $self->success;
}

sub _open_fh {
  my ($class, $file) = @_;
  my $dir = dirname($file);
  Carp::confess "couldn't make path $dir: $!" if not -d $dir or mkpath($dir);

  my $fh = IO::File->new($file, '>>')
    or Carp::confess "couldn't open $file for appending: $!";

  $fh->binmode(':raw');

  $class->_getlock($fh, $file);

  $fh->seek(0, 2);
  return $fh;
}

sub _close_fh {
  my ($class, $fh, $file) = @_;
  $class->_unlock($fh);
  return $fh->close;
}

sub _escape_from_body {
  my ($class, $email) = @_;

  my $body = $email->get_body;
  $body =~ s/^(From )/>$1/gm;

  my $simple = $email->cast('Email::Simple');
  return $simple->header_obj->as_string . $simple->crlf . $body;
}

sub _from_line {
  my ($class, $email, $envelope) = @_;

  my $fromtime = localtime;
  $fromtime =~ s/(:\d\d) \S+ (\d{4})$/$1 $2/;  # strip timezone.
  return "From $envelope->{from}  $fromtime\n";
}

sub _getlock {
  my ($class, $fh, $fn) = @_;
  for (1 .. 10) {
    return 1 if flock($fh, LOCK_EX | LOCK_NB);
    sleep $_;
  }
  Carp::confess "couldn't lock file $fn";
}

sub _unlock {
  my ($class, $fh) = @_;
  flock($fh, LOCK_UN);
}

no Moo;
1;

__END__