#!/usr/bin/perl
#
# Copyright (C) 2002, 2003, 2004, 2005, 2006 F-Secure Corporation
#
# svn ID below (look for $SVNid)

use strict;
use warnings;

use vars qw($VERSION $Id $spam_scanner_id $fsas_version);

### Files to be shot on sight :-)

# removed on startup end shutdown
my @temporary_files = qw(
    rules/bayes_journal
    rules/auto-whitelist
);

# removed on startup
my @obsolete_files = qw(
    lib/Storable.pm
);

# removed on startup, if empty
my @obsolete_directories = qw(
    lib/auto/Storable
);

# created on startup
my @needed_directories = qw(
    log
    var
);

my $spam_scanner_debug;

# dir name relative to the scanner top directory
my $spam_scanner_msglog_base_dir = "msglog";
my $spam_scanner_msglog_dir;
my $spam_scanner_msglog_limit;
my $spam_scanner_msglog_count = 0;

# stream to use to output SA score report for each message,
# or undef for no report
my $SPAM_SCANNER_REPORT;

sub ignore
{
    return;
}

sub gripe
{
    my ($level, $msg) = @_;
    my $id = '.';
    return if ($level == 2);		######## comment out to get level 2
    $id = '-' if ($level == 1);
    $id = '=' if ($level == 0);
    warn "debug: ", scalar (localtime ()), " ", $id x 8,
	" [$spam_scanner_id] $msg\n";
}

sub groan {
    my ($level, $msg) = @_;
    my $id = '.';
    #return if ($level == 2);		######## comment out to get level 2
    $id = '-' if ($level == 1);
    $id = '=' if ($level == 0);
    dbg("spamscanner: " . $id x 8 . " $msg");
}

sub reset_automatic_settings {
    my ($value) = @_;
    debug (1, ">>reset_automatic_settings($value)");
    # do any necessary cleanup in the /var directory here
    debug (1, "<<reset_automatic_settings()");
}

my @engine_settings = qw(
    userid maxsize instances checkifmail reports conflevel bwfile
    sender recipients
);

my %trigger = (
    reset => \&reset_automatic_settings
);

my %custom_settings = ();
my $custom_settings = "";
sub spam_submit_custom_settings {
    my ($settings) = @_;

    # TODO: add functionality here
    debug (1, "spam_submit_custom_settings($settings)");

    # Parse key=value pairs delimited with spaces, tabs, slashes (/) or
    # semicolons (;)
    # (the string is usually formatted "/key1=value1 /key2=value2")
    # Value should be surrounded with double quotes ("), if it contains
    # one of the delimiters.
    my $delim = '\s\t/;';
    # Bletch, workaround to make Emacs colorization happy
    while ($settings =~ /\G[$delim]*([^=]+)=(?:"([^"]*)"|([^$delim]*))(?:$|[$delim])/gc) {
	my ($key, $value) = ($1, $2);
	$value = $3 unless defined $value;
	$value = "" unless defined $value;

	debug(1, "spam_submit_custom_settings: [$key]=[$value]");
	if (my $func = $trigger{$key}) {
	    debug(1, "calling trigger $func($value) for $key");
	    next;    
	}

	$custom_settings{$key} = $value;
    }

    if ($settings =~ m,\G(.+)$,g) {
	debug(1, "spam_submit_custom_settings: unmatched stuff='$1'");
    }

    $custom_settings = "";
    while (my ($key, $value) = each %custom_settings) {
	# skip settings intended for FSAS.DLL
	next if grep {$_ eq $key} @engine_settings;

	$custom_settings .= "$key $value\n"
    }

    debug(1, "spam_submit_custom_settings: \$custom_settings = '$custom_settings'");

    return 1;
}

sub spam_scanner_id_gen
{
    my $id = rand();
    $id =~ s/^0\.//;
    return $id;
}

sub module_logger {
    my ($self, $module) = @_;
    debug(1, "trying to load module '$module'");
    return undef;
}

sub failure_logger {
    my ($self, $module) = @_;

    my @callers = ();
    my $depth = 1;
    while (1) {
	my ($package, $filename, $line, $subroutine) = caller($depth++);
	last unless defined $subroutine;
	push @callers, $subroutine;
    }

    #my $callers = join("/", @callers);
    my $callers = join("\n|   ", @callers);

    #
    # TODO: filter out known offenders based on $callers stack
    #
    my @ignore = qw(
	Storable.pm
	Mail/SpamAssassin/NoMailAudit.pm
	Mail/SpamAssassin/TextCat.pm

	Net/DNS/RR/SIG.pm
	Net/DNS/SEC.pm
	Socket6.pm
	IO/Socket/INET6.pm
	Sys/Hostname/Long.pm

	auto/Mail/SpamAssassin/HTML/DESTROY.al
    );

    if (grep { $module eq $_ } @ignore) {
	debug(1, "IGNORING LOAD FAILURE OF '$module'");
	return;
    }

    if ($module =~ /autosplit\.ix$/) {
	debug(1, "IGNORING autosplit.ix probe: '$module'");
	return;
    }

    debug(1, "FAILED TO LOAD MODULE '$module' in\n|   $callers");
    return undef;
}

sub dirsep
{
    return '\\' if ($^O =~ /win32/i);
    return '/';
}

# get diagnostic setting from an environment variable or a file
sub get_diag_setting {
	my ($setting) = @_;

	return $ENV{$setting} if defined $ENV{$setting};

	# TODO: using slash (/), not dirsep
	my $cfg_dir = $ENV{FS_SA_CFG_DIR} || "c:/";

	my $filename = sprintf "%s.cfg", join(dirsep(), $cfg_dir, lc($setting));

	open(my $fh, '<', $filename) or return undef;

	return scalar(<$fh>);
}

