File Coverage

blib/lib/Cache/Memcached/Mock.pm

Criterion	Covered	Total	%
statement	80	88	90.9
branch	21	24	87.5
condition	9	15	60.0
subroutine	20	23	86.9
pod	0	13	0.0
total	130	163	79.7

# ABSTRACT: A mock class for Cache::Memcached
package Cache::Memcached::Mock;

use strict;
use warnings;
use bytes;
use Storable ();

our $VERSION = '0.07';

sub VALUE ()     {0}
sub TIMESTAMP () {1}
sub REFERENCE () {2}

# All instances share the memory space
our %MEMCACHE_STORAGE = ();

sub add {
    my ($self, $key, $value, $expiry_time) = @_;
    if (exists $MEMCACHE_STORAGE{$key}) {
        return;
    }
    return $self->set($key, $value, $expiry_time);
}

sub new {

    my ($class, $options) = @_;

    $class = ref $class || $class;

    $options ||= {};

    # Default memcached size limit
    $options->{size_limit} ||= 1024 * 1024;

    # Default unsigned integer bit width when incrementing/decrementing.
    $options->{bit_width} ||= 32;

    my $self = { %{$options} };

    bless $self, $class;
    $self->flush_all();

    return $self;
}

sub delete {
    my ($self, $key) = @_;
    if (!exists $MEMCACHE_STORAGE{$key}) {
        return;
    }
    delete $MEMCACHE_STORAGE{$key};
    return 1;
}

sub disconnect_all {
    return    # noop
}

sub flush_all {
    %MEMCACHE_STORAGE = ();
    return;
}

sub get {
    my ($self, $key) = @_;
    return $self->get_multi($key)->{$key};
}

sub get_multi {
    my ($self, @keys) = @_;
    my %pairs;

    for my $key (@keys) {
        if (exists $MEMCACHE_STORAGE{$key}) {

            # Check if value had an expire time
            my $struct      = $MEMCACHE_STORAGE{$key};
            my $expiry_time = $struct->[TIMESTAMP];

            if (defined $expiry_time && (time > $expiry_time)) {
                delete $MEMCACHE_STORAGE{$key};
            }
            else {
                $pairs{$key}
                  = $struct->[REFERENCE]
                  ? Storable::thaw($struct->[VALUE])
                  : $struct->[VALUE];
            }
        }
    }

    return \%pairs;
}

sub replace {
    my ($self, $key, $value, $expiry_time) = @_;
    if (!exists $MEMCACHE_STORAGE{$key}) {
        return;
    }
    return $self->set($key, $value, $expiry_time);
}

sub set {
    my ($self, $key, $value, $expiry_time) = @_;
    my $size_limit = $self->_size_limit();
    my $is_ref     = 0;

    if (ref $value) {
        $is_ref = 1;
        $value  = Storable::nfreeze($value);
    }

    # Can't store values longer than (default) 1Mb limit
    if (defined $value and bytes::length($value) > $size_limit) {
        return;
    }

    if ($expiry_time) {
        $expiry_time += time();
    }
    else {
        $expiry_time = undef;
    }

    $MEMCACHE_STORAGE{$key} = [ $value, $expiry_time, $is_ref ];

    return 1;
}

sub set_servers {
    my ($self, $servers) = @_;
    return ($self->{servers} = $servers);
}

sub set_compress_threshold {
    my ($self, $comp_thr) = @_;
    return ($self->{compress_threshold} = $comp_thr - 0);
}

# XXX NIY
#sub set_readonly {
#    my ($self, $readonly) = @_;
#    return ($self->{readonly} = $readonly);
#}

sub incr {
    my ($self, $key, $offset) = @_;
    return $self->_incr_or_decr($key, $offset, '_add');
}

sub decr {
    my ($self, $key, $offset) = @_;
    return $self->_incr_or_decr($key, $offset, '_subtract');
}

sub _add {
    my ($self, $x, $y) = @_;
    my $result = $self->_to_uint($x) + $self->_to_uint($y);

    return $result % (2 ** $self->_bit_width());
}

sub _bit_width {
    my ($self) = @_;
    return $self->{bit_width};
}

sub _incr_or_decr {
    my ($self, $key, $offset, $operation) = @_;
    return unless exists $MEMCACHE_STORAGE{$key};

    $offset = 1 unless defined $offset;
    my $new_val = $self->$operation($MEMCACHE_STORAGE{$key}->[VALUE], $offset);

    return ($MEMCACHE_STORAGE{$key}->[VALUE] = $new_val);
}

sub _size_limit {
    my ($self) = @_;
    return $self->{size_limit};
}

sub _subtract {
    my ($self, $x, $y) = @_;
    my $result = $self->_to_uint($x) - $self->_to_uint($y);

    return $result <= 0 ? 0 : $result % (2 ** $self->_bit_width());
}

sub _to_uint {
    my ($self, $n) = @_;
    return $n & (2 ** $self->_bit_width() - 1);
}

1;

__END__