#!/usr/bin/perl -w

# sqlgrey: a postfix greylisting policy server using an SQL backend
# based on postgrey
# Copyright 2004 (c) ETH Zurich
# Copyright 2004 (c) Lionel Bouton

#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

# see the documentation with 'perldoc sqlgrey'

package sqlgrey;
use strict;
use Pod::Usage;
use Getopt::Long 2.25 qw(:config posix_default no_ignore_case);
use Net::Server::Multiplex;
use DBI;

#Store this hosts hostname in $HOSTNAME if Sys::Hostname is avail
my $HOSTNAME;
eval  { require Sys::Hostname; };
      if ($@) { $HOSTNAME = hostname();}
      
use POSIX ':sys_wait_h';

use vars qw(@ISA);
@ISA = qw(Net::Server::Multiplex);

my $VERSION = "1.7.4";
my $software = 'SQLgrey-' . $VERSION;

my $DB_VERSION = 3;

# Table names
my $connect       = 'connect';
my $from_awl      = 'from_awl';
my $domain_awl    = 'domain_awl';
my $optin_domain  = 'optin_domain';
my $optin_email   = 'optin_email';
my $optout_domain = 'optout_domain';
my $optout_email  = 'optout_email';
my $config        = 'config';

# defaults
my %dflt;
$dflt{loglevel}           = 2; # used for $dflt{log} entries in read_conffile()
$dflt{user}               = 'sqlgrey';
$dflt{group}              = 'sqlgrey';
$dflt{inet}               = '2501';
$dflt{pidfile}            = '/var/run/sqlgrey.pid';
$dflt{conf_dir}           = '/etc/sqlgrey';
$dflt{reconnect_delay}    = 5;            # 5 minutes
$dflt{max_connect_age}    = 24;           # 24 hours
$dflt{awl_age}            = 60;           # 60 days
$dflt{group_domain_level} = 2;            # 2 e-mail addr from same domain/IP
$dflt{reject_first_attempt} = 'delay';    # Use 'delay' or 'immed'
$dflt{reject_early_reconnect} = undef;    # Leave undef
$dflt{connect_src_throttle} = 0;          # 0 = Don't throttle
$dflt{db_type}            = 'Pg';
$dflt{db_name}            = 'sqlgrey';
$dflt{db_host}            = 'localhost';
$dflt{db_port}            = 'default';
$dflt{db_user}            = 'sqlgrey';
$dflt{db_pass}            = '';
$dflt{db_cluster}	  = 'off';
$dflt{prepend}            = 1;
$dflt{greymethod}         = 'smart';
$dflt{optmethod}          = 'none'; # or 'optin' or 'optout'
$dflt{db_cleandelay}	  = 30 * 60;
$dflt{clean_method}       = 'sync';
$dflt{admin_mail}         = 'postmaster';
$dflt{log_ident}          = undef;
$dflt{reject_code}	  = '450';

$dflt{discrimination} 	  = 0;
$dflt{discrimination_add_rulenr} = 0;

$dflt{log} = { # note values here are not used
	      'grey' => 2,
	      'whitelist' => 2,
	      'optin' => 2,
	      'spam' => 2,
	      'mail' => 2,
	      'dbaccess' => 2,
	      'martians' => 2,
	      'perf' => 2,
	      'system' => 2,
	      'conf' => 2,
	      'other' => 2,
	     };

# Default configuration file
my $config_file              = '/etc/sqlgrey/sqlgrey.conf';

# whitelist files
my $stat_ip_whitelist_file   = $dflt{conf_dir} . '/clients_ip_whitelist';
my $dyn_ip_whitelist_file    = $dflt{conf_dir} . '/clients_ip_whitelist.local';
my $stat_fqdn_whitelist_file = $dflt{conf_dir} . '/clients_fqdn_whitelist';
my $dyn_fqdn_whitelist_file  = $dflt{conf_dir} . '/clients_fqdn_whitelist.local';
# regexp files
my $smtp_server_regexp_file     = $dflt{conf_dir} . '/smtp_server.regexp';
my $dyn_fqdn_regexp_file        = $dflt{conf_dir} . '/dyn_fqdn.regexp';
my $discrimination_regexp_file  = $dflt{conf_dir} . '/discrimination.regexp';

my $prepend = 'PREPEND X-Greylist: ';

my $reload = 0; # non-zero signals a regexps/whitelists reload request

my $ref_to_sqlgrey; # we need this global var to access sqlgrey functions
                    # in signal handlers

sub mylog($$$$) {
    my ($self, $logtype, $loglevel, $message) = @_;

    $message =~ s/%/%%/g; # protect sprintf used by Syslog
    if (!defined $self->{sqlgrey}{log}{$logtype}) {
	$self->log($loglevel, "Unknown logtype ($logtype): $message");
    }
    if ($loglevel <= $self->{sqlgrey}{log}{$logtype}) {
	# workaround: we can't disable the TCP connections
	# logs if we use log_level 4 so log_level is capped by default
	$loglevel = $loglevel > $self->{server}{log_level} ?
	    $self->{server}{log_level} : $loglevel;
	$self->log($loglevel, "$logtype: $message");
    }
}

# Send mails
sub sendmail($$$) {
    my $self = shift;
    my $subject = shift;
    my $content = shift;
    my $now = time;

    return if $self->{sqlgrey}{admin_mail} eq '';
    # this code throttles the message rate
    # fill bucket
    $self->{sqlgrey}{mail_bucket} += ($now - $self->{sqlgrey}{last_mail})/
	(60*$self->{sqlgrey}{mail_period});
    $self->{sqlgrey}{last_mail} = $now;
    # but no more than its capacity
    $self->{sqlgrey}{mail_bucket} = $self->{sqlgrey}{mail_bucket} < $self->{sqlgrey}{mail_maxbucket} ?
	$self->{sqlgrey}{mail_bucket} : $self->{sqlgrey}{mail_maxbucket};

    $self->mylog('mail', 4, "mail_bucket: $self->{sqlgrey}{mail_bucket}");
    # is there room for a mail ?
    if ($self->{sqlgrey}{mail_bucket} >= 1) {
	if ($self->{sqlgrey}{mail_bucket} < 2) {
	    $content .= ' (max warn message rate hit, throttling)';
	}

        # actual mail sending
        my $return = system("echo '$content' | mail -s '$subject' $self->{sqlgrey}{admin_mail}");
	if ($return != 0) {
	    if ($? == -1) {
		$self->mylog('mail', 0, "failed to send: $!\n");
	    } elsif ($? & 127) {
		$self->mylog('mail', 0, sprintf('child died with ' .
				      "signal %d, %s coredump\n",
				      ($? & 127),  ($? & 128) ?
				      'with' : 'without'));
	    } else {
		$self->mylog('mail', 0, sprintf("child exited with value: %d\n",
				      $? >> 8));
	    }
	}
	# empty bucket
	$self->{sqlgrey}{mail_bucket}--;
    }
}

sub mydie($$) {
    my $self = shift;
    my $error = shift;
    $self->sendmail('SQLgrey died', $error);
    die $error;
}

##########################
## Database helper subs ##
##########################

# Trigger e-mails when the DB connection's state changes
sub db_unavailable($) {
    my $self = shift;

    if ($self->{sqlgrey}{db_available}) {
	if (! defined $self->{sqlgrey}{dbh}) {
	    $self->{sqlgrey}{warn_db} && $self->sendmail('SQLgrey lost database',
							 'SQLgrey lost database connection to: ' . $self->cnctinfo());
	} else {
	    $self->disconnectdb();
	    $self->{sqlgrey}{warn_db} && $self->sendmail('SQLgrey database error',
							 'SQLgrey encountered an SQL error and triggered a reconnection to: ' . $self->cnctinfo());
	}
	$self->{sqlgrey}{db_available} = 0;
    }
}

sub db_available($) {
    my $self = shift;

    if (! $self->{sqlgrey}{db_available}) {
	$self->{sqlgrey}{warn_db} && $self->sendmail('SQLgrey recovered DB',
			'SQLgrey established connection to: ' . $self->cnctinfo());
	$self->{sqlgrey}{db_available} = 1;
    }
}

# fault (lost connection) tolerant do
# allows a RDBMs restart without crash
sub do($$) {
    my $self = shift;
    my $query = shift;
    my $result;

    if (! $self->{sqlgrey}{db_available}) {
	$self->connectdb();
    }
    if (defined $self->{sqlgrey}{dbh} and
	($result = $self->{sqlgrey}{dbh}->do($query))) {
	$self->db_available();
	return $result;
    } else {
	# failure
	$self->db_unavailable();
        $self->mylog('dbaccess', 0, "warning: couldn't do query:\n" .
		   "$query:\n" .
		   "$DBI::errstr, reconnecting to DB");
	return undef;
    }
}

# prepare_cached needs to check for a dbh
sub prepare_cached($$) {
    my $self = shift;
    my $query = shift;

    if (! $self->{sqlgrey}{db_available}) {
	$self->connectdb();
    }
    if (!defined $self->{sqlgrey}{dbh}) {
	$self->db_unavailable();
	return undef;
    } else {
	my $result = $self->{sqlgrey}{dbh}->prepare_cached($query);
	if (! defined $result) {
	    $self->db_unavailable();
	} else {
	    $self->db_available();
	}
	return $result;
    }
}

# prepar needs to check for a dbh
sub prepare($$) {
    my $self = shift;
    my $query = shift;

    if (! $self->{sqlgrey}{db_available}) {
	$self->connectdb();
    }
    if (!defined $self->{sqlgrey}{dbh}) {
	$self->db_unavailable();
	return undef;
    } else {
	my $result = $self->{sqlgrey}{dbh}->prepare($query);
	if (! defined $result) {
	    $self->db_unavailable();
	} else {
	    $self->db_available();
	}
	return $result;
    }
}

# quote can't be called directly when dbh is undef
# we provide a wrapper
# we don't try to reconnect here
sub quote($$) {
    my $self = shift;
    my $toquote = shift;
    if (! defined $self->{sqlgrey}{dbh}) {
	return 'NULL';
    } else {
	return $self->{sqlgrey}{dbh}->quote($toquote);
    }
}

# Check if a table exists
sub table_exists($$) {
    my $self = shift;
    my $tablename = shift;

    # if we couldn't connect, do as if the table exist
    defined $self->{sqlgrey}{dbh} or return 1;
    # Seems the most portable way to do it
    # but needs SQL error reporting off at connect time :-<
    # don't use $self->do here (no need to reconnect on error)
    $self->{sqlgrey}{dbh}->do("SELECT 1 from $tablename LIMIT 0")
        or return 0;
    return 1;
}

# Drop a table
sub drop_table($$) {
    my $self = shift;
    my $table = shift;
    $self->do("DROP TABLE $table");
}

# Database type queries
sub SQLite($) {
    my $self = shift;
    return ($self->{sqlgrey}{db_type} eq 'SQLite');
}
sub PostgreSQL($) {
    my $self = shift;
    return ($self->{sqlgrey}{db_type} eq 'Pg');
}
sub MySQL($) {
    my $self = shift;
    return ($self->{sqlgrey}{db_type} eq 'mysql');
}

# build a SQL representation of a timestamp with a given
# interval from now
# we use $self->{sqlgrey}{dbnow} to make sure the SQL function
# now() can't make the optimizer think the value can change
# and make the DB evaluate it for *each* row of the table we'll select from
sub past_tstamp($$$) {
    my ($self, $nb, $unit) = @_;
    if ($self->MySQL()) {
	# MySQL doesn't want any ' char
        return 'timestamp ' . $self->{sqlgrey}{dbnow} .
	    " - INTERVAL $nb $unit";
    } elsif ($self->SQLite()) {
	my $delay;
	# SQLite doesn't recognise INTERVAL
        if ($unit eq 'DAY') {
            $delay = $nb * 24 * 60 * 60;
        } elsif ($unit eq 'HOUR') {
            $delay = $nb * 60 * 60;
        } elsif ($unit eq 'MINUTE') {
            $delay = $nb * 60;
        } else {
            # catch syntax errors
            $self->mydie('Interval error', 'interval(' . $nb . ', ' . $unit . ') for SQLite,'
		. " sqlgrey doesn't recognise $unit UNIT");
        }
	return 'now() - ' . $delay;
    } else { # use PostgreSQL syntax (probably the most SQL compliant)
        return 'timestamp ' . $self->{sqlgrey}{dbnow} .
	    " - INTERVAL '" . "$nb $unit" . "'";
    }
}

