Email-Fingerprint

 view release on metacpan or  search on metacpan

lib/Email/Fingerprint/Cache.pm  view on Meta::CPAN

  $file = $cache->set_file( 'foo' ) or die "Failed to set filename";
  # now $file eq 'foo.db' or 'foo.dir', etc., depending on the backend;
  # it is almost certainly NOT 'foo'.

Sets the file to be used for the cache. Returns the actual filename
on success; false on failure.

The actual filename will probably differ from the 'foo', because
the backend will usually add an extension or otherwise munge it.

C<set_file> has I<no> effect while the cache file is locked or open!

=cut

sub set_file {
    my ($self, $file) = @_;

    # Validation
    return if $self->get_backend->is_locked;
    return if $self->get_backend->is_open;

    # OK, there's no harm in changing the file attribute
    $self->get_backend->set_file($file);

    1; 
}

=head2 get_backend

lib/Email/Fingerprint/Cache.pm  view on Meta::CPAN

    $cache->dump;

    # Be a good neighbor
    $cache->close;
    $cache->unlock;

Dump a human-readable version of the contents of the cache. Data is
printed in timestamp order.

The cache I<must> first be opened, and I<should> first be locked.

=cut

sub dump {
    my $self = shift;
    my $hash = $self->get_hash;

    for my $key ( sort { $hash->{$a} <=> $hash->{$b} } keys %$hash )
    {
        my $value = $hash->{$key};

lib/Email/Fingerprint/Cache/AnyDBM.pm  view on Meta::CPAN

sub is_open {
    my $self = shift;
    my $hash = $self->get_hash;

    return 0 unless defined $hash and ref $hash eq 'HASH';
    return 0 unless tied %{ $hash };
    return 1;
}

=head2 is_locked

Returns true if the cache is locked; false otherwise.

=cut

sub is_locked {
    my $self = shift;
    return defined $lock{ ident $self } ? 1 : 0;
}

=head2 lock

  $cache->lock or die;                  # returns immediately
  $cache->lock( block => 1 ) or die;    # Waits for a lock

Lock the DB file. Returns false on failure, true on success.

=cut

sub lock {
    my $self = shift;
    my %opts = @_;

    return 1 if exists $lock{ ident $self };    # Success if already locked

    return unless defined $file{ ident $self }; # Can't lock nothing!
    my $file = $file{ ident $self };

    my $mgr = $mgr{ ident $self };

    # Minor validation that LockFile::Simple doesn't perform
    if (not -w dirname($file)) {
        warn "Directory " . dirname($file) . " is not writable\n";
        return;

t/anydbm.t  view on Meta::CPAN

my $file = "$tmp/tmp_cache";
mkdir $tmp;

ok $cache->set_file($file), "Setting the file name should succeed";
ok $cache->open, "... and opening the file should succeed";
ok $backend->is_open, "... causing the backend to report an open status";
ok $cache->close, "... which means that closing the file should also succeed";
ok ! $backend->is_open, "... causing the backend to report a closed status";
ok $cache->lock( block => 1 ), "Locking the cache (in blocking mode) should succeed immediately";
ok $cache->lock( block => 1 ), "... and locking it a second time should also succeed";
ok $backend->is_locked == 1, "... causing the backend to report a locked status";
ok $cache->unlock, "... which means that unlocking it should also succeed";
ok $backend->is_locked == 0, "... causing the backend to report an unlocked status";
ok $cache->unlock, "Unlocking an unlocked cache should succeed.";

# Turn off access permissions
SKIP: {
    if ($EUID == 0)
    {
        diag <<"EOF";


        ***************************************************************************
                                YOU ARE RUNNING TESTS AS ROOT!

t/anydbm.t  view on Meta::CPAN

        ***************************************************************************

EOF

        close TEST;
        skip "Can't test permissions--your system or perl is broken", 3;
    }

    # Confirm that the file can't be opened
    ok !defined $cache->open, "Opening a file should fail if we have no permission";
    ok $cache->lock, "... but it can still be locked";
    ok $cache->unlock, "... and, of course, unlocked";
}

# Clean up
remove_tree($tmp);

# That's all, folks!
done_testing();

t/cache.t  view on Meta::CPAN

    # Good luck with that!
    $status = system(
        $perl, '-I', $lib, qw/ -MPOSIX -MEmail::Fingerprint::Cache -e /,
        qq{
            \$cache = Email::Fingerprint::Cache->new({ file => '$file' });
            POSIX::_exit(0) if \$cache->lock;
            POSIX::_exit(1);
        },
    );

    ok +($status >> 8 == 1), "... and other processes should be unable to lock the locked cache";
    skip "failed to unlock test cache", 1 unless $cache1->unlock;

    $status = system(
        $perl, '-I', $lib, qw/ -MPOSIX -MEmail::Fingerprint::Cache -e /,
        qq{
            \$cache = Email::Fingerprint::Cache->new({ file => '$file' });
            POSIX::_exit(0) unless \$cache->lock;
            POSIX::_exit(0) unless \$cache->unlock;
            POSIX::_exit(1);
        },

t/cache.t  view on Meta::CPAN

});

# Open and lock the cache.
if (not $cache or not $cache->open or not $cache->lock)
{
    # Suppress spurious warnings
    $cache->close;
    $cache->unlock;
    undef $cache;

    ok 0, "Create an open, locked cache for warning test";
}
else
{
    warning_like
        { undef $cache }
        { carped => qr/before it was close/ },
        "Destroying an open, locked cache should generate a warning";
}

# Create another one
$cache = new Email::Fingerprint::Cache({
    file => $file,
    hash => {},
});

# This time, we open but don't lock the cache.
if (not $cache or not $cache->open)
{
    $cache->close;
    undef $cache;

    ok 0, "Create an open, unlocked cache for warning test";
}
else
{
    warning_like
        { undef $cache }
        { carped => qr/before it was close/},
        "Destroying an open, unlocked cache should generate a warning";
}

# Create another one
$cache = new Email::Fingerprint::Cache({
    file => $file,
    hash => {},
});

# This time, we lock but don't open the cache.
if (not $cache or not $cache->lock)
{
    $cache->close;
    undef $cache;

    ok 0, "Create a locked but unopened cache for warning test";
}
else
{
    warning_is { undef $cache } undef,
        "Destroying a locked but unopened cache should not generate warnings";
}



############################################################################
# Exercise purge() more thoroughly
############################################################################

SKIP: {
    %fingerprints = ();

t/cache.t  view on Meta::CPAN

############################################################################
# Test the set_file method, which only works when no file is open.
############################################################################

# Get a fresh cache
$cache = new Email::Fingerprint::Cache({
    file => $file,
    hash => {},
});

# Nothing should happen, either, if the file is locked
$cache->lock;
ok !defined $cache->set_file('foo'), "Setting a new cache file should fail when the cache is locked";
$cache->unlock;

# Nothing should happen, either, if the file is locked
$cache->open;
ok !defined $cache->set_file('foo'), "... or when the file is open";
$cache->close;

# Finally, the file is closed and unlocked, so it should work
ok $cache->set_file('foo'), "... but it should be successful if the cache is closed and unlocked";

# Clean up
unlink "t/data/cache.db";

# That's all, folks!
done_testing();