xt/20_saw_ampersand.t

#!/usr/bin/perl -T

# detect use of dollar-ampersand somewhere in the perl interpreter;
# once it is used once, it slows down every regexp match thereafter.

BEGIN {
  if (-d 'xt') { chdir 'xt'; }

  if (-e 'test_dir') {            # running from test directory, not ..
    unshift(@INC, '../blib/lib');
    unshift(@INC, '../lib');
  }
}

use lib '../t';
use SATest; 
sa_t_init("saw_ampersand");

use Test;

use Carp qw(croak);

# Starting with perl 5.17.7, this entire test becomes irrelevant:
# perldelta 5.17.7:
#
#  Core Enhancements
#  $&, $` and $' are no longer slow       '
#
#  These three infamous variables have been redeemed and no longer slow
#  down your program when used. Hence, the /p regular expression flag
#  now does nothing.

our $RUN_THIS_TEST;

BEGIN {
  $RUN_THIS_TEST = 1;
  if ($] >= 5.017007) {
    $RUN_THIS_TEST = 0;
  }
  use constant HAS_DSA => eval 'use Devel::SawAmpersand; 1;';
  plan tests => 0 if ! ( $RUN_THIS_TEST and HAS_DSA) ;

  if (!$RUN_THIS_TEST) {
    print "NOTE: This test is unnecessary as of perl 5.17.7.\n";
    exit;
  } 
  if ( !HAS_DSA ) {
    print "NOTE: This test requires Devel::SawAmpersand\n"; 
    exit;
  } 
}


plan tests => 37;

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

use strict;
require Mail::SpamAssassin;
use Devel::SawAmpersand;

# it is important to order these from least-plugin-code-run to most.

print "\ntrying local-tests-only with default plugins\n";
tryone (1, "");

print "\ntrying net with only local rule plugins\n";


# kill all 'loadplugin' lines
foreach my $file 
        (<log/localrules.tmp/*.pre>, <log/test_rules_copy/*.pre>) #*/
{
  $file = untaint_var($file);
  rename $file, "$file.bak" or die "rename $file failed";
  open IN, "<$file.bak" or die "cannot read $file.bak: $!";
  open OUT, ">$file" or die "cannot write $file: $!";
  while (<IN>) {
    s/^loadplugin/###loadplugin/g;
    print OUT;
  }
  close IN  or die "error closing $file.bak: $!";
  close OUT or die "error closing $file: $!";
}


my $plugins = q{
  loadplugin Mail::SpamAssassin::Plugin::Check
  loadplugin Mail::SpamAssassin::Plugin::HTTPSMismatch
  loadplugin Mail::SpamAssassin::Plugin::URIDetail
  loadplugin Mail::SpamAssassin::Plugin::Bayes
  loadplugin Mail::SpamAssassin::Plugin::BodyEval
  loadplugin Mail::SpamAssassin::Plugin::DNSEval
  loadplugin Mail::SpamAssassin::Plugin::HTMLEval
  loadplugin Mail::SpamAssassin::Plugin::HeaderEval
  loadplugin Mail::SpamAssassin::Plugin::MIMEEval
  loadplugin Mail::SpamAssassin::Plugin::RelayEval
  loadplugin Mail::SpamAssassin::Plugin::URIEval
  loadplugin Mail::SpamAssassin::Plugin::WLBLEval
  loadplugin Mail::SpamAssassin::Plugin::VBounce
  loadplugin Mail::SpamAssassin::Plugin::ReplaceTags
};
write_plugin_pre($plugins);
tryone (0, "");

print "\ntrying net with more local rule plugins\n";

$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::SpamCop
  loadplugin Mail::SpamAssassin::Plugin::AntiVirus
  loadplugin Mail::SpamAssassin::Plugin::TextCat
  loadplugin Mail::SpamAssassin::Plugin::AccessDB
  loadplugin Mail::SpamAssassin::Plugin::WhiteListSubject
  loadplugin Mail::SpamAssassin::Plugin::MIMEHeader
  loadplugin Mail::SpamAssassin::Plugin::ReplaceTags
  loadplugin Mail::SpamAssassin::Plugin::Shortcircuit
  loadplugin Mail::SpamAssassin::Plugin::Rule2XSBody
};
write_plugin_pre($plugins);
tryone (0, "");

print "\ntrying net with DCC rule plugins\n";
$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::DCC
};
write_plugin_pre($plugins);
tryone (0, "");

print "\ntrying net with Razor2 rule plugins\n";
$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::Razor2
};
write_plugin_pre($plugins);
tryone (0, "
score RAZOR2_CHECK 0
score RAZOR2_CF_RANGE_51_100 0
score RAZOR2_CF_RANGE_E4_51_100 0
score RAZOR2_CF_RANGE_E8_51_100 0
");

print "\ntrying net with Razor2 rule plugins\n";
$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::Razor2
};
write_plugin_pre($plugins);
tryone (0, "
score RAZOR2_CHECK 1
score RAZOR2_CF_RANGE_51_100 1
score RAZOR2_CF_RANGE_E4_51_100 1
score RAZOR2_CF_RANGE_E8_51_100 1
");

print "\ntrying net with DKIM rule plugins\n";
$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::DKIM
};
write_plugin_pre($plugins);
tryone (0, "");

print "\ntrying net with Pyzor rule plugins\n";
$plugins .= q{
  loadplugin Mail::SpamAssassin::Plugin::Pyzor
};
write_plugin_pre($plugins);
tryone (0, "");

print "\ntrying net with all default non-local rule plugins\n";

# TODO: unportable
untaint_system "perl -pi.bak -e 's/^###loadplugin/loadplugin/g' ".
                " log/localrules.tmp/*.pre log/test_rules_copy/*.pre";

($? >> 8 != 0) and die "perl failed";

tryone (0, "");
ok 1;

exit;

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

sub write_plugin_pre {
  my $cftext = shift;
  open OUT, ">log/localrules.tmp/test.pre"
    or die "cannot create log/localrules.tmp/test.pre: $!";
  print OUT $cftext
    or die "error writing to log/localrules.tmp/test.pre: $!";
  close OUT
    or die "cannot close log/localrules.tmp/test.pre: $!";
}

sub tryone {
  my ($ltests, $cftext) = @_;

  print "  SawAmpersand test using local_tests_only=>$ltests,\n".
        "  post_config_text=>'$cftext'\n\n";

  # note: do not use debug, that uses dollar-ampersand in rule debug output
  # (hit_rule_plugin_code() in lib/Mail/SpamAssassin/Plugin/Check.pm)
  my $sa = create_saobj({
    'dont_copy_prefs' => 1,
    # 'debug' => 1,
    'local_tests_only' => $ltests,
    'post_config_text' => $cftext,
  });

  $sa->init(1);
  ok($sa);

  open (IN, "<data/spam/009") or die "cannot open data/spam/009: $!";
  my $mail = $sa->parse(\*IN,0);
  close IN or die "error closing data/spam/009: $!";

  my $status = $sa->check($mail);
  my $rewritten = $status->rewrite_mail();
  my $msg = $status->{msg};

  ok $rewritten =~ /message\/rfc822; x-spam-type=original/;
  ok $rewritten =~ /X-Spam-Flag: YES/;

  print "saw ampersand?\n";
  ok (!Devel::SawAmpersand::sawampersand());

  # Devel::SawAmpersand::sawampersand() and croak("\$"."\& is in effect! dying");

  $mail->finish();
  $status->finish();
}