File Coverage

blib/lib/AnyEvent/CouchDB/Database.pm

Criterion	Covered	Total	%
statement	30	239	12.5
branch	0	40	0.0
condition	0	17	0.0
subroutine	10	47	21.2
pod	25	26	96.1
total	65	369	17.6

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;
}

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

sub all_docs {
  my ( $self, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  http_request(
    GET     => $self->uri . '_all_docs' . $query->($options),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub all_docs_by_seq {
  my ( $self, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  http_request(
    GET     => $self->uri . '_all_docs_by_seq' . $query->($options),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub open_doc {
  my ( $self, $doc_id, $options ) = @_;
  if ( not defined $doc_id ) {
    AnyEvent::CouchDB::Exception::UndefinedDocument->throw(
      "An undefined id was passed to open_doc()."
    );
  }
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my $id = uri_escape_utf8($doc_id);
  if ( $id =~ qr{^_design%2F} ) {
    $id =~ s{%2F}{/}g;
  }
  http_request(
    GET     => $self->uri . $id . $query->($options),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub open_docs {
  my ( $self, $doc_ids, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  $options ||= {};
  $options->{'include_docs'} = 'true';
  http_request(
    POST    => $self->uri . '_all_docs' . $query->($options),
    headers => $self->_build_headers($options),
    body    => $self->json( { "keys" => $doc_ids } ),
    $cb
  );
  $cv;
}

sub save_doc {
  my ( $self, $doc, $options ) = @_;

  # create attachment stubs for new inlined attachments
  my $_attachments = sub {
    my ( $doc ) = @_;
    my $_a = $doc->{_attachments};
    return unless defined $_a;
    my $revpos = $doc->{_rev};
    $revpos =~ s/-.*$//;
    for my $key (keys %$_a) {
      if ( exists($_a->{$key}{data}) ) {
        my $file = $_a->{$key};
        $file->{length} = length(decode_base64($file->{data}));
        $file->{revpos} = $revpos;
        $file->{stub}   = JSON::true();
        delete $file->{data};
      }
    }
  };

  if ( $options->{success} ) {
    my $orig = $options->{success};
    $options->{success} = sub {
      my ($resp) = @_;
      $orig->($resp);
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      $_attachments->($doc);
    };
  }
  else {
    $options->{success} = sub {
      my ($resp) = @_;
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      $_attachments->($doc);
    };
  }
  my ( $cv, $cb ) = cvcb( $options, 201, $self->json_encoder );
  my ( $method, $uri );
  if ( not defined $doc->{_id} ) {
    $method = 'POST';
    $uri    = $self->uri;
  }
  else {
    $method = 'PUT';
    $uri    = $self->uri . uri_escape_utf8( $doc->{_id} );
  }
  http_request(
    $method => $uri . $query->($options),
    headers => $self->_build_headers($options),
    body    => $self->json($doc),
    $cb
  );
  $cv;
}

sub remove_doc {
  my ( $self, $doc, $options ) = @_;
  die("Document is missing _id!") unless ( defined $doc->{_id} );
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  http_request(
    DELETE => $self->uri
        . uri_escape_utf8( $doc->{_id} )
        . $query->( { rev => $doc->{_rev} } ),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub attach {
  my ( $self, $doc, $attachment, $options ) = @_;
  my $body < io( $options->{src} );
  my $length = length($body);
  $options->{type} ||= 'text/plain';
  if ( $options->{success} ) {
    my $orig = $options->{success};
    $options->{success} = sub {
      my ($resp) = @_;
      $orig->($resp);
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      $doc->{_attachments} ||= {};
      $doc->{_attachments}->{$attachment} = {
        'content_type' => $options->{type},
        'length'       => $length,
        'stub'         => JSON::true,
      };
    };
  }
  else {
    $options->{success} = sub {
      my ($resp) = @_;
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      $doc->{_attachments} ||= {};
      $doc->{_attachments}->{$attachment} = {
        'content_type' => $options->{type},
        'length'       => $length,
        'stub'         => JSON::true,
      };
    };
  }
  my ( $cv, $cb ) = cvcb( $options, 201, $self->json_encoder );
  http_request(
    PUT => $self->uri
        . uri_escape_utf8( $doc->{_id} ) . "/"
        . uri_escape_utf8($attachment)
        . $query->( { rev => $doc->{_rev} } ),
    headers => $self->_build_headers($options),
    body    => $body,
    $cb
  );
  $cv;
}

sub open_attachment {
  my ( $self, $doc, $attachment, $options ) = @_;
  my $cv = AnyEvent->condvar;

  # passthrough handler without json encoding
  my $success = sub {
    $options->{success}->(@_) if ($options->{success});
    $cv->send(@_);
  };

  # error handler that croaks with http headers
  my $error = sub {
    my $headers = shift;
    $options->{error}->(@_) if ($options->{error});
    $cv->croak(encode_json $headers);
  };

  my $cb = sub {
    my ($body, $headers) = @_;
    if ($headers->{Status} >= 200 and $headers->{Status} < 400) {
      $success->(@_);
    } else {
      $error->($headers);
    }
  };

  http_request(
    GET => $self->uri
        . uri_escape_utf8( $doc->{_id} ) . "/"
        . uri_escape_utf8($attachment),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub detach {
  my ( $self, $doc, $attachment, $options ) = @_;
  if ( $options->{success} ) {
    my $orig = $options->{success};
    $options->{success} = sub {
      my ($resp) = @_;
      $orig->($resp);
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      delete $doc->{_attachments}->{$attachment};
    };
  }
  else {
    $options->{success} = sub {
      my ($resp) = @_;
      $doc->{_id}  = $resp->{id};
      $doc->{_rev} = $resp->{rev};
      delete $doc->{_attachments}->{$attachment};
    };
  }
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  http_request(
    DELETE => $self->uri
        . uri_escape_utf8( $doc->{_id} ) . "/"
        . uri_escape_utf8($attachment)
        . $query->( { rev => $doc->{_rev} } ),
    headers => $self->_build_headers($options),
    $cb
  );
  $cv;
}

sub bulk_docs {
  my ( $self, $docs, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );

  my %props = (); ## _bulk_docs properties go to the request body
  foreach my $property (qw(all_or_nothing new_edits)) {
    if (my $value = delete $options->{$property}) {
      ## convert the respective value to the JSON boolean type
      $props{$property} = $value eq 'false' ? JSON::false() : JSON::true();
    }
  }

  http_request(
    POST    => $self->uri . '_bulk_docs',
    headers => $self->_build_headers($options),
    body    => $self->json( { %props, docs => $docs } ),
    $cb
  );
  $cv;
}

sub query {
  my ( $self, $map_fun, $reduce_fun, $language, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  $language ||= ( ref($map_fun) eq 'CODE' ) ? 'text/perl' : 'javascript';
  my $body = {
    language => $language,
    map      => $code_to_string->($map_fun),
  };
  if ($reduce_fun) {
    $body->{reduce} = $code_to_string->($reduce_fun);
  }
  http_request(
    POST    => $self->uri . '_temp_view' . $query->($options),
    headers => $self->_build_headers($options),
    body    => $self->json($body),
    $cb
  );
  $cv;
}

sub view {
  my ( $self, $name, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my ( $dname, $vname ) = split( '/', $name );
  my $uri = $self->uri . "_design/" . $dname . "/_view/" . $vname;
  if ( $options->{keys} ) {
    my $body = { keys => $options->{keys} };
    my $opts = { %$options };
    delete $opts->{keys};
    http_request(
      POST    => $uri . $query->($opts),
      headers => $self->_build_headers($options),
      body    => $self->json($body),
      $cb
    );
  }
  else {
    my $headers = $self->_build_headers($options);
    http_request(
      GET     => $uri . $query->($options),
      headers => $headers,
      $cb
    );
  }
  $cv;
}

sub head {
  my ( $self, $path, $options ) = @_;
  my ( $cv, undef ) = cvcb( $options, undef, $self->json_encoder );
  my $headers = $self->_build_headers($options);
  my $uri     = $self->uri . "$path" . $query->($options);
  http_request(
    HEAD    => $uri,
    headers => $headers,
    sub { $cv->send( $_[1] ); }
  );
  $cv;
}

sub get {
  my ( $self, $path, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my $headers = $self->_build_headers($options);
  my $uri     = $self->uri . "$path" . $query->($options);
  http_request(
    GET     => $uri,
    headers => $headers,
    $cb
  );
  $cv;
}

sub post {
  my ( $self, $path, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my $headers = $self->_build_headers($options);
  my $uri     = $self->uri . "$path";
  http_request(
    POST    => $uri,
    headers => $headers,
    body    => $query->($options),
    $cb
  );
  $cv;
}

sub delete {
  my ( $self, $path, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my $headers = $self->_build_headers($options);
  my $uri     = $self->uri . "$path" . $query->($options);
  http_request(
    DELETE  => $uri,
    headers => $headers,
    $cb
  );
  $cv;
}

sub put {
  my ( $self, $path, $options ) = @_;
  my ( $cv, $cb ) = cvcb( $options, undef, $self->json_encoder );
  my $headers = $self->_build_headers($options);
  my $uri     = $self->uri . "$path";
  http_request(
    PUT     => $uri,
    headers => $headers,
    body    => $query->($options),
    $cb
  );
  $cv;
}


__END__