view release on metacpan or  search on metacpan

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

        my $code = "sub $set { \$_[0]->memcached_behavior_set($behavior(), \$_[1]) }\n"
                 . "sub $get { \$_[0]->memcached_behavior_get($behavior()) }";
        eval $code;
        die "$@ while executing $code" if $@;
    }

}

sub import
{
    my $class = shift;
    Memcached::libmemcached->export_to_level(1, undef, @_) ;
}

sub new
{
    my $class = shift;
    my %args  = %{ shift || {} };

    my $self = $class->SUPER::new();

    $self->trace_level(delete $args{debug}) if exists $args{debug};

    $self->namespace(delete $args{namespace})
        if exists $args{namespace};

    $self->{compress_threshold} = delete $args{compress_threshold};
    # Add support for Cache::Memcache::Fast's compress_ratio
    $self->{compress_savingsS}  = delete $args{compress_savings} || 0.20;
    $self->{compress_enable}    =
        exists $args{compress_enable} ? delete $args{compress_enable} : 1;

    # servers 
    $args{servers} || croak "No servers specified";
    $self->set_servers(delete $args{servers});

    # old-style behavior options (see behavior_ block below)
    foreach my $option (qw(no_block hashing_algorithm distribution_method binary_protocol)) {
        my $behavior = $behavior{$option}->[1] || $option;
        $args{"behavior_$behavior"} = delete $args{$option} if exists $args{$option};
    }

    # allow any libmemcached behavior to be set via args to new()
    for my $name (grep { /^behavior_/ } keys %args) {
        my $value = delete $args{$name};
        my $behavior = "Memcached::libmemcached::MEMCACHED_\U$name";
        no strict 'refs';
        if (not defined &$behavior) {
            carp "$name ($behavior) isn't available"; # sanity check
            next;
        }
        $self->memcached_behavior_set(&$behavior(), $value);
    }

    delete $args{readonly};
    delete $args{no_rehash};

    carp "Unrecognised options: @{[ sort keys %args ]}"
        if %args;

    # Set compression/serialization callbacks
    $self->set_callback_coderefs(
        # Closures so we have reference to $self
        $self->_mk_callbacks()
    );

    # behavior options
    foreach my $option (qw(no_block hashing_algorithm distribution_method binary_protocol)) {
        my $method = "set_$option";
        $self->$method( $args{$option} ) if exists $args{$option};
    }

    return $self;
}

sub namespace {
    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;