File Coverage

blib/lib/Mail/Audit.pm

Criterion	Covered	Total	%
statement	267	435	61.3
branch	91	200	45.5
condition	31	91	34.0
subroutine	35	56	62.5
pod	25	25	100.0
total	449	807	55.6

use 5.006;
use strict;
package Mail::Audit;
{
  $Mail::Audit::VERSION = '2.228';
}
# ABSTRACT: library for creating easy mail filters

use Carp ();
use File::Basename ();
use File::HomeDir 0.61 ();
use File::Spec ();
use Mail::Audit::MailInternet ();
use Mail::Internet ();
use Symbol ();

use Sys::Hostname ();

use Fcntl ':flock';

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


sub import {
  my ($pkg, @plugins) = @_;
  for (@plugins) {
    eval "use $pkg\::$_";
    die $@ if $@;
  }
}

sub _log { shift->log(@_) }

sub _get_opt {
  my ($self, $arg) = @_;

  my $opt;

  if (ref $arg->[0] eq 'HASH') {
    Carp::carp "prepending arguments is deprecated; append them instead"
      unless @$arg == 1;
    $opt = shift @$arg;
  } elsif (ref $arg->[-1] eq 'HASH') {
    $opt = pop @$arg;
  }

  return $opt || {};
}


my $default_mime_test = sub { $_[0]->get("MIME-Version") };

sub new {
  my $class = shift;
  my %opts  = @_;
  my $type  = ref($class) || $class;

  my $mime_test = (delete $opts{mime_test}) || $default_mime_test;

  my $self = Mail::Audit::MailInternet->new(
    (exists $opts{data} ? $opts{data} : \*STDIN),
    Modify => 0
  );

  # set up logging
  unless ($opts{no_log}) {
    my $log = {};
    $log->{level} = exists $opts{loglevel} ? $opts{loglevel} : 3;

    $log->{file} = exists $opts{log}
                 ? $opts{log}
                 : File::Spec->catfile(
                     File::HomeDir->my_home,
                     "mail-audit.log"
                   );

    my $output_fh;
    if ($log->{file} and open $output_fh, '>>', $log->{file}) {
      $log->{fh} = $output_fh;
    } else {
      warn "couldn't open $log->{file} to log: $!" if $log->{file};
      $log->{fh} = \*STDERR;
    }

    # This sucks, but the gut-construction order does, too.  We need to make it
    # saner in general. -- rjbs, 2006-06-04
    $self->{_log} = $log;
  }

  $self->_log(1, "------------------------------ new run at " . localtime);

  $self->_log(2, "   From: " . ($self->get("from")));
  $self->_log(2, "     To: " . ($self->get("to")));
  $self->_log(2, "Subject: " . ($self->get("subject")));

  # do we have a MIME-Version header?
  # if so,  we subclass MIME::Entity.
  # if not, we remain   Mail::Internet, and, presumably, diminish, and go
  # into the West.
  if ($opts{alwaysmime} or $mime_test->($self)) {
    unless ($opts{nomime}) {
      $self->_log(3,
        "message is MIME.  MIME-Version is " . ($self->get("MIME-Version"))
      );
      eval {
        require Mail::Audit::MimeEntity;
        Mail::Audit::MimeEntity->import;
      };
      die "$@" if $@;
      $self = Mail::Audit::MimeEntity->_autotype_new($self, $opts{mimeoptions});
    } else {
      $self->_log(3, "message is MIME, but 'nomime' option was set.");
    }
  }

  ($self->{_hostname} = Sys::Hostname::hostname) =~ s/\..*//;

  $self->{_audit_opts} = \%opts;
  $self->{_audit_opts}->{noexit}               ||= 0;
  $self->{_audit_opts}->{interpolate_strftime} ||= 0;
  $self->{_audit_opts}->{one_for_all}          ||= 0;

  return $self;
}

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

  return $self->{_audit_opts}->{emergency}
    if exists $self->{_audit_opts}->{emergency};

  return $self->{_audit_opts}->{emergency} = $self->_default_mbox;
}

sub _default_mbox {
  my ($self) = @_;
  return $self->{_default_mbox} if exists $self->{_default_mbox};

  # XXX: How very unixocentric of us; how can we fix this? -- rjbs, 2006-06-04
  #      It's not really broken, but it's also not very awesome.
  my $default_mbox = $ENV{MAIL};

  return $default_mbox if $default_mbox;

  my $default_maildir = File::Spec->catdir(
    File::HomeDir->my_home,
    'Maildir'
  );

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

  return $self->{_default_mbox} = $default_mbox;
}

# XXX: This is a test case until I have a better interface.  This will make
# testing simpler! -- rjbs, 2006-06-04
sub _exit {
  my ($self, $exit) = @_;

  return $self->{_audit_opts}->{_exit}->(@_)
    if exists $self->{_audit_opts}->{_exit};

  exit $exit;
}


sub _shorthand_expand {
  # perform ~user and %Y%m%d strftime expansion
  my $self       = shift;
  my $local_opts = $self->_get_opt(\@_);
  my @out        = @_;

  my $opt = 'interpolate_strftime';
  if (
    ((exists $local_opts->{$opt} and $local_opts->{$opt})
      or $self->{_audit_opts}->{$opt})
    and grep { index($_, '%') >= 0 } @out
  ) {
    my @localtime  = localtime;
    require POSIX;
    import POSIX qw(strftime);
    @out = map { strftime($_, @localtime) } @out;
  }

  return @out = map { $self->_expand_homedir($_) } @out;
}

sub _expand_homedir {
  my ($self, $path) = @_;

  my ($user, $rest) = $path =~ m!^~(\w*)((?:[/\\]).+)?$!;

  return $path unless defined $user and defined $rest;
  my $base = (length $user) ? File::HomeDir->users_home($user)
                            : File::HomeDir->my_home;

  return "$base$rest";
}

