sendmail

#!/home/scott/bin/perl
#!/usr/local/bin/perl

# cheap-o /usr/sbin/sendmail replacement that (doesn't work well but)
# works well with mutt in that if it returns a non-zero exit code,
# mutt will show all of the diagnostic output from this script.

use strict;
use warnings;

use Net::DNS;
use Net::DNS::Resolver;

use Mail::Sendmail;

my %header;
my $email = '';
my $fullemail = '';

# read the mail message from stdin

my $last_key;
while(<STDIN>) {
    my $line = $_;
    $fullemail .= $line;
    unless(/^$/ .. eof STDIN) {
        (my $key, my $value) = $line =~ m/^([A-Za-z_-]+): (.*)/;
        if( $key and $value ) {
            $last_key = $key;
            $header{$key} = '' if ! exists $header{$key};
            $header{$key} .= ' ' if length $header{$key}; 
            $header{$key} .= $value;
        } elsif( $last_key ) {
            # continued lines
            $header{$last_key} .= $line;
        } else {
            warn "parsing headers:  don't know what to do with ``$line''";
        }
    } else {
        $email .= $line;
    }
}

# Mail::Sendmail will use the specified MX to try to deliver to all 
# recipients, but each recipient should have stuff sent to their own MX.
# M::S keyes off of the To and Cc headers.  not sure how to solve this.
# I guess I have to modify, maybe monkey patch, M::S to use different
# args for who to actually try to send to as opposed to the headers
# it sends to the remote mail server.

warn "To: $header{To}";
warn "Cc: $header{Cc}";

my (@to) = grep m/\@/, map { split m/,?\s+/ } $header{To}, $header{Cc};

@to or die "after splitting on commas and grepping for \@'s, there's nothing left in the to field: $header{To}";

warn "after splitting, to looks like: @to";

for my $to (@to) {

    $to =~ s{.*<(.*?)>.*}{$1};

    (my $domain) = $to =~ m{.*\@([^ ]+)} or die "can't parse To: $to";

    warn "to: $to domain: $domain";

    my $res = Net::DNS::Resolver->new( retry => 2 )->query($domain, 'MX');
    $res or die "no DNS results for domain ``$domain''";
    $res->can('answer') or die "DNS response type has no answers for domain ``$domain''";
    my @rrs = $res->answer or die;

    # print "there are ", scalar @rrs, " records\n";
    # for my $rr (@rrs) { $rr->print };
    # print "----------";
    my $rr = $rrs[0] or die "no RR records from DNS lookup";
    # for(qw(name address class type)) { print $_, ': ', $rr->$_, "\n"; }
    #for(qw(name class type rdatastr)) {
    #     print $_, ': ', $rr->$_, "\n"; 
    #}

    my %header = %header;
    $header{To} = $to; # XXX 

    for my $rr (@rrs) {
    
        (my $mx) = (split m/ /, $rr->rdatastr)[1];
        $mx =~ s{\.$}{};
    
        warn "mx: $mx";
    
        Mail::Sendmail::sendmail(
            %header,   # To, From, Subject
            Message => $email,
            Server  => $mx,
        ) or do { warn "Mail::Sendmail: $Mail::Sendmail::error; trying again"; next; };

        goto success;

    }

    die "ran out of mxes to try";

    success:

    warn "success";

}