view release on metacpan or  search on metacpan

t/cache.t  view on Meta::CPAN

    package main;

    # Construction should fail
    throws_ok
        { $cache = new Email::Fingerprint::Cache({ backend => 'Backend8' }) }
        qr{Can't load},
        "Dies when constructor returns undef";
}

# Clean up a little
undef $cache;


############################################################################
# Exercise the lock() and unlock() methods
############################################################################
SKIP: {
    my $perl = $EXECUTABLE_NAME;
    my $lib  = "$FindBin::Bin/../lib";

    # We make a massive effort to make this test work on Windows,
    # even though fork() is completely broken there. We do skip this
    # part of the test if we simply can't launch Perl, though.
    my $status = system (
        $perl, '-I', $lib, qw/ -MPOSIX -MEmail::Fingerprint::Cache -e 0 /
    );
    if ($status != 0)
    {
        diag "Perl: $perl";
        diag "Lib: $lib";
        diag "\$0: $0";

        skip "can't run perl; your system looks broken", 3 unless $status == 0;
    }

    # Clean up the lockfile from any crashed test runs
    unlink "$file.lock";

    # Open two caches and make 'em fight.
    my $cache1 = new Email::Fingerprint::Cache({ file => $file });
    skip "failed to create cache for lock test", 3 unless $cache1;

    # Locking cache 1 should prevent locking the same cache in another process.
    # NOTE: It prevents locking cache2 in the *same* process on most UNIX
    # variants, except Solaris.
    ok $cache1->lock   ? 1 : 0,
        "Locking a cache should succeed when nobody else has a lock";

    # Now attempt a second lock, in a separate process, without forking.
    # 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);
        },
    );

    ok +($status >> 8 == 1), "... until after the original process releases its lock";

    # Destroy the caches
    undef $cache1;
}

############################################################################
# Test the ugly failsafe in the DESTROY() method
############################################################################

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

# 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 = ();

    $cache = new Email::Fingerprint::Cache({
        file => $file,
        hash => \%fingerprints,
        ttl  => 60,
    });

    # Open the cache.
    ok $cache,       "New cache for TTL test";
    ok $cache->open, "Opened cache";
    ok scalar(keys %fingerprints) == 0, "Cache initially empty";

    # Populate the cache with 500 items each: less than 60 seconds old;
    # between 60 and 119 seconds old; older than 120 seconds.
    for my $n ( 1..500 ) {
        my $timestamp = time;
        my $key       = sprintf "%03i", $n;

        $fingerprints{"a$key"} = $timestamp - int(rand(58)) -   1;  # Less than 1 minute
        $fingerprints{"b$key"} = $timestamp - int(rand(58)) -  61;  # Less than 2 minutes
        $fingerprints{"c$key"} = $timestamp - int(rand(59)) - 121;  # More than 2 minutes
    }

    # Add a fingerprint with no defined timestamp, or a timestamp
    # that evaluates to false.
    $fingerprints{101} = undef;
    $fingerprints{102} = 0;
    $fingerprints{103} = '';

    # And finally, add one entry that WON'T be purged.
    $fingerprints{104} = 60 + time; # Just in case the test runs slow...

    # Now confirm that they're there
    my $count = scalar(keys %fingerprints);
    ok $count == 1504, "The cache should contain 1,504 fingerprints, and contains: $count";

    # First, purge the invalid timestamps
    $cache->purge( ttl => 200 );
    $count = scalar(keys %fingerprints);
    ok $count == 1501, "...   3 with invalid timestamps, which should now be purged ($count remaining)";

    # Next, purge items older than 2 minutes, and check. The "false"
    # fingerprints should also be gone.
    $cache->purge( ttl => 120 );
    $count = scalar(keys %fingerprints);
    ok $count == 1001, "... 500 older than two minutes, which should now be purged ($count remaining)";

    # Then purge using the default TTL, which we set earlier to 60.
    # Confirm that the default TTL is used and not, e.g., 120.
    $cache->purge;

t/cache.t  view on Meta::CPAN

############################################################################
# Test the dump() method, which prints to STDOUT
############################################################################

$file = 't/data/cache';
my %hash;
our $data;

# Read the data, stored in Perl format: loads hashref $data
require "$file.pl";

$cache = new Email::Fingerprint::Cache({
    file => $file,
    hash => \%hash,
});

# Open the cache file
ok $cache->open, "Opening the test cache should succeed";

# Purge the cache, in case there's leftover test data around
$cache->purge( ttl => -1 );

# Add our data to the hash
$hash{$_} = $data->{$_} for keys %$data;

# Close and reopen
ok $cache->close, "... and closing it should also be successful";
ok $cache->open, "... as should reopening it";

my $output;

# Dump the cache, catching the output
tie *STDOUT, 'Test::Stdout', \$output;
$cache->dump;
untie *STDOUT;

# Read the test data
open IN, '<', "$file.txt";
my $standard = join '', <IN>;
close IN;

# Compare
ok $output eq $standard, "... and the contents should match our test data";

# Clean up
lives_ok { $cache->close } "Closing the cache should not throw an exception";
warning_is { undef $cache } undef, "Destroying the closed cache should not generate warnings";

############################################################################
# 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();