view release on metacpan or  search on metacpan

lib/Cache/Memcached/libmemcached.pm  view on Meta::CPAN

package Cache::Memcached::libmemcached;

require bytes;
use strict;
use warnings;

use Memcached::libmemcached 1.001701, qw(
    MEMCACHED_CALLBACK_PREFIX_KEY
    MEMCACHED_PREFIX_KEY_MAX_SIZE
);
use base qw(Memcached::libmemcached);

use Carp qw(croak carp);
use Scalar::Util qw(weaken);
use Storable ();

our $VERSION = '0.04001';

use constant HAVE_ZLIB    => eval { require Compress::Zlib } && !$@;
use constant F_STORABLE   => 1;
use constant F_COMPRESS   => 2;
use constant OPTIMIZE     => $ENV{PERL_LIBMEMCACHED_OPTIMIZE} ? 1 : 0;

my %behavior;

BEGIN
{
    # Make sure to load bytes.pm if HAVE_ZLIB is enabled
    if (HAVE_ZLIB) {
        require bytes;
    }

    # accessors
    foreach my $field (qw(compress_enable compress_threshold compress_savings)) {
        eval sprintf(<<"        EOSUB", $field, $field, $field, $field);
            sub set_%s { \$_[0]->{%s} = \$_[1] }
            sub get_%s { \$_[0]->{%s} }
        EOSUB
        die if $@;
    }
    # for Cache::Memcached compatibility
    sub enable_compress { shift->set_compress_enable(@_) }

    # XXX this should be done via subclasses
    if (OPTIMIZE) {
        # If the optimize flag is enabled, we do not support master key
        # generation, cause we really care about the speed.
        foreach my $method (qw(get set add replace prepend append cas delete)) {
            eval <<"            EOSUB";
                sub $method {
                    shift->SUPER::memcached_${method}(\@_)
                }
            EOSUB
            die if $@;
        }
    } else {
        # Regular case.
        # Mental note. We only do this cause while we're faster than
        # Cache::Memcached::Fast, *even* when the above optimization isn't
        # toggled.
        foreach my $method (qw(get set add replace prepend append cas delete)) {
            eval <<"            EOSUB";
                sub $method { 
                    my \$self = shift;
                    my \$key  = shift;
                    return \$self->SUPER::memcached_${method}(\$key, \@_)
                        unless ref \$key;
                    (my \$master_key, \$key) = @\$key;
                    if (\$master_key) {
                        \$self->SUPER::memcached_${method}_by_key(\$master_key, \$key, \@_);
                    } else {
                        \$self->SUPER::memcached_${method}(\$key, \@_);
                    }
                }

lib/Cache/Memcached/libmemcached.pm  view on Meta::CPAN

    my $self = shift;

    my $old_namespace = $self->memcached_callback_get(MEMCACHED_CALLBACK_PREFIX_KEY);
    if (@_) {
        my $namespace = shift;
        $self->memcached_callback_set(MEMCACHED_CALLBACK_PREFIX_KEY, $namespace)
            or carp $self->errstr;
    }

    return $old_namespace;
}

sub set_servers
{
    my $self = shift;
    my $servers = shift || [];

    # $self->{servers} = []; # for compatibility with Cache::Memcached

    # XXX should delete any existing servers from libmemcached
    foreach my $server (@$servers) {
        $self->server_add($server);
    }
}

sub server_add
{
    my $self = shift;
    my $server = shift
        or Carp::confess("server not specified");

    my $weight = 0;
    if (ref $server eq 'ARRAY') {
        my @ary = @$server;
        $server = shift @ary;
        $weight = shift @ary || 0 if @ary;
    }
    elsif (ref $server eq 'HASH') { # Cache::Memcached::Fast
        my $h = $server;
        $server = $h->{address};
        $weight = $h->{weight} if exists $h->{weight};
        # noreply is not supported
    }

    if ($server =~ /^([^:]+):([^:]+)$/) {
        my ($hostname, $port) = ($1, $2);
        $self->memcached_server_add_with_weight($hostname, $port, $weight);
    } else {
        $self->memcached_server_add_unix_socket_with_weight( $server, $weight );
    }

    # for compatibility with Cache::Memcached
    # push @{$self->{servers}}, $server;
}


sub _mk_callbacks
{
    my $self = shift;

    weaken($self);
    my $inflate = sub {
        my ($key, $flags) = @_;
        if ($flags & F_COMPRESS) {
            if (! HAVE_ZLIB) {
                croak("Data for $key is compressed, but we have no Compress::Zlib");
            }
            $_ = Compress::Zlib::memGunzip($_);
        }

        if ($flags & F_STORABLE) {
            $_ = Storable::thaw($_);
        }
        return ();
    };

    my $deflate = sub {
        # Check if we have a complex structure
        if (ref $_) {
            $_ = Storable::nfreeze($_);
            $_[1] |= F_STORABLE;
        }

        # Check if we need compression
        if (HAVE_ZLIB && $self->{compress_enable} && $self->{compress_threshold}) {
            # Find the byte length
            my $length = bytes::length($_);
            if ($length > $self->{compress_threshold}) {
                my $tmp = Compress::Zlib::memGzip($_);
                if (bytes::length($tmp) / $length < 1 - $self->{compress_savingsS}) {
                    $_ = $tmp;
                    $_[1] |= F_COMPRESS;
                }
            }
        }
        return ();
    };
    return ($deflate, $inflate);
}

sub incr
{
    my $self = shift;
    my $key  = shift;
    my $offset = shift || 1;
    my $val = 0;
    $self->memcached_increment($key, $offset, $val) || return undef;
    return $val;
}

sub decr
{
    my $self = shift;
    my $key  = shift;
    my $offset = shift || 1;
    my $val = 0;
    $self->memcached_decrement($key, $offset, $val) || return undef;
    return $val;
}