#!/usr/bin/perl
#
# VERSION: 1.5
#
# $Id: maildump2smtp 3:80246f09d077 2011-07-14 11:50 +0200 mw $
#
use strict;
use Getopt::Std;
use IO::File;
use Net::SMTP;

our(%opts);
getopts('dhvDISF:T:f:p:H:',\%opts);

if ($opts{h}) {
    print_help();
    exit 1;
}
my $DEBUG    = $opts{D};
my $verbose  = $opts{v};
my $delete   = $opts{d};
my $host     = $opts{H} || 'localhost';
my $port     = $opts{p} || 2500;
my $from     = $opts{F};
my $to       = $opts{T};
my $file     = $opts{f};
my $no_internal = $opts{I};
my $no_spam     = $opts{S};

my $send_file = 1;

my %header = fetch_header($file);
my ($rcptdomain) = $header{'X-REAL-RCPTTO'}   =~ /^\S+\@(.+)\>?$/;
my ($fromdomain) = $header{'X-REAL-MAILFROM'} =~ /^\S+\@(.+)\>?$/;
my ($spamflag)   = $header{'X-Spam-Flag'};

# suppress spam
if ($no_spam && ($spamflag =~ /YES/i)) {
    print "Will not send spam mail.\n" if $verbose;
    $send_file = 0;
}

# simple test of domains (X-REAL-RCPTTO could contain multiple adresses)
if ($no_internal && ($rcptdomain eq $fromdomain)) {
    print "Will not send internal mail.\n" if $verbose;
    $send_file = 0;
}

send_file($host,$port,$file,$from,$to) if $send_file;
unlink $file if $delete;


### SUBS #####################################################################

###
# send_file
#
sub send_file
{
    my ($smtphost,$smtpport,$file,$force_from,$force_to) = @_;
    my $ret;

    use Net::SMTP;
    my $smtp = Net::SMTP->new($smtphost,
        Port => $smtpport,
        Debug => $DEBUG,
        );

    if (!$smtp) {
        print STDERR "Cannot access smtp server at $smtphost:$smtpport\n";
        print STDERR "\n";
        print_help();
        exit 2;
    }

    print "Import mail from $file\n" if $verbose;
    my $fh = new IO::File;
    if ($file) {
        $fh->open($file) or die "Cannot open $file: $!\n";
    }
    else {
        $fh->fdopen(fileno(STDIN),"r");
    }

    # Extract maildump header (first lines)
    my $envelope_from;
    my @envelope_to;
    my $realheader;
    while (my $line = $fh->getline) {
        $realheader = $line;            # don't loose header
        # maildump headers are first
        last unless $line =~ /^X-REAL-(MAILFROM|RCPTTO):/;

        if (my ($mailfrom) = $line =~ /^X-REAL-MAILFROM:\s(.*)$/) {
            $envelope_from = $mailfrom;
        }
        if (my ($rcptto) = $line =~ /^X-REAL-RCPTTO:\s(.*)$/) {
            push @envelope_to, $rcptto;
        }
    }

    # If envelopes from maildump should not be used to for archiving,
    # force_* envelopes override the extracted envelopes
    if ($force_from) {
        $envelope_from = $force_from;
    }
    if ($force_to) {
        @envelope_to = ();
        push @envelope_to, $force_to;
    }


    $smtp->mail($envelope_from);            die_on_error($smtp);
    foreach my $envelope (@envelope_to) {
        $smtp->to($envelope);               die_on_error($smtp);
    }

    $smtp->data();                          die_on_error($smtp);

    $smtp->rawdatasend($realheader);        die_on_error($smtp); # don't loose header
    # loop over mailfile
    while (my $line = <$fh>) {
        $line =~ s/^\./../;                 # RFC 5321, 4.5.2. Transparency
        $smtp->rawdatasend($line);          die_on_error($smtp);
    }
    $smtp->rawdatasend("\r\n");             die_on_error($smtp);
    my $returncode = $smtp->quit;
    $fh->close;
}


###
# smtp_error
#
sub die_on_error
{
    my ($smtp) = shift;
    if (!$smtp->ok) {
        die 'SMTP error: ',$smtp->code,' ',$smtp->message,"\n";
    }
}


###
# fetch_header
#
sub fetch_header
{
    my $file = shift;
    my %header;

    my $fh = new IO::File;
    if ($file) {
        $fh->open($file) or die "Cannot open $file: $!\n";
    }
    else {
        $fh->fdopen(fileno(STDIN),"r");
    }

    my $folded = 0;
    my $hname;
    my $hvalue;
    while (my $line = $fh->getline) {
        last if $line =~ /^\r?$/;          # end of headers
        my $hname_old = $hname;
        ($hname,$hvalue) = $line =~ /^(\S+):\s*?(\S.*)$/;
        if ($line =~ /^\s+/) {
            $hvalue .= $line;
            $hname = $hname_old;
        }
        chomp $hvalue;
        if (exists $header{$hname}) {
            $header{$hname} .= "\n  ".$hvalue;
        }
        else {
            $header{$hname} = $hvalue;
        }
    }
    $fh->close;
    if ($DEBUG) {
        foreach my $var (keys %header) {
            print "Header $var: $header{$var}\n";
        }
    }
    return %header;
} 


###
# print_help
#
sub print_help
{
    my ($basename) = $0 =~ m!.*?([^/]+?)$!;
    print "Call: $basename [-d] [-f <file>] [-H <hostname>] [-p <port>] [-F <from>] [-T <to>]\n";
    print "\n";
    print "  Read eml file from STDIN and delivered it to the smtp server.\n";
    print "  Returns 0 if success.\n";
    print "\n";
    print "  -d             delete file if delivered\n";
    print "  -f             file to deliver (default STDIN)\n";
    print "  -H <hostname>  hostname of SMTP server (default: localhost)\n";
    print "  -p <port>      port of SMTP server (default: 2500)\n";
    print "  -F             override envelope-from (default: value of X-REAL-MAILFROM)\n";
    print "  -T             override envelope-to (default: value of X-REAL-RCPTTO)\n";
    print "  -I             \"Internal\" mail (same domain of sender,recipient) will not be send\n";
    print "  -S             Suppress delivering of SPAM mail (X-Spam-Flag: YES)\n";
    print "  -v             verbose\n";
    print "  -D             debug\n";
    print "\n";
}
