#!perl
# Script to extract the relaying host from an e-mail message via STDIN and
# write it to a file of "blocked hosts."
# Created 06-2000 by Andrew Greenburg <andrew@analogmarketing.net>.
# Modified 03-2006 by Andrew Greenburg <andrew@analogmarketing.net>.
 
use strict;
 
my $blockfile;
my $blockhost;
my @lines;
my @elements;
 
# Change this to the path and name of the file you want to use.
$blockfile = "/home/user/blockedhostfile";
 
# Initialize the final output variable.
$blockhost = "";
 
# Open the blockfile for reading.
open (BLOCKFILER, "$blockfile");
 
while (<BLOCKFILER>)
{
    # Read the lines into an array.
    chomp($_);
    push(@lines, $_);
}
 
# Close the blockfile so we can open it for appending later.
close (BLOCKFILER);
 
 
# Read the e-mail message via STDIN. (Usually piped from a mail client)
while (<STDIN>)
{
    my $host;
 
    # We're only looking at lines with "Received:" headers.
    if ( $_ =~ /^Received:/ )
    {
        # Initialize the host variable to something that won't pass our tests.
        $host = "000000";
 
        # Remove those pesky special characters.
        s/\[//g;
        s/\]//g;
        s/\(//g;
        s/\)//g;
 
        # If element four of the line has periods in it, let's assume
        # that this header is of the form "fakename (realname [realIP])".
        # Otherwise, we trust sendmail.
        my $test = (split())[4];
 
        if ($test =~ /\./)
        {
            $host = (split())[3];
        }
        else
        {
            $host = (split())[2];
        }
 
        # Meaningful names will have periods.
        $host =~ /\./ || next;
 
        # Meaningful names will NOT have '@' signs.
        $host =~ /\@/ && next;
 
        # Addresses with single-element names are no good.
        @elements = split(/\./, $host);
        $#elements < 1 && next;
 
        # The top level domain should be two to four characters; no more, no
        # less
        my $tldlen = length($elements[$#elements]);
        $tldlen > 4 && next;
        $tldlen < 2 && next;
 
        # If it's already in the file, we're done.
        foreach my $entry (@lines)
        {
            if ($host eq $entry)
            {
                die "$host already in file\!\n";
            }
        }
 
        # The first good one we find will do. This will take care of the open
        # relays, which is where a lot of junk mail comes from.
        $blockhost = $host;
        last;
    }
}
 
# Now, let's try and nab the dynamic dialup hosts
if ($#elements > 1 && $elements[0] =~ /\-/)
{
    my $bh1 = (split(/\-/, $blockhost))[0];
    my $bh2 = (split(/$elements[0]/, $blockhost))[1];
    $blockhost = "$bh1.\*$bh2";
}
 
# If we didn't find anything, we don't want to write a blank line to the file.
if ($blockhost eq "")
{
    die "No mail host found\!\n";
}
 
# Tell the user what we found.
print "$blockhost\n";
 
# Write it to the file.
open (BLOCKFILE, ">>$blockfile");
print BLOCKFILE "$blockhost\n";
close (BLOCKFILE);