sub accept {
  my $self = shift;

  my $local_opts = $self->_get_opt(\@_);

  return $self->{_audit_opts}->{accept}->(@_, $local_opts)
    if exists $self->{_audit_opts}->{accept};

  my @files = $self->_shorthand_expand(@_, $local_opts);

  @files = $self->_default_mbox unless @files;

  my @actually_saved_to_files = ();

  $self->_log(2, "accepting 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 $MSGPREFIX* 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., procmail 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 necessary 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 directories to deliver to
  #   (procmail will do so utilising hardlinks).
  #
  # for now we will support maildir and mbox delivery.
  # MH delivery remains TODO.
  my %accept_types = (
    mbox      => [],
    maildir   => [],
    mh        => [],
  );

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

  foreach my $accept_type (sort keys %accept_types) {
    next if not @{ $accept_types{$accept_type} };
    my $accept_handler = "_accept_to_$accept_type";
    $self->_log(3,
      "calling accept handler $accept_handler(@{$accept_types{$accept_type}})"
    );
    push @actually_saved_to_files,
      $self->$accept_handler(@{ $accept_types{$accept_type} }, $local_opts);
  }

  if ((my $success_count = @actually_saved_to_files) > 0) {
    $self->_log(3,
      "delivered successfully to $success_count destinations at " . localtime
    );
    unless ((exists $local_opts->{noexit} and $local_opts->{noexit})
      or $self->{_audit_opts}->{noexit}
    ) {
      $self->_log(2, "Exiting with status DELIVERED = " . DELIVERED);
      $self->_exit(DELIVERED);
    }
  } else {
    # nothing got delivered, take emergency action.

    my $emergency = $self->_emergency_mbox;
    if (not defined $emergency) {
      $self->_log(0,
        "unable to write to @files and no emergency mailbox defined; "
        . "exiting DEFERRED"
      );
      warn "unable to write to @files";
      $self->_exit(DEFERRED);
    } else {
      if (grep { $emergency eq $_ } @files) {  # already tried that mailbox
        if (@files == 1) {
          $self->_log(0, "unable to write to @files; exiting DEFERRED");
        } else {
          $self->_log(0,
            "unable to write to any of (@files), which includes the emergency mailbox; exiting DEFERRED"
          );
        }
        warn "unable to write to @files";
        $self->_exit(DEFERRED);
      } else {
        my $accept_type    = $self->_mailbox_type($emergency);
        my $accept_handler = "_accept_to_$accept_type";
        @actually_saved_to_files = $self->$accept_handler($emergency);
        if (not @actually_saved_to_files) {
          $self->_log(0,
            "unable to write to @files or to emergency mailbox $emergency either; exiting DEFERRED"
          );
          warn "unable to write to @files" ;
          $self->_exit(DEFERRED);
        } else {
          $self->_log(0,
            "unable to write to @files; wrote to emergency mailbox $emergency."
          );
        }
      }
    }
  }
  return @actually_saved_to_files;
}

sub _mailbox_type {
  my $self = shift;
  my $file = shift;

  return 'maildir' if $file =~ m{/\z};
  return 'mh'      if $file =~ m{/\.\z};
  return 'maildir' if -d $file;

  return 'mbox';
}

sub _accept_to_mbox {
  my $self       = shift;
  my @saved_to   = ();
  my $local_opts = $self->_get_opt(\@_);

  foreach my $file (@_) {
    # auto-create the parent dir.
    if (my $mkdir_error = $self->_mkdir_p(File::Basename::dirname($file))) {
      $self->_log(0, $mkdir_error);
      next;
    }
    my $error = $self->_write_message($file,
      { need_lock => 1, need_from => 1, extra_newline => 1 });
    if (not $error) { push @saved_to, $file; }
    else { $self->_log(1, $error); }
  }
  return @saved_to;
}

sub _write_message {
  my $self       = shift;
  my $file       = shift;
  my $write_opts = shift || {};

  $write_opts->{need_from} = 1 if not defined $write_opts->{need_from};
  $write_opts->{need_lock} = 1 if not defined $write_opts->{need_lock};
  $write_opts->{extra_newline} = 0
    if not defined $write_opts->{extra_newline};

  $self->_log(3, "writing to $file; options @{[%$write_opts]}");

  my $fh = Symbol::gensym;
  unless (open($fh, ">>$file")) { return "Couldn't open $file: $!"; }

  if ($write_opts->{need_lock}) {
    my $lock_error = $self->_audit_get_lock($fh, $file);
    return $lock_error if $lock_error;
  }
  seek $fh, 0, 2;

  if (not $write_opts->{need_from} and $self->head->header->[0] =~ /^From\s/)
  {
    $self->_log(3, "mbox From line found, stripping because we're maildir");
    $self->delete_header("From ");
    $self->unescape_from();
  }

  if ($write_opts->{need_from} and $self->head->header->[0] !~ /^From\s/) {
    $self->_log(3, "No mbox From line, making one up.");
    if (exists $ENV{UFLINE}) {
      $self->_log(3,
        "Looks qmail, but preline not run, prepending UFLINE, RPLINE, DTLINE");
      print $fh $ENV{UFLINE};
      print $fh $ENV{RPLINE};
      print $fh $ENV{DTLINE};
    } else {
      my $from = (
          $self->get('Return-path')
          || $self->get('Sender')
          || $self->get('Reply-To')
          || 'root@localhost'
      );
      chomp $from;
      $from = $1 if $from =~ /<(.*?)>/; # comment  -> name@domain
      $from      =~ s/\s*\(.*\)\s*//;   # name@domain (comment) -> name@domain
      $from =~ s/\s+//g;  # if any whitespace remains, get rid of it.

      # strip timezone.
      (my $fromtime = localtime) =~ s/(:\d\d) \S+ (\d{4})$/$1 $2/;

      print $fh "From $from  $fromtime\n";
    }
  }

  $self->_log(4, "printing self as mbox string.");
  if ($write_opts->{need_from}) {
    my $content = $self->as_string;
    $content =~ s/\nFrom /\n>From /g;
    print $fh $content;
  } else {
    print $fh $self->as_string;
  }

  # extra \n added because mutt seems to like a "\n\nFrom " in mbox files
  print $fh "\n" if $write_opts->{extra_newline};

  if ($write_opts->{need_lock}) {
    flock($fh, LOCK_UN) or return "Couldn't unlock $file";
  }

  close $fh or return "Couldn't close $file after writing: $!";
  $self->_log(4, "returning success.");
  return 0;  # success
}

sub _accept_to_mh {
  my $self       = shift;
  my @saved_to   = ();
  my $local_opts = $self->_get_opt(\@_);

  die "_accept_to_mh not implemented";
  return @saved_to;
}

# variables for accept_to_maildir

my $maildir_time    = 0;
my $maildir_counter = 0;

sub _accept_to_maildir {
  my $self       = shift;
  my @saved_to   = ();
  my $local_opts = $self->_get_opt(\@_);

  $local_opts->{one_for_all} = exists $local_opts->{one_for_all}
    ? $local_opts->{one_for_all}
    : $self->{_audit_opts}->{one_for_all};

  $self->_log(3, "will write to @_");

  # since mutt won't add a lines tag to maildir messages, we'll add it here
  # XXX: Why the nuts is this here?  This should be another method, or a
  # plugin! -- rjbs, 2006-05-30
  unless (length $self->get("Lines")) {
    my @lines = $self->body;
    @lines = @{ $lines[0] } if @lines == 1 and ref $lines[0] eq 'ARRAY';
    my $num_lines = @lines;
    $self->head->add("Lines", $num_lines);
    $self->_log(4, "Adding Lines: $num_lines header");
  }

  if ($maildir_time != time) {
    $maildir_time = time;
    $maildir_counter = 0;
  } else {
    $maildir_counter++;
  }

  # write the tmp file.
  # hardlink to all the new files.
  # unlink the temp file.

  # write the tmp file in the first writable maildir directory.

  my $tmp_path;
  foreach my $file (my @maildirs = @_) {
    $file =~ s/\/$//;
    my $tmpdir = $local_opts->{one_for_all} ? $file : "$file/tmp";

    my $msg_file;
    do {
      $msg_file = join ".",
        ($maildir_time, $$ . "_$maildir_counter", $self->{_hostname});
      $maildir_counter++;
    } while (-e "$tmpdir/$msg_file");

    $tmp_path = "$tmpdir/$msg_file";
    $self->_log(3, "writing to $tmp_path");

    # auto-create the maildir.
    if (
      my $mkdir_error = $self->_mkdir_p(
        $local_opts->{one_for_all}
        ? ($file)
        : map { "$file/$_" } qw(tmp new cur)
      )
    ) {
      $self->_log(0, $mkdir_error);
      next;
    }

    my $error
      = $self->_write_message($tmp_path, { need_from => 0, need_lock => 0 });

    # only write to the first writeable maildir
    last unless $error;

    $self->_log(1, $error);
    unlink $tmp_path;
    $tmp_path = undef;
  }

  # unable to write to any of the specified maildirs.
  if (not $tmp_path) {
    return 0;
  }

  # it is now in tmp/.  hardlink to all the new/ destinations.
  foreach my $file (my @maildirs = @_) {
    $file =~ s/\/$//;

    my $msg_file;
    my $newdir = $local_opts->{one_for_all} ? $file : "$file/new";
    $maildir_counter = 0;

    do {
      $msg_file = join ".",
        ($maildir_time = time, $$ . "_$maildir_counter", $self->{_hostname});
      $maildir_counter++;
    } while (-e File::Spec->catdir($newdir, $msg_file));

    # auto-create the maildir.
    if (
      my $mkdir_error = $self->_mkdir_p(
        $local_opts->{one_for_all}
        ? ($file)
        : map { File::Spec->catdir($file, $_) } qw(tmp new cur)
      )
    ) {
      $self->_log(0, $mkdir_error);
      next;
    }

    my $new_path = File::Spec->catfile($newdir, $msg_file);
    $self->_log(3, "maildir: hardlinking to $new_path");

    if (link $tmp_path, $new_path) {
      push @saved_to, $new_path;
    } else {
      require Errno;
      if ($! == Errno::EXDEV()) {
        # Invalid cross-device link, see /usr/**/include/*/errno.h
        $self->_log(0, "Couldn't link $tmp_path to $new_path: $!");
        $self->_log(0, "attempting direct maildir delivery to $new_path...");
        push @saved_to, $self->_accept_to_maildir($file);
        next;
      } else {
        $self->_log(0, "Couldn't link $tmp_path to $new_path: $!");
      }
    }
  }

  # unlink the temp file
  unlink $tmp_path or $self->_log(1, "Couldn't unlink $tmp_path: $!");
  return @saved_to;
}


sub reject {
  my $self = shift;

  my $local_opt = $self->_get_opt(\@_);

  return $self->{_audit_opts}->{reject}->(@_, $local_opt)
    if exists $self->{_audit_opts}->{reject};

  $self->_log(1, "Rejecting with exitcode " . REJECTED . " and reason $_[0]");

  $self->_exit(REJECTED);
}


sub resend {
  my $self       = shift;
  my $local_opts = $self->_get_opt(\@_);
  my $rcpt       = shift;

  $self->smtpsend(
    To => $rcpt,
    (exists $local_opts->{host}  ? (Host  => $local_opts->{host})  : ()),
    (exists $local_opts->{port}  ? (Port  => $local_opts->{port})  : ()),
    (exists $local_opts->{debug} ? (Debug => $local_opts->{debug}) : ()),
  );

  unless (
    (exists $local_opts->{noexit} and $local_opts->{noexit})
    or $self->{_audit_opts}->{noexit}
  ) {
    $self->_log(2, "Exiting with status DELIVERED = " . DELIVERED);
    $self->_exit(DELIVERED);
  }
}


sub pipe {
  my $self = shift;
  return $self->{_audit_opts}->{pipe}->(@_)
    if exists $self->{_audit_opts}->{pipe};

  my $local_opts = $self->_get_opt(\@_);
  my ($command) = @_;

  my ($file) = $self->_shorthand_expand($command, $local_opts);
  $self->_log(1, "Piping to $file");

  my $pipe = Symbol::gensym;
  unless (open($pipe, "|$file")) {
    $self->_log(0, "Couldn't open pipe $file: $!");
    $self->accept();
  }

  $self->print($pipe);
  close $pipe;
  my $status = $? >> 8;
  $self->_log(3, "Pipe closed with status $status");

  unless ((exists $local_opts->{noexit} and $local_opts->{noexit})
    or $self->{_audit_opts}->{noexit}
  ) {
    $self->_log(2, "Exiting with status DELIVERED = " . DELIVERED);
    $self->_exit(DELIVERED);
  }

  return $status;
}


sub ignore {
  my ($self, $reason) = @_;

  $self->_log(
    1,
    "Ignoring: " . (defined $reason ? $reason : '(no reason given)')
  );

  my $local_opts = $self->_get_opt(\@_);

  $self->_exit(DELIVERED)
    unless ((exists $local_opts->{noexit} and $local_opts->{noexit})
    or $self->{_audit_opts}->{noexit});
}


sub _reply_recipient {
  my $self = shift;

  # TODO: clean this up with Mail::Address.  right now if From: <> we barf.
  return ($self->get("Resent-From")
      || $self->get("Reply-To")
      || $self->get("From")
      || $self->get("Sender")
      || $self->get("Return-Path"));
}

sub reply {
  my $self       = shift;
  my %reply_opts = @_;
  foreach my $k (keys %reply_opts) {
    $reply_opts{ lc $k } = delete $reply_opts{$k};
  }  # lowercase option names

  # thanks to man procmailrc(1), this is ^FROM_DAEMON
  if ($self->from_daemon) {
    unless (defined $reply_opts{even_if_from_daemon}
      and $reply_opts{even_if_from_daemon}
    ) {
      $self->_log(2, "message is ^FROM_DAEMON, skipping reply");
      return "(^FROM_DAEMON, no reply)";
    }
  }

  if ( length $self->get("X-Loop")
    or length $self->get("X-Loop-Detect")
  ) {
    return "(X-Loop header found, not replying)";
  }

  require Mail::Mailer;

  my $rcpt = ($reply_opts{"to"} || $self->_reply_recipient);

  return if not $rcpt;

  my $subject = (
    $reply_opts{"subject"}
      || (
      defined $self->subject
      && length $self->subject
      ? (
        $self->subject !~ /\bRe:/i
        ? "Re: " . $self->subject
        : $self->subject
      )
      : "your mail"
      )
  );

  chomp($rcpt, $subject);

  my @references;
  @references = (
    defined $reply_opts{"references"}
    ? (
      ref($reply_opts{"references"})
      ? map { split ' ', $_ } @{ $reply_opts{"references"} }
      : split ' ', $reply_opts{"references"}
      )
    : grep { length $_ } (
      split(' ', $self->get("References")),
      split(' ', $self->get("Message-ID"))
    )
  );
  @references = grep { /^<.*>$/ } @references;

  my %headers = (
    To      => $rcpt,
    Subject => $subject,
  );
  $headers{From}       = $reply_opts{from} if defined $reply_opts{from};
  $headers{CC}         = $reply_opts{cc}   if defined $reply_opts{cc};
  $headers{BCC}        = $reply_opts{bcc}  if defined $reply_opts{bcc};
  $headers{References} = "@references"     if @references;
  $headers{"X-Loop"}   = $reply_opts{"x-loop"} || $self->get("X-Loop") || "1";
  $headers{"X-Loop-Detect"} = $self->get("X-Loop-Detect") || "1";

  my $reply = Mail::Mailer->new(qw(sendmail));

  $reply->open(\%headers);

  print $reply (
    defined $reply_opts{body}
    ? $reply_opts{body}
    : "Your message has been received.\n");
  $reply->close;  # complete the message and send it

  $self->_log(1, "reply sent to $rcpt");
  return $rcpt;
}


sub log {
  my ($self, $priority, $what) = @_;
  return unless $self->{_log};
  return if $self->{_log}{level} < $priority;
  chomp $what;
  chomp $what;
  my ($subroutine) = (caller(1))[3];
  $subroutine =~ s/(.*):://;
  my ($line) = (caller(0))[2];
  print { $self->{_log}{fh} } "$line($subroutine): $what\n"
    or die "couldn't write to log file: $!";
}


# ----------------------------------------------------------

sub header         { $_[0]->head->as_string() }
sub add_header     { $_[0]->head->add($_[1], $_[2]); }
sub put_header     { &add_header }
sub get_header     { &get }
sub replace_header { $_[0]->head->replace($_[1], $_[2]); }
sub delete_header  { $_[0]->head->delete($_[1]); }

sub get {
  my ($self, $header) = @_;

  if (wantarray) {
    my @strings = $self->head->get($header);
    chomp @strings;
    return @strings;
  } else {
    my $string = $self->head->get($header);
    chomp($string = (defined $string && length $string) ? $string : "");
    return $string;
  }
}

# inheriting from MIME::Entity breaks this.  mengwong 20020112
sub tidy {
  $_[0]->tidy_body();
}

sub noexit {
  $_[0]->{_audit_opts}->{noexit} = $_[1] ? 1 : 0;
}


# ----------------------------------------------------------
sub from     { $_[0]->get("From") }
sub to       { $_[0]->get("To") }
sub subject  { $_[0]->get("Subject") }
sub bcc      { $_[0]->get("BCC") }
sub cc       { $_[0]->get("CC") }
sub received { $_[0]->get("Received") }

# from_mailer and from_daemon inspired by procmailrc
sub from_daemon {
  my $message = shift;
  my $head    = $message->head->dup;
  $head->unfold;
  if (
    $head->as_string =~ /(^(Mailing-List:
      |List-ID:
      |Precedence:.*(junk|bulk|list)
      |To:.*Multiple recipients of
      |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )
      .*?\b
      (Post(ma?(st(e?r)?|n)|office)
       |(?-i)Mailer?(?i)
       |sendmail
       |daemon
       |m(mdf|ajordomo)
       |n?uucp
       |LIST(SERV|proc)
       |NETSERV
       |o(wner|ps)
       |(?-i)r(e(quest|sponse)|oot)(?i)
       |b(ounce|bs\.smtp)
       |mirror
       |s(erv(ices?|er)|mtp(error)?|ystem)
       |A(dmin(istrator)?|MMGR|utoanswer)
      )\@
      ))/imx
  ) {
    return $1;
  }
  return;
}

sub from_mailer {
  my $message = shift;
  my $head    = $message->head->dup;
  $head->unfold;
  __from_mailer($head->as_string);
}

sub __from_mailer {
  my $header = shift;

  if (
    $header =~ /
    (^(((Resent-)?(From|Sender)
     |X-Envelope-From):|>?From )
     .*?\b
     (Post(ma(st(er)?|n)|office)
     |(?-i)Mailer?(?i)
     |sendmail
     |daemon
     |mmdf
     |n?uucp
     |ops
     |(?-i)r(esponse|oot)(?i)
     |(bbs\.)?smtp(error)?
     |s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR)
     )\@
    )/imx
  ) {
    return $1;
  }

  return;
}

# ----------------------------------------------------------
# utility functions
# ----------------------------------------------------------

sub _audit_get_lock {
  my $self = shift;
  my $fh   = shift;
  my $file = shift;
  $self->_log(4, "  attempting to lock file $file");
  for (1 .. 10) {
    if (flock($fh, LOCK_EX)) {
      $self->_log(4, "  successfully locked file $file");
      return;
    } else {
      sleep $_ and next;
    }
  }
  $self->_log(1, my $errstr = "Couldn't get exclusive lock on $file");
  return $errstr;
}

sub _mkdir_p {  # mkdir -p (also create parents if necessary)
  my $self = shift;
  return if not @_;
  return if not length $_[0];
  foreach (@_) {
    next if -d $_;
    chop while m{/$};
    $self->_log(4, "$_ doesn't exist, creating.");
    if (my $error = $self->_mkdir_p(File::Basename::dirname($_))) {
      return $error
    }
    mkdir($_, 0755) or return "unable to mkdir $_: $!";
  }
  return;
}



1;

__END__