view release on metacpan or  search on metacpan

t/dnsbl_subtests.t  view on Meta::CPAN

#!/usr/bin/perl -w -T

# supporting tests for: Bug 6362 - Change urirhssub mask syntax

use strict;
use warnings;
use re 'taint';
use lib '.'; use lib 't';

use SATest; sa_t_init("dnsbl_subtests");

use vars qw(%patterns %anti_patterns);
use Test::More;

use Errno qw(EADDRINUSE EACCES);

plan skip_all => "Net tests disabled" unless conf_bool('run_net_tests');

use constant HAS_NET_DNS_NAMESERVER => eval { require Net::DNS::Nameserver; };
use constant HAS_NET_DNS_START_SERVER => eval { Net::DNS::Nameserver->can('start_server'); };
use constant HAS_NET_DNS_STOP_SERVER => eval { Net::DNS::Nameserver->can('stop_server'); };
use constant HAS_BAD_WINDOWS_NET_DNS => $RUNNING_ON_WINDOWS && HAS_NET_DNS_START_SERVER;
plan skip_all => "Net::DNS::Nameserver in unavailable on this system" unless (HAS_NET_DNS_NAMESERVER);
plan skip_all => "Tests don't work on Windows with recent versions of Net::DNS" if (HAS_BAD_WINDOWS_NET_DNS);
plan  tests => 46;

use Mail::SpamAssassin;

# Bug 5761 (no 127.0.0.1 in jail, use SPAMD_LOCALHOST if specified)
my $dns_server_localaddr = $ENV{'SPAMD_LOCALHOST'};
if (!$dns_server_localaddr) {
  $dns_server_localaddr = $have_inet4 ? '127.0.0.1' : '::1';
}

my $use_inet4 =
  !$have_inet6 ||
  ($have_inet4 && $dns_server_localaddr =~ /^\d+\.\d+\.\d+\.\d+\z/);

sub find_free_port($);  # prototype
my($dns_server_localport, $sock_udp, $sock_tcp) =
  find_free_port($dns_server_localaddr);

$dns_server_localport  or die "Failed to obtain a free port number";

printf("Using %s [%s]:%s for a spawned test DNS server\n",
       $use_inet4 ? 'inet' : 'inet6',
       $dns_server_localaddr, $dns_server_localport);

# test zone names (lowercase!)
my $z  = 'sa1-dbl-test.spamassassin.org';
my $z2 = 'sa2-dbl-test.spamassassin.org';

my $local_conf = <<"EOD";
  use_bayes 0
  use_razor2 0
  use_pyzor 0
# use_auto_whitelist 0
# use_dcc 0
  score NO_RELAYS 0
  score NO_RECEIVED 0
  score TVD_SPACE_RATIO 0

  rbl_timeout 5
  dns_available yes
  clear_dns_servers
  dns_server [$dns_server_localaddr]:$dns_server_localport

# zone 1
  urirhssub  X_URIBL_Y_2A   $z  A  127.0.1.2
  body       X_URIBL_Y_2A   eval:check_uridnsbl('X_URIBL_Y_2A')
  tflags     X_URIBL_Y_2A   domains_only

  urirhssub  X_URIBL_Y_2B   $z  A  127.0.1.2-127.0.1.2
  body       X_URIBL_Y_2B   eval:check_uridnsbl('X_URIBL_Y_2B')
  tflags     X_URIBL_Y_2B   domains_only

  urirhssub  X_URIBL_Y_2C   $z  A  127.0.1.2/0xffffffff
  body       X_URIBL_Y_2C   eval:check_uridnsbl('X_URIBL_Y_2C')
  tflags     X_URIBL_Y_2C   domains_only

  urirhssub  X_URIBL_Y_2D   $z  A  127.0.1.2/255.255.255.255
  body       X_URIBL_Y_2D   eval:check_uridnsbl('X_URIBL_Y_2D')
  tflags     X_URIBL_Y_2D   domains_only

  urirhssub  X_URIBL_Y_2E   $z  A  127.0.1.2/127.0.1.2
  body       X_URIBL_Y_2E   eval:check_uridnsbl('X_URIBL_Y_2E')
  tflags     X_URIBL_Y_2E   domains_only

  urirhssub  X_URIBL_Y_2F   $z  A  0/128.255.254.253
  body       X_URIBL_Y_2F   eval:check_uridnsbl('X_URIBL_Y_2F')
  tflags     X_URIBL_Y_2F   domains_only

  urirhssub  X_URIBL_Y_2G   $z  A  2
  body       X_URIBL_Y_2G   eval:check_uridnsbl('X_URIBL_Y_2G')
  tflags     X_URIBL_Y_2G   domains_only

  urirhssub  X_URIBL_N_2G   $z  A  5
  body       X_URIBL_N_2G   eval:check_uridnsbl('X_URIBL_N_2G')
  tflags     X_URIBL_N_2G   domains_only

  urirhssub  X_URIBL_Y_ANY  $z  A  127.0.1.1-127.0.1.254
  body       X_URIBL_Y_ANY  eval:check_uridnsbl('X_URIBL_Y_ANY')
  tflags     X_URIBL_Y_ANY  domains_only

  urirhssub  X_URIBL_Y_3    $z  A  127.0.1.3-127.0.1.19
  body       X_URIBL_Y_3    eval:check_uridnsbl('X_URIBL_Y_3')

