# the port number clients should connect to
$serverport = "9967";
# and the name of the server
$servername = "reportserver";    
# name to IP address
$serveraddr = inet_ntoa(scalar gethostbyname($servername)); 
$reporttoaddr  = "project\@example.com";
$reportfromaddr  = "project\@example.com";

$reserver = IO::Socket::INET->new(PeerAddr => $serveraddr,
                                  PeerPort => $serverport,
                                  Proto    => "tcp",
                                  Type     => SOCK_STREAM)
  or die "Unable to build our socket half: $!\n";


if ($ARGV[0] ne "-m"){
    print $reserver $ARGV[0];
}
else {
    use Mail::Mailer;

    print $reserver "DUMPNOW\n";
    chomp($subject = <$reserver>);
    $body = join("",<$reserver>);

    $type="sendmail";
    my $mailer = Mail::Mailer->new($type) or
      die "Unable to create new mailer object:$!\n";

    $mailer->open({
		   From => $reportfromaddr,
		   To => $reporttoaddr,
		   Subject => $subject
		  }) or die "Unable to populate mailer object:$!\n";

    print $mailer $body;
    $mailer->close;
}

close($reserver);
-------
#*
#* a subroutine (and example use of the subroutine) that provides 
#* decent problem reporting output
#*

use Text::Wrap;