sub update_dbnow($) {
    my $self = shift;

    # no dbnow needed for SQLite
    return if $self->SQLite();

    my $result;
    my $sth = $self->prepare_cached('SELECT now()');
    if (!defined $sth or !$sth->execute()) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't get now() from DB: $DBI::errstr");
	return if defined $self->{sqlgrey}{dbnow}; # defined: we don't update the value
	$self->{sqlgrey}{dbnow} = '0';
    } else {
	$self->db_available();
	$result = $sth->fetchall_arrayref();
	$self->{sqlgrey}{dbnow} = $self->quote($result->[0][0]);
    }
}

# Create tables if not done already
sub database_setup($) {
    my $self = shift;
    # AWL and connect tables checks
    if (! $self->table_exists($from_awl)) {
	$self->create_from_awl_table();
	$self->create_from_awl_indexes();
    }
    if (! $self->table_exists($domain_awl)) {
	$self->create_domain_awl_table();
	$self->create_domain_awl_indexes();
    }
    if (! $self->table_exists($connect)) {
	$self->create_connect_table();
	$self->create_connect_indexes();
    }
    # optin/out tables checks
    if (! $self->table_exists($optin_domain)) {
	$self->create_optin_domain_table();
    }
    if (! $self->table_exists($optin_email)) {
	$self->create_optin_email_table();
    }
    if (! $self->table_exists($optout_domain)) {
	$self->create_optout_domain_table();
    }
    if (! $self->table_exists($optout_email)) {
	$self->create_optout_email_table();
    }

    # config table check
    if (! $self->table_exists($config)) {
	$self->create_config_table();
	$self->setconfig('version',$DB_VERSION);
    }

    # if config did exist, we have to check the DB version
    my $current_version = $self->currentdbversion();
    # don't try an upgrade if we couldn't connect
    if (defined $current_version and $current_version < $DB_VERSION) {
	$self->mylog('dbaccess', 1, 'upgrading database from ' .
		   $self->currentdbversion() . ' to ' .
		   $DB_VERSION);
	$self->upgradedb();
    }

    # database errors were masked until now
    $self->{sqlgrey}{warn_db} = 1;
}

# Database configuration related, only used for checking
# schema version now, might be used to check compatibility
# between database schema and SQLgrey startup switches in the future
sub getconfig($$) {
    my $self = shift;
    my $param = shift;

    my $sth = $self->prepare_cached("SELECT value FROM $config " .
				    'WHERE parameter = ?');
    if (!defined $sth or !$sth->execute($param)) {
	$self->mylog('dbaccess', 0, "error: couldn't access $config table: $DBI::errstr");
	return undef;
	#$self->mydie('getconfig error',
	#	     'Can\'t continue: config table unreadable');
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('dbaccess', 0, 'error: unexpected SQL result (getconfig)');
	return undef;
	#$self->mydie('getconfig error',
	#	     'Can\'t continue: unexpected config table read error');
    } else {
        return $result->[0][0];
    }
}

sub setconfig($$$) {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    my $sth = $self->prepare_cached("SELECT value FROM $config " .
				    'WHERE parameter = ?');
    if (!defined $sth or !$sth->execute($param)) {
	$self->mylog('dbaccess', 0, "error: couldn't access $config table: $DBI::errstr");
	$self->mydie('setconfig error',
		     'Can\'t continue: config table unreadable');
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	# not a single value (should mean no value, not multiple ones)
	$self->insertconfig($param, $value);
    } else {
	$self->updateconfig($param, $value);
    }
}

sub updateconfig($$$) {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    return $self->do("UPDATE $config SET value = " .
		     $self->quote($value) .
		     ' WHERE parameter = ' .
		     $self->quote($param));
}

sub insertconfig($$$) {
    my $self = shift;
    my $param = shift;
    my $value = shift;

    return $self->do("INSERT INTO $config (parameter, value) VALUES(" .
		     $self->quote($param) . ',' .
		     $self->quote($value) . ')');
}

sub currentdbversion($) {
    my $self = shift;

    # No config table -> version 0
    if (! $self->table_exists("$config")) {
	return 0;
    }

    # Common case: read from config table
    return $self->getconfig('version');
}

sub upgradedb($) {
    my $self = shift;
    my $currentdbver = $self->currentdbversion();
    while ($currentdbver < $DB_VERSION) {
	$self->upgrade($currentdbver);
	$currentdbver++;
    }
}

sub upgrade($$) {
    my $self = shift;
    my $ver = shift;
    if ($ver == 0) {
	$self->mydie('Too old SQLgrey database',
		    'The current layout of the SQLgrey database is too old,' .
		    'please launch SQLgrey 1.4 to convert it to a layout I can understand');
    } elsif ($ver == 1) {
	$self->upgrade1();
    } elsif ($ver == 2) {
	$self->upgrade2();
    }
}

sub upgrade1($) {
    my $self = shift;
    $self->mylog('dbaccess', 1, 'upgrading database schema from version 1 to version 2');

    ## Note: SQLite 2.x needs a temporary table (no ALTER TABLE)
    ## can we detect SQLite 3+ ?

    # connect
    $self->mylog('dbaccess', 2, "$connect table: renaming ip_addr to src");
    if ($self->SQLite()) {
	$self->create_connect_table('temp');
	$self->do('INSERT INTO temp (sender_name, sender_domain, ' .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, ip_addr, ' .
		  'rcpt, first_seen ' .
		  "FROM $connect");
	$self->drop_table($connect);
    } else {
	$self->do("ALTER TABLE $connect RENAME TO $connect" . 'old');
    }
    $self->create_connect_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $connect (sender_name, sender_domain, " .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, ' .
		  'rcpt, first_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $connect (sender_name, sender_domain, " .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, ip_addr, ' .
		  'rcpt, first_seen ' .
		  "FROM $connect" . 'old');
	$self->drop_table("$connect" . 'old');
    }
    $self->mylog('dbaccess', 2, "$connect table: adding indexes");
    $self->create_connect_indexes();

    # from_awl
    $self->mylog('dbaccess', 2, "$from_awl: renaming host_ip to src, adding first_seen");
    if ($self->SQLite()) {
	$self->create_from_awl_table('temp');
	$self->do('INSERT INTO temp (sender_name, sender_domain, ' .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, host_ip, last_seen, last_seen ' .
		  "FROM $from_awl");
	$self->drop_table($from_awl);
    } else {
	$self->do("ALTER TABLE $from_awl RENAME TO $from_awl" . 'old');
    }
    if ($self->PostgreSQL()) { # we need to remove the pkey constraint
	$self->do("ALTER TABLE $from_awl" . 'old DROP CONSTRAINT ' .
		  'from_awl_pkey');
    }
    $self->create_from_awl_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $from_awl (sender_name, sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, last_seen, last_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $from_awl (sender_name, sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, host_ip, last_seen, last_seen ' .
		  "FROM $from_awl" . 'old');
	$self->drop_table("$from_awl" . 'old');
    }
    $self->mylog('dbaccess', 2, "$from_awl: adding indexes");
    $self->create_from_awl_indexes();

    # domain_awl
    $self->mylog('dbaccess', 2, "$domain_awl: renaming host_ip to src, adding first_seen");
    if ($self->SQLite()) {
	$self->create_domain_awl_table('temp');
	$self->do('INSERT INTO temp (sender_domain, ' .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_domain, host_ip, last_seen, last_seen ' .
		  "FROM $domain_awl");
	$self->drop_table($domain_awl);
    } else {
	$self->do("ALTER TABLE $domain_awl RENAME TO $domain_awl" . 'old');
    }
    if ($self->PostgreSQL()) { # we need to remove the pkey constraint
	$self->do("ALTER TABLE $domain_awl" . 'old DROP CONSTRAINT ' .
		  'domain_awl_pkey');
    }
    $self->create_domain_awl_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $domain_awl (sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_domain, src, last_seen, last_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $domain_awl (sender_domain, src, " .
		  'last_seen, first_seen) ' .
		  'SELECT sender_domain, host_ip, last_seen, last_seen ' .
		  "FROM $domain_awl" . 'old');
	$self->do("DROP TABLE $domain_awl" . 'old');
    }
    $self->mylog('dbaccess', 2, "$domain_awl: adding indexes");
    $self->create_domain_awl_indexes();

    # Update our schema
    $self->setconfig('version','2');
}

sub upgrade2($) {
    my $self = shift;
    $self->mylog('dbaccess', 1, 'upgrading database schema from version 2 to version 3');

    ## Note: SQLite 2.x needs a temporary table (no ALTER TABLE)
    ## can we detect SQLite 3+ ?

    # connect
    $self->mylog('dbaccess', 2, "$connect: making room for IPv6 in src");
    if ($self->SQLite()) {
	$self->create_connect_table('temp');
	$self->do('INSERT INTO temp (sender_name, sender_domain, ' .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, ' .
		  'rcpt, first_seen ' .
		  "FROM $connect");
	$self->drop_table($connect);
    } else {
	$self->do("ALTER TABLE $connect RENAME TO $connect" . 'old');
    }
    $self->create_connect_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $connect (sender_name, sender_domain, " .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, ' .
		  'rcpt, first_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $connect (sender_name, sender_domain, " .
		  'src, rcpt, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, ' .
		  'rcpt, first_seen ' .
		  "FROM $connect" . 'old');
	$self->drop_table("$connect" . 'old');
    }
    $self->mylog('dbaccess', 2, "$connect: adding indexes");
    $self->create_connect_indexes();

    # from_awl
    $self->mylog('dbaccess', 2, "$from_awl: making room for IPv6 in src");
    if ($self->SQLite()) {
	$self->create_from_awl_table('temp');
	$self->do('INSERT INTO temp (sender_name, sender_domain, ' .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, last_seen, last_seen ' .
		  "FROM $from_awl");
	$self->drop_table($from_awl);
    } else {
	$self->do("ALTER TABLE $from_awl RENAME TO $from_awl" . 'old');
    }
    if ($self->PostgreSQL()) { # we need to remove the pkey constraint
	$self->do("ALTER TABLE $from_awl" . 'old DROP CONSTRAINT ' .
		  'from_awl_pkey');
    }
    $self->create_from_awl_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $from_awl (sender_name, sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, last_seen, last_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $from_awl (sender_name, sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_name, sender_domain, src, last_seen, last_seen ' .
		  "FROM $from_awl" . 'old');
	$self->drop_table($from_awl . 'old');
    }
    $self->mylog('dbaccess', 2, "$from_awl: adding indexes");
    $self->create_from_awl_indexes();

    # domain_awl
    $self->mylog('dbaccess', 2, "$domain_awl: making room for IPv6 in src");
    if ($self->SQLite()) {
	$self->create_domain_awl_table('temp');
	$self->do('INSERT INTO temp (sender_domain, ' .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_domain, src, last_seen, first_seen ' .
		  "FROM $domain_awl");
	$self->drop_table($domain_awl);
    } else {
	$self->do("ALTER TABLE $domain_awl RENAME TO $domain_awl" . 'old');
    }
    if ($self->PostgreSQL()) { # we need to remove the pkey constraint
	$self->do("ALTER TABLE $domain_awl" . 'old DROP CONSTRAINT ' .
		  'domain_awl_pkey');
    }
    $self->create_domain_awl_table();
    if ($self->SQLite()) {
	$self->do("INSERT INTO $domain_awl (sender_domain, " .
		  'src, last_seen, first_seen) ' .
		  'SELECT sender_domain, src, last_seen, first_seen ' .
		  'FROM temp');
	$self->drop_table('temp');
    } else {
	$self->do("INSERT INTO $domain_awl (sender_domain, src, " .
		  'last_seen, first_seen) ' .
		  'SELECT sender_domain, src, last_seen, first_seen ' .
		  "FROM $domain_awl" . 'old');
	$self->do("DROP TABLE $domain_awl" . 'old');
    }
    $self->mylog('dbaccess', 2, "$domain_awl: adding indexes");
    $self->create_domain_awl_indexes();

    # Update our schema
    $self->setconfig('version','3');
}