t/dnsbl_subtests.t  view on Meta::CPAN

    }
  }
  # special DBL test case - numerical IP query handling
    # Bug 6983: Uninitialized value in lc in t/dnsbl_subtests for X_URIBL_Y_255A
    # Unicode case folding bug present in at least perl-5.8.[678], fixed 5.8.9
    # avoid case-insensitive regexp match, $z and $z2 are already in lowercase
  if ($qclass_uc eq 'IN' && lc $qname =~ /^[0-9.]+\.(?:\Q$z\E|\Q$z2\E)\z/s) {
    $rcode = 'NOERROR';
    if ($qtype_uc eq 'A' || $qtype_uc eq 'ANY') {
      push(@ans, Net::DNS::RR->new(join(' ',
                 $qname, '3600', $qclass, 'A', '127.0.1.255')));
    }
    if ($qtype_uc eq 'TXT' || $qtype_uc eq 'ANY') {
      push(@ans, Net::DNS::RR->new(join(' ',
                 $qname, '3600', $qclass, 'TXT', '"No IP queries allowed"')));
    }
  }
  return ($rcode, \@ans, \@auth, \@add);
}

my ($ns, @pid);

sub dns_server($$) {
  my($local_addr, $local_port) = @_;
  $ns = Net::DNS::Nameserver->new(
    LocalAddr => $local_addr, LocalPort => $local_port,
    ReplyHandler => \&reply_handler, Verbose => 0);
  $ns  or die "Cannot create a nameserver object";
  if (HAS_NET_DNS_STOP_SERVER) {
    $ns->start_server();
  } elsif (HAS_NET_DNS_START_SERVER) {
    @pid = $ns->start_server();
  } else {
    my $pid = fork();
    defined $pid or die "Cannot fork: $!";
    if (!$pid) {  # child
      $ns->main_loop();
      exit;
    }
    # parent
    push @pid, $pid;
    # print STDERR "Forked a DNS server process [$pid]\n";
  }
  sleep 1;
}

sub find_free_port($) {
  my($addr) = @_;
  my($port, $sock_udp, $sock_tcp);
  for (1..20) {  # choose a pair of free tcp & udp ports
    $port = 11001 + int(rand(65536-11001));
    my %args = (LocalAddr => $addr, LocalPort => $port);
    $sock_udp = $use_inet4 ? IO::Socket::INET->new(%args, Proto => 'udp')
                           : IO::Socket::INET6->new(%args, Proto => 'udp');
    $sock_udp || $! == EADDRINUSE || $! == EACCES
      or printf("Error creating UDP socket [%s]:%s: %s\n", $addr, $port, $!);
    $sock_tcp = $use_inet4 ? IO::Socket::INET->new(%args, Proto => 'tcp')
                           : IO::Socket::INET6->new(%args, Proto => 'tcp');
    $sock_tcp || $! == EADDRINUSE || $! == EACCES
      or printf("Error creating %s TCP socket [%s]:%s: %s\n",
                $use_inet4 ? 'inet' : 'inet6', $addr, $port, $!);
    last if $sock_tcp && $sock_udp;
  }
  undef $port if !$sock_tcp || !$sock_udp;
  return ($port, $sock_udp, $sock_tcp);
}

# ---------------------------------------------------------------------------

my $spamassassin_obj;

sub process_sample_urls(@) {
  my(@url_list) = @_;
  my($mail_obj, $per_msg_status, $spam_report);
  $spamassassin_obj->timer_reset;

  my $msg = <<'EOD';
From: "DNSBL Testing" <ab@example.org>
To: someone@example.org
Subject: test
Date: Mon, 8 Mar 2010 15:10:44 +0100
Message-Id: <test.123.test@example.org>

EOD
  $msg .= $_."\n" for @url_list;

  $mail_obj = $spamassassin_obj->parse($msg,0);
  if ($mail_obj) {
    local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.x bug, $1 can get tainted
    $per_msg_status = $spamassassin_obj->check($mail_obj);
  }
  if ($per_msg_status) {
    $spam_report = $per_msg_status->get_tag('REPORT');
    $per_msg_status->finish;
  }
  if ($mail_obj) {
    $mail_obj->finish;
  }
  $spam_report =~ s/\A(\s*\n)+//s;
# print "\t$spam_report\n";
  return $spam_report;
}

sub test_samples($$) {
  my($patt_antipatt_list,$url_list_ref) = @_;
  my $el = $patt_antipatt_list->[0];
  shift @$patt_antipatt_list  if @$patt_antipatt_list > 1;  # last autorepeats
  my($patt,$anti) = split(m{\s* / \s*}x, $el, 2);
  %patterns      = map { (" $_ ", $_) } split(' ',$patt);
  %anti_patterns = map { (" $_ ", $_) } split(' ',$anti);
  my $spam_report = process_sample_urls(@$url_list_ref);
  clear_pattern_counters();
  patterns_run_cb($spam_report);
  my $status = ok_all_patterns();
  printf("\nTest on %s failed:\n%s\n",
         join(', ',@$url_list_ref), $spam_report)  if !$status;
}


# there is a time gap between closing sockets and reusing them by a spawned
# DNS server - if we are very unlucky and the port is acquired by some other