File Coverage

blib/lib/Couchbase/Client/Compat.pm

Criterion	Covered	Total	%
statement	41	54	75.9
branch	12	14	85.7
condition	3	3	100.0
subroutine	8	11	72.7
pod	1	3	33.3
total	65	85	76.4

package Couchbase::Client::Compat;
use strict;
use warnings;
use base qw(Couchbase::Client);
use Couchbase::Client::Errors;
use base qw(Exporter);

our @EXPORT_OK = qw(return_for_multi_wrap return_for_op);

#These errors are 'negative replies', all others are 'error' replies.
our %ErrorMap = (
    COUCHBASE_NOT_STORED, 0,
    COUCHBASE_KEY_EEXISTS, 0,
    COUCHBASE_KEY_ENOENT, 0,
    COUCHBASE_DELTA_BADVAL, 0,
    COUCHBASE_E2BIG, 0,
);

sub return_for_multi_wrap {
    my ($requests,$response,$op) = @_;

    if(wantarray) {
        #ugh, really?
        my @retvals;
        foreach my $req (@$requests) {
            my $key = ref $req eq 'ARRAY' ? $req->[0] : $req;
            my $retval = return_for_op($response->{$key}, $op);
            push @retvals, $retval;
        }
        return @retvals;
    } else {
        #scalar:
        while (my ($k,$v) = each %$response) {
            $response->{$k} = return_for_op($v, $op);
        }
        return $response;
    }
}

sub return_for_op {
    my ($retval, $op) = @_;

    my $errval = $retval->errnum;

    if ($errval) {
        $errval = $ErrorMap{$errval};
    }

    if ($retval->errnum && (!defined $errval)) {
        # Fatal error:
        return undef;
    }

    if ($op =~ /^(?:get|incr|decr)$/) {
        return $retval->value;
    }

    if ($op eq 'gets') {
        return [$retval->cas, $retval->value];
    }

    if ($op =~ /^(?:set|cas|add|append|prepend|replace|remove|delete)/) {
        return int($retval->errnum == 0);
    }

}

sub new {
    my ($cls,$options) = @_;
    my $o = $cls->SUPER::new($options);
    bless $o, $cls;
    return $o;
}


foreach my $sub (qw(
                 get gets
                 set append prepend replace add
                 remove delete
                 incr decr cas)) {
    no strict 'refs';
    *{$sub} = sub {
        my $self = shift;
        my $ret = $self->${\"SUPER::$sub"}(@_);
        $ret = return_for_op($ret, $sub);
        return $ret;
    };

    my $multi = "$sub\_multi";
    *{$multi} = sub {
        my $self = shift;
        my $ret = $self->${\"SUPER::$multi"}(@_);
        return return_for_multi_wrap(\@_, $ret, $sub)
    };
}

1;

__END__