File Coverage

blib/lib/Mail/ThreadKiller.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Mail::ThreadKiller;
use strict;
use warnings;

use DB_File;
use Fcntl ':flock';
use Carp;

our $VERSION = '1.0.1';

sub new
{
	my ($class) = @_;
	return bless {
		db_file => undef,
		lock_fd => undef,
		lockfile => undef,
		lock_fd => undef,
		tied => undef,
	}, $class;
}

sub set_db_file
{
	my ($self, $filename) = @_;
	$self->{db_file} = $filename;
}

sub open_db_file
{
	my ($self, $filename) = @_;
	if (defined($filename)) {
		$self->{db_file} = $filename;
	}

	croak("DB file not set") unless defined($self->{db_file});
	my $lockfile = $self->{db_file} . '.lock';
	my $fp;
	open($fp, ">>$lockfile") or croak("Cannot open $lockfile: $!");
	flock($fp, LOCK_EX) or croak("Cannot lock $lockfile: $!");
	$self->{lock_fd} = $fp;
	$self->{lockfile} = $lockfile;
	if (!tie(%{$self->{tied}}, 'DB_File', $self->{db_file})) {
		croak("Cannot tie to " . $self->{db_file} . ": $!");
	}
	return 1;
}

sub close_db_file
{
	my ($self) = @_;
	if (defined($self->{tied})) {
		untie(%{$self->{tied}});
		$self->{tied} = undef;
	}
	if (defined($self->{lock_fd})) {
		close($self->{lock_fd});
		$self->{lock_fd} = undef;
	}
	if (defined($self->{lockfile})) {
		unlink($self->{lockfile});
		$self->{lockfile} = undef;
	}
}

sub DESTROY
{
	my ($self) = @_;
	$self->close_db_file();
}

# Add a message-ID to the database
sub add_message_id {
	my ($self, $msgid) = @_;
	my $now = time();

	$self->{tied}->{$msgid} = $now;
	return $now;
}

# Are any IDs in the database?
sub any_ids_in_database {
	my ($self, $msgid_line, $in_reply_to_line, $references_line) = @_;
	if (defined($msgid_line) && ($msgid_line =~ /(<\S+>)/)) {
		return $self->{tied}->{$1} if (exists($self->{tied}->{$1}));
	}
	if (defined($in_reply_to_line) && ($in_reply_to_line =~ /(<\S+>)/)) {
		return $self->{tied}->{$1} if (exists($self->{tied}->{$1}));
	}
	if (defined($references_line)) {
		my @ids = split(/\s+/, $references_line);
		foreach my $id (@ids) {
			return $self->{tied}->{$id} if (exists($self->{tied}->{$id}));
		}
	}
	return 0;
}

# Convenience function
sub kill_message
{
	my ($self, $mail) = @_;
	my $mid = $mail->header('Message-ID');
	return 0 unless defined($mid);
	return $self->add_message_id($mid);
}

# Convenience function
sub should_kill_message {
	my ($self, $mail) = @_;
	# NOTE: We need to force scalar context, hence the crazy || '' code.
	if ($self->any_ids_in_database(($mail->header('Message-ID') || ''),
				       ($mail->header('In-Reply-To') || ''),
				       ($mail->header('References') || ''))) {
		$self->add_message_id($mail->header('Message-ID'));
		return 1;
	}
	return 0;
}

# Clean out anything in DB older than $days
sub clean_db {
	my ($self, $days) = @_;
	my ($k, $v);
	my (@toKill);
	my ($secs) = $days * 86400;
	my ($now) = time();
	while (($k, $v) = each(%{$self->{tied}})) {
		push @toKill, $k if (($now - $v) > $secs);
	}
	my $num_cleaned = 0;
	foreach $k (@toKill) {
		$num_cleaned++;
		delete $self->{tied}->{$k};
	}
	return $num_cleaned;
}

1;

__END__