BEGIN
{
    ######## TODO: upgrade when we release a new version
    $VERSION = '3.131';
    my $SVNid = qw($Id: spamscanner.pl 4149 2006-11-15 10:24:56Z eriker $)[2];
    $Id = "svn$SVNid";

    $spam_scanner_debug = "";
    $spam_scanner_id = spam_scanner_id_gen();

    # fix around wrong DLL call convention
    @INC = map { split (";", $_) } @INC;

    # add path/to/db to parallel any path/to/lib, all in front of old @INC
    # (so, uh, if map returns nothing, discard that, with grep)
    unshift @INC, grep { $_ } map { m%(^|.*[/\\])lib% and "${1}dlib" } @INC;

    if (my $log = get_diag_setting("FS_SA_DEBUG")) {
	$spam_scanner_debug = "all";
	$spam_scanner_debug = $1 if $log =~ s/^(-?\w+(?:,-?\w+)*);//;

	# Heuristic for what "looks like" an IP:port designator
	if ($log =~ m/^(\d+\.\d+\.\d+\.\d+):(\d+)$/)
	{
	    use Socket;

	    my ($ip, $port) = ($1, $2);
	    my ($iaddr, $paddr, $proto);
	    open (my $err, ">&STDERR");
	    unless ($iaddr = inet_aton ($ip) and
		$paddr = sockaddr_in ($port, $iaddr) and
		$proto = getprotobyname('tcp') and
		socket (STDERR, PF_INET, SOCK_STREAM, $proto) and
		connect (STDERR, $paddr))
	    {		
		close (STDERR);
		open (STDERR, ">&$err");
		warn "$0: You probably won't see this, but $!";
	    }
	    close ($err);
	}
	######## FIXME: vague heuristic for what "looks like" a file name
	# If the value contains any of `/', `\', or `.', try it as a file
	elsif ($log =~ qr'[\\/.]')
	{
	    open (STDERR, '>>', $log);
	}

	# Make STDERR and STDOUT unbuffered (the latter probably unnecessary)
	select (STDERR); $| = 1;
	select (STDOUT); $| = 1;

	eval {
	    require Mail::SpamAssassin::Logger;
	    import Mail::SpamAssassin::Logger;
	    Mail::SpamAssassin::Logger::add_facilities($spam_scanner_debug);
	};
	*debug = $@ ? *gripe : *groan;

	debug (0, "F-Secure SpamAssassin v$::VERSION/$Id starting up");

	#unshift @INC, \&module_logger;
	push @INC, \&failure_logger;
    }
    else
    {
	*debug = *ignore;
    }

    debug (2, ">> BEGIN (actually since some time already)");

    if (my $log = get_diag_setting("FS_SA_REPORT")) {
	######## FIXME: vague heuristic for what "looks like" a file name
	# If the value contains any of `/', `\', or `.', try it as a file
	unless ($log =~ qr'[\\/.]' && open ($SPAM_SCANNER_REPORT, '>>', $log))
	{
	    if (open ($SPAM_SCANNER_REPORT, ">&STDOUT")) {
		# make the stream unbuffered so that it interleaves better with
		# other STDOUT output.
		# It would be cleaner to say
		#    use IO::Handle;$SPAM_SCANNER_REPORT->autoflush(1);
		# but IO::Handle might bring some bloat...
		my $oldfh = select ($SPAM_SCANNER_REPORT);
		$| = 1;
		select($oldfh);
	    } else {
		undef $SPAM_SCANNER_REPORT;
	    }
	}
    }

    # Print a stack trace when we get an error
    $SIG{__DIE__} = sub {
	# react only to runtime errors
	return unless defined $^S && !$^S;

	warn "\nError:\n\t" . $_[0];
	require Carp if defined $^S;

	# skip our main::__ANON__ routine from the trace
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;

	Carp::confess("Stack trace:\n") if defined &Carp::confess;
	die "Something wrong, but could not load Carp to give backtrace...\n" .
	    "To see backtrace try starting Perl with -MCarp switch";
    };

    # Bogus declarations of legacy packages to make downgrade work (#35947)
    package bogus;
    use strict;
    use warnings;
    for my $lib (qw(Storable
		    Mail::SpamAssassin::NoMailAudit
		    Mail::SpamAssassin::Logger
		    Mail::SpamAssassin::TextCat))
    {
	eval "require $lib;";
	if ($@)
	{
	    my $path = $lib;
	    $path =~ s%::%/%g;
	    if ($@ !~ m%^Can't locate $path.pm in \@INC %)
	    {
		main::debug (1, "unexpected exception: $@");
	    }
	    main::debug (1, "declaring bogus $lib");
	    $::INC{"$path.pm"} = "bogus, my friend";
	}
    }

    package main;
    debug (2, "<< BEGIN");
}

sub spam_scanner_remove_hook
{
    my ($dir, $files, $directories) = @_;
    debug (2, ">>spam_scanner_remove_hook($dir)");

    # Hook to remove obsolete files
    for my $file (@$files) {
	my $path = join(dirsep(), $dir, $file);

	debug (2, "spam_scanner_remove_hook: considering '$path'");

	next unless -w $path;

	debug (1, "spam_scanner_remove_hook: unlinking $path");
	unlink $path or debug (1, "Could not unlink $path: $!");
    }

    # Hook to remove obsolete directories
    for my $file (@$directories) {
	my $path = join(dirsep(), $dir, $file);

	debug (2, "spam_scanner_remove_hook: considering directory '$path'");

	next unless -d $path;

	debug (1, "spam_scanner_remove_hook: removing directory '$path'");
	rmdir $path or debug (1, "Could not remove directory '$path': $!");
    }

    debug (2, "<<spam_scanner_remove_hook()");
}

my $spam_scanner_directory = undef;
END
{
    spam_scanner_remove_hook($spam_scanner_directory, \@temporary_files, [])
	if defined $spam_scanner_directory;
}


use Mail::SpamAssassin 2.6301; # really 2.64 (and now 3.1.3) -- see bug 34781

my @mapping = ();
my %cached = ();			# Cache per-user configurations
my $cached;

# Return this api version
sub spam_scan_api_version { return 100; }

sub mkdir_path {
    my ($base, $path) = @_;
    my @parts = split(/\//, $path);

    $path = $base;
    for my $part (@parts) {
    	$path = join(dirsep(), $path, $part);
	unless (mkdir $path) {
	    debug (1, "Could not create directory '$path': $!");
	    return 0;
	}
    }
    return 1;
}

sub create_directories {
    my ($base, @dirs) = @_;

    for my $file (@dirs) {
	my $path = join(dirsep(), $base, $file);
	debug (2, "considering creating directory '$path'");

	next if -d $path;

	debug (1, "creating directory '$path'");
	mkdir_path($base, $file) or
	    debug (1, "Could not create directory '$path': $!");
    }
}

sub init_logging {
    my ($dir) = @_;

    my $dirsep = dirsep();
    my $log_path = join($dirsep, $dir, "log/fs_sa_log.txt");
    my $log_path2 = join($dirsep, $dir, "log/fs_sa_log-old.txt");
    my $max_log_file_size = 10000;

    if ((-s $log_path || 0 ) > $max_log_file_size) {
	close(STDERR);
	rename $log_path, $log_path2 or print "rename failed: $!\n";
    }

    open(STDERR, '>>', $log_path);
    select (STDERR); $| = 1;
    select (STDOUT); $| = 1;
}

sub get_mapping {
    my ($mappings) = @_;

    die "Could not open $mappings: $!\n"
	unless open (my $MAPPINGS, '<', $mappings);

    my @mapping = ();
    while (<$MAPPINGS>)
    {
	# Skip comments && empty lines
	next if m/^\s*(\#.*)?\r?$/;

	if (m/^\s*(\d+)\s+(-?((\.\d+)|\d+(\.\d+)?))\s*\r?$/)
	{
	    my ($from, $to) = ($1, $2);
	    die "$mappings:$.:Target rating $from not between 1 and 9: $_"
		unless ($from >= 1 && $from <= 9);
	    $mapping[$from] = $to;
	}
	else
	{
	    die "$mappings:$.:Invalid input $_";
	}
    }
    close $MAPPINGS;

    # Some final sanity checking of mappings
    ######## TODO: interpolate missing limits geometrically instead of gripe?
    for (my $i = 1; $i <= 9; ++$i)
    {
	die "$mappings: Confidence level rating $_ remains undefined"
	    unless (defined $mapping[$i]);
    }

    return @mapping;
}

sub init_msglog {
    my ($dir) = @_;
    my $dirsep = dirsep();

    return unless my $msglog_setting = get_diag_setting("FS_SA_MSGLOG");

    # expand the relative directory name
    $spam_scanner_msglog_dir =
	join($dirsep, $dir, $spam_scanner_msglog_base_dir);

    unless (-d $spam_scanner_msglog_dir) {
	mkdir($spam_scanner_msglog_dir) or
	    debug(1, "msglog: failed to create directory '$spam_scanner_msglog_dir': $!");
    }

    return unless -d $spam_scanner_msglog_dir;

    $spam_scanner_msglog_limit = $msglog_setting + 0;
    debug(1, "msglog: requested to log $spam_scanner_msglog_limit messages");

    # the files are logged with names of the form "CLR%d-msg%04d.txt"
    # count, if there are any matching ones already from a
    # previous invocation and continue from there

    my @msg_names = ();
    if (opendir(my $dir, $spam_scanner_msglog_dir)) {

	@msg_names = map {
	    /^CLR\d+-msg(\d{4})\.txt$/i ? $1 : ()
	} readdir($dir);

	closedir($dir);
    }


    my $count = @msg_names;
    my $last = $count ? (sort(@msg_names))[-1] + 0 : 0;

    debug(1, "msglog: found $count messages, highest numbered '$last'");

    $spam_scanner_msglog_count = $count + $last;
    $spam_scanner_msglog_limit += $last;
    debug(1, "msglog: logging messages from $spam_scanner_msglog_count to $spam_scanner_msglog_limit");

    # copy the configuration file to the logging directory first
    my $cfg = join($dirsep, $dir, "fssc.cfg");
    require File::Copy;
    File::Copy::copy($cfg, $spam_scanner_msglog_dir) or
	debug(1, "msglog: failed to copy '$cfg'");
}

sub is_validating {
    my ($top_dir) = @_;

    # normally the Spam Control directory contains this, but the
    # database update directory not
    return ! -e join(dirsep(), $top_dir, "fsas.dll");
}

sub spam_scan_init {
    my ($rules, $fsas_version) = @_;

    # store globally as an integer "vector"
    $::fsas_version = defined $fsas_version ?
	pack("U*", grep { s/^(\d+).*$/$1/ } split /\./, $fsas_version) : 0.0.0;

    debug (2, ">> spam_scan_init(" . join(", ", grep defined, @_) . ")");
    my $dirsep = dirsep();

    debug (1, sprintf "spam_scan_init (%s/%s [%s], engine %s)",
	$Mail::SpamAssassin::VERSION,
	$VERSION,
	$Id,
	$fsas_version || "unknown"
    );
    
    $spam_scanner_directory = join($dirsep, $rules, "..");
    spam_scanner_remove_hook($spam_scanner_directory, [@temporary_files, @obsolete_files], \@obsolete_directories);

    my $is_validating = is_validating($spam_scanner_directory);
    debug(1, "preparing for " .
	($is_validating ? "database validation" : "spam scanning")
    );

    unless ($is_validating) {
	create_directories($spam_scanner_directory, @needed_directories);
	init_logging($spam_scanner_directory) unless $spam_scanner_debug;
    }

    my ($mappings) = join ($dirsep, $rules, "mappings.txt");

    @mapping = get_mapping($mappings);

    my $cfg = join ($dirsep, $rules, "..", "site");

    $::sa = new Mail::SpamAssassin({
	    rules_filename      => $rules,
	    site_rules_filename => $cfg,
	    userstate_dir       => $rules,
	    local_tests_only    => 0,	# 1,
	    dont_copy_prefs     => 1,
	    debug               => $spam_scanner_debug,
	});

    # FIXME: Not valid anymore?
    if ($spam_scanner_debug)
    {
	$Mail::SpamAssassin::DEBUG->{rulesrun} = 127;
	$Mail::SpamAssassin::DEBUG->{rbl} = -1;
	$::sa->{save_pattern_hits} = 1;
    }

    $::sa->compile_now(0);

    # Cache global settings
    eval {
	$::sa->copy_config(undef, \%{$cached{''}}) or
	    debug (1, "failed to copy_config");
    };
    debug (1, "could not find copy_config: $@") if ($@);
    $cached = '';

    init_msglog($spam_scanner_directory) unless $is_validating;

    debug (2, "<<spam_scan_init()");
}

sub spam_scan_version {
    return ($::sa->Version . "+fs$VERSION");
}

sub spam_scan_lint_rules {
    ######## TODO: maybe remove this braindeath altogether one day
    debug (1, "spam_scan_lint_rules bypassed (bug #34781)");
    return 0;
    #return &spam_scan_lint_really();
}

sub open_or_debug {
    my $ok = open($_[0], $_[1], $_[2]);
    debug(1, "could not open file '$_[2]': $!")
	unless $ok;

    return $ok;
}

sub set_sa_config {
    my ($config) = @_;

    if ($config eq $cached)
    {
	# no action
    }
    elsif ($cached{$config})
    {
	debug (1, "set_sa_config: retreiving cached config");
	$::sa->copy_config($cached{$config}, undef) or
	    die "copy_config failed";
	$cached = $config;
    }
    else
    {
	debug (1, "set_sa_config: no cached config");

	# Massage $config into the format it really needs to be in.
	# That is, any F-specific directives are either handled and removed,
	# or transformed into the corresponding generic SA directives.

	my $rawconfig = $config;
	my $username;

	my %directives = (
	    username => sub { $username = shift; },
	);
	my $directives = join ('|', keys %directives);

	######## FIXME: ugly spaces required in most values in %subst
	my %subst = (
	    blacklist => 'blacklist_from ',
	    whitelist => 'whitelist_from ',
	    mydomain  => 'whitelist_from *@',
	    # blacklist_to => (identity),
	    # whitelist_to => (identity),
	);
	my $subst = join ('|', keys %subst);

	my @addr_options = qw(
	    whitelist_from unwhitelist_from whitelist_from_rcvd
	    def_whitelist_from_rcvd whitelist_allows_relays
	    unwhitelist_from_rcvd blacklist_from unblacklist_from
	    whitelist_to more_spam_to all_spam_to blacklist_to
	);
	my $addr_options = join('|', @addr_options);

	$config =~ s/^\s*($directives)\s(.*)\r?/&{$directives{$1}}($2)/mge;
	$config =~ s/^\s*($subst)\s+(.*)\r?$/$subst{$1}$2/mg;
	$config =~ s/^\s*($addr_options)\s+<(\S+)>(\s|$)/$1 $2$3/mg;

	# Augment $::sa->{conf} with additional configuration data in $config

	# restore the common configuration
	$::sa->copy_config($cached{''}, undef) or
	    die "copy_config failed";
	$cached = '';

	# Go and parse the config!
	$::sa->{conf}->{main} = $::sa;

	$::sa->{conf}->parse_scores_only ($config);
	$::sa->{conf}->finish_parsing ();
	delete $::sa->{conf}->{main}; # to allow future GC'ing

	$::sa->signal_user_changed ({ username => $username });

	# and cache the newly parsed
	$::sa->copy_config(undef, \%{$cached{$rawconfig}}) or
	    die "copy_config failed";
	$cached = $rawconfig;
    }

}

sub spam_scan_message {
    debug (2, ">>spam_scan_message");

    my ($c, @data) = @_;
    my ($config, $conf);
    if (ref $c eq "HASH")
    {
	$config = $c->{bwlist} || '';
	$conf = $c->{settings} || { };
    }
    else
    {
	$conf = { };
	$config = $c;
    }
    $config = $custom_settings . $config if $custom_settings;

    # Default is to use envelope sender and recipient, if available.
    my $use_envelope = 0;
    if (defined $conf->{sender} ||
	defined $conf->{recipients})
    {
	if (defined $conf->{sender} &&
	    defined $conf->{recipients})
	{
	    $use_envelope = 1;
	    debug (2, "Envelope sender and recipients supplied: " .
		   "/sender:" . $conf->{sender} .
		   "; /recipients:" . $conf->{recipients});
	}
	else
	{
	    my ($supplied, $missing) =
		(defined $conf->{sender}
		 ? ("/sender:" . $conf->{sender}, "/recipients")
		 : ("/recipients:" . $conf->{recipients}, "/sender") );
	    warn "$supplied supplied but $missing missing\n";
	    debug (2, "$supplied supplied but $missing missing");
	}
    }
    else
    {
	debug (1, "No envelope information supplied; using headers");
    }

    if ($use_envelope)
    {
	# Zapping the scores for these rules mean they will not show in hits,
	# but we are still able to check if an address is black/whitelisted

	$config .= "
score USER_IN_DEF_WHITELIST 0
score USER_IN_DEF_BLACKLIST 0
score USER_IN_WHITELIST_TO  0
score USER_IN_BLACKLIST_TO  0
score USER_IN_WHITELIST     0
score USER_IN_BLACKLIST     0
";
    }

    my $spam_scanner_msglog_on = 0;
    if (
	defined $spam_scanner_msglog_limit &&
	$spam_scanner_msglog_count < $spam_scanner_msglog_limit
    ) {
	$spam_scanner_msglog_on = 1;
	$spam_scanner_msglog_count++;
    }

    if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on) {
	print $SPAM_SCANNER_REPORT "file: '$c->{filename}'\n"
	    if defined $SPAM_SCANNER_REPORT && ref $c && defined $c->{filename};

	$config .= "
clear_report_template
report
report report _REPORT_
report total _SCORE_/_REQD_
";
    }
### TODO: _REQD_ doesn't seem to match what fsas.dll has as a limit
### (at least when fpirun calls it), take it out? Or set it somehow?

    my $hits = "N/A";

    set_sa_config($config);

    my $confidence_level_rating;
    my $report;

    # Default is to do full test, but bypass if we get black/white envelope
    my $full_test = 1;
    my $full_report;

    if ($use_envelope)
    {
	my $dummy = Mail::SpamAssassin::PerMsgStatus->new($::sa, undef);
	@{$dummy->{all_from_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
	    ";", $conf->{sender});
	@{$dummy->{all_to_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
	    ";", $conf->{recipients});
######## FIXME: rules/97_fs-whitelist-from.cf should work with envelopes too
######## TODO: should we copy over def_whitelist_from etc?
#	for my $key (qw(    whitelist_from      whitelist_to
#			    whitelist_from_rcvd
#			def_whitelist_from
#			def_whitelist_from_rcvd
#			    blacklist_from      blacklist_to
#			    more_spam_to all_spam_to))
#	{
#	    $dummy->{conf}->{$key} = $::sa->{conf}->{$key};
#warn "\$dummy->{conf}->{$key} =\n"; map { warn "   '$_' => '", $dummy->{conf}->{$_} || "", "'\n" } keys %{$dummy->{conf}->{$key}};
#	}

	if ($dummy->check_from_in_whitelist
	 || $dummy->check_to_in_whitelist)
	{
	    $confidence_level_rating = 0;
	    $report = "WHITELISTED";
	    $full_test = 0;
	}
	elsif ($dummy->check_from_in_blacklist
	    || $dummy->check_to_in_blacklist)
	{
	    $confidence_level_rating = 10;
	    $report = "BLACKLISTED";
	    $full_test = 0;
	}
    }

    my %classifications = ( );
    if ($full_test)
    {
	# IGK/FSAV4IMTTLATIMLA >= 6.40 adds spurious Received: header and
	# final trailing CRLF -- trim them if present (CTS #49919)
	######## TODO: make conditional on engine.cf too?
	my $i = 0;
	if ($data[$i++] =~ m/\AReceived: from .*\(.* \[[.0-9]+\]\)\r\n\Z/
	    && ($data[$i] =~ m/\A by .* \(\[[.0-9]+\]:\d+\) \(.*\)\r\n\Z/
		&& ++$i || '# this will be missing in "anonymous mode"')
	    && $data[$i++] =~ m/\A[ ]with[ ].*;[ ]		# SMTP or ESMTP
		([A-Z][a-z]{2},[ ]				# weekday,
		[ 0-3][0-9][ ][A-Z][a-z]{2}[ ][12]\d{3}[ ]	# nn Mon yyyy
		[012]\d:\d{2}:\d{2}[ ]				# hh:mm:ss
		[-+ ]?\d{4})					# -TZ00
		\r\n\Z/x
	    && (my $datestamp = $1)
	    && $data[$i] =~ m/\A \(envelope-from .*\)\r\n\Z/
	    && $data[-1] eq "\r\n")
	{
	    my $age = Mail::SpamAssassin::Util::parse_rfc822_date ($datestamp);
	    my $t;
	    if (! defined $age)
	    {
		debug (1, "Invalid date in IGK/FSAV4IM Received: header");
	    }
	    elsif ($age > ($t = time))
	    {
		debug (1, "IGK/FSAV4IM Received: header dated in the future");
	    }
	    elsif ($age < $t-300)	######## FIXME: higher age limit?
	    {
		debug (1, "IGK/FSAV4IM Received: header older than 5 minutes");
	    }
	    else
	    {
		debug (1,
		    "Trimming IGK/FSAV4IM >= 6.40 Received: and final CRLF");
		splice @data, 0, $i;
		splice @data, -1, 1;
	    }
	}

	# If mail seems to contain \r?\r\n's throughout, attempt to fix
	for my $regex (qr(\r\r\n\Z), qr(\r\n\Z))
	{
	    my @dataclone;
	    foreach (@data)
	    {
		my $datum = $_;
		unless ($datum =~ s/$regex/\n/)
		{
		    @dataclone = ();
		    last;
		}
		push @dataclone, $datum;
	    }

	    if (@dataclone)
	    {
		debug (1, "spam_scan_message: $regex line endings normalized");
		@data = @dataclone;
		last;
	    }
	}

	# Check mail with current settings
	my $mail = $::sa->parse(\@data);
	my $status = $::sa->check ($mail); # The check is in the mail

	# If white/blacklisted, just return ({WHITE,BLACK}LISTED, {0,10})
	######## TODO: is there a less resource-intensive way to do this?
	# One gets the feeling that the check($mail) above does lots of work
	# Plan: factor out and use only pertinent parts of SpamAssassin->check
	######## FIXME: perhaps also check other PerMsgStatus->..._whitelist

	if (! $use_envelope &&
	    ($status->check_from_in_whitelist
 	  || $status->check_to_in_whitelist))
	{
	    $confidence_level_rating = 0;
	    $report = "WHITELISTED";
	}
	elsif (! $use_envelope &&
		($status->check_from_in_blacklist
		|| $status->check_to_in_blacklist))
	{
	    $confidence_level_rating = 10;
	    $report = "BLACKLISTED";
	}
	else
	{
	    $hits = $status->get_hits();
	    $confidence_level_rating = get_clr($hits);
	    $report = $status->get_names_of_tests_hit();
	}

	if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on)
	{
	    $full_report = $status->get_report();
	}

	%classifications = %{$status->{fs_phishblplugin} || {}};
	$status->finish();
	$mail->finish();
    }

    printf $SPAM_SCANNER_REPORT "%sCLR %s\n",
	$full_report, $confidence_level_rating
	    if (defined $SPAM_SCANNER_REPORT);

    if ($spam_scanner_msglog_on) {
	if (open_or_debug(my $fh, '>', sprintf(
	    "$spam_scanner_msglog_dir/CLR%d-msg%04d.txt",
	    $confidence_level_rating,
	    $spam_scanner_msglog_count
	))) {
	    print $fh $config;
	    print $fh "-" x 80, "\n";
	    printf $fh "%sCLR %s\nreport %s\nhits %s\n",
		$full_report,
		$confidence_level_rating,
		$report, $hits;
	    print $fh "=" x 80,"\n";
	    print $fh @data;
	    close($fh);
	}

    }

    # report the traditional spam score also as a "spam class" score
    $classifications{spam} = $confidence_level_rating;

    # convert any heuristic phishing rule matches to "phishing class"
    # score of 9, unless specific phishing score is already higher,
    # or explicitly whitelisted (phishing score zero).
    $classifications{phishing} = 9 if
	$report =~ /PHISH/ && (
	    !exists $classifications{phishing} || (
		$classifications{phishing} < 9 &&
		$classifications{phishing} != 0
	    )
	);

    # add any specific classifications as pseudo rules of the form
    # FS_CLASS_<class>_<value> into the matched rule names list
    $report .= ($report ? "," : "")  . join(",",
	map { "FS_CLASS_\U$_\E_$classifications{$_}" }
	keys %classifications
    );

    debug (0, sprintf "spam_scan_message result: CLR = %s (%s; %s; %s)",
	$confidence_level_rating,
	$hits,
	$report ? "$report" : '',
	join(", ", map { "$_ = $classifications{$_}" } keys %classifications)
    );

    if ($::fsas_version lt 1.22.0) {
	# for old clients that only know about spam scores,
	# convert any phishing score into a spam score, unless
	# the score is already higher, or the message whitelisted.
	# this way any phishing messages get moved at least to
	# the junk mail folder.
	if (
	    $confidence_level_rating > 0 &&
	    exists $classifications{phishing} &&
	    $confidence_level_rating < $classifications{phishing})
	{
	    $confidence_level_rating = $classifications{phishing};
	}

	debug (2, "<<spam_scan_message (old engine, CLR = $confidence_level_rating)");
	return ($report, $confidence_level_rating);
    }
  
    debug (2, "<<spam_scan_message");
    return ($report, $confidence_level_rating, \%classifications);
}

sub get_clr
{
    ######## FIXME: do a binary search here instead
    my ($score) = @_;
    my $i;
    for ($i = 9; $i >= 1; --$i)
    {
	last if ($mapping[$i] <= $score);
    }
    return $i;
}

sub spam_scan_lint_really
{
    debug (1, "lint");
    #$::sa->{conf} = $cached{''}->copy() if (defined $cached{''});
    return ($::sa->lint_rules_really);
}



1;