sub problemreport {
# $shortcontext should be a one-line description of the problem
# $usercontext should be a detailed description of the problem
# $nextstep should be the best suggestion for how to remedy the problem 
    my($shortcontext,$usercontext,$nextstep) = @_;
    my($filename, $line, $subroutine) = (caller(1))[1,2,3];
    
    push(@return,"Problem with $filename: $shortcontext\n");

    push(@return,"*** Problem report for $filename ***\n\n");
    push(@return,fill("","","- Problem: $usercontext")."\n\n");
    push(@return,"- Location: line $line of file $filename in
                 $subroutine\n\n");
    push(@return,"- Occurred: ".scalar localtime(time)."\n\n");

    push(@return,"- Next step: $nextstep\n");

    \@return;
}
    
sub fireperson {
    $report = &problemreport("the computer is on fire",<<EOR,<<EON);
While running the accounting report, smoke started pouring out of the 
back of the machine. This occurred right after we processed the ORA 
pension plan.
EOR
Please put fire out before continuing.
EON

  print @{$report};

}

&fireperson;
-------
#*
#* parsing an email message
#*

use Mail::Internet;

$messagefile = "mail";

open(MESSAGE,"$messagefile") or die "Unable to open $messagefile:$!\n";
$message = new Mail::Internet \*MESSAGE;
close(MESSAGE);
-------
#*
#* parsing an email message header
#*

use Mail::Header;

$messagefile = "mail";

open(MESSAGE,"$messagefile") or die "Unable to open $messagefile:$!\n";
$header = new Mail::Header \*MESSAGE;
close(MESSAGE);

print join("\n",sort $header->tags);
-------
#*
#* display the path a message took to get to us
#*

use Mail::Header;

$header = new Mail::Header \*STDIN;

$header->unfold('Received');
@received = $header->get('Received');

for (reverse @received){
    chomp;
    parseline($_);
    if (!defined $ehelo and !defined $validname and !defined $validip){
	print "$_\n";
    }
    else {
	write;
    }
}

format STDOUT =
@<<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<
$ehelo,$validname,$validip
.

sub parseline {
    my $line = $_;

    # "normal" -- from HELO (REAL [IP])
    if (/from\s+(\w\S+)\s*\((\S+)\s*\[(\d+\.\d+\.\d+\.\d+)/){
	($ehelo,$validname,$validip) = ($1,$2, $3);
    }
    # can't reverse resolve -- from HELO ([IP])
    elsif (/from\s+(\w\S+)\s+\(\[(\d+\.\d+\.\d+\.\d+)\]/){
	($ehelo,$validname,$validip) = ($1,undef, $2);
    }	
    # exim -- from [IP] (helo=[HELO IP])
   elsif (/from\s+\[(\d+\.\d+\.\d+\.\d+)\]\s+\(helo=\[(\d+\.\d+\.\d+\.\d+)\]/){
	($validip,$ehelo,$validname) = ($1,$2, undef);
    }	
    # Sun Internet Mail Server -- from [IP] by HELO
    elsif (/from\s+\[(\d+\.\d+\.\d+\.\d+)\]\s+by\s+(\S+)/){
	($validip,$ehelo,$validname) = ($1,$2, undef);
    }	
    # Microsoft SMTPSVC -- from HELO - (IP)
    elsif (/from\s+(\S+)\s+-\s+(\d+\.\d+\.\d+\.\d+)\s+/){
	($ehelo,$validname,$validip) = ($1,$2, $3);
    }
    else { # punt!
	$ehelo = $validname = $validip = undef;
    }

    return [$ehelo,$validname,$validip];
}
-------
#*
#* subroutine that checks if the name we were given matches the IP address
#* we recorded when we received the mail
#*

use Socket;

sub checkrev{
    my($ip,$name) = @_;

    return 0 unless ($ip and $name);

    my $namelook = gethostbyaddr(inet_aton($ip),AF_INET);
    my $iplook   = gethostbyname($name);

    $iplook = inet_ntoa($iplook) if $iplook;
    
    # may be recorded with different capitilization
    if ($iplook eq $ip and lc $namelook eq lc $name){
        return 0;
    }
    else {
        return 1;
    }
}
-------
#*
#* display the contents of a local sendmail blacklist
#*

$blacklist = "/etc/mail/blacklist.db";

use BerkeleyDB;

# tie the hash %blist to the blacklist file, using Berkeley DB 
# to retrieve values
tie %blist, 'BerkeleyDB::Hash', -Filename  => $blacklist
  or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

# iterate over each key and value in this file, printing only 
# the REJECT entries
while(($key,$value) = each %blist){
    # the entry in the list can also be marked "OK", "RELAY", etc. 
    next if ($value ne "REJECT"); 
    
    print "$key\n";
}
-------
#*
#* two ways to check against a local black list
#*

use BerkeleyDB;

$blacklist = "/etc/mail/blacklist.db";

&loadblist;

# take a host name as a command line argument and complain 
# if it is in the blacklist
if (defined &checkblist($ARGV[0])){
    print "*** found $found in our blacklist\n";
}

# load the blacklist into an array of anonymous subroutines
sub loadblist{
    tie %blist, 'BerkeleyDB::Hash', -Filename  => $blacklist
      or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

    while(my($key,$value) = each %blist){
        # the blacklist can also say "OK", "RELAY", and etc. 
        next if ($value ne "REJECT"); 
        push(@blisttests, eval 'sub {$_[0] =~ /\Q$key/o and $key}');
    }    
}

sub checkblist{
    my($line) = shift;

    foreach $subref (@blisttests){
        return $found if ($found = &$subref($line));
    }
    return undef;
}

### OR ###

sub loadblist{
    tie %blist, 'BerkeleyDB::Hash', -Filename  => $blacklist
      or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

    while(my($key,$value) = each %blist){
        # the blacklist can also say "OK", "RELAY", and etc. 
        next if ($value ne "REJECT"); 
        push(@blisttests,[qr/\Q$key/,$key]);
    }    
}

sub checkblist{
    my($line) = shift;

    foreach my $test (@blisttests){
        my($re,$key) = @{$test};
        return $key if ($line =~ /$re/);
    }
    return undef;
}
-------
#*
#* subroutine to check an address against an Internet-wide black list
#*

sub checkaddr{
    my($ip,$domain) = @_;

    return undef unless (defined $ip);

    my $lookupip = join('.',reverse split(/\./,$ip));
    
    if (gethostbyname($lookupip.$domain)){
        return $ip;
    }
    else {
        return undef;
    }
}
-------
#*
#* retrieve WHOIS information about a particular IP address
#*
sub getwhois{
    my($ip) = shift;
    my($info);

    $cn = new Net::Telnet(Host => $whoishost,
                          Port => 'whois',
                          Errmode => "return",
                          Timeout => 30)
      or die "Unable to set up $whoishost connection:$!\n";

    unless ($cn->print($ip."\n")){
        $cn->close;
        die "Unable to send $ip to $whoishost: ".$cn->errmsg."\n";
    }

    while ($ret = $cn->get){
        $info .=$ret;
    };

    $cn->close;

    return $info;
}
-------
#*
#* examine a piece of spam/UCE and tell us information about it
#* NOTE: this requires several subroutines from above
#*

use Mail::Header;
use Socket; 
use BerkeleyDB;
use Net::Telnet;

$header = new Mail::Header \*STDIN;

$header ->unfold('Received');
@received = $header->get('Received');

$rbldomain  = ".rbl.maps.vix.com";
$orbsdomain = ".relays.orbs.org";
$duldomain  = ".dul.maps.vix.com";
$blacklist  = "/etc/mail/blacklist.db";
$whoishost  = "whois.geektools.com";

&loadblist;

for (reverse @received){
    chomp;


    parseline($_);
    if (!defined $ehelo and !defined $validname and !defined $validip){
       print "$_\n";
    }
    else {
     $flags  = (&checkaddr($validip,$rbldomain)  ? "R" : ""); # in RBL?
     $flags .= (&checkaddr($validip,$orbsdomain) ? "O" : ""); # in ORBS?
     $flags .= (&checkaddr($validip,$duldomain)  ? "D" : ""); # in DUL?
     $flags .= (&checkblist($_)              ? "B" : ""); # in our list?
     $flags .= (&checkrev($validip,$validname) ? "L" : ""); # rev-lookup?
      push(@iplist,$validip);
	
      write;
    }
}

for (@iplist){
    print "\nWHOIS info for $_:\n";
    print &getwhois($_);
}

format STDOUT =
@<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<  @<<<<<<<<<<<<<<< @<<<<
$ehelo,$validname,$validip,$flags
.
-------
#*
#* suss - attempts to determine problem machine by looking at message itself
#*

use Mail::Internet;
$localdomain = ".example.com";

# read in our host file
open(HOSTS,"/etc/hosts") or die "Can't open host file\n";
while(defined($_ = <HOSTS>)){
    next if /^#/;        # skip comments
    next if /^$/;        # skip blank lines
    next if /monitor/i;  # an example of a misleading host 

    $machine = lc((split)[1]);  # extract the first host name & downcase
    $machine =~ s/\Q$localdomain\E$//oi; # remove our domain name
    $machines{$machine}++ unless $machines{$machine};
}

# parse the message
$message = new Mail::Internet \*STDIN;
$message->head->unfold();

# check in the subject line
my $subject = $message->head->get('Subject');
$subject  =~ s/[.,;?]//g;
for (split(/\s+/,$subject)) {
    if (exists $machines{lc $_}) {
	print "subject: $_\n";
	$found++;
    }
}
exit if $found;

# check in the body of the message
chomp(my @body = @{$message->body()});
my $body = join(" ",@body);
$body =~ s/[^\w\s]/ /g;              # remove punctuation 
@body{split(' ', lc $body)} = ();    # uniq'ify the body
for (keys %body) {
    if (exists $machines{lc $_}) {
	print "body: $_\n";
	$found++;
    }
}
exit if $found;

# last resort: check the last Received: line
$received = (reverse $message->head->get('Received'))[0]; 
$received =~ s/\Q$localdomain\E//g;
for (split(/\s+/,$received)) {
    if (exists $machines{lc $_}) {
	print "received: $_\n";
    }
}
-------
#*
#* a suss-like program that checks against a printer database
#*

use Mail::Internet;
use DB_File;

$localdomain = ".example.com";

# printdb is a Berkeley DB file with a host for a key and a 
# printer for a value
$printdb     = "printdb"; 

# parse the message
$message = new Mail::Internet \*STDIN;
$message->head->unfold();

# check in the subject line
my $subject = $message->head->get('Subject');
if ($subject =~ /print(er|ing)?/i){
    # find sending machine (assumes Sendmail's header format)
    $received = (reverse $message->head->get('Received'))[0]; 
    ($host) = 
      $received =~ /^from \S+ \((?:\S+@)?(\S+)\Q$localdomain\E \[/;
}

tie %printdb, "DB_File",$printdb  or die "Can't tie $printdb database:$!\n";

print "Problem on $host may be with the printer called " . 
  $printdb{$host} . ".\n";

untie %printdb;