#!/usr/bin/perl -s

######## ------- CLASS  ZRList ------------------------------------------------
########       PURPOSE  Zero Redundancy, Case Insesitive List that behaves 
########                like a 'hash' when acccessed via method as_key ()
########     COPYRIGHT  (C) 1998, Vipul Ved Prakash. <mail@vipul.net>  
########   CONSTRUCTOR  new () 
######## ----------------------------------------------------------------------

package ZRList;

%HOL = (); 

## -- CONSTRUCTOR  new () ----------------------------------------------------
##      ARGUMENTS  None.
##       FUNCTION  Creates a new ZRList Object.
## ---------------------------------------------------------------------------

sub new { 
    return bless []; 
} 

## ------ METHOD  add () ----------------------------------------------------- 
##     ARGUMENTS  qw/Object-reference Scalar/
##      FUNCTION  Adds the Scalar to the ZRList. 
## ---------------------------------------------------------------------------

sub add { 
    my ($self, $item) = @_;  
    grep { 
        my $check = $_; $check =~ s/^\s*//; $check =~ y/A-Z/a-z/; 
        push @$self, $check unless $check eq '' || grep {$_ eq $check} @$self; 
    } ref ($item) ? @$item : ($item); 
} 

## ------ METHOD  sub () ----------------------------------------------------- 
##     ARGUMENTS  qw/Object-reference Scalar/
##      FUNCTION  Removes the Scalar from the ZRList. 
## ---------------------------------------------------------------------------

sub sub { 
    my ($self, $item) = @_; $item =~ y/A-Z/a-z/; 
    my @temp = grep {$_ ne $item} @$self; 
    @$self = @temp; 
} 

## ------ METHOD  iexists () ------------------------------------------------- 
##     ARGUMENTS  qw/Object-reference Scalar/
##      FUNCTION  Checks whether the Scalar is in the ZRList.
## ---------------------------------------------------------------------------

sub iexists {
    my ($self, $item) = @_; $item =~ y/A-Z/a-z/; 
    return 1 if grep {$_ eq $item} @$self; 
    return undef; 
} 


## ------ METHOD  as_key () -------------------------------------------------- 
##     ARGUMENTS  qw/Object-reference Key [Scalar-value]/
##      FUNCTION  Provides read/write access to a private hash indexed by the
##                List items. 
## ---------------------------------------------------------------------------

sub as_key { 
    my ($self, $key, $item) = @_; 
    $HOL{$self}{$key} = $item if $item; 
    return $HOL{$self}{$key}; 
}
        
## ------ METHOD  as_string () ----------------------------------------------- 
##     ARGUMENTS  Object Reference. 
##      FUNCTION  Returns a comma separated list of all items.
## ---------------------------------------------------------------------------

sub as_string { 
    my $self = shift; 
    return join', ', @$self;  
} 

sub as_fmt_list { 
	my $self = shift; 
	my $return; 
	for (@$self) { 
		$return .= "o $_\n"
    }
	return $return; 
}

######## ------- CLASS  Spam::Ricochet ---------------------------------------
########       PURPOSE  Auto Tracing and Reporting Agent for RFC 822 Compliant
########                Mail.  
########     COPYRIGHT  (C) 1998, Vipul Ved Prakash. <mail@vipul.net>  
########   CONSTRUCTOR  new () 
######## ---------------------------------------------------------------------

package Spam::Ricochet; 
use vars qw ($VERSION $AUTOLOAD); 
use Carp; 
use Net::DNS; 
use Mail::Internet; 
use Text::Template; 
use LWP::UserAgent; 
use Net::XWhois; 
use POSIX; 

( $VERSION )  = '$Revision: 0.97 $' =~ /\s(\d+\.\d+)\s/; 

