view release on metacpan or  search on metacpan

lib/Mail/LocalDelivery.pm  view on Meta::CPAN

use strict;
package Mail::LocalDelivery;
{
  $Mail::LocalDelivery::VERSION = '0.305';
}
# ABSTRACT: Deliver mail to a local mailbox

use Carp;
use Email::Abstract;
use File::Basename;
use Fcntl ':flock';
use Mail::Internet;
use Sys::Hostname; (my $HOSTNAME = hostname) =~ s/\..*//;

my $debuglevel        = 0;
our $ASSUME_MSGPREFIX = 0;

use constant DEFERRED  => 75;
use constant REJECTED  => 100;
use constant DELIVERED => 0;


sub _debug {
  my ($self, $priority, $what) = @_;
  return $self->{logger}->($priority, $what) if $self->{logger};
  return if $debuglevel < $priority;
  chomp $what;
  chomp $what;
  my ($subroutine) = (caller(1))[3];
  $subroutine =~ s/(.*):://;
  my ($line) = (caller(0))[2];

  warn "$line($subroutine): $what\n";
}


sub new {
  my $class = shift;
  my $stuff = shift;

  my %opts = @_;

  my $self = {
    interpolate_strftime => 0,
    one_for_all          => 0,
    %opts,
  };

  # What sort of stuff do we have?
  if (eval { $stuff->isa('Mail::Internet') }) {
    $self->{email} = $stuff;
  } elsif (my $email = eval { Email::Abstract->new($self); }) {
    $self->{email} = $email->cast('Mail::Internet');
  } elsif (ref $stuff eq "ARRAY" or ref $stuff eq "GLOB") {
    $self->{email} = Mail::Internet->new($stuff);
  } else {
    croak
      "Data was neither a mail object or a reference to something I understand";
  }

  my $default_maildir = ((getpwuid($>))[7]) . "/Maildir/";

  my $default_mbox = $ENV{MAIL}
    || (-d File::Spec->catdir($default_maildir, 'new') ? $default_maildir : ())
    || ((grep { -d $_ } qw(/var/spool/mail/ /var/mail/))[0] . getpwuid($>));

  $self->{default_mbox} = $default_mbox;
  $self->{emergency} ||= $default_mbox;

  return bless $self => $class;
}


sub _nifty_interpolate {
  # perform ~user and %Y%m%d strftime interpolation
  my $self      = shift;
  my @out       = @_;
  my @localtime = localtime;

  if ($self->{interpolate_strftime} and grep { /%/ } @out) {
    require POSIX;
    POSIX->import(qw(strftime));
    @out = map { strftime($_, @localtime) } @out;
  }

  @out = map {
    s{^~/}     {((getpwuid($>))[7])."/"}e;
    s{^~(\w+)/}{((getpwnam($1))[7])."/"}e;
    $_
  } @out;

  return @out;
}

sub deliver {
  my $self = shift;

  my @files = $self->_nifty_interpolate(@_);
  @files = ($self->{default_mbox}) if not @files;

  my @actually_saved_to_files;

  $self->_debug(2, "delivering to @files");

  # from man procmailrc:
  #   If  it  is  a  directory,  the mail will be delivered to a newly created,
  #   guaranteed to be unique file named $MSGPRE- FIX* in the specified
  #   directory.  If the mailbox name ends in "/.", then this directory  is
  #   presumed  to  be  an  MH folder;  i.e.,  procmail will use the next
  #   number it finds available.  If the mailbox name ends  in  "/",  then
  #   this directory  is presumed to be a maildir folder; i.e., proc- mail will
  #   deliver the message to a file in a subdirectory named  "tmp"  and  rename
  #   it  to be inside a subdirectory named "new".  If the mailbox is
  #   specified  to  be an  MH folder  or maildir folder, procmail will create
  #   the neces- sary directories if they don't exist,  rather  than  treat the
  #   mailbox as a non-existent filename.  When procmail is delivering to
  #   directories, you can specify multiple direc- tories  to deliver  to
  #   (procmail  will  do  so utilising hardlinks).
  #
  # for now we will support maildir and mbox delivery.
  # MH delivery and MSGPREFIX delivery remain todo.

  my %deliver_types = (
    mbox      => [],
    maildir   => [],
    mh        => [],
    msgprefix => [],
  );

  for my $file (@files) {
    my $mailbox_type = $self->_mailbox_type($file);
    push @{ $deliver_types{$mailbox_type} }, $file;
    $self->_debug(3, "$file is of type $mailbox_type");
  }

  foreach my $deliver_type (sort keys %deliver_types) {
    next if not @{ $deliver_types{$deliver_type} };
    my $deliver_handler = "_deliver_to_$deliver_type";
    $self->_debug(3,
      "calling deliver handler "
      . "$deliver_handler(@{$deliver_types{$deliver_type}})"
    );

    # Don't try to deliver to things for which we have no delivery method.
    next unless $self->can($deliver_handler);

    push @actually_saved_to_files,