File Coverage

blib/lib/URBL/Prepare.pm

Criterion	Covered	Total	%
statement	47	75	62.6
branch	9	18	50.0
condition	3	10	30.0
subroutine	7	11	63.6
pod	6	8	75.0
total	72	122	59.0

package URBL::Prepare;

use strict;
#use diagnostics;
use AutoLoader 'AUTOLOAD';
use vars qw($VERSION);

$VERSION = do { my @r = (q$Revision: 0.09 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

sub loadcache;
sub Destroy {};

=head1 NAME

URPL::Prepare -- prepare hostname for URBL domain lookup

=head1 SYNOPSIS

  require URBL::Prepare;

  my $ubp = new URBL::Prepare;

  $tlds = $blessed->cachetlds($localfilelistptr);
  $whitelist = $blessed->cachewhite($localfilelistptr);
  $domain = $blessed->urbldomain($hostname);
  $response_code = $proto->loadcache($url,$localfile);
  ($response,$message) = $proto->loadcache($url,$localfile);
  $rv = $blessed->urblblack($hostname);
  $rv = $blessed->urblwhite($hostname);

=head1 DESCRIPTION

=over 2

=item * my $urbl = new URBL::Prepare;

This method returns a blessed reference to an empty hash.

For use with other modules:

  require URBL::Prepare;

  @ISA = qw(URBL::Prepare);

=back

=cut

sub new {
  my $proto = shift;
  my $class = ref $proto || $proto || __PACKAGE__;
  bless {}, $class;
}

=head1 URBL Preparation for lookup methods

The following three methods are for facilitating URBL lookups.

  SEE:	http://www.uribl.com/about.shtml
  and	http://www.surbl.org/guidelines

=over 2

=item * $tldlist = $blessed->cachetlds($localfilelistptr);

This method opens local files in "file list" and extracts the tld's found
therein.

  input: 	ptr to array of local/file/path/names
  return:	array ptr to list of tld's

NOTE: place level 3 tld's ahead of level 2 tld's

=cut

# do level3 tld's first
sub cachetlds {
  my($bls,$files) = @_;
  my @tldlist;
  foreach my $infile (@$files) {
    my $tldf;
    next unless open $tldf, $infile;
    foreach (<$tldf>) {
      chomp;
      next unless $_ =~ /\S/;
      $_ =~ s/\./\\./g;
      push @tldlist, lc $_;
    }
  }
  $bls->{-urblpreparebad} = \@tldlist;
}

=item * $whitelist = $blessed->cachewhite($localfilelistptr);

This method opens local file(s) in "file list" and extracts the domains
found therein.

  See http://wiki.apache.org/spamassassin/DnsBlocklists		and
  http://spamassasin.googlecode.com/svn-history/r6/trunk/share/spamassassin/

Note:: these URL's may change

  input:	ptr to array of local/file/path/names
  return:	array ptr to whitelist domain names

=cut

sub cachewhite {
  my($bls,$files) = @_;
  my @whitelist;
  foreach my $infile (@$files) {
    my $wfile;
    next unless open $wfile, $infile;
    foreach(<$wfile>) {
      next unless $_ =~ /uridnsbl_skip_domain\s+(.+)/;
      (my $white = $1) =~ s/\./\\./g;
      chomp $white;
      my @wtmp = split /\s+/, lc $white;
      push @whitelist, @wtmp;
    }
  }
  $bls->{-urblpreparewhite} = \@whitelist;
}

=item * $blacklist = $blessed->cacheblack($localfilelistptr);

This method opens local file(s) in "file list" and extracts the domains found
therein. The domains may be space seperated many to a line.

  input:	ptr to array of local/file/path/names
  return:	ptr to blacklist domain names

=cut

sub cacheblack {
  my($bls,$files) = @_;
  my @blacklist;
  foreach my $infile (@$files) {
    my $bkfile;
    next unless open $bkfile, $infile;
    foreach(<$bkfile>) {
      chomp;
      (my $black = $_) =~ s/\./\\./g;
      my @btmp = split /\s+/, lc $black;
      push @blacklist, @btmp;
    }
  }
  $bls->{-urblprepareblack} = \@blacklist;
}

=item * $domain = $blessed->urbldomain($hostname)

This method extracts a domain name to check against an SURBL. If the
hostname is whitelisted, the return value is false, otherwise a domain name
is returned.

  input:	hostname
  return:	false if whitelisted
	else	domain to check against SURBL

NOTE: optionally white or tld testing will be bypassed if the pointer
is undefined or points to an empty array.

=cut

# Implementation Guidelines
#
# http://www.surbl.org/guidelines
#
# Extract base (registered) domains from those URIs. This includes removing
# all leading host names, subdomains, www., randomized subdomains, etc. In
# order to determine the level of domain to check, use our tables of two level
# and three level TLDs. Originally these were CCTLDs, but they now also
# include some frequently abused hosting domains. (Note that these files only
# rarely update. Please don't retrieve them more often than once per day.) The
# usage is:
#
#    For any domain on the three level list, check it at the fourth level.
#    For any domain on the two level list, check it at the third level.
#    For any other domain, check it at the second level.
#
# For example, any domain found in the two level list should have a third
# level domain name (such as foo.co.uk) checked against SURBLs. Domains not
# specifically on the two level list (such as foo.com or foo.fr) should be
# checked at two levels. Please do not check at levels other than these as
# doing so will cause unnecessary queries that won't result in matches.

sub urbldomain {
  my $bls   = shift;
  my $host  = lc shift;
  my $white = $bls->{-urblpreparewhite} || [];
  my $tlds  = $bls->{-urblpreparebad} || [];

  foreach(@$white) {
    return undef if $host =~ /$_$/;	# whitelisted?
  }
  foreach (@$tlds) {
    if ($host =~ /([^\.]+\.$_)$/) {
      ($host = $1) =~ s/\\//g;
      return $host;
    }
  }
  $host =~ /([^\.]+\.[^\.]+)$/;
  return $1;
}

=item * $rv = $blessed->urblblack($hostname)

This method check if a hostname is found within the local black list(s).

  input:	hostname
  return:	domain found, else false

=cut

sub urblblack {
  my $bls   = shift;
  my $host  = lc shift;
  my $tlds  = $bls->{-urblprepareblack} || [];
  foreach (@$tlds) {
    if ($host =~ /$_$/) {
      ($host = $_) =~ s/\\//g;
      return $host;
    }
  }
  return undef;
}

=item * $rv = $blessed->urbwhite($hostname)

This method check if a hostname is found within the local white list.

  input:	hostname
  return:	domain found, else false

=cut

sub urblwhite {
  my $bls   = shift;
  my $host  = lc shift;
  my $white  = $bls->{-urblpreparewhite} || [];
  foreach (@$white) {
    if ($host =~ /$_$/) {
      ($host = $_) =~ s/\\//g;
      return $host;
    }
  }
  return undef;
}

1;
__END__