my %data = (
	SENDMAIL => '/usr/sbin/sendmail -t', ## Location of sendmail binary with 
                                         ## required arguments.  

	SPAM              => undef,          ## Text of the spam mail. 
	SPAM_FROM         => undef,          ## From and matched Received Headers. 
	RECEIVE           => undef, 
	SUBJECT           => undef,          ## Subject of spam mail. 
	ORIG_DOMAINS      => new ZRList,     ## Domains/Hosts used for 
	ORIG_HOSTS        => new ZRList,     ## originating the SPAM. 
	TRANSMIT_DOMAINS  => new ZRList,     ## Domains/Hosts used for 
	TRANSMIT_HOSTS    => new ZRList,     ## transmitting the mail. 

	CONTACTS          => new ZRList,     ## List of email addresses of 
                                         ## contacts of originating/transmit 
                                         ## domain and contacts of name-servers 
                                         ## for the domains.  

	EXTRA_LIST        => [qw/abuse postmaster/],  
										 ## List of receipients at ORIG_DOMAN 
                                         ## besides the CONTACTS.

##  Anything there can be easily faked, producing lots of unwanted
##  complaints. Better will not use it.
##  EXTRA_HEADERS     => [qw/from reply-to sender errors-to return-path/],
    EXTRA_HEADERS     => undef,
                                         ## Headers to analyze besides 
                                         ## 'Received'

	EXTRA_EMAIL_HEADERS => [qw/from reply-to sender errors-to x-abuse \ 
                               x-complaints-to/], 
                                         ## List of mail headers for 
                                         ## extracting email addresses.


	MAIL              => undef,          ## A Mail::Internet object. 
	RELAXED           => undef,          ## Relaxed parsing of headers. 
	DEBUG_ON          => undef,          ## Debug mode 
	DONT_SEND         => undef,          ## Won't send the mail if set. 
                                         ## Will print it to STDOUT. 
    FROM_HEADERS      => undef,          ## Won't extract email from headers
                                         ## unless true. 
	GUESS             => undef,          ## Guess with EXTRA_LIST. 
	SKIPLIST          => undef,          ## Hosts and emails to skip. 
	ABUSECONTACTS     => undef,          ## List of abuse contacts. 
	AC                => undef,          ## Use the AC list if set. 
	NOSEC             => undef,          ## Doesn't Whois lookup NS entries if set.
    ABUSENET          => undef,          ## Lookup abuse.net database if set.
	ABUSE_LIST        => new ZRList,     
	SKIP_LIST         => new ZRList,    
	WHOIS_DONE        => new ZRList,     ## List of domains that don't require
                                         ## Whois Lookups. 
    WHOIS_CACHE       => undef,          ## Location of the Whois Cache.
	BACKGROUND        => undef,          ## Background the ricochet process. 
	LOG               => undef,          ## The log file. 
	INTERACTIVE       => undef,          ## Interactive mode. 
     
	FUNCTIONS         => [qw/DEBUG_ON DONT_SEND FROM_EMAIL SPAM_FROM SPAM \
					         GUESS SKIPLIST LOG BACKGROUND AC ABUSECONTACTS \
                             INTERACTIVE RELAXED SUBJECT ABUSENET NOSEC 
                             WHOIS_CACHE FROM_HEADERS/], 
                                         ## Instance data items that need 
                                         ## autoloaded function interfaces. 

);

## -- CONSTRUCTOR  new () ----------------------------------------------------
##      ARGUMENTS  Class-name RFC822-compliant-spam-mail
##       FUNCTION  Creates a new Spam::Ricochet Object 
## ---------------------------------------------------------------------------

