File Coverage

blib/lib/WWW/RobotRules/Memcache.pm

Criterion	Covered	Total	%
statement	15	72	20.8
branch	0	14	0.0
condition	0	3	0.0
subroutine	5	13	38.4
pod	1	8	12.5
total	21	110	19.0

package WWW::RobotRules::Memcache;

use strict;
use warnings;

use base 'WWW::RobotRules';

use Cache::Memcached;
use Carp;

our $VERSION = '0.1';

sub new  {
    my ($class, @mem_nodes) = @_;
    if (! @mem_nodes) {
        Carp::croak('WWW::RobotRules::Memcache servers required')
    }
    my $self = bless { }, $class;
	$self->{'memd'} = Cache::Memcached->new({
        'servers' => [ @mem_nodes ],
    });
    return $self;
}

sub no_visits {
    my ($self, $netloc) = @_;
    my $t = $self->{'memd'}->get("$netloc|vis");
    if (! $t) { return 0; }
    return ( split( /;\s*/, $t ) )[0];
}

sub last_visit {
    my ($self, $netloc) = @_;
    my $t = $self->{'memd'}->get("$netloc|vis");
    if (! $t) { return 0; }
    return ( split( /;\s*/, $t ) )[1];
}

sub fresh_until {
    my ($self, $netloc, $fresh) = @_;
    my $old = $self->{'memd'}->get("$netloc|exp");
    if ($old) {
        $old =~ s/;.*//;
    }
    if (defined $fresh) {
	    $fresh .= "; " . localtime($fresh);
	    $self->{'memd'}->set("$netloc|exp", $fresh);
    }
    return $old;
}

sub visit {
    my($self, $netloc, $time) = @_;
    $time ||= time;

    my $count = 0;
    my $old = $self->{'memd'}->get("$netloc|vis");
    if ($old) {
	    my $last;
	    ($count,$last) = split(/;\s*/, $old);
	    if ($last > $time) { $time = $last; }
    }
    $count++;
    $self->{'memd'}->set("$netloc|vis", "$count; $time; " . localtime($time));
    return 1;
}

sub push_rules {
    my($self, $netloc, @rules) = @_;
    my $cnt = 1;
    while ($self->{'memd'}->get("$netloc|r$cnt")) {
	    $cnt++;
    }
    foreach my $rule (@rules) {
        $self->{'memd'}->set("$netloc|r$cnt", $rule);
	    $cnt++;
    }
    return 1;
}

sub clear_rules {
    my ($self, $netloc) = @_;
    my $cnt = 1;
    while ($self->{'memd'}->get("$netloc|r$cnt")) {
	    $self->{'memd'}->delete("$netloc|r$cnt");
	    $cnt++;
    }
    return 1;
}

sub rules {
    my($self, $netloc) = @_;
    my @rules = ();
    my $cnt = 1;
    while (my $rule = $self->{'memd'}->get("$netloc|r$cnt")) {
        push @rules, $rule;
        $cnt++;
    }
    return @rules;
}

1;
__END__