gistfile1.pl

#!/usr/local/bin/perl5.19.9

use strict;
use warnings;

use Carp;

$SIG{USR1} = sub { Carp::confess(@_); };

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

# use Mail::Sendmail;

use Net::SMTPS;
use IO::Handle;
use Data::Dumper;

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;
    }
}

my $user = $ENV{USER};
$user = 'scott' if $user eq 'root';

# extract the password from the .fetchmailrc file

open my $fetchmail, '<', "/home/$user/.fetchmailrc" or die "$user has no .fetchmailrc to pick passwords from: $!";
my @fetchmail;
my $password;
while(my $line = readline $fetchmail) {
    chomp $line;
    if( $line =~ m/^\s*$/ ) {
        # end of a block of config for a user
        push @fetchmail, 'foo' if @fetchmail % 2; # avoid the "Odd number of..." warning
        my %fetchmail = ( @fetchmail, 'foo', @fetchmail ); # some tokens are parts of pairs while others appear by themselves
        @fetchmail = ();
        # warn Dumper \%fetchmail;
        next unless $fetchmail{user};
        # warn "comparing $header{From} and $fetchmail{user}";
        next unless index($header{From}, $fetchmail{user}) > -1;
        $password = $fetchmail{password} or die "failed to pick out a password out of the .fetchmailrc for user $fetchmail{user}";
        # print "password = `$password'";
        last;
    } else {
        push @fetchmail, $2 while $line =~ m/\G(['"]?)(.*?)\1\s+/cgs;
        # warn Dumper \@fetchmail;
    }

}
$password or die "failed to find config in .fetchmailrc for $header{From}";

my $smtp = Net::SMTPS->new('smtp.gmail.com', Port => 465, doSSL => 'ssl', Debug => 1) or die "failed to create Net::SMTP object";

if( $header{From} =~ m/slowass/ ) {
    $smtp->auth('scott@slowass.net', $password) or die "auth";
} elsif( $header{From} =~ m/biketempe/ ) {
    $smtp->auth('scrottie@biketempe.org', $password) or die "auth";
} else {
    die "bad From address or no gmail account for this From address: ``$header{From}''";
}

$smtp->mail($header{From});
$smtp->to($header{To}) or die "Net::SMTPS error to ->to for $header{To}: " . $smtp->message();
$smtp->recipient(split m/,/, $header{Cc}) if $header{Cc};
$smtp->recipient(split m/,/, $header{Bcc}) if $header{Bcc};
$smtp->data();
$smtp->datasend($fullemail);
$smtp->dataend();
$smtp->quit;


__END__

# previous implementation tried to deliver directly by looking up the MX and talking to it with Mail::SMTP; however, ISPs started blocking outgoing SMTP (bleah) so
# the idea for incarnation two of this was to have accounts on all of the major mail providers and treat them each as a walled garden, connecting to that mail provider
# to deliver mail to users there, but then I stopped having to deal with companies hosted at Yahoo! (serious problems with spam filtering there) and Microsoft so
# I've just been funneling things through gmail.
# in the future, I'll probably start hosting slowass.net somewhere else or myself but continue to use gmail for outgoing mail from there if the new outfit doesn't
# manage good mail relaying, which is hard in this day and age.

warn "To: $header{To}";

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

@to or die "after splitting on whitespace 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) {

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

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

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

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

    my @rrs = Net::DNS::Resolver->new->search($domain, 'MX')->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"; 
    #}

    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,
        ) and goto success;

        warn "Mail::Sendmail: $Mail::Sendmail::error";
        # next;
        last; # only try the first MX

    }

    die "failed";
    # die "ran out of mxes to try";

    success:

    warn "success";

}