sub new {

    my ($class, $spam) = @_;
    my ($self, $i) = ({}, 0); 
    $self = \%data; 

    CLEAN: for (@$spam) { /^[\s\n]*$/ ? $i++ : last CLEAN } 
    splice (@$spam, 0, $i); 
    for (@$spam) { if ( /^\>From\s+\S+\s+(?=Mon|Tue|Wed|Thr|Fri|Sat|Sun)/i ) { s/^\>// } }

    $self->{SPAM} = join'',@$spam; 
    $self->{MAIL} = Mail::Internet->new($spam) || die "$!"; 
    return bless $self; 

}

## ------ METHOD  AUTOLOAD () ------------------------------------ INTERNAL --
##     ARGUMENTS  Object Reference.
##      FUNCTION  Provides Autoloaded functions for data instance specified 
##                through 'FUNCTIONS' key of the data instance hash. 
## ---------------------------------------------------------------------------

sub AUTOLOAD {
    my $self = shift;
    my $key = $AUTOLOAD;
    $key =~ s/.*://; $key =~ tr/a-z/A-Z/;
    Carp::croak "Method $key is not defined in Class @{[ref($self)]}." unless 
                grep {$_ eq $key} @{$self->{FUNCTIONS}};
    if (@_) { 
        my $argument = shift; 
        $self->{$key} = $argument if ! (ref $self->{$key}); 
    } else { return $self->{$key} } 
}
            
## ------ METHOD  analyze_mail () -------------------------------------------- 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Mail Analysis Wrapper.
## ---------------------------------------------------------------------------

sub analyze_mail { 
    my $self = shift; 
    my ($match, $i, $rr, $MX, $NS); 

    my $header = $self->{MAIL}->head;
    if ($self->from_headers) { 
        $self->{SPAM_FROM} = $header->get ('From'); chomp $self->{SPAM_FROM}; 
    }
    $self->{SUBJECT} = $header->get ('Subject'); chomp $self->{SUBJECT};
    my @received = $header->get ('Received'); 
    die "Fatal Error: No 'Received' headers found. Can't trace.\n\n" if $#received == -1 ;

     
    $self->debug (0, "\nANALYZING HEADERS...\n"); 
    my $ip = $header->get ('X-Originating-IP');
    grep { 
        my $header_text = $_;
        my $hdata = $header->get ($header_text); 
        unless ($hdata eq '') {
            $hdata =~ s/\n*$//; 
            $self->debug (1,"o [$_] -- $hdata"); 
	    my $host = _host ($hdata);
	    if ($host =~ /^(.*\.)?hotmail\.(msn\.)?com$/i && $ip eq '') {
		$self->debug (2,"- FAKE hotmail.com, NO X-Originating-IP.\n");
		goto EXTFAKE;
	    }
	    my ($NS, $MX);
            if ((_nslookup ($host) && ($NS = 1)) || (_mxlookup ($host) && ($MX = 1))) { 
                $self->debug (2,"+ $host EXISTS.\n") if $NS; 
                $self->debug (2,"+ $host HAS A MX RECORD.\n") if $MX; 
                $self->{ORIG_HOSTS}->add ($host);   
                if (grep {$header =~ /^$_$/i} @{$self->{EXTRA_EMAIL_HEADERS}}) {
                    $self->{CONTACTS}->add (_email ($hdata)); 
                    $self->{EXTRA_EMAIL_HEADERS}->as_key ($header_text, 'GOT'); 
                }  
            } else { $self->debug (2,"- POSSIBLY FAKED HEADER. $host DOESN'T EXIST.\n") } 
        }
EXTFAKE:
    } @{$self->{EXTRA_HEADERS}}; 

    while ($match == 0) {
        $receive = "$received[$#received - $i++]";
    
        if ($self->authentic ($receive)) {

            $match = 1; $self->{RECEIVE} = $receive; 

            ## Do the skipping and digging...

            ## Skip all hosts in the skip list...
            grep {
                $self->{ORIG_HOSTS}->sub ($_); 
                $self->{TRANSMIT_HOSTS}-> sub ($_); 
                $self->{WHOIS_DONE}->add (_domain ($_)); 
            } @{$self->{SKIP_LIST}}; 

            if ($self->interactive == 1) { 
                _chooser ($self->{ORIG_HOSTS}, "Edit the list of Originating Systems:"); 
                _chooser ($self->{TRANSMIT_HOSTS}, "Edit the list of Transmit Systems:"); 
            }
            
            ## Make a list of originating/transmit domains. Mark the domains which 
            ## have abuse-contact data so we don't Whois 'em. 

            $self->debug (0, "\nCOLLECTING CONTACT INFORMATION...\n"); 

            $self->debug (1,'o Checking the Abuse Contacts List...') if $self->ac == 1; 
            grep {
                my $domain = _domain ($_); my $add; 
                unless (grep { $domain =~ /^$_$/i } @{$self->{SKIP_LIST}}) { 
                    if (($self->ac == 1) && ($add = $self->get_abuse_contact ($_) || 
                                        ($add = $self->get_abuse_contact ($domain)))) { 
                        $self->{CONTACTS}->add ($add); 
                        $self->{ORIG_DOMAINS}->as_key ($domain, 'GOT');
                        $self->{WHOIS_DONE}->add ($domain); 
                        $self->debug (2, "o $domain -- $add"); 
                    } else {$self->{ORIG_DOMAINS}->add ($domain)}
                }
            } @{$self->{ORIG_HOSTS}};
            
            grep {
                my $domain = _domain ($_); my $add;
                unless (grep { $domain =~ /^$_$/i } @{$self->{SKIP_LIST}}) { 
                    if (($self->ac == 1) && ($add = $self->get_abuse_contact ($domain) ||
                                        ($add = $self->get_abuse_contact ($domain)))) { 
                        $self->{CONTACTS}->add ($add); 
                        $self->{TRANSMIT_DOMAINS}->as_key ($domain, 'GOT');
                        $self->{WHOIS_DONE}->add ($domain); 
                        $self->debug (2, "o $domain -- $add"); 
                    } else {$self->{TRANSMIT_DOMAINS}->add ($domain)}
                }
            } @{$self->{TRANSMIT_HOSTS}}; 

            if ( $self->abusenet == 1 ) { 
                $self->debug (1,"\no Looking up the Abuse.net database...");

                grep {
                    my $domain = _domain ($_);
                    unless ( (grep { $domain =~ /^$_$/i } @{$self->{SKIP_LIST}}) || ( $self->{WHOIS_DONE}->iexists ($domain)) )  { 
                        my $add = abuse_net_lookup ($domain);
                        if ( $add ) {
                            for (@$add) { $self->{CONTACTS}->add ($_) }
                            $self->{ORIG_DOMAINS}->as_key ($domain, 'GOT');
                            $self->{WHOIS_DONE}->add ($domain); 
                            $self->debug (2, "o $domain -- @$add"); 
                        } else {$self->{ORIG_DOMAINS}->add ($domain)}
                    }
                } @{$self->{ORIG_HOSTS}};

                grep {
                    my $domain = _domain ($_);
                    unless ( (grep { $domain =~ /^$_$/i } @{$self->{SKIP_LIST}}) || ( $self->{WHOIS_DONE}->iexists ($domain)) )  { 
                        my $add = abuse_net_lookup ($domain);
                        if ($add) {
                            for (@$add) { $self->{CONTACTS}->add ($_) }
                            $self->{TRANSMIT_DOMAINS}->as_key ($domain, 'GOT');
                            $self->{WHOIS_DONE}->add ($domain); 
                            $self->debug (2, "o $domain -- @$add"); 
                        } else {$self->{ORIG_DOMAINS}->add ($domain)}
                    }
                } @{$self->{TRANSMIT_HOSTS}};

            }

            $self->debug (1, "\no Whois Lookups...");
            grep {
                if ( $self->nosec == 1) { 
                    $self->{ORIG_DOMAINS}->as_key ($_, 'GOT') if $self->dig ($_, 1, 0)
                } else { 
                    $self->{ORIG_DOMAINS}->as_key ($_, 'GOT') if $self->dig ($_, 2, 0)
                }
            } @{$self->{ORIG_DOMAINS}}; 

            grep {
                $self->{TRANSMIT_DOMAINS}->as_key ($_, 'GOT') if $self->dig ($_, 1, 0)
            } @{$self->{TRANSMIT_DOMAINS}}; 

            $self->generate_addresses if $self->guess == 1; 

            _chooser ($self->{CONTACTS}, "Edit the list of Contacts:") if $self->interactive == 1; 
            $self->debug (1, "\no List of contacts...");
            $self->debug (2, $self->{CONTACTS}->as_fmt_list);
        }    

        if (($i-1) == $#received && $match != 1) { 
            if ($self->relaxed == 0) { 
                $self->debug (1,">> Received headers didn't match. Will parse with a relaxed rule-set. <<\n");
                $self->relaxed (1), 
                $i = 0; 
            } else { 
                print "Error: Ricochet can't reliably determine the origin of this spam.\n";
                print "If you are sure the headers you fed to ricochet weren't mangled\n";
                print "in some way, send a copy of the headers (including -DEBUG output)\n"; 
                print "to ricochet-parse-error\@vipul.net\n";
                die ("\n"); 
            }
        }
    }

    if (scalar @{$self->{CONTACTS}} == 0) { 
	    print "Error: Couldn't find contact addresses. Try upgrading Net::XWhois.\n";
        print "The latest Net::XWhois can be found at:\n";
        print "http://search.cpan.org/search?dist=Net-XWhois\n";
        die("\n");
    }
}

## ------ METHOD  authentic () ----------------------------------------------- 
##     ARGUMENTS  qw/Object-Reference Received-Header/
##      FUNCTION  Analyzes a 'RFC 822 Recevied Header' for authenticity.
## ---------------------------------------------------------------------------

sub authentic { 
    my $HOSTRE = '[\dA-Za-z\-\.]+\.[A-Za-z]{2,4}(?=[^A-Za-z\-\d])';
    my $IPRE = '\d{1,3}\.\d{1,3}\.\d{1,3}.\d{1,3}';

    my ($self, $received) = @_;
    unless ($self->relaxed == 1) {  
         return undef unless $received =~ /from/s && $received =~ /by/s; 
            # && $received =~ /with|via/s; (commented out in 0.95)
    }

    if ($self->relaxed == 1) { 
        $rfc = '( id\s| from\s| by\s| with\s| for\s| via\s|\n$)';
    } else { 
        $rfc = '( from | by\s| with\s| for\s| via\s|\n$)';
    }

    my $auth = 0; 
   
    chomp $received;  
    $self->debug (1,"o [received] -- $received");
    
    $received =~ /from\s(.*?)$rfc/s; my $from = " $1 "; 
    $received =~ /by\s(.*?)$rfc/s; my $by = " $1 "; 

    ## Trust only "(host.name [" part, HELO can be fake
    my @orig_hosts = $from =~ /\([^()\[\]]*?($HOSTRE)[^()\[\]]*?\[/gs;
    my @orig_ips = $from =~ /($IPRE)/gs; 
    my @transmit_hosts = $by =~ /($HOSTRE)/gs; 
    my @ips = $by =~ /($IPRE)/gs; 

    my $header = $self->{MAIL}->head;
    my $ip = $header->get ('X-Originating-IP');

    grep { 
	if (/^(.*\.)?hotmail\.(msn\.)?com$/i && $ip eq '') {
	    $self->debug (2, "- FAKE originating hotmail.com, NO X-Originating-IP.");
	} elsif (_nslookup ($_)) {
            $auth = 1;
            $self->{ORIG_HOSTS}->add ($_); 
            $self->debug (2,"+ $_ EXISTS."); 
        }
    } @orig_hosts; 

    my $host; 
    grep { 
        if ($host = _ptrquery ($_)) { 
            $self->debug (2,"+ $_ RESOLVES TO $host."); 
	    if ($host =~ /^(.*\.)?hotmail\.(msn\.)?com$/i && $ip eq '') {
		$self->debug (2, "- FAKE originating IP of hotmail.com, NO X-Originating-IP.");
	    } else {
		$auth = 1;
		$self->{ORIG_HOSTS}->add ($host);
	    }
        }
    } @orig_ips;

    if ($self->relaxed == 1) {  ## Check the transmit headers too.
        grep { 
	    if (/^(.*\.)?hotmail\.(msn\.)?com$/i && $ip eq '') {
		$self->debug (2, "- FAKE transmitting hotmail.com, NO X-Originating-IP.");
	    } elsif (_nslookup ($_)) {
                $auth = 1; 
                $self->{TRANSMIT_HOSTS}->add ($_); 
                $self->debug (2,"+ $_ EXISTS.");
            }
        } @transmit_hosts; 
    } 
 
    if ($auth == 0) { 
        $self->debug (2, "- POSSIBLY FAKED HEADER. SKIPPING.\n"); 
        return undef; 
    }

    unless ($self->relaxed == 1) {    
	grep {
	    if (/^(.*\.)?hotmail\.(msn\.)?com$/i && $ip eq '') {
		$self->debug (2, "- FAKE transmitting hotmail.com, NO X-Originating-IP.");
	    } else {
                $self->{TRANSMIT_HOSTS}->add ($_); 
	    }
	} @transmit_hosts;
    }
    
    $self->debug (2, "+ Seems Authentic.\n"); 
	$self->debug (0, "\nRESPONSIBLE SYSTEMS...\n"); 
    $self->debug (1, "o Originating... "); 
    $self->debug (2, $self->{ORIG_HOSTS}->as_fmt_list); 
    $self->debug (1, "o Relay... "); 
    $self->debug (2, $self->{TRANSMIT_HOSTS}->as_fmt_list); 
    return 1;
}


## ------ METHOD  emails_from_header () -------------------------------------- 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Extracts valid email addresses from a set of headers. 
## ---------------------------------------------------------------------------

sub emails_from_header { 
    my $self = shift; 
    my $header = $self->{MAIL}->head () ; 
    grep { 
        my $email = $header->get ($_); chomp $email; 
        $email = _email ($email); 
        my $host = _host ($email); 
        $self->{CONTACTS}->add ($email) if $email;
    } @{$self->{EXTRA_EMAIL_HEADERS}};
}

## ------ METHOD  generate_addresses () -------------------------------------- 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Extracts valid email addresses from a set of headers. 
## ---------------------------------------------------------------------------

sub generate_addresses { 
    my $self = shift; 
    grep {
        my $domain = $_; 
        unless (defined $self->{ORIG_DOMAINS}->as_key ($domain)) { 
            grep {$self->{CONTACTS}->add ("$_\@$domain")} @{$self->{EXTRA_LIST}};
        }
    } @{$self->{ORIG_DOMAINS}}; 

    grep {
        my $domain = $_; 
        unless ($self->{TRANSMIT_DOMAINS}->as_key ($domain)) { 
            grep {$self->{CONTACTS}->add ("$_\@$domain")} @{$self->{EXTRA_LIST}};
        }
    } @{$self->{TRANSMIT_DOMAINS}}; 
}


## ------ METHOD  read_abuse_list () ----------------------------------------- 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Reads the list of abuse contacts from the disk and stores 
##                in an internal hash. 
## ---------------------------------------------------------------------------

sub read_abuse_list { 
    my $self = shift; 
    open (AC, $self->{ABUSECONTACTS}) || return undef; 
    my @temp = <AC>; close AC; chomp @temp;
    grep { 
        s/\#.*$//; if ($_ ne "") { 
        my ($domain, $address) = split /\s*:\s*/, $_, 2; 
        $domain =~ y/A-Z/a-z/; 
        $self->{ABUSE_LIST}->add ($domain); 
        $self->{ABUSE_LIST}->as_key ($domain, $address); 
        }
    } @temp;
    return 1; 
}

## ------ METHOD  get_abuse_contact () --------------------------------------- 
##     ARGUMENTS  qw/Object-Reference Hostname/
##      FUNCTION  Returns abuse contact address for Hostname. 
## ---------------------------------------------------------------------------

sub get_abuse_contact { 
    my ($self, $host) = @_; 
    return $self->{ABUSE_LIST}->as_key ($host) if $self->{ABUSE_LIST}->iexists ($host); 
    return undef;
} 

## -- SUBROUTINE  _abuse_net_lookup () --------------------------- INTERNAL --
##     ARGUMENTS  Domain name.  
##      FUNCTION  Looks up the abuse.net database for reporting addresses.
## ---------------------------------------------------------------------------

sub abuse_net_lookup { 

    my ( $domain ) = @_;
    $ua = new LWP::UserAgent;
    $ua->agent("Ricochet/0.1 " . $ua->agent);
    my $req = new HTTP::Request POST => 'http://www.abuse.net/lookup.phtml'; 
    $req->content_type('application/x-www-form-urlencoded');
    $req->content("DOMAIN=$domain");
    my $res = $ua->request($req);

   if ($res->is_success) {
        my $content = $res->content;
        return undef if $content =~ /no information for this domain/;
        my @matches = $content =~ /(\S+\@\S+)\s*<BR>/ig; 
        return \@matches;
   } else {
        return undef;
   }

}

## ------ METHOD  read_skip_list () ------------------------------------------ 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Reads the list of host/domains to be skipped from the disk 
##                and stores in an internal hash. 
## ---------------------------------------------------------------------------

sub read_skip_list { 
    my $self = shift; 
    open (SL, $self->{SKIPLIST}) || return undef; 
    my @temp = <SL>; close SL, chomp @temp; 
    grep { 
        s/#.*$//; 
        $self->{SKIP_LIST}->add ($_) if ($_ ne ""); 
    } @temp; 
    return 1; 
}
        
## ------ METHOD  initialize () ---------------------------------------------- 
##     ARGUMENTS  Object Reference.
##      FUNCTION  Initialize a Spam::Ricochet Object with frozen values of 
##                instance data from the configuration files. 
## ---------------------------------------------------------------------------

sub initialize { 
    my $self = shift; 
    my $rc = "$ENV{RICOCHET}" || -d "$ENV{HOME}/.ricochet" ? "$ENV{HOME}/.ricochet" : "/usr/local/share/ricochet";
    $rc .= "/ricochetrc"; 
    Carp::croak "** Ricochet configuration file $rc doesn't exist. Aborting.\n" unless -e $rc; 
    open (RC, $rc); 
    grep { 
        chomp; 
        s/#.*$//; 
        my ($field, $value) = split /:/, $_, 2; $value =~ s/\s//g; $field =~ s/\s//g; 
        $self->{$field} = $value unless $field ne "SENDMAIL" && defined $self->{$field}; 
    } (<RC>); 
    close RC; 

    $self->background (0) if $self->interactive == 1; ## BACKGROUND and INTERACTIVE are 
                                                      ## mutually exclusive. 
    if ($self->background == 1) { 
        close 0,1,2; 
        $| = 1; 
        my $LOGFILE = $self->log; 
        open (STDIN, ">>$LOGFILE");
        open (STDOUT, ">>$LOGFILE");
        open (STDERR, ">>$LOGFILE"); 
        my $timestamp = "-"x50 . " ". scalar localtime () . " --"; 
        $self->debug ($timestamp); 
    }

	$self->debug (0, "RICOCHET VERSION: $VERSION.\n\nINITIALIZING...\n");
    $self->debug (1, "o Reading the config file...");    
    
    unless (-e $self->{TEMPLATE}) { 
        print "\nERROR:\n"; 
        print "\tThe complaint mail template, $self->{TEMPLATE}, does not exist.\n";
        Carp::croak "\nAborting.\n\n"; 
    }
    $self->debug (1, "o Reading the abuse-contacts file...") if $self->read_abuse_list; 
    $self->debug (1, "o Reading the skip-list file...") if $self->read_skip_list; 
    $self->relaxed (0); 
    $self->debug; 
    return 1;
}

## ------ METHOD  debug () --------------------------------------------------- 
##     ARGUMENTS  qw/Object-Reference Text-Message/
##      FUNCTION  Prints the Text Message on STDOUT. 
## ---------------------------------------------------------------------------

sub debug { 
    my ($self, $leading, @message) = @_; 
    return unless $self->debug_on == 1 ; 
	$tab = "    "x$leading; print $tab;
    grep {s/\n/\n$tab/g; print } @message; 
    print "\n"; 
}

## ------ METHOD  dig () ----------------------------------------------------- 
##     ARGUMENTS  qw/Object-Reference Domain [Max-Depth] [Current-Depth]/
##      FUNCTION  Performs a Whois _dig_ by building and traversing a tree of
##                height Max-Depth with its 'kid' nodes as DNS servers of the
##                'parent' nodes. Makes a list of contact addresses of all
##                domains in the tree. 
## ---------------------------------------------------------------------------

sub dig { 
    my ($self, $domainname, $maxlevel, $level) = @_; 
    my ($cinfo, $list, @mails, %mailhash, $add); 
    
    $domainname = _domain ($domainname); 
    $domainname =~ y/A-Z/a-z/;

    $level = 0 unless $level; 
    
    return if $self->{WHOIS_DONE}->iexists ($domainname) || $domainname eq ''; 

    if (($self->ac == 1) && ($add = $self->get_abuse_contact ($domainname))) { 
        $self->{CONTACTS}->add ($add); 
        $self->{WHOIS_DONE}->add ($domainname); 
        return 1;
    };  

    $self->{WHOIS_DONE}->add ($domainname); 
    $self->debug (2, "o $domainname..."); 

    if ( $self->whois_cache ) { 
        my $r = new Net::XWhois; 
        $r->register_cache ( $self->whois_cache ); 
    }

    my $domain = new Net::XWhois Domain => $domainname
                 || die "Error: dns lookup failed on $domainname."; 
    if ($domain) { 
        my @contacts = $domain->contact_emails (); 
		for (@contacts) {  $self->{CONTACTS}->add ($_) if $_ }
        unless (++$level == $maxlevel) { 
            my @ns = $domain->nameservers(); 
            grep { $self->dig (_domain ($_), $maxlevel, $level) } @ns
        }
    } else { 
        return undef; 
    } 
    return 1; 
} 

## ------ METHOD  sendmail () ------------------------------------------------ 
##     ARGUMENTS  qw/Object-Reference [Template-File]/
##      FUNCTION  Send out a complaint mail by filling out a RFC822 template. 
## ---------------------------------------------------------------------------

sub sendmail { 
    my ($self, $template_file) = @_; 
    $template_file = $self->{TEMPLATE} unless $template_file; 
    die "Can't open Template File" unless -e $template_file;

    $TEMP::elist = new ZRList; $TEMP::domains = new ZRList; 
    $TEMP::elist->add ($self->{CONTACTS}); 
    $TEMP::domains->add ($self->{ORIG_DOMAINS}); 
    $TEMP::domains->add ($self->{TRANSMIT_DOMAINS}); 

    ## Fill the template 
    $TEMP::self = $self; 
    my $template = new Text::Template ('type' => FILE, 'source' => "$template_file" ) || die "$!"; 
    my $mailtext = $template->fill_in ('package' => 'TEMP'); 

    if ($self->dont_send == 1) { 
        $self->debug (0, "\nCOMPLAINT MAIL FOLLOWS...\n"); 
        print $mailtext; 
        return 1; 
    } else { 
        $self->debug (0, "\nSENDING MAIL...\n");
        open SENDMAIL, "| $self->{SENDMAIL}"; 
        print SENDMAIL $mailtext; 
        close SENDMAIL;     
        $self->debug (); 
    }
}
 
## -- SUBROUTINE  _ptrquery () ----------------------------------- INTERNAL --
##     ARGUMENTS  IP Address.
##      FUNCTION  Performs a PTR Query and returns the associated hostname. 
## ---------------------------------------------------------------------------

sub _ptrquery { 
    my ($ip) = @_; my $query;
    my $res = new Net::DNS::Resolver; 
    if ($query = $res->query ($ip)) { 
        grep {
            return $_->ptrdname if ($_->type eq 'PTR');
        } $query->answer; 
    }
    return undef; 
}

## -- SUBROUTINE  _nslookup () ----------------------------------- INTERNAL --
##     ARGUMENTS  Hostname.
##      FUNCTION  Performs a NS Lookup to check if the host exists. 
## ---------------------------------------------------------------------------

sub _nslookup { 
    my $host = shift; 
    my $res = new Net::DNS::Resolver; 
    $res->tcp_timeout (60); ## TCP Timeout 1 minute. 
    my $ip = $res->search ($host) || return undef; 
    return 1 if $ip ne "";
    return undef; 
}

## -- SUBROUTINE  _mxlookup () ----------------------------------- INTERNAL --
##     ARGUMENTS  Hostname/IP Address.
##      FUNCTION  Performs an MX Query for the given address.
## ---------------------------------------------------------------------------

sub _mxlookup { 
    my $host = shift; 
    my $res = new Net::DNS::Resolver; 
    $res->tcp_timeout (60); ## TCP Timeout 1 minute. 
    my $ip = $res->search ($host, "MX") || return undef; 
    return 1 if $ip ne "";
    return undef; 
}

## -- SUBROUTINE  _domain () ------------------------------------- INTERNAL --
##     ARGUMENTS  Hostname.
##      FUNCTION  Returns the domain part of the host. 
## ---------------------------------------------------------------------------

sub _domain { 
    my $host = shift; $host =~ y/A-Z/a-z/; my $domain = ''; 
    ($domain) = $host =~ /([\da-z\-]+\.(edu?|com?|net?|org?|gov?|int|ac|pp)\.[a-z]{2})$/;
    ($domain) = $host =~ /([\da-z\-]+\.[a-z]{2,4})$/ unless $domain;
    return $domain ? $domain : undef; 
}

## -- SUBROUTINE  _host () --------------------------------------- INTERNAL --
##     ARGUMENTS  Text. 
##      FUNCTION  Extracts hostname from the Text. RFC819. 
## ---------------------------------------------------------------------------

sub _host { 
    my $hostre = '[\dA-Za-z\-\.]+\.[A-Za-z]{2,4}(?=[^A-Za-z\-\d]|$)';
    my $data = shift; 
    my ($host) = $data =~ /($hostre)/; 
    return $host if $host ne ''; 
}

## -- SUBROUTINE  _email () -------------------------------------- INTERNAL --
##     ARGUMENTS  Text. 
##      FUNCTION  Extracts an email address from the Text. 
## ---------------------------------------------------------------------------

sub _email {
    my $text = shift;
    return undef unless $text =~ /(\S+\@\S+)/;
    $text = $1;  
    $text =~ s/^.*?<//;
    $text =~ s/>$//;
    return $text;
}




## -- SUBROUTINE  _chooser () ------------------------------------ INTERNAL --
##     ARGUMENTS  qw/ZRList [Text-Message]/ 
##      FUNCTION  Adds/Removes items from a ZRList based on user input. 
## ---------------------------------------------------------------------------

sub _chooser { 
    my $zrl = shift; 
    my $message = shift || "Contents of the List:"; 

    print "\no $message\n", "-"x(length($message)+2), "\n\n"; 
    my $i = 0; grep { print "    $i.    $_\n"; $i++ } @$zrl; 
    print "\n    o Remove following item numbers from the list: "; 
    grep { $zrl->sub ($zrl->[$_]) } split /\s+/, _getstring (); 
    print "\n    o Add following items to the list: "; 
    grep { $zrl->add ($_) } split /\s+/, _getstring (); 
    print "\n    o The new list is:\n      (", $zrl->as_string, ")\n\n";  
}

## -- SUBROUTINE  _getstring () ---------------------------------- INTERNAL --
##     ARGUMENTS  None.
##      FUNCTION  Reads a newline (\n) terminated string from STDIN.
## ---------------------------------------------------------------------------

sub _getstring { 
    my ($key, $string); 

    open (STDIN); 
    while ($key ne "\n") { 
        $key = getc (STDIN);
        $string .= $key;
    }
    return $string ne '' ? $string : undef; 
}

######## ----- PACKAGE  Main -------------------------------------------------
########       PURPOSE  The Ricochet Spam Tracing and Reporting Agent. 
########     COPYRIGHT  (C) 1998, Vipul Ved Prakash. <mail@vipul.net>  
######## ---------------------------------------------------------------------
    
package main; 

if ( $v ) { print "$Spam::Ricochet::VERSION\n"; exit 0 };

@mail = <ARGV>;

my $ricochet = new Spam::Ricochet (\@mail); 

$ricochet->debug_on ($DEBUG) if defined $DEBUG; 
$ricochet->dont_send ($DONT_SEND) if defined $DONT_SEND; 
$ricochet->from_headers ($FROM_HEADERS) if defined $FROM_HEADERS; 
$ricochet->guess ($GUESS) if defined $GUESS; 
$ricochet->ac ($AC) if defined $AC; 
$ricochet->nosec ($NOSEC) if defined $NOSEC; 
$ricochet->abusenet ($ABUSENET) if defined $ABUSENET; 
$ricochet->background ($BACKGROUND) if defined $BACKGROUND; 
$ricochet->interactive ($INTERACTIVE) if defined $INTERACTIVE; 

$ricochet->initialize (); 

if ($ricochet->background == 1)  {
    chdir '/'; 
    fork && exit;
    POSIX::setsid;
}

$ricochet->analyze_mail (); 
$ricochet->sendmail (); 

## ----------------------- Ricochet * Copyright (c) 1998, Vipul Ved Prakash --  
## -------------------------------------------------------- THIS IS THE END --
