home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / FS / FSEvalTests.pm < prev    next >
Text File  |  2006-11-29  |  3KB  |  127 lines
  1. # FS::FSEvalTests.pm -- era Tue May 17 11:02:17 2005
  2. # $Id: FSEvalTests.pm 3248 2006-05-03 06:23:54Z eriker $
  3. # Copyright (C) 2005 F-Secure Corporation
  4.  
  5.  
  6. package FS::FSEvalTests;
  7.  
  8. =head1 NAME
  9.  
  10. FS::FSEvalTests - Additional EvalTests for use in F-Secure SpamAssassin
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.   loadplugin   FS::FSEvalTests
  15.  
  16.   header   RDNS_DYNAMIC_HEX_IP eval:rdns_dynamic_hex_ip()
  17.   describe RDNS_DYNAMIC_HEX_IP Injection point's RDNS has IP address in hex
  18.   score    RDNS_DYNAMIC_HEX_IP 3
  19.  
  20. =head1 DESCRIPTION
  21.  
  22. The B<FS::FSEvalTests> SpamAssassin plugin
  23. defines the following eval tests
  24. for use from within SpamAssassin rules.
  25.  
  26. =cut
  27.  
  28.  
  29. # Cruft cased and pasted from Mail::SpamAssassin::Plugin manual page
  30.  
  31. # package declared above
  32.  
  33. use Mail::SpamAssassin::Plugin;
  34. our @ISA = qw(Mail::SpamAssassin::Plugin);
  35.  
  36. *dbg = *Mail::SpamAssassin::Plugin::dbg;
  37. # Register our own codepath 'fseval' for this plugin
  38. $Mail::SpamAssassin::DEBUG->{fseval} = 0
  39.   unless exists $Mail::SpamAssassin::DEBUG->{fseval};
  40.  
  41. sub new {
  42.   my ($class, $mailsa) = @_;
  43.  
  44.   # the usual perlobj boilerplate to create a subclass object
  45.   $class = ref($class) || $class;
  46.   my $self = $class->SUPER::new($mailsa);
  47.   bless ($self, $class);
  48.  
  49.   # then register an eval rule, if desired...
  50.   $self->register_eval_rule ("rdns_dynamic_hex_ip");
  51.  
  52.   # and return the new plugin object
  53.   return $self;
  54. }
  55.  
  56.  
  57. =over 4
  58.  
  59. =item B<rdns_dynamic_hex_ip>
  60.  
  61. If the F<rdns=> field of the last entry
  62. in the F<X-Spam-Relays-Untrusted> pseudo-header
  63. (i.e. the probable injection point)
  64. contains a hex representation of
  65. the value in the F<ip=> field,
  66. this eval rule matches.
  67.  
  68. =cut
  69.  
  70.  
  71. sub rdns_dynamic_hex_ip {
  72.   my ($self, $permsgstatus) = @_;
  73.  
  74.   # For debugging
  75.   my $rule = $permsgstatus->get_current_eval_rule_name;
  76.  
  77.   my $untrusted = $permsgstatus->get("X-Spam-Relays-Untrusted");
  78.  
  79.   if ($untrusted =~ m/\[ ip=(\d+)\.(\d+)\.(\d+)\.(\d+) rdns=([^][ ]+) .*\]$/)
  80.   {
  81.     my ($rdns, @ip) = ($5, $1, $2, $3, $4);
  82.  
  83.     # Make a regex which contains the IP's octets in hex,
  84.     # optionally with a random non-number character in between,
  85.     # and/or leading zeros
  86.     my $hexregex = join ('',
  87.     (map { sprintf ("[^0-9]?0?%x", $_) } @ip),
  88.     '[^0-9]'
  89.     );
  90.     # Make the regex case-insensitive to avoid an expensive (?) m/.../i below
  91.     $hexregex =~ s/([a-f])/sprintf ("[%s%s]", uc($1), $1) /eg;
  92.  
  93.     dbg(join ("", "$rule: ip=", join (".", @ip),
  94.     ", rdns=$rdns, hexregex=$hexregex"),
  95.     'fseval', -1);
  96.     return 1 if ($rdns =~ $hexregex);
  97.   }
  98.   else
  99.   {
  100.     dbg("$rule: no untrusted relay found, or no rdns for remotest entry " .
  101.     "(X-Spam-Relays-Untrusted is '$untrusted')",
  102.     'fseval', -1);
  103.   }
  104.   return 0;
  105. }
  106.  
  107.  
  108.  
  109. =back
  110.  
  111. More eval tests will likely be added to this module in the future.
  112.  
  113. =cut
  114.  
  115. 1;
  116.  
  117.  
  118. #=head1 BUGS
  119. #
  120. #
  121.  
  122. =head1 COPYRIGHT
  123.  
  124. Copyright (C) 2005-2006 F-Secure Corporation
  125.  
  126. =cut
  127.