# Build a connect string for DBI
sub cnctinfo($) {
# Tested with PostgreSQL, MySQL and SQLite
    my $self = shift;
    my $dsn = 'DBI:' . $self->{sqlgrey}{db_type};
    # only MySQL uses database=
    if ($self->MySQL()) {
        $dsn .= ':database=';
    } else {
        $dsn .= ':dbname=';
    }
    $dsn .= $self->{sqlgrey}{db_name};
    # only SQLite doesn't require a hostname or port
    if (! $self->SQLite()) {
        $dsn .= ';host=' . $self->{sqlgrey}{db_host};
        if ($self->{sqlgrey}{db_port} ne "default") {
            $dsn .= ';port=' . $self->{sqlgrey}{db_port};
        }
    }
    return $dsn;
}

# Global DB Init code
sub initdb($) {
    my $self = shift;
    $self->connectdb();
    $self->update_dbnow();
    $self->database_setup();
}

sub connectdb($) {
    my $self = shift;
    # we can't use connect_cached as we create another connection
    # in the child responsible for cleanups
    no warnings 'uninitialized'; #Perl will spew warn's if running DBI only
    if ($dflt{db_cluster} ne 'on') {
    
    	$self->{sqlgrey}{dbh} = DBI->connect($self->cnctinfo(),
					 $self->{sqlgrey}{db_user},
					 $self->{sqlgrey}{db_pass},
					 { PrintError => 0,
					   AutoCommit => 1,
					   InactiveDestroy => 1 }
					)
	or $self->mylog('dbaccess', 0, "can't connect to DB: $DBI::errstr");

    } else {

        $self->mylog('dbaccess', 1, "Using DBIx:DBCluster");
        
        my @read_hosts = split(/[,\s]+/ ,$dflt{'read_hosts'});
        $self->mylog('dbaccess', 3, "Read_hosts: ".join(', ', @read_hosts)); 
        
	#Setting up cluster db's
    	$DBIx::DBCluster::CLUSTERS = {
        		"$self->{sqlgrey}{db_host}" => {
            		'WRITE_HOSTS'  => [$self->{sqlgrey}{db_host}],
            		'READ_HOSTS'   => [@read_hosts],
        		},
    	};
    	
    	#Flags tells DBCluster never to use WRITE_HOSTS for reading 
    	#(unless specified in READ_HOSTS). This only works with Dan Faerch's patch to DBIx::DBCluster
    	$DBIx::DBCluster::WRITE_HOSTS_NEVER_READ=1; 
                
    	$self->{sqlgrey}{dbh} = DBIx::DBCluster->connect($self->cnctinfo(),
                                         $self->{sqlgrey}{db_user},
                                         $self->{sqlgrey}{db_pass},
                                         { PrintError => 0,
                                           AutoCommit => 1,
                                           InactiveDestroy => 1 }
                                        )
        or $self->mylog('dbaccess', 0, "can't connect to DB: $DBI::errstr");
    }

    #Ugly hack to make perl shut up about about "possible typo".
    1 if ($DBIx::DBCluster::WRITE_HOSTS_NEVER_READ);
    1 if ($DBIx::DBCluster::CLUSTERS);


    ## we can't touch dbh if it isn't defined!
    if (! defined $self->{sqlgrey}{dbh}) { return; }

    # mysql drops the connection, we have some glue code
    # to reinit the connection, but better use mysql DBD code
    if ($self->MySQL()) {
        $self->{sqlgrey}{dbh}->{mysql_auto_reconnect} = 1;
    }
    # Create "now()" function for SQLite
    if ($self->SQLite()) {
        $self->{sqlgrey}{dbh}->func('now', 0, sub { return time },
				    'create_function' );
    }
}

sub disconnectdb($) {
    my $self = shift;
    if (defined $self->{sqlgrey}{dbh}) {
	$self->{sqlgrey}{dbh}->disconnect();
    }
}

#####################
## Table creations ##
#####################

sub create_from_awl_table {
    my $self = shift;
    # allow optional table name
    my $tablename = shift;
    $tablename = ! defined $tablename ? $from_awl : $tablename;
    $self->do("CREATE TABLE $tablename " .
	      '(sender_name varchar(64) NOT NULL, ' .
	      'sender_domain varchar(255) NOT NULL, ' .
	      'src varchar(39) NOT NULL, ' .
	      'first_seen timestamp NOT NULL, ' .
	      'last_seen timestamp NOT NULL, ' .
	      'PRIMARY KEY ' .
	      '(src, sender_domain, sender_name))')
	or $self->mydie('create_from_awl_table error',
			'Couldn\'t create table $tablename: $DBI::errstr');
}
sub create_from_awl_indexes($) {
    my $self = shift;
    $self->do("CREATE INDEX $from_awl" . '_lseen ' .
	     "ON $from_awl (last_seen)")
	or $self->mydie('create_from_awl_table error',
			"couldn't create index on $from_awl (last_seen)");
}

sub create_domain_awl_table {
    my $self = shift;
    # allow optional table name
    my $tablename = shift;
    $tablename = ! defined $tablename ? $domain_awl : $tablename;
    $self->do("CREATE TABLE $tablename " .
	      '(sender_domain varchar(255) NOT NULL, ' .
	      'src varchar(39) NOT NULL, ' .
	      'first_seen timestamp NOT NULL, ' .
	      'last_seen timestamp NOT NULL, ' .
	      'PRIMARY KEY (src, sender_domain))')
	or $self->mydie('create_domain_awl_table error',
			"Couldn't create table $tablename: $DBI::errstr");
}
sub create_domain_awl_indexes($) {
    my $self = shift;
    $self->do("CREATE INDEX $domain_awl" . '_lseen ' .
	     "ON $domain_awl (last_seen)")
	or $self->mydie('create_domain_awl_table error',
			"couldn't create index on $domain_awl (last_seen)");
}

sub create_connect_table {
    my $self = shift;
    # allow optional table name
    my $tablename = shift;
    $tablename = ! defined $tablename ? $connect : $tablename;
    # Note: no primary key, Mysql can't handle 500+ byte primary keys
    # connect should not become big enough to make it a problem
    $self->do("CREATE TABLE $tablename " .
	      '(sender_name varchar(64) NOT NULL, ' .
	      'sender_domain varchar(255) NOT NULL, ' .
	      'src varchar(39) NOT NULL, ' .
	      'rcpt varchar(255) NOT NULL, ' .
	      'first_seen timestamp NOT NULL)')
	or $self->mydie('create_connect_table',
			"Couldn't create table $tablename: $DBI::errstr");
}
sub create_connect_indexes($) {
    my $self = shift;
    $self->do("CREATE INDEX $connect" . '_idx ' .
	     "ON $connect (src, sender_domain, sender_name)")
	or $self->mydie('create_connect_table error',
			"couldn't create index on $connect (src, sender_domain, sender_name)");
    $self->do("CREATE INDEX $connect" . '_fseen ' .
	     "ON $connect (first_seen)")
	or $self->mydie('create_connect_table error',
			"couldn't create index on $connect (first_seen)");
}

sub create_config_table($) {
    my $self = shift;
    $self->do("CREATE TABLE $config " .
	      '(parameter varchar(255) NOT NULL, ' .
	      'value varchar(255), ' .
	      'PRIMARY KEY (parameter));')
        or $self->mydie('create_config_table',
			"Couldn't create table $config: $DBI::errstr");
    # we just created the table: this is the current version
    $self->setconfig('version', $DB_VERSION);
}

sub create_optin_domain_table($) {
    my $self = shift;
    $self->do("CREATE TABLE $optin_domain " .
	      '(domain varchar(255) NOT NULL, ' .
	      'PRIMARY KEY (domain));')
	or $self->mydie('create_optin_domain_table',
			"Couldn't create table $optin_domain: $DBI::errstr");
}

sub create_optin_email_table($) {
    my $self = shift;
    $self->do("CREATE TABLE $optin_email " .
	      '(email varchar(255) NOT NULL, ' .
	      'PRIMARY KEY (email));')
	or $self->mydie('create_optin_email_table',
			"Couldn't create table $optin_email: $DBI::errstr");
}

sub create_optout_domain_table($) {
    my $self = shift;
    $self->do("CREATE TABLE $optout_domain " .
	      '(domain varchar(255) NOT NULL, ' .
	      'PRIMARY KEY (domain));')
	or $self->mydie('create_optout_domain_table',
			"Couldn't create table $optout_domain: $DBI::errstr");
}

sub create_optout_email_table {
    my $self = shift;
    $self->do("CREATE TABLE $optout_email " .
	      '(email varchar(255) NOT NULL, ' .
	      'PRIMARY KEY (email));')
	or $self->mydie('create_optout_email_table',
			"Couldn't create table $optout_email: $DBI::errstr");
}

##########
## Misc ##
##########

# don't try too hard to do exact matches here
sub is_ipv4($) {
    my $addr = shift;
    return (($addr =~ /^[\d\.]*$/) ? 1 : 0);
}

sub is_ipv6($) {
    my $addr = shift;
    return (($addr =~ /^[0123456789abcdef:]*$/) ? 1 : 0);
}

