#!/usr/bin/perl -w



# Multi-process rsp. multi-threaded version of rblcheck



$Version='perl rblcheck 0.1.3a';

$Copyright='Copyright (C) 2003 Hatto von Hatzfeld';



# Need help? Just start this script with Option -h



# Don't forget to check the CONFIGURATION sector below.



# Compared with rblcheck written by Edward S. Marshall

# you'll find advantages and disadvantages of this perl

# version of rblcheck. Like rblcheck this script returns

# 1 if at there was any match, otherwise 0 (255 in case

# of syntax errors).



# Advantages:

# - needs much less time to check a high number of RBLs

# - you may indicate a time out (option -o) after which

#   all checks are stopped (no effect when run under

#   Windows with just one IP)

# - is able to filter mail header: "| rblcheck.pl -mq -"

#   (e.g. for procmail)



# Disadvantages:

# - it needs a perl interpreter (maybe you have to change the 

#   first line to fit to your system)

# - the option -t does not return any TXT record

# - output is not sorted the same way



# The script will return 1 if any IP matched with any of

# the RBLs.



# The script has been tested on Linux SuSE 6.2. and works well.



# It has been tested under Windows 98 with ActivePerl 5.6.1.633

# (Perl Version 5.006001), and it works, but not well...

# (available from http://www.ActiveState.com/ActivePerl).



# The script comes "as it is" without any warranty



# You may send improvements and questions to hatto@salesianer.de



# CHANGES

# 2003-06-27  0.1.4a Bug relating to RfC 1918 fixed

# 2002-08-02  0.1.3 Added ability to filter whole mail headers

#                   Don't check private address space (RfC 1918)

# 2002-07-30  0.1.2 First published version



# TODO

# - fight the crashes under Windows mentioned below





# CONFIGURATION



$TimeOutDefault=10; # Default time out (seconds)



$sleepseconds=0; # Set this to 1 if you experience crashes under Windows

                 # especially when checking a high number of RBLs



# RBL Services

# uncomment or comment out services according to your needs!

# Note: In some environments you will get problems if you 

# activate too many services (especially under Windows)



@rbls=(

# "3y.spam.mrs.kithrup.com",

# "bl.redhatgate.com",

"bl.spamcop.net",

# "blackhole.compu.net",

"blackhole.securitysage.com",

# "blackholes.2mbit.com",

"blackholes.five-ten-sg.com",

# "blackholes.intersil.net",

# "blackholes.mail-abuse.org",

# "blackholes.wirehub.net",

# "blacklist.spambag.org",

"block.blars.org",

# "cbl.abuseat.org", # incorporated by xbl.spamhaus.org

# "dev.null.dk",

# "dews.qmail.org",

# "dialup.blacklist.jippg.org",

# "dialups.mail-abuse.org",

"dnsbl.ahbl.org",

"dnsbl.njabl.org",

"dnsbl.sorbs.net",

# "dssl.imrss.org",

# "dul.dnsbl.sorbs.net",

# "dul.maps.vix.com",

# "dul.orca.bc.ca",

# "dynablock.wirehub.net",

# "flowgoaway.com",

# "http.opm.blitzed.org",

# "inputs.orbz.org",

"ipwhois.rfc-ignorant.org",

"korea.services.net",

# "KR.rbl.cluecentral.net",

"list.dsbl.org",

# "manual.orbz.gst-group.co.uk",

# "mr-out.imrss.org",

"multihop.dsbl.org",

"opm.blitzed.org",

# "or.orbl.org",

"orbs.dorkslayers.com",

# "orbz.gst-group.co.uk",

# "outputs.orbz.org",

# "pm0-no-more.compu.net",

"psbl.surriel.com",

# "rbl-plus.mail-abuse.org",

# "rbl.maps.vix.com",

# "rbl.spam.org.tr",

# "relayips.rbl.shub-inter.net",

"relays.bl.kundenserver.de", # public use restricted, see http://relaytest.kundenserver.de/faq/admin/6.html

"relays.dorkslayers.com",

# "relays.mail-abuse.org",

"relays.ordb.org",

# "relays.radparker.com",

"relays.visi.com",

"sbl.spamhaus.org",

# "sbl-xbl.spamhaus.org", # combination of sbl.spamhaus.org and xbl.spamhaus.org

# "socks.opm.blitzed.org",

# "spamguard.leadmon.net",

# "spamips.rbl.shub-inter.net",

# "spammers.v6net.org",

# "spamsources.fabel.dk",

# "l2.spews.dnsbl.sorbs.net",

"l1.spews.dnsbl.sorbs.net",

"t1.bl.reynolds.net.au",

"unconfirmed.dsbl.org",

# "wingate.opm.blitzed.org",

"xbl.selwerd.cx",

"xbl.spamhaus.org", # incorporates cbl.abuseat.org

# "ztl.dorkslayers.com",

);







