view release on metacpan or  search on metacpan

lib/AnyEvent/CouchDB.pm  view on Meta::CPAN

  # 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