The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Net::Riak::Role::PBC::Object;
{
  $Net::Riak::Role::PBC::Object::VERSION = '0.1702';
}
use JSON;
use Moose::Role;
use List::Util 'first';

sub store_object {
    my ($self, $w, $dw, $object) = @_;

    die "Storing object without a key is not supported in the PBC interface" unless $object->key;

    my $value = (ref $object->data && $object->content_type eq 'application/json')
            ? JSON::encode_json($object->data) : $object->data;

    my $content = {
        content_type => $object->content_type,
        value => $value,
    };

    if ($object->has_links) {
        $content->{links} = $self->_links_for_message($object);
    }

    if ($object->has_meta) {
        $content->{usermeta} = $self->_metas_for_message($object);
    }

    $self->send_message(
        PutReq => {
            bucket  => $object->bucket->name,
            key     => $object->key,
            content => $content,
        }
    );
    return $object;
}

sub load_object {
    my ( $self, $params, $object ) = @_;

    my $resp = $self->send_message(
        GetReq => {
            bucket => $object->bucket->name,
            key    => $object->key,
            r      => $params->{r},
        }
    );

    $self->populate_object($object, $resp);

    return $object;
}

sub delete_object {
    my ( $self, $params, $object ) = @_;

    my $resp = $self->send_message(
        DelReq => {
            bucket => $object->bucket->name,
            key    => $object->key,
            rw     => $params->{dw},
        }
    );

    $object;
}

sub populate_object {
    my ( $self, $object, $resp) = @_;

    $object->_clear_links;
    $object->exists(0);

    if ( $resp->content && scalar (@{$resp->content}) > 1) {
        my %seen;
        my @vtags = grep { !$seen{$_}++ } map { $_->vtag } @{$resp->content};
        $object->siblings(\@vtags);
    }

    my $content = $resp->content ? $resp->content->[0] : undef;

    return unless $content and $resp->vclock;

    $object->vclock($resp->vclock);
    $object->vtag($content->vtag);
    $object->content_type($content->content_type);

    if($content->links) {
        $self->_populate_links($object, $content->links);
    }

    if($content->usermeta) {
        $self->_populate_metas($object, $content->usermeta);
    }

    my $data = ($object->content_type eq 'application/json')
        ? JSON::decode_json($content->value) : $content->value;

    $object->exists(1);

    $object->data($data);
}


# This emulates the behavior of the existing REST client.
sub retrieve_sibling {
    my ($self, $object, $params) = @_;

    my $resp = $self->send_message(
        GetReq => {
            bucket => $object->bucket->name,
            key    => $object->key,
            r      => $params->{r},
        }
    );

    # hack for loading 1 sibling
    if ($params->{vtag}) {
        $resp->{content} = [
            first {
                $_->vtag eq $params->{vtag}
            } @{$resp->content}
        ];
    }

    my $sibling = Net::Riak::Object->new(
        client => $self,
        bucket => $object->bucket,
        key    => $object->key
    );

    $sibling->_jsonize($object->_jsonize);

    $self->populate_object($sibling, $resp);

    $sibling;
}

1;

__END__

=pod

=head1 NAME

Net::Riak::Role::PBC::Object

=head1 VERSION

version 0.1702

=head1 AUTHOR

franck cuny <franck@lumberjaph.net>, robin edwards <robin.ge@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by linkfluence.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut