File Coverage

blib/lib/AnyEvent/CouchDB.pm

Criterion	Covered	Total	%
statement	36	108	33.3
branch	0	26	0.0
condition	0	10	0.0
subroutine	12	25	48.0
pod	8	9	88.8
total	56	178	31.4

package AnyEvent::CouchDB;

use strict;
use warnings;
our $VERSION = '1.31';

use JSON;
use AnyEvent::HTTP;
use AnyEvent::CouchDB::Database;
use AnyEvent::CouchDB::Exceptions;
use URI;
use URI::Escape;
use File::Basename;
use MIME::Base64;

use Exporter;
use base 'Exporter';

our @EXPORT = qw(couch couchdb);

# exception class shortcuts
our $HTTPError = "AnyEvent::CouchDB::Exception::HTTPError";
our $JSONError = "AnyEvent::CouchDB::Exception::JSONError";

# default JSON encoder
our $default_json = JSON->new->allow_nonref->utf8;

# arbitrary uri support
sub _build_headers {
  my ( $self, $options ) = @_;
  my $headers = $options->{headers};
  if ( ref($headers) ne 'HASH' ) {
    $headers = {};
  }

  # should probably move $options->{type} to $options->{headers}
  if ( exists $options->{type} ) {
    $headers->{'Content-Type'} = $options->{type};
  }
  elsif ( !exists $headers->{'Content-Type'} ) {
    $headers->{'Content-Type'} = 'application/json';
  }

  if ( exists $self->{http_auth} ) {
    $headers->{'Authorization'} = $self->{http_auth};
  }

  return $headers;
}

# return a condvar and callback
#
# - The condvar is what most of our methods return.
#   You can call recv on them to get data back, or
#   you can call cb on them to assign an asynchronous callback to
#   run WHEN the data comes back
#
# - The callback is the code that handles the
#   generic part of every CouchDB response.  This is given
#   to AnyEvent::HTTP.
#
sub cvcb {
  my ($options, $status, $json) = @_;
  $status ||= 200;
  $json   ||= $default_json;
  my $cv = AE::cv;
  AE::now_update();

  # default success handler sends back decoded json response
  my $success = sub {
    my ($resp) = @_;
    $options->{success}->(@_) if ($options->{success});
    $cv->send($resp);
  };

  # default error handler croaks w/ http headers and response
  my $error = sub {
    my ($headers, $response) = @_;
    $options->{error}->(@_) if ($options->{error});
    $cv->croak(
      $HTTPError->new(
        message  => sprintf("%s - %s - %s", $headers->{Status}, $headers->{Reason}, $headers->{URL}),
        headers  => $headers,
        body     => $response
      )
    );
  };

  my $cb = sub {
    my ($body, $headers) = @_;
    my $response;
    eval { $response = $json->decode($body); };
    $cv->croak(
      $JSONError->new(
        message  => $@,
        headers  => $headers,
        body     => $body
      )
    ) if ($@);
    if ($headers->{Status} >= $status and $headers->{Status} < 400) {
      $success->($response);
    } else {
      $error->($headers, $body);
    }
  };
  ($cv, $cb);
}

sub couch {
  AnyEvent::CouchDB->new(@_);
}

sub couchdb {
  my $db = shift;
  if ($db =~ /^https?:/) {
    $db .= '/' if ($db !~ /\/$/);
    my $uri  = URI->new($db);
    my $name = basename($db);
    AnyEvent::CouchDB::Database->new($name, $uri);
  } else {
    AnyEvent::CouchDB->new->db($db);
  }
}

sub new {
  my ($class, $uri) = @_;
  $uri ||= 'http://localhost:5984/';
  my $self = bless { uri => URI->new($uri) } => $class;
  if (my $userinfo = $self->{uri}->userinfo) {
    my $auth = encode_base64($userinfo, '');
    $self->{http_auth} = "Basic $auth";
  }
  return $self;
}

sub all_dbs {
  my ($self, $options) = @_;
  my ($cv, $cb) = cvcb($options);
  http_request(
    GET => $self->{uri}.'_all_dbs',
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub db {
  my ($self, $name) = @_;
  my $uri = $self->{uri}->clone;
  $uri->path(($uri->path ? $uri->path . $name : $name) . "/");
  AnyEvent::CouchDB::Database->new($name, $uri);
}

sub info {
  my ($self, $options) = @_;
  my ($cv, $cb) = cvcb($options);
  http_request(
    GET => $self->{uri}->as_string,
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub config {
  my ($self, $options) = @_;
  my ($cv, $cb) = cvcb($options);
  http_request(
    GET => $self->{uri} . '_config',
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub replicate {
  my ($self, $source, $target, $options) = @_;
  my ($cv, $cb) = cvcb($options);
  my $replication = {source => $source, target => $target};
  if (my $continuous = delete $options->{continuous}) {
    $replication->{continuous} = 1;
  }
  my $body = $default_json->encode($replication);
  http_request(
    POST    => $self->{uri}.'_replicate',
    headers => $self->_build_headers($options),
    body    => $body,
    $cb
  );
  $cv;
}

1;

__END__