view release on metacpan or  search on metacpan

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

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) {