view release on metacpan or  search on metacpan

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

package AnyEvent::CouchDB::Database;

use strict;
use warnings;
no  warnings 'once';
use JSON;
use AnyEvent::HTTP;
use AnyEvent::CouchDB::Exceptions;
use Data::Dump::Streamer;
use URI::Escape qw( uri_escape uri_escape_utf8 );
use IO::All;
use MIME::Base64;

our $default_json;

# manual import ;-)
*cvcb           = *AnyEvent::CouchDB::cvcb;
*default_json   = *AnyEvent::CouchDB::default_json;
*_build_headers = *AnyEvent::CouchDB::_build_headers;

our $query = sub {
  my $options = shift;
  my $json    = $default_json;
  my @buf;
  if (defined($options) && keys %$options) {
    for my $name (keys %$options) {
      next if ($name eq 'error' || $name eq 'success' || $name eq 'headers');
      my $value = $options->{$name};
      if ($name eq 'key' || $name eq 'startkey' || $name eq 'endkey') {
        $value = uri_escape( $json->encode($value) );
      } else {
        $value = uri_escape_utf8($value);
      }
      if ($name eq 'group' || $name eq 'reduce' || $name eq 'descending' || $name eq 'include_docs') {
        $value = $value
          ? ( ($value eq 'false') ? 'false' : 'true' )
          : 'false';
      }
      push @buf, "$name=$value";
    }
  }
  (@buf)
    ? '?' . join('&', @buf)
    : '';
};

our $code_to_string = sub {
  ref($_[0])
    ? sprintf 'do { my $CODE1; %s; $CODE1 }',
      Data::Dump::Streamer->new->Data($_[0])->Out
    : $_[0];
  # ^- taken from CouchDB::View::Document ------^
};

sub new {
  my ($class, $name, $uri, $json_encoder) = @_;
  $json_encoder ||= $default_json;
  my $self = bless { name => $name, uri => $uri, json_encoder => $json_encoder } => $class;
  if (my $userinfo = $self->uri->userinfo) {
    my $auth = encode_base64($userinfo, '');
    $self->{http_auth} = "Basic $auth";
  }
  return $self;
}

sub name {
  $_[0]->{name};
}

sub uri {
  $_[0]->{uri};
}

sub json_encoder {
  my ($self, $encoder) = @_;
  if ($encoder) {
    $self->{json_encoder} = $encoder;
  } else {
    $self->{json_encoder};
  }
}

sub json {
  my ( $self, $target ) = @_;
  ref($target) ? $self->json_encoder->encode($target) : $target;
}

sub compact {
  my ( $self, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, 202, $self->json_encoder );
  http_request(
    POST    => ( $self->uri . "_compact" ),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub create {
  my ( $self, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, 201, $self->json_encoder );
  http_request(
    PUT     => $self->uri,
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub drop {
  my ( $self, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  http_request(
    DELETE  => $self->uri,
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;