view release on metacpan or  search on metacpan

lib/Data/Model/Driver/Memcached.pm  view on Meta::CPAN

# storaged to memcache protocol (not for cache)
package Data::Model::Driver::Memcached;
use strict;
use warnings;
use base 'Data::Model::Driver';

use Carp ();
$Carp::Internal{(__PACKAGE__)}++;

sub memcached { shift->{memcached} }

sub update_direct { Carp::croak("update_direct is NOT IMPLEMENTED") }

sub init {
    my $self = shift;
    if (my $serializer = $self->{serializer}) {
        $serializer = 'Data::Model::Driver::Memcached::Serializer::' . $serializer
            unless $serializer =~ s/^\+//;
        unless ($serializer eq 'Data::Model::Driver::Memcached::Serializer::Default') {
            eval "use $serializer"; ## no critic
            Carp::croak $@;
        }
        $self->{serializer} = $serializer;
    }
}

sub lookup {
    my($self, $schema, $key) = @_;
    my $cache_key = $self->cache_key($schema, $key);
    my $ret = $self->{memcached}->get( $cache_key );
    return unless $ret;
    $ret = $self->{serializer}->deserialize($self, $ret) if $self->{serializer};
    my $map = $schema->options->{column_name_rename};
    $ret = $self->column_name_rename($map, $ret, 1)      if $map;
    $ret = $self->revert_undefvalue($schema, $ret)       if $self->{ignore_undef_value};
    $ret = $self->revert_keyvalue($schema, $key, $ret)   if $self->{strip_keys};
    return $ret;
}

sub lookup_multi {
    my($self, $schema, $keys) = @_;
    my $keys_map = {};
    my @cache_keys = map { my $k = $self->cache_key($schema, $_); $keys_map->{$k} = $_ ; $k } @{ $keys };
    my $ret = $self->{memcached}->get_multi( @cache_keys );
    return unless $ret;

    my %resultlist;
    while (my($id, $data) = each %{ $ret }) {
        $data = $self->{serializer}->deserialize($self, $data)           if $self->{serializer};
        my $map = $schema->options->{column_name_rename};
        $data = $self->column_name_rename($map, $data, 1)                if $map;
        $data = $self->revert_undefvalue($schema, $data)                 if $self->{ignore_undef_value};
        $data = $self->revert_keyvalue($schema, $keys_map->{$id}, $data) if $self->{strip_keys};
        my $key = $schema->get_key_array_by_hash($data);
        $resultlist{join "\0", @{ $key }} = +{ %{ $data } };
    }
    return \%resultlist;
}

sub get {
    my($self, $schema, $key, $columns, %args) = @_;

    my $cache_key = $self->cache_key($schema, $key);
    my $ret = $self->{memcached}->get( $cache_key );
    return unless $ret;
    $ret = $self->{serializer}->deserialize($self, $ret) if $self->{serializer};
    my $map = $schema->options->{column_name_rename};
    $ret = $self->column_name_rename($map, $ret, 1)      if $map;
    $ret = $self->revert_undefvalue($schema, $ret)       if $self->{ignore_undef_value};
    $ret = $self->revert_keyvalue($schema, $key, $ret)   if $self->{strip_keys};
    return $self->_generate_result_iterator([ $ret ]), +{};
}

sub set {
    my($self, $schema, $key, $columns, %args) = @_;

    my $cache_key = $self->cache_key($schema, $key);
    my $data = $columns;
    $data = $self->strip_keyvalue($schema, $key, $data)  if $self->{strip_keys};
    $data = $self->strip_undefvalue($schema, $data)      if $self->{ignore_undef_value};
    my $map = $schema->options->{column_name_rename};
    $data = $self->column_name_rename($map, $data)       if $map;
    $data = $self->{serializer}->serialize($self, $data) if $self->{serializer};
    my $ret = $self->{always_overwrite} ?
        $self->{memcached}->set( $cache_key, $data ) :
            $self->{memcached}->add( $cache_key, $data );
    return unless $ret;

    $columns;
}

sub replace {
    my($self, $schema, $key, $columns, %args) = @_;

    my $cache_key = $self->cache_key($schema, $key);
    my $data = $columns;
    $data = $self->strip_keyvalue($schema, $key, $data)  if $self->{strip_keys};
    $data = $self->strip_undefvalue($schema, $data)      if $self->{ignore_undef_value};
    my $map = $schema->options->{column_name_rename};
    $data = $self->column_name_rename($map, $data)       if $map;
    $data = $self->{serializer}->serialize($self, $data) if $self->{serializer};
    my $ret = $self->{memcached}->set( $cache_key, $data );
    return unless $ret;

    $columns;
}

sub update {
    my($self, $schema, $old_key, $key, $old_columns, $columns, $changed_columns, %args) = @_;

    my $old_cache_key = $self->cache_key($schema, $old_key);
    my $new_cache_key = $self->cache_key($schema, $key);
    unless ($old_cache_key eq $new_cache_key) {
        my $ret = $self->delete($schema, $old_key);
        return unless $ret;
    }

    my $data = $columns;
    $data = $self->strip_keyvalue($schema, $key, $data)  if $self->{strip_keys};
    $data = $self->strip_undefvalue($schema, $data)      if $self->{ignore_undef_value};
    my $map = $schema->options->{column_name_rename};
    $data = $self->column_name_rename($map, $data)       if $map;
    $data = $self->{serializer}->serialize($self, $data) if $self->{serializer};
    my $ret = $self->{memcached}->set( $new_cache_key, $data );
    return unless $ret;

    $columns;
}

sub delete {
    my($self, $schema, $key, $columns, %args) = @_;
    my $cache_key = $self->cache_key($schema, $key);
    my $data = $self->{memcached}->get( $cache_key );
    return unless $data;
    my $ret = $self->{memcached}->delete( $cache_key );
    return unless $ret;
    $data;
}

sub strip_keyvalue {
    my($self, $schema, $keys, $columns) = @_;
    my $data = { %{ $columns } };
    for my $key (@{ $schema->key }) {
        delete $data->{$key};
    }
    $data;
}

sub revert_keyvalue {
    my($self, $schema, $keys, $columns) = @_;
    my $i = 0;
    my $data = { %{ $columns } };
    for my $key (@{ $schema->key }) {
        $data->{$key} = $keys->[$i++].''; # copy
    }
    $data;
}

sub strip_undefvalue {
    my($self, $schema, $columns) = @_;
    my $data = { %{ $columns } };
    for my $key (@{ $schema->columns }) {
        delete $data->{$key} unless exists $data->{$key} && defined $data->{$key};
    }
    $data;
}

sub revert_undefvalue {