File Coverage

blib/lib/Cache/Range.pm

Criterion	Covered	Total	%
statement	15	60	25.0
branch	0	12	0.0
condition			n/a
subroutine	5	8	62.5
pod	3	3	100.0
total	23	83	27.7

package Cache::Range;

use strict;
use warnings;

use Tree::R;
use Storable qw(freeze thaw);

use namespace::clean;

our $VERSION = '0.01';

sub new {
    my ( $class, $cache ) = @_;

    return bless \$cache, $class;
}

sub set {
    my $self  = shift;
    my $key   = shift;
    my $start = shift;
    my $data  = shift;
    my $cache = $$self;
    my $end   = $start + $#$data;

    $cache->set(join('_', $key, $start, $end), freeze($data), @_);
    $data = {
        end   => $end,
        start => $start,
    };
    my $rtree = $cache->get($key . '_rtree');
    if($rtree) {
        $rtree = thaw($rtree);
    } else {
        $rtree = Tree::R->new;
    }
    $rtree->insert($data, $start, 0, $end, 0);
    $cache->set($key . '_rtree', freeze($rtree), $Cache::EXPIRES_NEVER);
}

sub get {
    my ( $self, $key, $start, $end ) = @_;

    my $cache = $$self;
    my $rtree = $cache->get($key . '_rtree');
    my $dirty = 0;

    return unless $rtree;
    $rtree = thaw($rtree);

    my @results;
    my @retval;
    $rtree->query_partly_within_rect($start, 0, $end, 0, \@results);
    @results = sort { $a->{'start'} <=> $b->{'start'} } @results;

    foreach my $entry (@results) {
        my ( $e, $s ) = @{$entry}{qw/end start/};
        my $data = $cache->get(join('_', $key, $s, $e));

        unless($data) {
            $rtree->remove($entry);
            $dirty = 1;
            next;
        }
        $data = thaw($data);

        $data = [ @$data ];

        if($s < $start) {
            splice @$data, 0, $start - $s;
            $s = $start;
        }
        if($e > $end) {
            splice @$data, $end - $e;
        }

        push @retval, $s, $data;
    }
    if($dirty) {
        $cache->set($key . '_rtree', freeze($rtree), $Cache::EXPIRES_NEVER);
    }
    return @retval;
}

1;

__END__