package Email::AutoReply::DB::BerkeleyDB;
our $rcsid = '$Id: BerkeleyDB.pm 3002 2008-06-05 20:23:24Z adam $';
use strict;
use warnings;
use Email::AutoReply::DB '-Base';
use Email::AutoReply::Recipient;
use BerkeleyDB;
use Carp qw(confess);
field 'email_autoreply_settings_dir';
field 'cachedb_file' => "replied_cache.db";
field 'cachedb_path'; # a path, not ending in a path separator
field '_db'; # the reference to the actual tied hash
sub new {
$self = super;
$self->_check_path_available;
$self->_init_db;
return $self;
}
sub _check_path_available {
my $dir = $self->email_autoreply_settings_dir;
defined($dir) or confess "must pass in email_autoreply_settings_dir";
$self->cachedb_path($self->email_autoreply_settings_dir);
}
sub _init_db {
my %autoreply_cache;
my $filename = $self->cachedb_path . '/' . $self->cachedb_file;
tie %autoreply_cache, 'BerkeleyDB::Hash',
-Filename => $filename,
-Flags => DB_CREATE|DB_INIT_LOCK,
or die "Cannot open file $filename: $! $BerkeleyDB::Error\n";
$self->_db(\%autoreply_cache);
}
sub store {
my $input_type = 'Email::AutoReply::Recipient';
ref $_[0] eq $input_type or confess "input object must be an $input_type";
$_[0]->email && $_[0]->timestamp or confess "invalid input";
$self->_db->{$_[0]->email} = $_[0]->timestamp;
}
# INPUT: string to search for
# OUTPUT: Email::AutoReply::Recipient object, or zero
sub fetch {
my $timestamp = $self->_db->{$_[0]};
my $rv = 0;
if ($timestamp) {
$rv = Email::AutoReply::Recipient->new(
email => $_[0], timestamp => $timestamp
);
}
return $rv;
}
# INPUT:
# OUTPUT: list of Email::AutoReply::Recipient objects, or an empty list
sub fetch_all {
return keys %{ $self->_db };
}
return 1;
__END__
=head1 NAME
Email::AutoReply::DB::BerkeleyDB - Berkeley DB autoreply cache database
=head1 DESCRIPTION
Please see L<Email::AutoReply::DB>, the interface this class implements.
=head1 AUTHOR
Adam Monsen, <haircut@gmail.com>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2004-2008 by Adam Monsen
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.3 or,
at your option, any later version of Perl 5 you may have available.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut