Mail-RBL-1.10/0000755000076500000240000000000010615722763012643 5ustar lemstaff00000000000000Mail-RBL-1.10/Makefile.PL0000644000076500000240000000063510321011022014566 0ustar lemstaff00000000000000use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Mail::RBL', 'VERSION_FROM' => 'RBL.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => 0, 'Net::DNS' => 0, 'NetAddr::IP' => 3.26, }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'RBL.pm', AUTHOR => 'Luis E. Muñoz ') : ()), ); Mail-RBL-1.10/MANIFEST0000644000076500000240000000014610347370732013772 0ustar lemstaff00000000000000Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml RBL.pm README t/00-load.t t/10-rbl.t Mail-RBL-1.10/MANIFEST.SKIP0000644000076500000240000000025310347370557014543 0ustar lemstaff00000000000000^Build$ ^_build/ ^blib/ ^blibdirs ^Makefile$ ^Makefile\.[a-z]+$ ^pm_to_blib CVS/.* \.cvs ,v$ ^tmp/ \.old$ \.bak$ \.tmp$ ~$ ^# \.shar$ \.tar$ \.tgz$ \.tar\.gz$ \.zip$ _uu$ Mail-RBL-1.10/META.yml0000644000076500000240000000062510347371033014107 0ustar lemstaff00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Mail-RBL version: 1.04 version_from: RBL.pm installdirs: site requires: Net::DNS: 0 NetAddr::IP: 3.26 Test::More: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Mail-RBL-1.10/RBL.pm0000644000076500000240000001235410613553554013623 0ustar lemstaff00000000000000package Mail::RBL; require 5.005_62; use Carp; use Socket; use strict; use warnings; use Net::DNS; use NetAddr::IP ':aton'; # $Id: RBL.pm,v 1.10 2007/04/25 04:22:04 lem Exp $ our $VERSION = do { sprintf " %d.%02d", (q$Revision: 1.10 $ =~ /\d+/g) }; =pod =head1 NAME Mail::RBL - Perl extension to access RBL-style host verification services =head1 SYNOPSIS use Mail::RBL; my $list = new Mail::RBL('list.org'); # You can also specify a resolver to use with Net::DNS::Resolver my $list = new Mail::RBL('list.org', $res); if ($list->check($host)) { print "$host is in the list"; } my ($ip_result, $optional_info_txt) = $list->check($host); # $optional_info_txt will be undef if the list does not provide TXT # RRs along with the A RRs. print "The list says ", ($list->check($host))[1], " in its TXT RR\n"; my ($ip_result, $optional_info_txt) = $list->check_rhsbl($hostname); =head1 DESCRIPTION This module eases the task of checking if a given host is in the list. The methods available are described below: =over =item C<-Enew(suffix, resolver)> Creates a list handle. The C parameter is mandatory and specifies which suffix to append to the queries. If left unspecified, defaults to C. An optional DNS resolver can be specified. An object of the Net::DNS::Resolver(3) class is expected. =cut sub new { my $type = shift; my $class = ref($type) || $type || "Mail::RBL"; my $suffix = shift; my $res = shift || Net::DNS::Resolver->new; my $self = { suffix => defined $suffix ? $suffix : 'bl.spamcop.net', res => $res, }; bless $self, $class; } =pod =item C<-Echeck($host)> C<$host> can be either a hostname or an IP address. In the case of an IP Address. In the case of a hostname, all the IP addresses will be looked up and checked against the list. If B of the addresses is in the list, the host will be considered in the list as a whole. Returns either a C object as returned by the RBL itself, or C in case the RBL does not supply an answer. This is important because many lists inject some semantics on the DNS response value, which now can be recovered easily with the program that uses this module. In array context, any IP addresses are returned, followed by any TXT RR (or undef if none). If no match is found, an empty list is returned instead. In scalar context, only the first IP address (or undef) is returned. =back =cut sub check ($$) { my $self = shift; my $host = shift; croak "Must call ->check() with a host to check" unless length $host; foreach my $addr (_inverted_addresses($host)) { if (my $val = $self->_do_check($addr)) { if (wantarray) { return ($val, $self->_do_txt($addr)); } else { return $val; } } } return; } =pod =item C<-Echeck_rhsbl($host)> Analogous to C<-Echeck()>, but queries RHSBLs instead of IP-based lists. This is useful for using lists such as some of B. Results and return values are the same as C<-Echeck()>. =cut sub check_rhsbl ($$) { my $self = shift; my $host = shift; croak "Must call ->check_rhsbl() with a host to check" unless length $host; if (my $val = $self->_do_check($host)) { if (wantarray) { return ($val, $self->_do_txt($host)); } else { return $val; } } return; } sub _do_txt { my $self = shift; my $host = shift; my $res = $self->{res}; my $q = $res->query($host . '.' . $self->{suffix}, "TXT"); my @txt = (); if ($q) { for my $rr ($q->answer) { next unless $rr->class eq 'IN' and $rr->type eq 'TXT'; push @txt, $rr->rdatastr; } } return @txt; } sub _do_check { my $self = shift; my $host = shift; my $res = $self->{res}; my $q = $res->query($host . '.' . $self->{suffix}, "A"); if ($q) { for my $rr ($q->answer) { next unless $rr->class eq 'IN' and $rr->type eq 'A'; return NetAddr::IP->new($rr->address); } } return; } sub _inverted_addresses { my $host = shift; my @addresses; my @ret; if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) { push @ret, join('.', reverse split(/\./, $host)); } else { @addresses = (gethostbyname($host))[4]; } foreach my $addr (@addresses) { push @ret, join('.', reverse unpack('C4', $addr)); } return @ret; } 1; __END__ =pod =head1 HISTORY $Log: RBL.pm,v $ Revision 1.10 2007/04/25 04:22:04 lem Finished adding support for the custom resolver code - Implementation was incomplete Revision 1.9 2006/12/08 00:01:14 lem Get version straight from the CVS revision. Revision 1.8 2006/12/07 23:58:07 lem Allow the user to provide a Net::DNS::Resolver object to perform DNS resolution - This allows finer control over how the queries are performed. Suggested by Eric Langheinrich. =over =item 1.00 Original version. =item 1.01 Minor bug fixes. Cleaned up MS-DOS line endings. Changed test cases (more and better tests). Now requires Test::More. More useful return values. Improved docs. First crypto-signed distribution of this module. =back =head1 AUTHOR Luis E. Munoz =head1 SEE ALSO Net::DNS::Resolver(3), perl(1). =cut Mail-RBL-1.10/README0000644000076500000240000000644510347370555013534 0ustar lemstaff00000000000000-----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 Mail::RBL - Perform queries to blacklists - - ----------------------------------------- This module is meant to help querying blackhole lists, typically for use in anti-spam solutions. This code could be used as follows: use Mail::RBL; my $rbl = new Mail::RBL 'list.dsbl.org'; print "yeah!\n" unless $rbl->check('10.10.10.10'); This module is entirely written in Perl, so you do not need access to a compiler to use it. It has been extensively tested in a variety of platforms. An extensive test suite is provided with the module to verify correct results. The lastest version of this module should be preferred. You can obtain it on http://www.cpan.org/authors/id/L/LU/LUISMUNOZ/ or one of the many CPAN mirrors. Please find a mirror near you to help spread the load. This module depends on you having the following co-requisite modules (which you can obtain from CPAN): - - - Test::More - - - NetAddr::IP To install, follow the standard CPAN recipe of: $ perl Makefile.PL $ make $ make test If all tests pass, then do $ make install To access the module's documentation, please see $ perldoc Mail::RBL Bug reports are welcome. Please do not forget to tell me what version/platform are you running this code on. Providing a small piece of code that shows the bug helps me a lot in sorting it out and possibly in writting more tests for the distribution. Also, this code is intended to be strict and -w safe, so please report cases where warnings are generated so that I can fix them. Report your bugs to me (luismunoz@cpan.org). DO YOU WANT TO SAY THANKS? I've been asked this question enough times so as to setup a page where you can express your gratitude, at either of those URLs http://mipagina.cantv.net/lem/thanks-en.html (English) http://mipagina.cantv.net/lem/thanks-es.html (Spanish) This is in no way a requirement for using my code, getting support or requesting features. SECURITY CONSIDERATIONS I have no control on the machanisms involved in the storage or transport of this distribution. This means that I cannot guarantee that the distribution you have in your hands is indeed, the same distribution I packed and uploaded. Along the distribution file, you should have a file with the extension ".asc". This contains a GPG "detached signature" that makes it impossible for anybody to alter this distribution. If security is of any concern to you, by all means verify the signature of this file and contact the author if any discrepancy is detected. You can find more information about this at the following URL http://mipagina.cantv.net/lem/gpg/ This information includes the correct keys, fingerprints, etc.Note that this README file should also be signed. LICENSE AND WARRANTY This software is (c) Luis E. Muñoz. It can be used under the terms of the perl artistic license provided that proper credit for the work of the author is preserved in the form of this copyright notice and license for this module. No warranty of any kind is expressed or implied. This code might make your computer go up in a puff of black smoke. -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.2.1 (Darwin) iD8DBQFDnfA/QyDWGRI/hhARAk7zAKChr+Nc8sDu93nuHtC3xJJbep+KAwCeKljW lxZwaf03rntkPWrHZCi/byM= =0UWN -----END PGP SIGNATURE----- Mail-RBL-1.10/t/0000755000076500000240000000000010615722763013106 5ustar lemstaff00000000000000Mail-RBL-1.10/t/00-load.t0000644000076500000240000000006007627566120014425 0ustar lemstaff00000000000000use Test::More tests => 1; use_ok('Mail::RBL');Mail-RBL-1.10/t/10-rbl.t0000644000076500000240000000721510613553726014274 0ustar lemstaff00000000000000#!/usr/bin/perl use Test::More; use Net::DNS::Resolver; @prefixes = qw( bl.spamcop.net dnsbl.sorbs.net list.dsbl.org multihop.dsbl.org unconfirmed.dsbl.org ); @rhsbls = qw( postmaster.rfc-ignorant.org dsn.rfc-ignorant.org abuse.rfc-ignorant.org bogusmx.rfc-ignorant.org ); SKIP: { if ($ENV{SKIP_RBL_TESTS}) { plan tests => 2; diag (''); diag (''); diag('You have set $SKIP_RBL_TESTS to true, thus skipping'); diag('testing that involves DNS queries.'); diag (''); use_ok('Mail::RBL'); skip 'User requested skipping of query tests', 1; diag (''); } plan tests => @prefixes*4 + (grep {/spamcop/} @prefixes)*10 + @rhsbls*16 + 1; diag(''); diag(''); diag('The following tests perform queries to some known RBLs.'); diag('Failures do not necesarily mean that the code is broken'); diag('If failures are seen, please insure that the relevant RBL'); diag('Can be queried from this machine.'); diag(''); diag('You can skip this test by setting the environment variable'); diag('$SKIP_RBL_TESTS to true'); diag(''); use_ok('Mail::RBL'); for (@prefixes) { my $rbl_i = new Mail::RBL $_; my $rbl_e = new Mail::RBL $_, Net::DNS::Resolver->new; isa_ok($rbl_i, 'Mail::RBL'); isa_ok($rbl_e, 'Mail::RBL'); ok(!$rbl_i->check('127.0.0.1'), "Check localhost (unblocked) against $_"); ok($rbl_i->check('127.0.0.2'), "Check 127.0.0.2 (blocked) against $_"); } for (grep { $_ =~ /spamcop/ } @prefixes) { my $rbl_i = new Mail::RBL $_; my $rbl_e = new Mail::RBL $_, Net::DNS::Resolver->new; isa_ok($rbl_i, 'Mail::RBL'); isa_ok($rbl_e, 'Mail::RBL'); my @r_i = $rbl_i->check('127.0.0.1'); my @r_e = $rbl_e->check('127.0.0.1'); ok(!@r_i, "Localhost in array context against $_ (int res)"); ok(!@r_e, "Localhost in array context against $_ (ext res)"); @r_i = $rbl_i->check('127.0.0.2'); @r_e = $rbl_i->check('127.0.0.2'); ok(@r_i == 2, "127.0.0.2 in array context against $_ (int res)"); ok(@r_e == 2, "127.0.0.2 in array context against $_ (ext res)"); ok($r_i[0], "True block result (int res)"); ok($r_e[0], "True block result (ext res)"); ok($r_i[1], "Non-empty message returned (int res)"); ok($r_e[1], "Non-empty message returned (ext res)"); } for (@rhsbls) { my $rbl_i = new Mail::RBL $_; my $rbl_e = new Mail::RBL $_, Net::DNS::Resolver->new; isa_ok($rbl_i, 'Mail::RBL'); isa_ok($rbl_e, 'Mail::RBL'); ok(!$rbl_i->check_rhsbl('127.0.0.1'), "Check localhost rhsbl $_ (int res)"); ok(!$rbl_e->check_rhsbl('127.0.0.1'), "Check localhost rhsbl $_ (ext res)"); ok($rbl_i->check_rhsbl('example.tld'), "Check example.tld rhsbl $_ (int res)"); ok($rbl_e->check_rhsbl('example.tld'), "Check example.tld rhsbl $_ (ext res)"); my @r_i = $rbl_i->check_rhsbl('127.0.0.1'); ok(!@r_i, "Localhost in array context is false: $_ (int res)"); my @r_e = $rbl_e->check_rhsbl('127.0.0.1'); ok(!@r_e, "Localhost in array context is false: $_ (ext res)"); @r_i = $rbl_i->check_rhsbl('example.tld'); @r_e = $rbl_i->check_rhsbl('example.tld'); ok(@r_i, "Listed domain in array context is true: $_ (int res)"); ok(@r_e, "Listed domain in array context is true: $_ (ext res)"); ok(@r_i == 2, "Listed domain in array context count: $_ (int res)"); ok(@r_e == 2, "Listed domain in array context count: $_ (ext res)"); ok($r_i[0], "Domain in array context has value: $_ (int res)"); ok($r_i[1], "Domain in array context non-empty message: $_ (int res)"); ok($r_e[0], "Domain in array context has true value: $_ (ext res)"); ok($r_e[1], "Domain in array context non-empty message: $_ (ext res)"); } }