File Coverage

blib/lib/Couchbase/Client.pm

Criterion	Covered	Total	%
statement	30	114	26.3
branch	0	44	0.0
condition	0	22	0.0
subroutine	10	16	62.5
pod	1	1	100.0
total	41	197	20.8

package Couchbase::Client;

BEGIN {
    require XSLoader;
    our $VERSION = '1.0.2';
    XSLoader::load(__PACKAGE__, $VERSION);
}

use strict;
use warnings;

use Couchbase::Client::Errors;
use Couchbase::Client::IDXConst;
use Couchbase::Client::Return;

my $have_storable = eval "use Storable; 1;";
my $have_zlib = eval "use Compress::Zlib; 1;";

use Array::Assign;

{
    no warnings 'once';
    *gets = \&get;
    *gets_multi = \&get_multi;
}

#this function converts hash options for compression and serialization
#to something suitable for construct()

sub _make_conversion_settings {
    my ($arglist,$options) = @_;
    my $flags = 0;


    $arglist->[CTORIDX_MYFLAGS] ||= 0;

    if($options->{dereference_scalar_ref}) {
        $arglist->[CTORIDX_MYFLAGS] |= fDEREF_RVPV;
    }

    if(exists $options->{deconversion}) {
        if(! delete $options->{deconversion}) {
            return;
        }
    } else {
        $flags |= fDECONVERT;
    }

    if(exists $options->{compress_threshold}) {
        my $compress_threshold = delete $options->{compress_threshold};
        $compress_threshold =
            (!$compress_threshold || $compress_threshold < 0)
            ? 0 : $compress_threshold;
        $arglist->[CTORIDX_COMP_THRESHOLD] = $compress_threshold;
        if($compress_threshold) {
            $flags |= fUSE_COMPRESSION;
        }
    }

    my $meth_comp;
    if(exists $options->{compress_methods}) {
        $meth_comp = delete $options->{compress_methods};
    } elsif($have_zlib) {
        $meth_comp = [ sub { ${$_[1]} = Compress::Zlib::memGzip(${$_[0]}) },
                      sub { ${$_[1]} = Compress::Zlib::memGunzip(${$_[0]}) }]
    }

    if(defined $meth_comp) {
        $arglist->[CTORIDX_COMP_METHODS] = $meth_comp;
    }

    my $meth_serialize = 0;
    if(exists $options->{serialize_methods}) {
        $meth_serialize = delete $options->{serialize_methods};
    }

    if($meth_serialize == 0 && $have_storable) {
        $meth_serialize = [ \&Storable::freeze, \&Storable::thaw ];
    }

    if($meth_serialize) {
        $flags |= fUSE_STORABLE;
        $arglist->[CTORIDX_SERIALIZE_METHODS] = $meth_serialize;
    }

    $arglist->[CTORIDX_MYFLAGS] |= $flags;
}

sub _MkCtorIDX {
    my $opts = shift;

    my @arglist;
    my $server = delete $opts->{server} or die "Must have server";
    arry_assign_i(@arglist,
        CTORIDX_SERVERS, $server,
        CTORIDX_USERNAME, delete $opts->{username},
        CTORIDX_PASSWORD, delete $opts->{password},
        CTORIDX_BUCKET, delete $opts->{bucket});

    _make_conversion_settings(\@arglist, $opts);

    my $tmp = delete $opts->{io_timeout} ||
            delete $opts->{select_timeout} ||
            delete $opts->{connect_timeout} ||
            delete $opts->{timeout};

    $tmp ||= 2.5;
    $arglist[CTORIDX_TIMEOUT] = $tmp if defined $tmp;
    $arglist[CTORIDX_NO_CONNECT] = delete $opts->{no_init_connect};


    if(keys %$opts) {
        warn sprintf("Unused keys (%s) in constructor",
                     join(", ", keys %$opts));
    }
    return \@arglist;
}

my %RETRY_ERRORS = (
    COUCHBASE_NETWORK_ERROR, 1,
    COUCHBASE_CONNECT_ERROR, 1,
    COUCHBASE_ETIMEDOUT, 1,
    COUCHBASE_UNKNOWN_HOST, 1
);

sub new {
    my ($pkg,$opts) = @_;
    my $server_list;
    if($opts->{servers}) {
        $server_list = delete $opts->{servers};
        if(ref $server_list ne 'ARRAY') {
            $server_list = [$server_list];
        }
    } elsif ($opts->{server}) {
        $server_list = [ delete $opts->{server} or die "server is false" ];
    } else {
        die("Must have server or servers");
    }

    my $connected_ok;
    my $no_init_connect = $opts->{no_init_connect};
    my $self;

    my @all_errors;

    my $privopts;
    while(!$connected_ok && (my $server = shift @$server_list)) {
        $opts->{server} = $server;
        $privopts = {%$opts};
        my $arglist = _MkCtorIDX($privopts);
        $self = $pkg->construct($arglist);
        my $errors = $self->get_errors;
        my $error_retriable;
        if(scalar @$errors) {
            push @all_errors, @$errors;
            foreach (@$errors) {
                my ($errno,$errstr) = @$_;
                if(exists $RETRY_ERRORS{$errno}) {
                    $error_retriable++;
                }
            }
            if(!$error_retriable) {
                last;
            }
        } else {
            last;
        }
        if($no_init_connect) {
            last;
        }
    }
    @{$self->get_errors} = @all_errors;
    return $self;

}

#This is called from within C to record our stats:
sub _stats_helper {
    my ($hash,$server,$key,$data) = @_;
    #printf("Got server %s, key%s\n", $server, $key);
    $key ||= "__default__";
    ($hash->{$server}->{$key} ||= "") .= $data;
}

1;

__END__