sub class_c($) {
    my $addr = shift;
    if (is_ipv4($addr)) {
	return join('.', (split(/\./, $addr))[0..2]);
    } elsif (is_ipv6($addr)) {
	my @splitted = split(/:/, $addr);
	return join(':', $splitted[0 .. ($#splitted - 2)]);
    } else {
	# don't know, don't touch...
	return $addr;
    }
}

sub get_last_addr_part($) {
    my $addr = shift;
    if (is_ipv4($addr)) {
	return (split(/\./, $addr))[3];
    } elsif (is_ipv6($addr)) {
	my @splitted = split(/:/, $addr);
	return $splitted[$#splitted - 1];
    } else {
	# don't know...
	return undef;
    }
}

#################
## Normalizers ##
#################

# generic single-use addresses
# normaliser
sub deverp_user($$) {
    my ($user, $rcpt) = @_;

    ## Try to match single-use addresses
    # SRS (first and subsequent levels of forwarding)
    $user =~ s/^srs0=[^=]+=[^=]+=([^=]+)=([^=]+)$/srs0=#=#=$1=$2/;
    $user =~ s/^srs1=[^=]+=([^=]+)(=+)[^=]+=[^=]+=([^=]+)=([^=]+)$/srs1=#=$1$2#=#=$3=$4/;

    # strip extension, used sometimes for mailing-list VERP
    $user =~ s/\+.*//;

    ## BATV
    # eliminate recipient put in originator
    my $dot_sep_re = '[\.\*-]+';
    my $at_sep_re = '[=\?\*~\.]+';
    my ($rcpt_lhs, $rcpt_rhs) = split /\@/, $rcpt, 2;

    # quote all pattern metacharacters and replace '.' with match of possible separators
    $rcpt_lhs = join $dot_sep_re, map { "\Q$_\E"}  split /\./, $rcpt_lhs;
    $rcpt_rhs = join $dot_sep_re, map { "\Q$_\E"}  split /\./, $rcpt_rhs;

    # build pattern with the 3 alternatives to match recipient in originator
    # BATV implementations use third or first alternative (first by abuse.net)
    my $pat = qr/$rcpt_lhs$at_sep_re$rcpt_rhs|$rcpt_rhs$at_sep_re$rcpt_lhs|$rcpt_lhs/;

    # replace address with capital RCPT to be safe with deletes
    # (MySQL matches case insensitive unfortunately)
    $user =~ s/(?<=[\*=\.-])$pat|$pat(?=[\*=\.-])/RCPT/;

    # strip frequently used bounce/return masks
    $user =~ s/((bo|bounce|notice-return|notice-reply)[\._-])[0-9a-z-_\.]+$/$1#/g; # Added by JR

    # strip hexadecimal sequences
    # at the beginning only if user will contain at least 4 consecutive alpha chars
    $user =~ s/^[0-9a-f]{2,}(?=[._\/=-].*[a-z]{4,})|(?<=[._\/=-])[0-9a-f]+(?=[._\/=-]|$)/#/g;

    return $user;
}

# returns:
# 1/ sender's user
# 2/ sender's domain
# 3/ sender's deverped address
sub normalize_sender($$$) {
    my $self = shift;
    my $from = lc shift;
    my $rcpt = lc shift;
    my $empty = '-undef-';
    if ($from eq '') {
        # Probably MAILER-DAEMON talking to us
        return ($empty,$empty,$empty)
    }
    my ($user, $domain) = split(/@/, $from, 2);
    # undefined user or domain can jeopardize SELECTs result
    # replace with invalid user/domain strings
    if (! defined $domain) {
        $domain = $empty;
        # log : shouldn't happen
        $self->mylog('martians', 2, "undefined domain, from is '$from'");
    }
    if (! defined $user) {
        $user = $empty;
        # log : shouldn't happen
        $self->mylog('martians', 2, "undefined user, from is '$from'");
    }

    # per RFC, user should be < 64, domain < 255
    # our database schema doesn't support more
    return (substr($user, 0, 64),substr($domain, 0, 255),
	    substr(deverp_user($user, $rcpt), 0, 64));
}

# make sure rcpt will be VARCHAR storable
sub normalize_rcpt($$) {
    my $self = shift;

    # trim to 255 chars ( although "$user" . "@" . "$domain"
    # can be 64 + 1 + 255, VARCHAR is 255 max)
    return substr(lc shift, 0, 255);
}

##########################################
## Grey listing related database access ##
##########################################

#########
## AWLs

## Match connections to AWLs ##

sub is_in_from_awl($$$$) {
    my ($self, $sender_name, $sender_domain, $host) = @_;

    # last_seen less than $self->{sqlgrey}{awl_age} days ago
    my $sth = $self->prepare("SELECT 1 FROM $from_awl " .
			     'WHERE sender_name = ? ' .
			     'AND sender_domain = ? ' .
			     'AND src = ? ' .
			     'AND last_seen > ' .
			     $self->past_tstamp($self->{sqlgrey}{awl_age},
						'DAY')
			    );
    if (!defined $sth or !$sth->execute($sender_name, $sender_domain, $host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $from_awl table: $DBI::errstr");
        return 1; # in doubt, accept
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	return 0; # not a single entry
    } else {
	return 1; # one single entry (no multiple entries by design)
    }
}

sub is_in_domain_awl($$$) {
    my ($self, $sender_domain, $host) = @_;

    # last_seen less than $self->{sqlgrey}{awl_age} days ago
    my $sth = $self->prepare("SELECT 1 FROM $domain_awl " .
			     'WHERE sender_domain = ? ' .
			     'AND src = ? ' .
			     'AND last_seen > ' .
			     $self->past_tstamp($self->{sqlgrey}{awl_age},
						'DAY')
			    );
    if (!defined $sth or !$sth->execute($sender_domain, $host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $domain_awl table: $DBI::errstr");
        return 1; # in doubt, accept
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	return 0; # not a single entry
    } else {
	return 1; # one single entry (no multiple entries by design)
    }
}

## Put entries in AWLs ##

sub put_in_from_awl($$$$$) {
    my ($self, $sender_name, $sender_domain, $host, $first_seen) = @_;

    # delete old entries
    $self->do("DELETE FROM $from_awl " .
	      'WHERE sender_name = ' . $self->quote($sender_name) .
	      ' AND sender_domain = ' . $self->quote($sender_domain) .
	      ' AND src = ' . $self->quote($host));

    # create new entry
    $self->do("INSERT INTO $from_awl (sender_name, sender_domain, " .
	      'src, first_seen, last_seen) VALUES(' .
	      $self->quote($sender_name) . ',' .
	      $self->quote($sender_domain) . ',' .
	      $self->quote($host) . ',' .
	      $self->quote($first_seen) . ',NOW())');
}

sub put_in_domain_awl($$$$) {
    my ($self, $sender_domain, $host, $first_seen) = @_;

    # delete old entries
    $self->do("DELETE FROM $domain_awl " .
	      'WHERE sender_domain = ' . $self->quote($sender_domain) .
	      ' AND src = ' . $self->quote($host));

    # create new entry
    $self->do("INSERT INTO $domain_awl (sender_domain, src, " .
	      'first_seen, last_seen) VALUES(' .
	      $self->quote($sender_domain) . ',' .
	      $self->quote($host) . ',' .
	      $self->quote($first_seen) . ',NOW())');
}

## Update AWL entries ##

sub update_from_awl($$$$) {
    my ($self, $sender_name, $sender_domain, $host) = @_;

    $self->do("UPDATE $from_awl " .
	      'SET last_seen = NOW(), first_seen = first_seen ' .
	      'WHERE sender_name = ' . $self->quote($sender_name) .
	      ' AND sender_domain = ' . $self->quote($sender_domain) .
	      ' AND src = ' . $self->quote($host));
}

sub update_domain_awl($$$) {
    my ($self, $sender_domain, $host) = @_;

    $self->do("UPDATE $domain_awl " .
	      'SET last_seen = NOW(), first_seen = first_seen ' .
	      'WHERE sender_domain = ' . $self->quote($sender_domain) .
	      ' AND src = ' . $self->quote($host));
}

# check from_awl entries for a domain/IP
sub count_from_awl($$$) {
    my ($self, $sender_domain, $host) = @_;

    my $sth = $self->prepare_cached("SELECT COUNT(*) FROM $from_awl " .
				    'WHERE sender_domain = ? AND src = ?');
    if (!defined $sth or !$sth->execute($sender_domain, $host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $from_awl table: $DBI::errstr");
        return 0; # do as if table is empty
    } else {
	$self->db_available();
    }

    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('dbaccess', 0, 'error: unexpected SQL result (count_from_awl)');
	return 0; # do as if table is empty
    } else {
        return $result->[0][0];
    }
}

# Check number of entries from a given IP in domain_awl
sub count_src_domain_awl($$) {
    my ($self, $host) = @_;

    my $sth = $self->prepare_cached("SELECT COUNT(*) FROM $domain_awl " .
				    'WHERE src = ?');
    if (!defined $sth or !$sth->execute($host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $domain_awl table: $DBI::errstr");
        return 0; # do as if table is empty
    } else {
	$self->db_available();
    }

    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('dbaccess', 0, 'error: unexpected SQL result (count_src_domain_awl)');
	return 0; # do as if table is empty
    } else {
        return $result->[0][0];
    }
}

# Check number of entries from a given IP in from_awl
sub count_src_from_awl($$) {
    my ($self, $host) = @_;

    my $sth = $self->prepare_cached("SELECT COUNT(*) FROM $from_awl " .
				    'WHERE src = ?');
    if (!defined $sth or !$sth->execute($host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $from_awl table: $DBI::errstr");
        return 0; # do as if table is empty
    } else {
	$self->db_available();
    }

    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('dbaccess', 0, 'error: unexpected SQL result (count_src_from_awl)');
	return 0; # do as if table is empty
    } else {
        return $result->[0][0];
    }
}

# Check number of entries from a given IP in connect
sub count_src_connect($$) {
    my ($self, $host) = @_;

    my $sth = $self->prepare_cached("SELECT COUNT(*) FROM $connect " .
				    'WHERE src = ?');
    if (!defined $sth or !$sth->execute($host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $connect table: $DBI::errstr");
        return 0; # do as if table is empty
    } else {
	$self->db_available();
    }

    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('dbaccess', 0, 'error: unexpected SQL result (count_src_connect)');
	return 0; # do as if table is empty
    } else {
        return $result->[0][0];
    }
}

## Cleanup AWL entries ##

sub cleanup_from_awl($) {
    my ($self) = @_;

    my $rows = $self->do("DELETE FROM $from_awl " .
                	 'WHERE last_seen < ' .
	                 $self->past_tstamp($self->{sqlgrey}{awl_age}, 'DAY')
	                );

    $rows = 0 if (!defined $rows or $rows eq '0E0');
    return $rows;
}

sub cleanup_domain_awl($) {
    my ($self) = @_;

    my $rows = $self->do("DELETE FROM $domain_awl " .
	                 'WHERE last_seen < ' .
	                 $self->past_tstamp($self->{sqlgrey}{awl_age}, 'DAY')
	                );

    $rows = 0 if (!defined $rows or $rows eq '0E0');
    return $rows;
}

sub delete_domain_from_mail_awl($$$) {
    my ($self, $domain, $host) = @_;
    $self->do("DELETE FROM $from_awl " .
	      'WHERE sender_domain = ' . $self->quote($domain) .
	      ' AND src = ' . $self->quote($host));
}

sub delete_domain_from_connect($$$) {
    my ($self, $domain, $host) = @_;
    $self->do("DELETE FROM $connect " .
	      'WHERE sender_domain = ' . $self->quote($domain) .
	      ' AND src = ' . $self->quote($host));
}

# Active domain AWL for a domain/IP
sub move_domain_from_mail_to_domain_awl($$$) {
    my ($self, $domain, $host) = @_;

    my $first_seen = $self->get_first_seen_in_from_awl($domain, $host);
    $self->put_in_domain_awl($domain, $host, $first_seen);
    $self->delete_domain_from_mail_awl($domain, $host);
}

sub get_first_seen_in_from_awl($$$) {
    my ($self, $domain, $host) = @_;
    my $sth = $self->prepare_cached("SELECT MIN(first_seen) FROM $from_awl " .
				    'WHERE sender_domain = ? AND src = ?');

    if (!defined $sth or !$sth->execute($domain, $host)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $from_awl table: $DBI::errstr");
        return 0; # do as if table is empty
    } else {
	$self->db_available();
    }

    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
        $self->mylog('grey', 0, 'error: unexpected SQL result (get_first_seen_in_from_awl)');
	return 0; # do as if table is empty
    } else {
        return $result->[0][0];
    }
}

############
## Connect

# check for a valid reconnection
sub in_connect($$$$$) {
    my ($self, $sender_name, $sender_domain, $addr, $rcpt) = @_;

    # last_seen less than $self->{sqlgrey}{max_connect_age} hours ago
    # but more than $self->{sqlgrey}{reconnect_delay} minutes ago
    my $sth = $self->prepare("SELECT 1 FROM $connect " .
			     'WHERE sender_name = ? AND sender_domain = ? ' .
			     'AND src = ? AND rcpt = ? ' .
			     'AND first_seen BETWEEN ' .
			     $self->past_tstamp($self->{sqlgrey}{max_connect_age},
						'HOUR') .
			     ' AND ' .
			     $self->past_tstamp($self->{sqlgrey}{reconnect_delay},
						'MINUTE')
			    );
    if (!defined $sth or !$sth->execute($sender_name, $sender_domain, $addr, $rcpt)) {
	$self->db_unavailable();
        $self->mylog('dbaccess', 0, "error: couldn't access $connect table: $DBI::errstr");
        return 1; # in doubt, accept
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result < 0) {
	return 0; # not a single entry
    } else {
	return 1; # at least one entry
    }
}

# check for early reconnection
sub recently_in_connect($$$$$) {
    my ($self, $sender_name, $sender_domain, $addr, $rcpt) = @_;

    # last_seen less than $self->{sqlgrey}{reconnect_delay} minutes ago
    my $sth = $self->prepare("SELECT 1 FROM $connect WHERE sender_name = ? " .
			     'AND sender_domain = ? ' .
			     'AND src = ? AND rcpt = ? ' .
			     'AND first_seen >= ' .
			     $self->past_tstamp($self->{sqlgrey}{reconnect_delay},
						'MINUTE')
			     );
    if (!defined $sth or !$sth->execute($sender_name, $sender_domain, $addr, $rcpt)) {
	$self->db_unavailable();
        $self->mylog('dbaccess', 0, "error: Couldn't access $connect table: $DBI::errstr");
        return 0; # in doubt, accept
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result < 0) {
	return 0; # not a single entry
    } else {
	return 1; # at least one entry
    }
}

# add a first attempt
sub put_in_connect($$$$$) {
    my ($self, $sender_name, $sender_domain, $addr, $rcpt) = @_;

    # create new entry
    $self->do("INSERT INTO $connect (sender_name, sender_domain, " .
	      'src, rcpt, first_seen) ' .
	      'VALUES(' .
	      $self->quote($sender_name) . ',' .
	      $self->quote($sender_domain) . ',' .
	      $self->quote($addr) . ',' .
	      $self->quote($rcpt) . ', NOW())');
}

# For logging purpose
sub get_reconnect_delay($$$$$) {
    my ($self, $sender_name, $sender_domain, $addr, $rcpt) = @_;

    my $query;
    if ($self->MySQL()) {
        $query = 'SELECT first_seen, SEC_TO_TIME(UNIX_TIMESTAMP(NOW())-' .
	    'UNIX_TIMESTAMP(first_seen)) ' .
		"FROM $connect ";
    } else {
        $query = "SELECT first_seen, now() - first_seen FROM $connect ";
    }
    $query .= 'WHERE sender_name = ? AND sender_domain = ? ' .
	      'AND src = ? AND rcpt = ?';
    my $sth = $self->prepare_cached($query);
    if (!defined $sth or !$sth->execute($sender_name, $sender_domain,
					$addr, $rcpt)) {
	$self->db_unavailable();
        $self->mylog('dbaccess', 0, "error: couldn't get reconnect delay: $DBI::errstr");
        return 'sql error';
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result < 0) {
        $self->mylog('grey', 0, 'get_reconnect_delay error: no connect in database for ' .
		      "$sender_name\@$sender_domain, $addr, $rcpt");
	return 'error: nothing in connect';
    } else {
        return $result->[0][0], $result->[0][1];
    }
}

# Clean connect entries for a whitelisted mail/IP
sub delete_mail_ip_from_connect($$$$) {
    my ($self, $deverp_sender_name, $sender_domain, $addr) = @_;

    $deverp_sender_name =~ s/#/%/g;

    $self->do("DELETE FROM $connect " .
	      'WHERE src = ' . $self->quote($addr) .
	      ' AND sender_domain = ' . $self->quote($sender_domain) .
	      ' AND sender_name LIKE ' . $self->quote($deverp_sender_name) );
}

# clean probable SPAM attempts and log them
sub cleanup_connect($) {
    my $self = shift;
    my $tstamp = $self->past_tstamp($self->{sqlgrey}{max_connect_age}, 'HOUR');

    if ($self->{sqlgrey}{log}{spam} >= 2) {
        # Print probable SPAM:
        my $sth = $self->prepare('SELECT sender_name, sender_domain, src, ' .
				 'rcpt, first_seen ' .
				 "FROM $connect " .
				 'WHERE first_seen < ' .
				 $tstamp);
        if (defined $sth and $sth->execute()) {
	    $self->db_available();
	    my $result = $sth->fetchall_arrayref();
	    for my $spam (@{$result}) {
	        $self->mylog('spam', 2, "$$spam[2]: " .
	   	           "$$spam[0]\@$$spam[1] -> " .
		           "$$spam[3] at $$spam[4]");
	    }
        } else {
	    $self->db_unavailable();
	    $self->mylog('dbaccess', 0,
			 "error: couldn't list detected spam attempts: $DBI::errstr");
        }
    }
    my $rows = $self->do("DELETE FROM $connect " .
	                 'WHERE first_seen < ' .
	                 $tstamp
	                );

   # DBI returns 0E0 if no rows is affected.
   $rows = 0 if (!defined $rows or $rows eq '0E0');

   return $rows;
}

## Choose the actual cleanup method
sub start_cleanup {
    my $self = shift;

    if ($dflt{dont_db_clean}) {
            $self->mylog('conf', 2, "This host has db-cleaning disabled");
            return;
    }

    if ($self->{sqlgrey}{clean_method} eq 'sync') {
        $self->cleanup();
    } else {
        $self->fork_cleanup();
    }
}


## Synchronous cleanup
sub cleanup($) {
    my ($self) = @_;
    my $time = time();
    my $frows = $self->cleanup_from_awl();
    my $drows = $self->cleanup_domain_awl();
    my $crows = $self->cleanup_connect();
    $time = time() - $time;
    $self->mylog('perf', 2, 'spent ' . $time . "s cleaning: from_awl ($frows) domain_awl ($drows) connect ($crows)");
}

## Forked cleanup
sub fork_cleanup($) {
    my $self = shift;
    my $pid = fork();
    if (!defined $pid) {
	$self->mylog('system', 0, 'couldn\'t fork child: no cleanup!');
    } elsif ($pid == 0) { # child
	$self->mylog('system', 3, "forked cleanup child ($$)");
	# we *WANT* a new DB connection or we will delay other processings
	# or worse send garbage to the DB
	$self->connectdb();
	$self->{sqlgrey}{dbh}{InactiveDestroy} = 0;
	$self->cleanup();
	# we don't want nasty error messages saying we should have destroyed
	# an out-of-scope dbh
	$self->disconnectdb();
	$self->mylog('system', 3, "cleanup child exit ($$)");
	exit;
    }
}

##################
## Whitelisting ##
##################

sub init_whitelists($) {
    my $self = shift;
    $self->read_ip_whitelists();
    $self->read_fqdn_whitelists();
    # check dynamic files' mtime
    $self->{sqlgrey}{dyniptime} = get_mtime($dyn_ip_whitelist_file);
    $self->{sqlgrey}{dynfqdntime} = get_mtime($dyn_fqdn_whitelist_file);
}

sub read_ip_whitelists($) {
    my $self = shift;
    $self->read_static_ip_whitelist();
    $self->read_dyn_ip_whitelist();
}

sub read_fqdn_whitelists($) {
    my $self = shift;
    $self->read_static_fqdn_whitelist();
    $self->read_dyn_fqdn_whitelist();
}

sub read_static_ip_whitelist($) {
    my $self = shift;
    $self->{sqlgrey}{stat_ip_whitelist} =
	$self->read_an_ip_whitelist($stat_ip_whitelist_file);
}

sub read_dyn_ip_whitelist($) {
    my $self = shift;
    $self->{sqlgrey}{dyn_ip_whitelist} =
	$self->read_an_ip_whitelist($dyn_ip_whitelist_file);
}

sub read_an_ip_whitelist($$) {
    my $self = shift;
    my $file = shift;
    # Prepare empty whitelist
    my $whitelist;
    $whitelist->{IP} = {};
    $whitelist->{C} = {};
    if (! open (FILE, '<' . $file)) {
	$self->mylog('conf', 1, "warning: $file not found or unreadable");
	return $whitelist;
    }
    while (<FILE>) {
	chomp;
	# strip comments
	s/#.*//;
	# strip spaces
	s/\s+//;
	# Anything left ?
	next unless length;
	if (/^\d+\.\d+\.\d+\.\d+$/) {
	    $whitelist->{IP}{$_} = '';
	    next;
	} elsif (/^\d+\.\d+\.\d+$/) {
	    $whitelist->{C}{$_} = '';
	    next;
	} else {
	    $self->mylog('conf', 0, "unrecognised line in $file: $_");
	}
    }
    close FILE;
    return $whitelist;
}

sub read_static_fqdn_whitelist($) {
    my $self = shift;
    $self->{sqlgrey}{stat_fqdn_whitelist} =
	$self->read_an_fqdn_whitelist($stat_fqdn_whitelist_file);
}

sub read_dyn_fqdn_whitelist($) {
    my $self = shift;
    $self->{sqlgrey}{dyn_fqdn_whitelist} =
	$self->read_an_fqdn_whitelist($dyn_fqdn_whitelist_file);
}

sub read_an_fqdn_whitelist($$) {
    my $self = shift;
    my $file = shift;

    # Prepare empty whitelists
    my $whitelist;
    my @re_whitelist;
    my @domain_whitelist;
    my $system_whitelist;

    if (! open (FILE, '<' . $file)) {
	$self->mylog('conf', 1, "warning: $file not found or unreadable");
	$whitelist->{system} = $system_whitelist;
	$whitelist->{domain} = \@domain_whitelist;
	$whitelist->{regexp} = \@re_whitelist;
	return $whitelist;
    }
    while (<FILE>) {
	chomp;
	# strip comments and whitespaces
	s/#.*//; s/\s+//;
	# Anything left ?
	next unless length;
	if (/\/(\S+)\/$/) { # regexp, we use qr// to compile them here
	    push @re_whitelist, qr/$1/;
	} elsif (/^\*\.(.*$)/) { # whole domain
	    push @domain_whitelist, $1;
	} elsif (/^([\w-]+\.)+[\w-]+$/) { # looks like a system name
	    $system_whitelist->{$_} = 1;
	} else {
	    $self->mylog('conf', 0, "unrecognised line in $file: $_");
	}
    }
    close FILE;
    $whitelist->{system} = $system_whitelist;
    $whitelist->{domain} = \@domain_whitelist;
    $whitelist->{regexp} = \@re_whitelist;
    return $whitelist;
}

sub update_dyn_whitelists($) {
    my $self = shift;
    $self->update_dyn_ip_whitelist();
    $self->update_dyn_fqdn_whitelist();
}

# Set the reload flag
sub mark_reload_request() {
    $reload = 1;
}

# When not in the middle of a processing...
# check the reload flag
sub got_reload_request() {
    my $myreload = ($reload == 1);
    $reload = 0;
    return ($myreload);
}

sub update_static_whitelists($) {
    my $self = shift;
    $self->read_static_ip_whitelist();
    $self->read_dyn_fqdn_whitelist();
}

sub get_mtime($) {
    my $file = shift;
    # file exists ?
    if (stat($file)) {
	# return mtime
	return (stat(_))[9];
    } else {
	return 0;
    }
}

sub update_dyn_ip_whitelist($) {
    my $self = shift;
    my $dyntime = get_mtime($dyn_ip_whitelist_file);
    if ($dyntime > $self->{sqlgrey}{dyniptime}) {
	$self->mylog('whitelist', 3, "reloading $dyn_ip_whitelist_file");
	$self->{sqlgrey}{dyniptime} = $dyntime;
	$self->read_dyn_ip_whitelist();
    }
}

sub update_dyn_fqdn_whitelist($) {
    my $self = shift;
    my $dyntime = get_mtime($dyn_fqdn_whitelist_file);
    if ($dyntime > $self->{sqlgrey}{dynfqdntime}) {
	$self->mylog('whitelist', 3, "reloading $dyn_fqdn_whitelist_file");
	$self->{sqlgrey}{dynfqdntime} = $dyntime;
	$self->read_dyn_fqdn_whitelist();
    }
}

sub is_in_whitelists($$$$$$) {
    ## expects all parameters
    ## for rcpt_whitelists for example
    my ($self, $sender_name, $sender_domain, $ip, $fqdn, $rcpt) = @_;
    return ($self->is_in_ip_whitelists($ip) or
	$self->is_in_fqdn_whitelists($fqdn));
}

sub is_in_ip_whitelists($$) {
    my ($self, $ip) = @_;
    return ($self->is_in_static_ip_whitelist($ip)
	or $self->is_in_dyn_ip_whitelist($ip));
}

sub is_in_fqdn_whitelists($$) {
    my ($self, $fqdn) = @_;
    return ($self->is_in_static_fqdn_whitelist($fqdn)
	or $self->is_in_dyn_fqdn_whitelist($fqdn));
}

sub is_in_static_ip_whitelist($$) {
    my ($self, $ip) = @_;
    if (defined $self->{sqlgrey}{stat_ip_whitelist}->{IP}{$ip}) {
	$self->mylog('whitelist', 3, "$ip in static IP whitelist");
	return 1;
    }
    if (defined $self->{sqlgrey}{stat_ip_whitelist}->{C}{class_c($ip)}) {
	$self->mylog('whitelist', 3, "$ip in static class-C whitelist");
	return 1;
    }
    return 0;
}

sub is_in_dyn_ip_whitelist($$) {
    my ($self, $ip) = @_;
    if (defined $self->{sqlgrey}{dyn_ip_whitelist}->{IP}{$ip}) {
	$self->mylog('whitelist', 3, "$ip in dynamic IP whitelist");
	return 1;
    }
    if (defined $self->{sqlgrey}{dyn_ip_whitelist}->{C}{class_c($ip)}) {
	$self->mylog('whitelist', 3, "$ip in dynamic class-C whitelist");
	return 1;
    }
    return 0;
}

sub is_in_static_fqdn_whitelist($$) {
    my ($self, $fqdn) = @_;
    return $self->is_in_fqdn_whitelist($fqdn,
				       $self->{sqlgrey}{stat_fqdn_whitelist},
				       'static');
}

sub is_in_dyn_fqdn_whitelist($$) {
    my ($self, $fqdn) = @_;
    return $self->is_in_fqdn_whitelist($fqdn,
				       $self->{sqlgrey}{dyn_fqdn_whitelist},
				       'dynamic');
}

sub is_in_fqdn_whitelist($$$$) {
    my ($self, $fqdn, $whitelist, $type) = @_;
    # check hostnames
    if (defined $whitelist->{system}->{$fqdn}) {
	$self->mylog('whitelist', 3, "$fqdn in $type whitelist");
	return 1;
    }
    # check domains
    foreach my $domain (@{$whitelist->{domain}}) {
	if ($fqdn =~ /\.$domain$/) {
	    $self->mylog('whitelist', 3, "$fqdn: $domain domain in $type whitelist");
	    return 1;
	}
    }
    # check regexps
    foreach my $regexp (@{$whitelist->{regexp}}) {
	if ($fqdn =~ $regexp) {
	    $self->mylog('whitelist', 3, "$fqdn: match $type whitelist regexp");
	    return 1;
	}
    }
    # Nothing matches
    return 0;
}

####################
## Optin / Optout ##
####################

sub greylisting_active($$) {
    my ($self, $email) = @_;
    my $domain = (split(/@/, $email))[1];
    if ($self->{sqlgrey}{optmethod} eq 'optin') {
	return (
		($self->is_in_optin_domain($domain) and
		 not $self->is_in_optout_email($email))
		or
		$self->is_in_optin_email($email)
		);
    } elsif ($self->{sqlgrey}{optmethod} eq 'optout') {
 	return not (
		($self->is_in_optout_domain($domain) and
		 not $self->is_in_optin_email($email))
		or
		$self->is_in_optout_email($email)
		);
    } else {
	return 1;
    }
}

sub is_in_optin_domain($$) {
    my ($self, $domain) = @_;

    my $sth = $self->prepare_cached("SELECT 1 FROM $optin_domain " .
				    'WHERE domain = ?');
    if (!defined $sth or !$sth->execute($domain)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $optin_domain table: $DBI::errstr");
        return 0; # in doubt, no greylisting
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	$self->mylog('optin', 4, "$domain not in $optin_domain");
	return 0; # not a single entry
    } else {
	$self->mylog('optin', 4, "$domain in $optin_domain");
	return 1; # one single entry (no multiple entries by design)
    }
}

sub is_in_optin_email($$) {
    my ($self, $email) = @_;

    my $sth = $self->prepare_cached("SELECT 1 FROM $optin_email " .
				    'WHERE email = ?');
    if (!defined $sth or !$sth->execute($email)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $optin_email table: $DBI::errstr");
        return 0; # in doubt, no greylisting
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	$self->mylog('optin', 4, "$email not in $optin_email");
	return 0; # not a single entry
    } else {
	$self->mylog('optin', 4, "$email in $optin_email");
	return 1; # one single entry (no multiple entries by design)
    }
}

sub is_in_optout_domain($$) {
    my ($self, $domain) = @_;

    my $sth = $self->prepare_cached("SELECT 1 FROM $optout_domain " .
				    'WHERE domain = ?');
    if (!defined $sth or !$sth->execute($domain)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $optout_domain table: $DBI::errstr");
        return 1; # in doubt, no greylisting
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	$self->mylog('optin', 4, "$domain not in $optout_domain");
	return 0; # not a single entry
    } else {
	$self->mylog('optin', 4, "$domain in $optout_domain");
	return 1; # one single entry (no multiple entries by design)
    }
}

sub is_in_optout_email($$) {
    my ($self, $email) = @_;

    my $sth = $self->prepare_cached("SELECT 1 FROM $optout_email " .
				    'WHERE email = ?');
    if (!defined $sth or !$sth->execute($email)) {
	$self->db_unavailable();
	$self->mylog('dbaccess', 0, "error: couldn't access $optin_email table: $DBI::errstr");
        return 1; # in doubt, no greylisting
    } else {
	$self->db_available();
    }
    my $result = $sth->fetchall_arrayref();
    if ($#$result != 0) {
	$self->mylog('optin', 4, "$email not in $optout_email");
	return 0; # not a single entry
    } else {
	$self->mylog('optin', 4, "$email in $optout_email");
	return 1; # one single entry (no multiple entries by design)
    }
}

################################
## Discriminating Greylisting ##
################################

sub init_discrimination($) {
    my $self = shift;
    
    # If discimination is enabled, load the regexps and
    # convert configuration value into a 1/0 (true/false) value
    if ($dflt{discrimination} =~ m/on/i) {
            $dflt{discrimination}=1;
            $dflt{discrimination_add_rulenr}= ($dflt{discrimination_add_rulenr}=~ m/on/i) ? 1 : 0;
            
	    $self->read_discrimination_regexp(); #Read regexp file
    } else {
            $dflt{discrimination}=0;
    }    
}


sub read_discimination_regexp_file($$) {
    my $self = shift;
    my $file = shift;

    my ($data);
    if (! open (REGEXP, '<' . $file)) {
	$self->mylog('conf', 0, "error: $file not found or unreadable");
	return '.'; # fallback regexp
    } else {
	my $count = 0;
	while (<REGEXP>) {
	    chomp; 
	    s/#.*//; # Remove comments
	    if (m/(\w+)\s*(?:([=!])[~=]?)\s*(.*?)\s*$/) { # capture attrib-name, comparison-operater (as = or !) and regex
	        $data->{$1}->{++$count}->{oper} = $2;     	    # Store the data in a hash (attrib-name => comparison-operator)
	        $data->{$1}->{$count}->{regex} = qr/$3/; 	    # Store the data in a hash (attrib-name => compiled regex)
	    } elsif (!m/^\s*$/) {
	         $self->mylog('conf', 1, "Skipping invalid line in discrimination file: $_\n");
	    }	    
	}
	close REGEXP;
	if ($count > 1) {
	    $self->mylog('conf', 1, "Read $count discrimination regexp's from $file");
	}
	return $data;
    }
}

sub read_discrimination_regexp($) {
    my $self = shift;
    $self->{sqlgrey}{discrimination_re} =
	$self->read_discimination_regexp_file($discrimination_regexp_file);
}

# Check the attr fields delivered by postfix against the regexps.
# If nothing matches, greylisting is skipped.
sub discriminate_check($$) {
    my ($self, $attr)  = @_; 
    my $hash  = $self->{sqlgrey}{discrimination_re};
    my $match = 0;
    
    keys %$hash; #This resets the hash. I have no idea why the iteration counter isnt reset upon leaving this function
  
    #Loop loaded expressions
    while ( my ($var,$data) = each(%$hash)) {
      keys %$data; # reset hash
      
      while ( my ($rulenr,$regex) = each(%$data)) {
           
           if (!defined $attr->{$var}) {
                 $self->mylog('conf', 3 , "Discrimination attrib '$var' unsupported by postfix. Skipping.");
                 next;
           }
           
           if ($regex->{oper} eq '=') { $match=1 if ($attr->{$var} =~ $regex->{regex}); } #if var equal to regex
           if ($regex->{oper} eq '!') { $match=1 if ($attr->{$var} !~ $regex->{regex}); } #if var not equal to regex
           
           if ($match) {
                   $self->mylog('conf', 3 , "Discrimination verdict: Greylist");
                   $self->mylog('conf', 3 , "Discrimination check: $var $regex->{oper}~ $regex->{regex}");
                   return $rulenr;
           }
      }
    }
    $self->mylog('conf', 3 , "Discrimination verdict: Dont Greylist ");
    return 0; #default DONT greylist
}

#################################
## Regexps for smart algorithm ##
#################################

sub init_smart_regexps($) {
    my $self = shift;
    $self->read_smtp_server_regexp();
    $self->read_dyn_fqdn_regexp();
}

sub read_a_regexp($$) {
    my $self = shift;
    my $file = shift;

    my $regexp;
    if (! open (REGEXP, '<' . $file)) {
	$self->mylog('conf', 0, "error: $file not found or unreadable");
	return '.'; # fallback regexp
    } else {
	# we expect only one line
	my $count = 0;
	while (<REGEXP>) {
	    chomp;
	    # compile the regexp
	    $regexp = qr/$_/i;
	    $count++;
	}
	close REGEXP;
	if ($count > 1) {
	    $self->mylog('conf', 1, "warning: more than one line in $file," .
			 'took only last one');
	}
	return $regexp;
    }
}

sub read_smtp_server_regexp($) {
    my $self = shift;
    $self->{sqlgrey}{smtp_server_re} =
	$self->read_a_regexp($smtp_server_regexp_file);
}

sub read_dyn_fqdn_regexp($) {
    my $self = shift;
    $self->{sqlgrey}{dyn_fqdn_re} =
	$self->read_a_regexp($dyn_fqdn_regexp_file);
}


## client_identifier can be its IP-address or the class-C network
## we decide here
sub client_identifier($$$) {
    my ($self, $addr, $fqdn) = @_;
    my $greymethod = $self->{sqlgrey}{greymethod};
    my $classc = class_c($addr);

    if ($greymethod eq 'full') {
	return $addr;
    } elsif ($greymethod eq 'classc') {
	return $classc;
    } elsif ($greymethod eq 'smart') {
	# check $fqdn
	# no fqdn, treat as suspicious
	if ($fqdn eq 'unknown') {
	    $self->mylog('grey', 3, "unknown RDNS: $addr");
	    return $addr;
	}

	# we need the last byte
	my $last_part = get_last_addr_part($addr);
	return $addr unless defined $last_part;

        # We use Michel Bouissou's Regexp Horror Museum ;-)
        # Regexp from hell ;-) that sorts out known SMTP servers patterns
        if ($fqdn =~ $self->{sqlgrey}{smtp_server_re}) {
	    $self->mylog('grey', 3, "identified SMTP server pattern: $fqdn, $addr: Using C-class ($classc).");
	    return $classc;
        }

        # Regexp from hell ;-) that sorts out known end-user / dynamic
        # pools patterns
        if ($fqdn =~
	    /(^|[0-9.x_-])((cm?|gv|h|ip|host|m|p(a|c|u)?)?0*$last_part([._-]))/i) {
	    $self->mylog('grey', 3, "identified dynamic pattern (last IP byte): $fqdn, $addr: Using full IP.");
	    return $addr;
        }

        if ($fqdn =~ $self->{sqlgrey}{dyn_fqdn_re}) {
	    $self->mylog('grey', 3, "identified dynamic pattern (name): $fqdn, $addr: Using full IP.");
	    return $addr;
        }

	# If not specifically identified as dynamic, return C-Class address
        $self->mylog('grey', 3, "unknown pattern: $fqdn, $addr: using C-class ($classc).");
	return $classc;
    }
}

# main routine:
# based on attributes specified as argument, return policy decision
sub smtpd_access_policy($$)
{
    my ($self, $attr) = @_;
    my ($discrimination_rulenr) = 0;

    # prepare lookup
    my ($sender_name,$sender_domain,$deverp_sender_name) =
	$self->normalize_sender($attr->{sender}, $attr->{recipient});
    my $recipient = $self->normalize_rcpt($attr->{recipient});
    my $addr = $attr->{client_address};
    my $fqdn = $attr->{client_name};

    # Check for new whitelists
    $self->update_dyn_whitelists();
    # Check if we got the reload signal.
    # We can't process this signal as soon as we receive it as
    # we may be using variables for which it will trigger an update
    if ($self->got_reload_request()) {
	$self->mylog('conf', 2, 'reloading static whitelists and smart regexps');
	$self->update_static_whitelists();
	$self->init_smart_regexps();
	$self->init_discrimination();
    }

    #Generate the rejection response (moved here to avoid redundancy)
    my ($reject_text) =      $self->{sqlgrey}{reject_early} . ' Greylisted for ' .
  	                     $self->{sqlgrey}{reconnect_delay} . ' minutes';

    

    # whitelist check
    if ($self->is_in_whitelists($sender_name, $sender_domain,
				$addr, $fqdn, $recipient)) {
	$self->mylog('whitelist', 2,
		     "$sender_name\@$sender_domain, $addr($fqdn) -> $recipient");
        return $self->{sqlgrey}{prepend} ?
	    $prepend . 'whitelisted by ' . $software
		: 'dunno';
    }

    # optin/optout checks
    if (! $self->greylisting_active($recipient)) {
	$self->mylog('optin', 3, "greylisting inactive for $recipient");
	return $self->{sqlgrey}{prepend} ?
	    $prepend . "greylisting inactive for $recipient in $software"
		: 'dunno';
    } else {
	$self->mylog('optin', 3, "greylisting active for $recipient");
    }

    # discrimination checks
    if ($dflt{discrimination}) { # if discrimination is enabled
              # Check if sender data lets him skip greylisting
              
              if ($discrimination_rulenr = $self->discriminate_check($attr)) { # note: Checks are run against the raw $attr fields.
                      #We DO greylist
                        # Add the rule.nr. (that is, linenumber in regexfile) of the rule that matched to response (helps the support department)
                        $reject_text.= " ($discrimination_rulenr)" if ($dflt{discrimination_add_rulenr});
              } else {
                      #We DONT greylist
                        $self->mylog('conf', 3, "Discrimination Passed check - not greylisting $addr");
                        return $self->{sqlgrey}{prepend} ?
                            $prepend . "not greylisting mail from $addr in $software"
                                : 'dunno';
              }

    }


    # this is the identifier we use in AWLs
    my $cltid = $self->client_identifier($addr, $fqdn);
    # we need the value of now() in the database
    $self->update_dbnow();
    # Is it time for cleanups ?
    if (time() > $self->{sqlgrey}{next_maint}) {
            $self->start_cleanup();
            $self->{sqlgrey}{next_maint} = time() + $self->{sqlgrey}{db_cleandelay};
    }
    # domain scale awl check
    if ($self->is_in_domain_awl($sender_domain, $cltid)) {
	$self->mylog('grey', 2, "domain awl match: updating $cltid($addr), $sender_domain");
	# update awl entry
	$self->update_domain_awl($sender_domain, $cltid);
	return $self->{sqlgrey}{prepend} ?
	    $prepend . 'domain auto-whitelisted by ' . $software
	    : 'dunno';
    }
    # address scale awl check
    if ($self->is_in_from_awl($deverp_sender_name, $sender_domain, $cltid)) {
	$self->mylog('grey', 2, "from awl match: updating $cltid($addr), " .
		      "$deverp_sender_name\@$sender_domain" .
		      "($sender_name\@$sender_domain)");
	# update awl entry
	$self->update_from_awl($deverp_sender_name, $sender_domain, $cltid);
	return $self->{sqlgrey}{prepend} ?
	    $prepend . 'from auto-whitelisted by ' . $software
	    : 'dunno';
    }
    # is it an early reconnect ?
    if ($self->recently_in_connect($sender_name, $sender_domain,
				   $cltid, $recipient)) {
        $self->mylog('grey', 2, "early reconnect: $cltid($addr), " .
	 	      "$sender_name\@$sender_domain -> $recipient");
	return $reject_text;
    }
    # is it a reconnection ?
    if ($self->in_connect($sender_name, $sender_domain, $cltid, $recipient)) {
	my ($first_seen, $delay) =
	    $self->get_reconnect_delay($sender_name, $sender_domain,
				       $cltid, $recipient);
        $self->mylog('grey', 2, "reconnect ok: $cltid($addr), $sender_name" . '@' . $sender_domain .
		      " -> $recipient ($delay)");
	# check if we have others from the same domain in the from_awl
	# add 1 for our sample and compare to the aggregation level
	if (
	    ($self->{sqlgrey}{domain_level} != 0)
	    and
	    ($self->count_from_awl($sender_domain, $cltid)+1 >=
	     $self->{sqlgrey}{domain_level})
	   ) {
	    # use domain-level AWL
	    $self->move_domain_from_mail_to_domain_awl($sender_domain,
						       $cltid);
	    $self->mylog('grey', 2, "domain awl: $cltid, $sender_domain added");
	    $self->delete_domain_from_connect($sender_domain, $cltid);
	} else {
	    # add to mail-level AWL
	    $self->mylog('grey', 2, "from awl: $cltid, $deverp_sender_name" .
			 '@' . "$sender_domain added");
	    $self->put_in_from_awl($deverp_sender_name, $sender_domain,
				   $cltid, $first_seen);
	    $self->delete_mail_ip_from_connect($deverp_sender_name, $sender_domain,
				   $cltid);
	}
	return $self->{sqlgrey}{prepend} ?
	    $prepend . "delayed $delay by $software" : 'dunno';
    }
    # Throttling too many connections from same new host
    if (defined $self->{sqlgrey}{connect_src_throttle} and $self->{sqlgrey}{connect_src_throttle} > 0) {
        if ($self->count_src_connect($cltid) >= $self->{sqlgrey}{connect_src_throttle}
	    and $self->count_src_domain_awl($cltid) < 1
	    and $self->count_src_from_awl($cltid) < $self->{sqlgrey}{connect_src_throttle}) {
	        $self->mylog('grey', 2, "throttling: $cltid($addr), $sender_name\@$sender_domain -> $recipient");
		return ($self->{sqlgrey}{reject_first} . ' Throttling too many connections from new source - ' .
		' Try again later.');
	}
    }

    # new connection
    $self->mylog('grey', 2, "new: $cltid($addr), $sender_name\@$sender_domain -> $recipient");
    $self->put_in_connect($sender_name, $sender_domain, $cltid, $recipient);
    return $reject_text;
}

sub read_conffile($)
{
    my $optional_file = shift;
    if (defined $optional_file) {
	$config_file = $optional_file;
    }

    # Check if conf file is readable if explicitly told to use one
    if (defined $optional_file) {
	open(CONF, '<' . $config_file)
	    or die "Couldn't open $config_file for reading: $!\n";
    } else {
	open(CONF, '<' . $config_file)
	    or return;
    }

    while (<CONF>) {
        chomp;          # no newline
        s/#.*//;        # no comments
        s/^\s+//;       # no leading white
        s/\s+$//;       # no trailing white
        next unless length;     # anything left ?
        my ($var, $value) = split(/\s*=\s*/, $_, 2);
        $dflt{$var} = $value;
	if (! defined $value) {
	    $dflt{$var} = 1;
	}
    }
    close CONF
	or die "Couldn't close config file $config_file\n";
    # log levels
    # 1/ use default one
    foreach my $logtype (keys %{$dflt{log}}) {
	$dflt{log}{$logtype} = $dflt{loglevel};
    }
    # 2/ apply exceptions
    if (defined $dflt{log_override}) {
	my @overrides = split(/\s*,\s*/, $dflt{log_override});
	foreach my $override (@overrides) {
	    my ($logtype, $loglevel) = split(/\s*:\s*/, $override);
	    # some simple checks
	    if (!defined $loglevel) {
		die "Invalid log_override format\n";
	    }
	    if (! defined $dflt{log}{$logtype}){
		die "Invalid logtype in log_override: $logtype\n";
	    }
	    if ($loglevel eq '0') {
		$loglevel = -1;
	    }
	    if ($loglevel !~ /\d/ || $loglevel > 4) {
		die "Invalid loglevel for $logtype: $loglevel\n";
	    }
	    $dflt{log}{$logtype} = $loglevel;
	}
    }
    # file locations
    # whitelist files
    $stat_ip_whitelist_file   = $dflt{conf_dir} . '/clients_ip_whitelist';
    $dyn_ip_whitelist_file    = $dflt{conf_dir} . '/clients_ip_whitelist.local';
    $stat_fqdn_whitelist_file = $dflt{conf_dir} . '/clients_fqdn_whitelist';
    $dyn_fqdn_whitelist_file  = $dflt{conf_dir} . '/clients_fqdn_whitelist.local';
    # regexp files
    $smtp_server_regexp_file  = $dflt{conf_dir} . '/smtp_server.regexp';
    $dyn_fqdn_regexp_file     = $dflt{conf_dir} . '/dyn_fqdn.regexp';
}

# Setup the environment
sub main()
{
    # save arguments for Net:Server HUP restart
    my @ARGV_saved = @ARGV;

    # options parsing
    my %opt = ();
    GetOptions(\%opt, 'help|h', 'man', 'version', 'configfile|f=s',
	'daemonize|d', 'kill|k')
	or exit(1);

    if ($opt{help})    { pod2usage(1) }
    if ($opt{man})     { pod2usage(-exitstatus => 0, -verbose => 2) }
    if ($opt{version}) { print "sqlgrey $VERSION\n"; exit(0) }

    # Read the config file
    read_conffile($opt{configfile});
    
    # Set some cluster specific stuff (move to an init_cluster() sub?)
    no warnings 'uninitialized'; #Perl will spew warn's if running DBI only
    if ($dflt{db_cluster} eq 'on') {
            #if loglevel >= 4, enable debugging for DBCluster
            $DBIx::DBCluster::DEBUG = ($dflt{'loglevel'}>3)?1:0;

            #Ugly hack to make perl shut up about about "possible typo".
            1 if ($DBIx::DBCluster::DEBUG);

            if ((defined $HOSTNAME) && (defined $dflt{db_cleanup_hostname})) {
                
                    if ($HOSTNAME eq $dflt{db_cleanup_hostname}) {
                          $dflt{dont_db_clean} = 0;
                    } else {
                          $dflt{dont_db_clean} = 1;
                    }
                    
                
            } else {
                    $dflt{dont_db_clean} = 0; 
            }
    }
    
    # Are we on a killing spray ?
    if (defined $opt{kill}) {
	my $pidfile = $dflt{pidfile};
	open(PIDFILE, '<' . $pidfile)
	    or die "Coudn't read pidfile: $pidfile\n";
	while (<PIDFILE>) { # should only have one pid
	    kill 15, $_;
	}
	close PIDFILE;
	unlink $pidfile;
	exit;
    }

    # bind only localhost if no host is specified
    if(defined $dflt{inet} and $dflt{inet}=~/^\d+$/) {
        $dflt{inet} = "localhost:$dflt{inet}";
    }

    # set the actual reject code values
    if ($dflt{reject_first_attempt} eq 'delay') {
    	$dflt{reject_first_attempt} = 'defer_if_permit';
    } elsif ($dflt{reject_first_attempt} eq 'immed') {
	$dflt{reject_first_attempt} = $dflt{reject_code};
    } else {
    	pod2usage(1);
    }
    if (defined $dflt{reject_early_reconnect}) {
	if ($dflt{reject_early_reconnect} eq 'delay') {
	    $dflt{reject_early_reconnect} = 'defer_if_permit';
	} elsif ($dflt{reject_early_reconnect} eq 'immed') {
	    $dflt{reject_early_reconnect} = $dflt{reject_code};
	} else {
	    pod2usage(1);
	}
    }

    # create Net::Server object and run it
    my $server = bless {
        server => {
            commandline     => [ $0, @ARGV_saved ],
            port            => [ $dflt{inet} ],
            proto           => 'tcp',
            user            => $dflt{user},
	    group           => $dflt{group},
            setsid          => $opt{daemonize} ? 1 : undef,
            pid_file        => $opt{daemonize} ? $dflt{pidfile} : undef,
	    # ugly hack: 4 will triger Net::Server debugs
            log_level       => $dflt{loglevel} > 2 ? $dflt{loglevel} : 2,
            log_file        => $opt{daemonize} ? 'Sys::Syslog' : undef,
            syslog_facility => 'mail',
            syslog_logsock  => 'unix',
            syslog_ident    => defined $dflt{log_ident} ? $dflt{log_ident} :
		                                          # process name
		                                          $0 =~ m{.*/(.*)},
	    syslog_logopt   => 'cons',
        },
        sqlgrey => {
	    # min time before reconnect (min)
            reconnect_delay => $dflt{reconnect_delay},
	    # max time before reconnect (hour)
            max_connect_age => $dflt{max_connect_age},
	    # How long is an AWL entry valid (days)
            awl_age         => $dflt{awl_age},
	    # How many from match a domain/IP before a switch to domain AWL
	    domain_level    => $dflt{group_domain_level},
            next_maint      => time + $dflt{db_cleandelay},
	    db_cleandelay   => $dflt{db_cleandelay}, # between table cleanups (seconds)

            db_type         => $dflt{db_type},
            db_name         => $dflt{db_name},
            db_host         => $dflt{db_host},
            db_port         => $dflt{db_port},
	    db_user         => $dflt{db_user},
            db_pass         => $dflt{db_pass},
	    db_available    => 1, # used to trigger e-mails
	    clean_method    => $dflt{clean_method},
	    prepend         => $dflt{prepend},
	    greymethod      => $dflt{greymethod},
	    optmethod       => $dflt{optmethod},
	    reject_first    => $dflt{reject_first_attempt},
	    reject_early    => $dflt{reject_early_reconnect}
	    			|| $dflt{reject_first_attempt},
	    connect_src_throttle => $dflt{connect_src_throttle},
	    admin_mail      => $dflt{admin_mail},
	    warn_db         => 0, # mask SQL errors during db init
	    mail_maxbucket  => 10, # max burst of mails
	    mail_period     => 10, # one mail each 10 minutes max
	    mail_bucket     => 5, # initial bucket
	    last_mail       => time,
	    log             => $dflt{log},

#	    discrimination => $dflt{discrimination}
        },
    }, 'sqlgrey';

    my $greymethod = $server->{sqlgrey}{greymethod};
    if ($greymethod ne 'smart' and $greymethod ne 'full' and
	$greymethod ne 'classc') {
	pod2usage(1);
    }
        
    $server->run;
}

####################################
## Net::Server::Multiplex methods ##
####################################

# Called before the first query comes.
sub pre_loop_hook() {
    my $self = shift;

    # store ourselves
    $ref_to_sqlgrey = $self;

    # be sure to put in syslog any warnings / fatal errors
    if($self->{server}{log_file} eq 'Sys::Syslog') {
        $SIG{__WARN__} = sub {Sys::Syslog::syslog('warning', "warning: $_[0]")};
        $SIG{__DIE__}  = sub {Sys::Syslog::syslog('crit', "fatal: $_[0]");
			      die @_;};
    }

    $SIG{USR1} = \&mark_reload_request;

    $self->initdb();
    $self->mylog('other', 4, 'Initial cleanup');
    $self->start_cleanup();
    $self->init_whitelists();
    $self->init_smart_regexps();
    $self->init_discrimination();

    if (defined $self->{server}{setsid}) {
        # Detach from terminal
        close(STDIN);
        close(STDOUT);
        close(STDERR);
	# Ugly hack to prevent perl from complaining
	# 'warning: Filehandle STDERR reopened as FILE only \
	# for input at /usr/bin/sqlgrey line 717, <FILE> line 57'
	open(STDIN,'</dev/null');
	open(STDOUT,'>/dev/null');
	open(STDERR,'>/dev/null');
    }
}

sub restart_open_hook() {
    my $self = shift;
    my $pidfile = $self->{server}{pid_file};
    unlink $pidfile;
}

sub restart_close_hook() {
    my $self = shift;

    # SIGUSR1 triggers the whitelist reloading
    $self->mark_reload_request();
}

# Main muxer :
# reads a line at a time, call smtpd_access_policy if the input looks valid
# and return the result
sub mux_input()
{
    my ($self, $mux, $fh, $in_ref) = @_;
    defined $self->{sqlgrey_attr} or $self->{sqlgrey_attr} = {};
    my $attr = $self->{sqlgrey_attr};

    # consume entire lines
    while ($$in_ref =~ s/^([^\n]*)\n//) {
        next unless defined $1;
        my $in = $1;
        if($in =~ /([^=]+)=(.*)/) {
            # read attributes
            $attr->{substr($1, 0, 512)} = substr($2, 0, 512);
        }
        elsif($in eq '') {
            defined $attr->{request} or $attr->{request}='';
            if($attr->{request} ne 'smtpd_access_policy') {
                $self->{net_server}->log(1, 'unrecognized request type: ' .
					    "'$attr->{request}'");
            }
            else {
                # decide
                my $action = $self->{net_server}->smtpd_access_policy($attr);
                # debug
                if ($ref_to_sqlgrey->{sqlgrey}{log}{other} >= 4) {
                    my $a = 'request: ';
                    $a .= join(' ', map {"$_=$attr->{$_}"} (sort keys %$attr));
                    $a .= " action=$action";
                    $self->{net_server}->log(4, $a);
                }
                # give answer
                print $fh "action=$action\n\n";
            }
            $self->{sqlgrey_attr} = {};
        }
        else {
             $self->{net_server}->log(1, 'ignoring garbage: <' .
				         substr($in, 0, 100).'>');
        }
    }
}

main;

__END__

=head1 NAME

sqlgrey - Postfix Greylisting Policy Server

=head1 SYNOPSIS

B<sqlgrey> [I<options>...]

 -h, --help                 display this help and exit
     --man                  display man page
     --version              output version information and exit
 -d, --daemonize            run in the background
 -k, --kill                 kill a running sqlgrey
                            (identified by 'pidfile' content)
 -f, --configfile=FILE      read config from FILE
                            (default /etc/sqlgrey/sqlgrey.conf)
                            expecting config_param=value lines,
                            - spaces are ignored,
                            - '#' is used for comments

See the default config file at /etc/sqlgrey/sqlgrey.conf for runtime parameters.
If you got sqlgrey from sources, read the HOWTO file in the compressed archive.
If it came prepackaged, look into the documentation tree for this file:
/usr/share/doc/sqlgrey-<version>/ on most Linux distributions for example.

=head1 DESCRIPTION

Sqlgrey is a Postfix policy server implementing greylisting.

When a request for delivery of a mail is received by Postfix via SMTP,
the triplet C<CLIENT_IP> / C<SENDER> / C<RECIPIENT> is built. If it is
the first time that this triplet is seen, or if the triplet was first
seen less than I<reconnect-delay> minutes (1 is the default), then
the mail gets rejected with a temporary error. Hopefully spammers or
viruses will not try again later, as it is however required per RFC.

In order to alleviate the reconnect delay, sqlgrey uses a 2-level
auto-white-list (AWL) system:

=over 4

=item *

As soon as a C<CLIENT IP> / C<SENDER> is accepted, it is added to an
AWL. The couple expires when it isn't seen for more than I<awl-age>
days (60 is the default).

=item *

If I<group-domain-level> C<SENDER>s (2 is the default) from the same
domain or more use the same C<CLIENT IP>, another AWL is used based on a
C<CLIENT IP> / C<DOMAIN> couple.
This couple expires after awl-age days too. This AWL is meant to be used
on high throughput sites in order to :

=over 4

=item *

minimize the amount of data stored in database,

=item *

minimize the amount of processing required to find an entry in the AWL.

=item *

don't impose any further mail delay when a C<CLIENT IP> / C<DOMAIN>
couple is known.

=back

It can be disabled by setting I<group-domain-level> to 0.

=back

General idea:

When a SMTP client has been accepted once, if the IP isn't dynamic,
greylisting the IP again is only a waste of time when it sends another
e-mail. As we already know that this IP runs an RFC-compliant MTA (at
least the 4xx error code handling) and will get the new e-mail through
anyway.

In the case of mail relays, these AWLs works very well as the same
senders and mail domains are constantly coming through the same IP
addresses -E<gt> the e-mails are quickly accepted on the first try.
In the case of individual SMTP servers, this works well if the IP is
fixed too.
When using a floating IP address, the AWLs are defeated, but it should
be the least common case by far.

Why do we put the domain in the AWL and not the IP only ? If we did
only store IP addresses, polluting the AWL would be far too easy. It
would only take one correctly configured MTA sending one e-mail from
one IP one single time to put it in a whitelist used whatever future
mails from this IP look like.

With this AWL system, one single mail can only allow whitelisting of
mails from a single sender from the same IP...

=head1 INSTALLATION

=over 4

=item *

Create a C<sqlgrey> user. This will be the user the daemon runs as.

=item *

When using a full-fledge SGBD (MySQL and PostgreSQL, not SQLite),
create a 'sqlgrey' db user and a 'sqlgrey' database. Grant access
to the newly created database to sqlgrey.

=item *

Use the packaged init script to start sqlgrey at boot and start it
manually.

=back

=head1 CONFIGURATION

=head2 General

=over 4

=item *

Start by adding check_policy_service after reject_unauth_destination in
/etc/postfix/main.cf :

 smtpd_recipient_restrictions =
               ...
               reject_unauth_destination
               check_policy_service inet:127.0.0.1:2501

=item *

Be aware that some servers do not behave correctly and do not resend
mails (as required by the standard) or use unique return addresses.
This is the reason why you should maintain whitelists for them.

SQLgrey comes with a comprehensive whitelisting system. It can
even be configured to fetch up-to-date whitelists from a repository. See
the HOWTO for the details.

=back

=head2 Disabling greylisting for some users

If you want to disable greylisting for some users you can configure
Postfix like this:

/etc/postfix/sqlgrey_recipient_access:
  i_like_spam@ee.ethz.ch                OK

Then you'll add a check_recipient_access in main.cf before the
check_policy_service :
 smtpd_recipient_restrictions =
       ...
       reject_unauth_destination
       check_client_access    hash:/etc/postfix/sqlgrey_client_access
       check_recipient_access hash:/etc/postfix/sqlgrey_recipient_access
       check_policy_service inet:127.0.0.1:10023

=head1 SEE ALSO

See L<http://www.greylisting.org/> for a description of what greylisting
is and L<http://www.postfix.org/SMTPD_POLICY_README.html> for a
description of how Postfix policy servers work.

=head1 COPYRIGHT

Copyright (c) 2004 by Lionel Bouton.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

=head1 AUTHOR

S<Lionel Bouton E<lt>lionel-dev@bouton.nameE<gt>>

=cut

# Emacs Configuration
#
# Local Variables:
# mode: cperl
# eval: (cperl-set-style "PerlStyle")
# mode: flyspell
# mode: flyspell-prog
# End:
#
# vi: sw=4 et