# END OF CONFIGURATION







use Socket;

use POSIX ":sys_wait_h";



$myname=($0=~/([^\/ ]+)$/) ? $1 : 'rblcheck';



$TimeOut=$TimeOutDefault;



sub ShowSyntax {

  print STDERR "$myname\n$Version\n$Copyright\n";

  print STDERR "Usage: $myname [-qtmlcvh?] [-o <NN>] [-s <services>] <IP> [<IP> ...]\n\n";

  print STDERR "    -q            Quiet mode; no output\n";

  print STDERR "    -t            Print Pseudo-IP reported by rbl (not TXT record!)\n";

  print STDERR "    -m            Stop checking after first address match in any list\n";

  print STDERR "    -l            List default RBL services to check\n";

  print STDERR "    -c            Clear the current list of RBL services\n";

  print STDERR "    -o <NN>       Change time out to NN seconds (default: $TimeOutDefault)\n";

  print STDERR "    -s <service>  Add a new service to the RBL services list\n";

  print STDERR "    -h, -?        Display this help message\n";

  print STDERR "    -v            Display version information\n";

  print STDERR "    <IP>          An IP address to look up; specify '-' to read multiple\n";

  print STDERR "                  addresses (or a whole mail header) from standard input\n";

if($< == 0) { print STDERR "Attention: -m and -o will not be very efficient under Windows!\n"; }

}



# Check parameters

$showtxt=0;

$quit1stpos=0;

$quiet=0;

if($#ARGV<0) { &ShowSyntax; exit 255; }

while($#ARGV>=0) {

  if($ARGV[0]=~/^\-([a-z\?])([a-z\?]*)$/i) {

    if($1 eq "c") { @rbls=(); }

    elsif($1 eq "s") { 

      if($#ARGV<1) { die ("$myname: No parameter (rbl) after -s.\n"); }

      shift @ARGV; push (@rbls, $ARGV[0]); 

    }

    elsif($1 eq "o") { 

      if($#ARGV<1) { die ("$myname: No parameter (time in seconds) after -o.\n"); }

      shift @ARGV; $TimeOut=$ARGV[0]; 

    }

    elsif($1 eq 'm') { $quit1stpos=-1; }

    elsif($1 eq 'q') { $quiet=-1; }

    elsif($1 eq 'h' || $1 eq '?') { &ShowSyntax; exit; }

    elsif($1 eq 't') { $showtxt=-1; }

    elsif($1 eq 'v') { print STDERR "$Version\n$Copyright\n"; exit; }

    elsif($1 eq 'l') {

      for($i=0;$i<=$#rbls;$i++) { print $rbls[$i]."\n"; }

      exit 0;

    }

    else { die("$myname: Unknown parameter -$1.\n"); }

    # place next parameter in first position

    if($2 ne '') { $ARGV[0]="-$2"; }

    else { shift @ARGV; }

  }

  elsif($ARGV[0] eq '-') { # Read IPs from STDIN

    while(defined($inputline=<STDIN>)) {

      chomp $inputline; 

      @inputwords=split(/ /,$inputline);

      foreach $inputword(@inputwords) {

        if(!defined(@IPs)) { $IPs[0]=$inputword; } else { push (@IPs,$inputword); }

      }

    }

    shift @ARGV;

  }

  else {

    # Must be an IP

    if(!defined(@IPs)) { $IPs[0]=shift @ARGV; } else { push(@IPs, shift @ARGV); }

  }

}

if($#rbls<0) { die("$myname: no rbl listing(s) specified (need `-s <IP>'?)\n"); }

$imax=0;

for($i=0;$i<=$#IPs;$i++) {

  if($IPs[$i]=~/(\d+)\.(\d+)\.(\d+)\.(\d+)/) {

    $IPs[$imax]=1*$1.".".1*$2.".".1*$3.".".1*$4;

    $RevIPs[$imax]=1*$4.".".1*$3.".".1*$2.".".1*$1.".";

    # skip Private Address Space (cp. RfC 1918)

    if(!($1==10 || $1==172 && $2>15 && $2<33 || 

         $1==192 && $2==168 || $IPs[$imax] eq '127.0.0.1')) { $imax++; }

  }

}

if($imax<1) {

  print STDERR "$myname: no public IP address(es) specified\n";

  &ShowSyntax;

  exit 1;

}

$ParentP="y"; $NumChildren=0; $Windows="n";

while($ParentP eq "y" && $#rbls>=0) { # LOOP TO GENERATE CHILDREN

  if ($Windows eq "y") { sleep $sleepseconds; } # a helpless workaround :-/

  $rbl=$rbls[0]; # next rbl to be checked

  $rnr=fork(); # generate a child

  if($rnr == 0 ) {  # a child should not generate children

    $ParentP="n"; 

    last;

  }

  elsif($rnr<0) { $Windows="y"; } # supposed

  # Parent; associate PID of new child with rbl to check;

  $NumChildren++; $RBL2CHK{$rnr}=$rbl;

  shift @rbls;

}

if($ParentP eq "n") { # Each child has to check all IPs against one rbl

  $listed=0;

  for($i=0;$i<$imax;$i++) {

    $zwi=$RevIPs[$i].$rbl;

    $Result=gethostbyname($zwi);

    if(!defined($Result)) { $Result=$IPs[$i]." not RBL filtered by ".$rbl."\n"; }

    else {

      $listed=1;

      $Result=$IPs[$i]." RBL filtered by ".$rbl.

             ($showtxt ? " (".inet_ntoa($Result).")\n" : "\n");

    }

    if(!$quiet) { print STDOUT $Result; }

    if($quit1stpos && $listed) { exit 1; }

  }

  exit $listed;

}

else { # Parent has to wait for the deaths of all children or to kill them in case of time out

  $Ende=$TimeOut+time; $Killed="n"; $listed=0;

  for($i=0;$i<$NumChildren;$i++) {

    do { 

      if(time>$Ende && $Killed eq "n" && $Windows ne "y") { # Time out - kill it

        foreach $Pid (keys %RBL2CHK) {

          if($RBL2CHK{$Pid} ne "-") { 

            if(!($quit1stpos && $listed==1) && !$quiet) {

              print STDERR "Check for filtering by ".$RBL2CHK{$Pid}.

                  " timed out (".$TimeOut." s).\n";

            }

            kill 9,$Pid;

          }

        }

        $Killed="y";

      }

      $rv=waitpid(-1, &WNOHANG); $rvc=$?;

    } until $rv != 0;

    if($rv>=0 || $Windows eq "y") { # It was a child

      if($rvc!=0 && !($rvc==9 && $Killed eq "y")) {

        if($rvc==256) { $listed=1; if($quit1stpos) { $Ende=time; } }

        else {

          print STDERR "Check for ".$RBL2CHK{$rv}." finished with code $rvc.\n";

        }

      }

      $RBL2CHK{$rv}="-"; # bury it

    }

    else { # This should never happen :-)

      print STDERR "$myname: Internal error - parent process $$ says: No child to wait for!\n";

    }

  }

  exit $listed;

}