Couch-DB
view release on metacpan or search on metacpan
bin/reference-table view on Meta::CPAN
my %impls_by_call; # from this module
my %impls_by_use; # from this module
my %http_order;
$http_order{$_} = keys %http_order for qw/GET POST PUT COPY DELETE/;
####
###### parse the couchdb api index
####
sub fill_index()
{
my $routing;
if($refresh || ! -r $couchdb_cache || -M $couchdb_cache > 14)
{ print "Loading new routing table from couchdb.org\n";
my $ua = LWP::UserAgent->new;
my $overview = $ua->get($couchdb_index);
$routing = $overview->decoded_content;
write_text $couchdb_cache, $routing;
}
else
bin/reference-table view on Meta::CPAN
my @modules = (
{ file => 'lib/Couch/DB.pm', base => '$couch' },
{ file => 'lib/Couch/DB/Client.pm', base => '$client' },
{ file => 'lib/Couch/DB/Cluster.pm', base => '$cluster' },
{ file => 'lib/Couch/DB/Database.pm', base => '$db' },
{ file => 'lib/Couch/DB/Document.pm', base => '$doc' },
{ file => 'lib/Couch/DB/Design.pm', base => '$ddoc' },
{ file => 'lib/Couch/DB/Node.pm', base => '$node' },
);
sub fill_impls_by_call()
{
MODULE:
foreach my $module (@modules)
{ my $last_use;
my $package;
my $file = $module->{file};
unless(-e $file)
{ print "Module $file does not exist yet.\n";
next MODULE;
bin/reference-table view on Meta::CPAN
my %status_counts;
map $status_counts{$_->{status}}++, @$_ for values %impls_by_call;
warn Dumper \%status_counts;
my %mistakes = map +($_ => 1), keys %impls_by_call;
delete @mistakes{keys %index};
warn "Implementation mismatch: $_\n" for sort keys %mistakes;
sub progress()
{ print <<__PROGRESS;
<h2>Development progress counts</h2>
<p>The implementation is really new, therefore, not everything is ready and
complete. Below, you find the follow conditions.
<table id="status-explain">
<tr><td>DONE</td>
<td class="count">$status_counts{DONE}</td>
<td>Minimally tested: sometimes visual inspection only.</td></tr>
<tr><td>PARTIAL</td>
bin/reference-table view on Meta::CPAN
<tr><td>TODO</td>
<td class="count">$status_counts{TODO}</td>
<td>Implementation not started.</td></tr>
<tr><td>UNSUPPORTED</td>
<td class="count">$status_counts{UNSUPPORTED}</td>
<td>For some reason, it seems useless to implement this.</td></tr>
</table>
__PROGRESS
}
sub cdb2mod()
{ print <<__HEADER;
<h2 name="cdb2mod">CouchDB endpoint → Couch::DB method</h2>
<ul>
<li><a href="#mod2cdb">Couch::DB method → CouchDB endpoint</a></li>
</ul>
<table id="cdb2mod">
<tr><th style="width: 50%"><a href="https://docs.couchdb.org/en/stable/">CouchDB API "stable"</a> and official summary</th>
<th>impl status</th>
<th>Couch::DB use</th></tr>
bin/reference-table view on Meta::CPAN
__ROW2b
}
print <<__FOOTER;
</table>
__FOOTER
}
sub mod2cdb()
{
print <<__HEADER;
<h2 name="mod2cdb">Couch::DB method → CouchDB endpoint</h2>
<ul>
<li><a href="#cdb2mod">CouchDB endpoint → Couch::DB method</a></li>
</ul>
<table id="mod2cdb">
<tr><th>Couch::DB use</th>
<th>impl status</th>
lib/Couch/DB.pm view on Meta::CPAN
use Scalar::Util qw(blessed);
use Storable qw/dclone/;
use URI ();
use URI::Escape qw/uri_escape uri_unescape/;
use constant
{ DEFAULT_SERVER => 'http://127.0.0.1:5984',
};
sub new(%)
{ my ($class, %args) = @_;
$class ne __PACKAGE__
or panic "You have to instantiate extensions of this class";
(bless {}, $class)->init(\%args);
}
sub init($)
{ my ($self, $args) = @_;
my $v = delete $args->{api} or panic "Parameter 'api' is required";
$self->{CD_api} = blessed $v && $v->isa('version') ? $v : version->parse($v);
$self->{CD_clients} = [];
# explicit undef for server means: do not create
my $create_client = ! exists $args->{server} || defined $args->{server};
my $server = delete $args->{server};
my $external = $ENV{PERL_COUCH_DB_SERVER};
lib/Couch/DB.pm view on Meta::CPAN
if $create_client;
$self->{CD_toperl} = delete $args->{to_perl} || {};
$self->{CD_tojson} = delete $args->{to_json} || {};
$self->{CD_toquery} = delete $args->{to_query} || {};
$self;
}
#-------------
sub api() { $_[0]->{CD_api} }
#-------------
sub createClient(%)
{ my ($self, %args) = @_;
my $client = Couch::DB::Client->new(couch => $self, %{$self->{CD_auth}}, %args);
$client ? $self->addClient($client) : undef;
}
sub db($%)
{ my ($self, $name, %args) = @_;
Couch::DB::Database->new(name => $name, couch => $self, %args);
}
sub node($)
{ my ($self, $name) = @_;
$self->{CD_nodes}{$name} ||= Couch::DB::Node->new(name => $name, couch => $self);
}
sub cluster() { $_[0]->{CD_cluster} ||= Couch::DB::Cluster->new(couch => $_[0]) }
#-------------
#XXX the API-doc might be mistaken, calling the "analyzer" parameter "field".
sub searchAnalyze(%)
{ my ($self, %args) = @_;
my %send = (
analyzer => delete $args{analyzer} // panic "No analyzer specified.",
text => delete $args{text} // panic "No text to inspect specified.",
);
$self->call(POST => '/_search_analyze',
introduced => '3.0',
send => \%send,
$self->_resultsConfig(\%args),
);
}
sub requestUUIDs($%)
{ my ($self, $count, %args) = @_;
$self->call(GET => '/_uuids',
introduced => '2.0.0',
query => { count => $count },
$self->_resultsConfig(\%args),
);
}
sub freshUUIDs($%)
{ my ($self, $count, %args) = @_;
my $stock = $self->{CDC_uuids} || [];
my $bulk = delete $args{bulk} || 50;
while($count > @$stock)
{ my $result = $self->requestUUIDs($bulk, _delay => 0) or last;
push @$stock, @{$result->values->{uuids} || []};
}
splice @$stock, 0, $count;
}
#-------------
sub addClient($)
{ my ($self, $client) = @_;
$client or return $self;
$client->isa('Couch::DB::Client') or panic;
push @{$self->{CD_clients}}, $client;
$self;
}
sub clients(%)
{ my ($self, %args) = @_;
my $clients = $self->{CD_clients};
my $role = delete $args{role};
$role ? grep $_->canRole($role), @$clients : @$clients;
}
sub client($)
{ my ($self, $name) = @_;
$name = "$name" if blessed $name;
first { $_->name eq $name } $self->clients; # never many: no HASH needed
}
sub call($$%)
{ my ($self, $method, $path, %args) = @_;
$args{method} = $method;
$args{path} = $path;
$args{query} ||= my $query = {};
my $headers = $args{headers} ||= {};
$headers->{Accept} ||= 'application/json';
$headers->{'Content-Type'} ||= 'application/json';
#use Data::Dumper;
lib/Couch/DB.pm view on Meta::CPAN
}
}
# The error from the last try will remain.
$result;
}
sub _callClient { panic "must be extended" }
# Described in the DETAILS below, non-paging commands
sub _resultsConfig($%)
{ my ($self, $args, @more) = @_;
my %config;
exists $args->{"_$_"} && ($config{$_} = delete $args->{"_$_"})
for qw/delay client clients headers/;
exists $args->{$_} && (push @{$config{$_}}, delete $args->{$_})
for qw/on_error on_final on_chain on_values/;
while(@more)
lib/Couch/DB.pm view on Meta::CPAN
{ # Other parameters used as default
exists $config{$key} or $config{$key} = $value;
}
}
keys %$args and warn "Unused call parameters: ", join ', ', sort keys %$args;
%config;
}
# Described in the DETAILS below, paging commands
sub _resultsPaging($%)
{ my ($self, $args, @more) = @_;
my %state = (harvested => []);
my $succ; # successor
if(my $succeeds = delete $args->{_succeed})
{ delete $args->{_clients}; # no client switching within paging
if(blessed $succeeds && $succeeds->isa('Couch::DB::Result'))
{ # continue from living previous result
$succ = $succeeds->nextPageSettings;
lib/Couch/DB.pm view on Meta::CPAN
$result->_pageAdd($result->answer->{bookmark}, @found); # also call with 0
};
# When less elements are returned
return
( $self->_resultsConfig($args, @more, on_final => $harvest),
paging => \%state,
);
}
sub _pageRequest($$$$)
{ my ($self, $paging, $method, $query, $send) = @_;
my $params = $method eq 'GET' ? $query : $send;
my $progress = @{$paging->{harvested}}; # within the page
my $start = $paging->{start};
$params->{limit} = $paging->{all} ? $paging->{req_max} : (min $paging->{page_size} - $progress, $paging->{req_max});
if(my $bookmark = $paging->{bookmarks}{$start + $progress})
{ $params->{bookmark} = $bookmark;
$params->{skip} = $paging->{skip};
lib/Couch/DB.pm view on Meta::CPAN
my %default_toperl = ( # sub ($couch, $name, $datum) returns value/object
abs_uri => sub { URI->new($_[2]) },
epoch => sub { DateTime->from_epoch(epoch => $_[2]) },
isotime => sub { DateTime::Format::ISO8601->parse_datetime($_[2]) },
mailtime => sub { DateTime::Format::Mail->parse_datetime($_[2]) }, # smart choice by CouchDB?
version => sub { version->parse($_[2]) },
node => sub { $_[0]->node($_[2]) },
);
sub _toPerlHandler($)
{ my ($self, $type) = @_;
$self->{CD_toperl}{$type} || $default_toperl{$type};
}
sub toPerl($$@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toPerlHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
$self;
}
lib/Couch/DB.pm view on Meta::CPAN
uri => sub { "$_[2]" },
node => sub { my $n = $_[2]; blessed $n ? $n->name : $n },
# In Perl, the int might come from text (for instance a configuration
# file. In that case, the JSON::XS will write "6". But the server-side
# JSON is type sensitive and may crash.
int => sub { defined $_[2] ? int($_[2]) : undef },
);
sub _toJsonHandler($)
{ my ($self, $type) = @_;
$self->{CD_tojson}{$type} || $default_tojson{$type};
}
sub toJSON($@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toJsonHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
$self;
}
# Extend/override the list of toJSON converters
my %default_toquery = (
bool => sub { $_[2] ? 'true' : 'false' },
json => sub { encode_json $_[2] },
);
sub _toQueryHandler($)
{ my ($self, $type) = @_;
$self->{CD_toquery}{$type} || $default_toquery{$type}
|| $self->{CD_tojson}{$type} || $default_tojson{$type};
}
sub toQuery($@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toQueryHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
$self;
}
sub jsonText($%)
{ my ($self, $json, %args) = @_;
JSON->new->pretty(not $args{compact})->encode($json);
}
my (%surpress_depr, %surpress_intro);
sub check($$$$)
{ $_[1] or return $_[0];
my ($self, $condition, $change, $version, $what) = @_;
# API-doc versions are sometimes without 3rd part.
my $cv = version->parse($version);
if($change eq 'removed')
{ $self->api < $cv
or error __x"{what} got removed in {release}, but you specified api {api}.",
what => $what, release => $version, api => $self->api;
lib/Couch/DB.pm view on Meta::CPAN
$self;
}
#-------------
#### Extension which perform some tasks which are framework object specific.
# Returns the JSON structure which is part of the response by the CouchDB
# server. Usually, this is the bofy of the response. In multipart
# responses, it is the first part.
sub _extractAnswer($) { panic "must be extended" }
# The the decoded named extension from the multipart message
sub _attachment($$) { panic "must be extended" }
# Extract the decoded body of the message
sub _messageContent($) { panic "must be extended" }
1;
#-------------
lib/Couch/DB/Client.pm view on Meta::CPAN
use Log::Report 'couch-db';
use Scalar::Util qw(weaken blessed);
use List::Util qw(first);
use MIME::Base64 qw(encode_base64);
use Storable qw(dclone);
use URI::Escape qw(uri_escape);
sub new(@) { (bless {}, shift)->init( {@_} ) }
sub init($)
{ my ($self, $args) = @_;
$self->{CDC_server} = my $server = delete $args->{server} or panic "Requires 'server'";
$self->{CDC_name} = delete $args->{name} || "$server";
$self->{CDC_ua} = delete $args->{user_agent} or panic "Requires 'user_agent'";
$self->{CDC_uuids} = [];
$self->{CDC_couch} = delete $args->{couch} or panic "Requires 'couch'";
weaken $self->{CDC_couch};
$self->{CDC_hdrs} = my $headers = delete $args->{headers} || {};
lib/Couch/DB/Client.pm view on Meta::CPAN
auth => delete $args->{auth} || 'BASIC',
username => $username,
password => delete $args->{password},
) if length $username;
$self;
}
#-------------
sub name() { $_[0]->{CDC_name} }
sub couch() { $_[0]->{CDC_couch} }
sub server() { $_[0]->{CDC_server} }
sub userAgent() { $_[0]->{CDC_ua} }
sub headers($) { $_[0]->{CDC_hdrs} }
#-------------
sub _clientIsMe($) # check no client parameter is used
{ my ($self, $args) = @_;
defined $args->{_client} and panic "No parameter 'client' allowed.";
$args->{_clients} && @{delete $args->{_clients}} and panic "No parameter '_clients' allowed.";
$args->{_client} = $self;
}
sub login(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $auth = delete $args{auth} || 'BASIC';
my $username = delete $args{username} or panic "Requires username";
my $password = delete $args{password} or panic "Requires password";
if($auth eq 'BASIC')
{ $self->headers->{Authorization} = 'Basic ' . encode_base64("$username:$password", '');
return $self; #XXX must return Result object
lib/Couch/DB/Client.pm view on Meta::CPAN
$self->couch->call(POST => '/_session',
send => $send,
query => { next => delete $args{next} },
$self->couch->_resultsConfig(\%args, on_final => sub {
$self->{CDC_roles} = $_[0]->isReady ? $_[0]->values->{roles} : undef;
}),
);
}
sub session(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $couch = $self->couch;
my %query;
$query{basic} = delete $args{basic} if exists $args{basic};
$couch->toQuery(\%query, bool => qw/basic/);
$couch->call(GET => '/_session',
query => \%query,
$couch->_resultsConfig(\%args, on_final => sub {
$self->{CDC_roles} = $_[0]->isReady ? $_[0]->values->{userCtx}{roles} : undef; $_[0];
}),
);
}
sub logout(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(DELETE => '/_session',
$self->couch->_resultsConfig(\%args),
);
}
sub roles()
{ my $self = shift;
$self->{CDC_roles} or $self->session(basic => 1); # produced as side-effect
@{$self->{CDC_roles} || []};
}
sub hasRole($) { first { $_[1] eq $_ } $_[0]->roles }
#-------------
sub __serverInfoValues
{ my ($result, $data) = @_;
my %values = %$data;
# 3.3.3 does not contain the vendor/version, as the example in the spec says
# Probably a mistake.
$result->couch->toPerl(\%values, version => qw/version/);
\%values;
}
sub serverInfo(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $cached = delete $args{cached} || 'YES';
$cached =~ m!^(?:YES|NEVER|RETRY|PING)$!
or panic "Unsupported cached parameter '$cached'.";
if(my $result = $self->{CDC_info})
{ return $self->{CDC_info}
if $cached eq 'YES' || ($cached eq 'RETRY' && $result->isReady);
lib/Couch/DB/Client.pm view on Meta::CPAN
if($cached ne 'PING')
{ $self->{CDC_info} = $result;
delete $self->{CDC_version};
}
$result;
}
sub version()
{ my $self = shift;
return $self->{CDC_version} if exists $self->{CDC_version};
my $result = $self->serverInfo(cached => 'YES');
$result->isReady or return undef;
my $version = $result->values->{version}
or error __x"Server info field does not contain the server version.";
$self->{CDC_version} = $version;
}
sub __activeTasksValues($$)
{ my ($result, $tasks) = @_;
my $couch = $result->couch;
my @tasks;
foreach my $task (@$tasks)
{ my %task = %$task;
$couch->toPerl(\%task, epoch => qw/started_on updated_on/);
push @tasks, \%task;
}
\@tasks;
}
sub activeTasks(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(GET => '/_active_tasks',
$self->couch->_resultsConfig(\%args, on_values => \&__activeTasksValues),
);
}
sub __dbNameFilter($)
{ my ($self, $search) = @_;
my $query = +{ %$search };
$self->couch
->toQuery($query, bool => qw/descending/)
->toQuery($query, json => qw/endkey end_key startkey start_key/);
$query;
}
sub databaseNames(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $search = delete $args{search} || {};
$self->couch->call(GET => '/_all_dbs',
query => $self->__dbNameFilter($search),
$self->couch->_resultsConfig(\%args),
);
}
sub databaseInfo(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $names = delete $args{names};
my $search = delete $args{search} || {};
my ($method, $query, $send, $intro) = $names
? (POST => undef, +{ keys => $names }, '2.2.0')
: (GET => $self->_dbNameFilter($search), undef, '3.2.0');
$self->couch->call($method => '/_dbs_info',
introduced => $intro,
query => $query,
send => $send,
$self->couch->_resultsConfig(\%args),
);
}
sub dbUpdates($%)
{ my ($self, $feed, %args) = @_;
$self->_clientIsMe(\%args);
my $query = +{ %$feed };
$self->couch->call(GET => '/_db_updates',
introduced => '1.4.0',
query => $query,
$self->couch->_resultsConfig(\%args),
);
}
sub __clusterNodeValues($)
{ my ($result, $data) = @_;
my $couch = $result->couch;
my %values = %$data;
foreach my $set (qw/all_nodes cluster_nodes/)
{ my $v = $values{$set} or next;
$values{$set} = [ $couch->listToPerl($set, node => $v) ];
}
\%values;
}
sub clusterNodes(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(GET => '/_membership',
introduced => '2.0.0',
$self->couch->_resultsConfig(\%args, on_values => \&__clusterNodeValues),
);
}
sub __replicateValues($$)
{ my ($result, $raw) = @_;
my $couch = $result->couch;
my $history = delete $raw->{history} or return $raw;
my %values = %$raw;
my @history;
foreach my $event (@$history)
{ my %event = %$event;
$couch->toPerl(\%event, mailtime => qw/start_time end_time/);
push @history, \%event;
}
$values{history} = \@history;
\%values;
}
sub replicate($%)
{ my ($self, $rules, %args) = @_;
$self->_clientIsMe(\%args);
my $couch = $self->couch;
$couch->toJSON($rules, bool => qw/cancel continuous create_target winning_revs_only/);
#TODO: warn for upcoming changes in source and target: absolute URLs required
$couch->call(POST => '/_replicate',
send => $rules,
$couch->_resultsConfig(\%args, on_values => \&__replicateValues),
);
}
sub __replJobsValues($$)
{ my ($result, $raw) = @_;
my $couch = $result->couch;
my $values = dclone $raw;
foreach my $job (@{$values->{jobs} || []})
{
$couch->toPerl($_, isotime => qw/timestamp/)
foreach @{$job->{history} || []};
$couch->toPerl($job, isotime => qw/start_time/)
->toPerl($job, abs_url => qw/target source/)
->toPerl($job, node => qw/node/);
}
$values;
}
sub replicationJobs(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(GET => '/_scheduler/jobs',
$self->couch->_resultsPaging(\%args, on_values => \&__replJobsValues),
);
}
sub __replDocValues($$)
{ my ($result, $raw) = @_;
my $v = +{ %$raw }; # $raw->{info} needs no conversions
$result->couch
->toPerl($v, isotime => qw/start_time last_updated/)
->toPerl($v, abs_url => qw/target source/)
->toPerl($v, node => qw/node/);
$v;
}
sub __replDocsValues($$)
{ my ($result, $raw) = @_;
my $couch = $result->couch;
my $values = dclone $raw;
$values->{docs} = [ map __replDocValues($result, $_), @{$values->{docs} || []} ];
$values;
}
sub replicationDocs(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
my $dbname = delete $args{dbname} || '_replicator';
my $path = '/_scheduler/docs';
if($dbname ne '_replicator')
{ $path .= '/' . uri_escape($dbname);
}
$self->couch->call(GET => $path,
$self->couch->_resultsPaging(\%args, on_values => \&__replDocsValues),
);
}
#XXX the output differs from replicationDoc
sub replicationDoc($%)
{ my ($self, $doc, %args) = @_;
$self->_clientIsMe(\%args);
my $dbname = delete $args{dbname} || '_replicator';
my $docid = blessed $doc ? $doc->id : $doc;
my $path = '/_scheduler/docs/' . uri_escape($dbname) . '/' . $docid;
$self->couch->call(GET => $path,
$self->couch->_resultsPaging(\%args, on_values => \&__replDocValues),
);
}
sub __nodeNameValues($)
{ my ($result, $raw) = @_;
my $values = dclone $raw;
$result->couch->toPerl($values, node => qw/name/);
$values;
}
sub nodeName($%)
{ my ($self, $name, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(GET => "/_node/$name",
$self->couch->_resultsConfig(\%args, on_values => \&__nodeNameValues),
);
}
sub node()
{ my $self = shift;
return $self->{CDC_node} if defined $self->{CDC_node};
my $result = $self->nodeName('_local', client => $self);
$result->isReady or return undef; # (temporary?) failure
my $name = $result->value('name')
or error __x"Did not get a node name for _local";
$self->{CDC_node} = $self->couch->node($name);
}
sub serverStatus(%)
{ my ($self, %args) = @_;
$self->_clientIsMe(\%args);
$self->couch->call(GET => '/_up',
introduced => '2.0.0',
$self->couch->_resultsConfig(\%args),
);
}
sub serverIsUp()
{ my $self = shift;
my $result = $self->serverStatus;
$result && $result->answer->{status} eq 'ok';
}
1;
lib/Couch/DB/Cluster.pm view on Meta::CPAN
use Couch::DB::Util qw/flat/;;
use Log::Report 'couch-db';
use Scalar::Util qw(weaken);
use URI::Escape qw(uri_escape);
use Storable qw(dclone);
sub new(@) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
sub init($)
{ my ($self, $args) = @_;
$self->{CDC_couch} = delete $args->{couch} or panic "Requires couch";
weaken $self->{CDC_couch};
$self;
}
#-------------
sub couch() { $_[0]->{CDC_couch} }
#-------------
sub clusterState(%)
{ my ($self, %args) = @_;
my %query;
my @need = flat delete $args{ensure_dbs_exists};
$query{ensure_dbs_exists} = $self->couch->jsonText(\@need, compact => 1)
if @need;
$self->couch->call(GET => '/_cluster_setup',
introduced => '2.0.0',
query => \%query,
$self->couch->_resultsConfig(\%args),
);
}
sub clusterSetup($%)
{ my ($self, $config, %args) = @_;
$self->couch->toJSON($config, int => qw/port node_count/);
$self->couch->call(POST => '/_cluster_setup',
introduced => '2.0.0',
send => $config,
$self->couch->_resultsConfig(\%args),
);
}
#-------------
sub reshardStatus(%)
{ my ($self, %args) = @_;
my $path = '/_reshard';
$path .= '/state' unless delete $args{counts};
$self->couch->call(GET => $path,
introduced => '2.4.0',
$self->couch->_resultsConfig(\%args),
);
}
sub resharding(%)
{ my ($self, %args) = @_;
my %send = (
state => (delete $args{state} or panic "Requires 'state'"),
reason => delete $args{reason},
);
$self->couch->call(PUT => '/_reshard/state',
introduced => '2.4.0',
send => \%send,
$self->couch->_resultsConfig(\%args),
);
}
sub __jobValues($$)
{ my ($couch, $job) = @_;
$couch->toPerl($job, isotime => qw/start_time update_time/)
->toPerl($job, node => qw/node/);
$couch->toPerl($_, isotime => qw/timestamp/)
for @{$job->{history} || []};
}
sub __reshardJobsValues($$)
{ my ($result, $data) = @_;
my $couch = $result->couch;
my $values = dclone $data;
__jobValues($couch, $_) for @{$values->{jobs} || []};
$values;
}
sub reshardJobs(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => '/_reshard/jobs',
introduced => '2.4.0',
$self->couch->_resultsConfig(\%args, on_values => \&__reshardJobsValues),
);
}
sub __reshardStartValues($$)
{ my ($result, $data) = @_;
my $values = dclone $data;
$result->couch->toPerl($_, node => 'node')
for @$values;
$values;
}
sub reshardStart($%)
{ my ($self, $create, %args) = @_;
$self->couch->call(POST => '/_reshard/jobs',
introduced => '2.4.0',
send => $create,
$self->couch->_resultsConfig(\%args, on_values => \&__reshardStartValues),
);
}
sub __reshardJobValues($$)
{ my ($result, $data) = @_;
my $couch = $result->couch;
my $values = dclone $data;
__jobValues($couch, $values);
$values;
}
sub reshardJob($%)
{ my ($self, $jobid, %args) = @_;
$self->couch->call(GET => "/_reshard/jobs/$jobid",
introduced => '2.4.0',
$self->couch->_resultsConfig(\%args, on_values => \&__reshardJobValues),
);
}
sub reshardJobRemove($%)
{ my ($self, $jobid, %args) = @_;
$self->couch->call(DELETE => "/_reshard/jobs/$jobid",
introduced => '2.4.0',
$self->couch->_resultsConfig(\%args),
);
}
sub reshardJobState($%)
{ my ($self, $jobid, %args) = @_;
$self->couch->call(GET => "/_reshard/job/$jobid/state",
introduced => '2.4.0',
$self->couch->_resultsConfig(\%args),
);
}
sub reshardJobChange($%)
{ my ($self, $jobid, %args) = @_;
my %send = (
state => (delete $args{state} or panic "Requires 'state'"),
reason => delete $args{reason},
);
$self->couch->call(PUT => "/_reshard/job/$jobid/state",
introduced => '2.4.0',
send => \%send,
$self->couch->_resultsConfig(\%args),
);
}
sub __dbshards($$)
{ my ($result, $data) = @_;
my $couch = $result->couch;
my %values = %$data;
my $shards = delete $values{shards} || {};
$values{shards} = [ map +($_ => $couch->listToPerl($_, node => $shards->{$_}) ), keys %$shards ];
\%values;
}
sub shardsForDB($%)
{ my ($self, $db, %args) = @_;
$self->couch->call(GET => $db->_pathToDB('_shards'),
introduced => '2.0.0',
$self->couch->_resultsConfig(\%args, on_values => \&__dbshards),
);
}
sub __docshards($$)
{ my ($result, $data) = @_;
my $values = +{ %$data };
$values->{nodes} = [ $result->couch->listToPerl($values, node => delete $values->{nodes}) ];
$values;
}
sub shardsForDoc($%)
{ my ($self, $doc, %args) = @_;
my $db = $doc->db;
$self->couch->call(GET => $db->_pathToDB('_shards/'.$doc->id),
introduced => '2.0.0',
$self->couch->_resultsConfig(\%args, on_values => \&__docshards),
);
}
sub syncShards($%)
{ my ($self, $db, %args) = @_;
$self->couch->call(POST => $db->_pathToDB('_sync_shards'),
send => {},
introduced => '2.3.1',
$self->couch->_resultsConfig(\%args),
);
}
1;
lib/Couch/DB/Database.pm view on Meta::CPAN
use Log::Report 'couch-db';
use Couch::DB::Util qw(flat);
use Scalar::Util qw(weaken blessed);
use HTTP::Status qw(HTTP_OK HTTP_NOT_FOUND);
use JSON::PP ();
sub new(@) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
sub init($)
{ my ($self, $args) = @_;
my $name = $self->{CDD_name} = delete $args->{name} or panic "Requires name";
$name =~ m!^[a-z][a-z0-9_$()+/-]*$!
or error __x"Illegal database name '{name}'.", name => $name;
$self->{CDD_couch} = delete $args->{couch} or panic "Requires couch";
weaken $self->{CDD_couch};
$self->{CDD_batch} = delete $args->{batch};
$self;
}
#-------------
sub name() { $_[0]->{CDD_name} }
sub couch() { $_[0]->{CDD_couch} }
sub batch() { $_[0]->{CDD_batch} }
sub _pathToDB(;$) { '/' . $_[0]->name . (defined $_[1] ? '/' . $_[1] : '') }
#-------------
sub ping(%)
{ my ($self, %args) = @_;
$self->couch->call(HEAD => $self->_pathToDB,
$self->couch->_resultsConfig(\%args),
);
}
sub exists()
{ my $self = shift;
my $result = $self->ping(_delay => 0);
$result->code eq HTTP_NOT_FOUND ? 0
: $result->code eq HTTP_OK ? 1
: undef; # will probably die in the next step
}
sub __detailsValues($$)
{ my ($result, $raw) = @_;
my $couch = $result->couch;
my %values = %$raw; # deep not needed;
$couch->toPerl(\%values, epoch => qw/instance_start_time/);
\%values;
}
sub details(%)
{ my ($self, %args) = @_;
my $part = delete $args{partition};
#XXX Value instance_start_time is now always zero, useful to convert if not
#XXX zero in old nodes?
$self->couch->call(GET => $self->_pathToDB($part ? '_partition/'.uri_escape($part) : undef),
$self->couch->_resultsConfig(\%args, on_values => \&__detailsValues),
);
}
sub create(%)
{ my ($self, %args) = @_;
my $couch = $self->couch;
my %query;
exists $args{$_} && ($query{$_} = delete $args{$_})
for qw/partitioned q n/;
$couch->toQuery(\%query, bool => qw/partitioned/);
$couch->toQuery(\%query, int => qw/q n/);
$couch->call(PUT => $self->_pathToDB,
query => \%query,
send => { },
$self->couch->_resultsConfig(\%args),
);
}
sub remove(%)
{ my ($self, %args) = @_;
$self->couch->call(DELETE => $self->_pathToDB,
$self->couch->_resultsConfig(\%args),
);
}
sub userRoles(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => $self->_pathToDB('_security'),
$self->couch->_resultsConfig(\%args),
);
}
sub userRolesChange(%)
{ my ($self, %args) = @_;
my %send = (
admin => delete $args{admin} || [],
members => delete $args{members} || [],
);
$self->couch->call(PUT => $self->_pathToDB('_security'),
send => \%send,
$self->couch->_resultsConfig(\%args),
);
}
sub changes { ... }
sub compact(%)
{ my ($self, %args) = @_;
my $path = $self->_pathToDB('_compact');
if(my $ddoc = delete $args{design})
{ $path .= '/' . (blessed $ddoc ? $ddoc->id :$ddoc);
}
$self->couch->call(POST => $path,
send => { },
$self->couch->_resultsConfig(\%args),
);
}
sub __ensure($$)
{ my ($result, $raw) = @_;
return $raw unless $raw->{instance_start_time}; # exists && !=0
my $v = { %$raw };
$result->couch->toPerl($v, epoch => qw/instance_start_time/);
$v;
}
sub ensureFullCommit(%)
{ my ($self, %args) = @_;
$self->couch->call(POST => $self->_pathToDB('_ensure_full_commit'),
deprecated => '3.0.0',
send => { },
$self->couch->_resultsConfig(\%args, on_values => \&__ensure),
);
}
sub purgeDocs($%)
{ my ($self, $plan, %args) = @_;
#XXX looking for smarter behavior here, to construct a plan.
my $send = $plan;
$self->couch->call(POST => $self->_pathToDB('_purge'),
$self->couch->_resultsConfig(\%args),
);
}
#XXX seems not really a useful method.
sub purgeRecordsLimit(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => $self->_pathToDB('_purged_infos_limit'),
$self->couch->_resultsConfig(\%args),
);
}
#XXX attribute of database creation
sub purgeRecordsLimitSet($%)
{ my ($self, $value, %args) = @_;
$self->couch->call(PUT => $self->_pathToDB('_purged_infos_limit'),
send => int($value),
$self->couch->_resultsConfig(\%args),
);
}
sub purgeUnusedViews(%)
{ my ($self, %args) = @_;
#XXX nothing to send?
$self->couch->call(POST => $self->_pathToDB('_view_cleanup'),
$self->couch->_resultsConfig(\%args),
);
}
sub revisionsMissing($%)
{ my ($self, $plan, %args) = @_;
#XXX needs extra features
$self->couch->call(POST => $self->_pathToDB('_missing_revs'),
send => $plan,
$self->couch->_resultsConfig(\%args),
);
}
sub revisionsDiff($%)
{ my ($self, $plan, %args) = @_;
#XXX needs extra features
$self->couch->call(POST => $self->_pathToDB('_revs_diff'),
send => $plan,
$self->couch->_resultsConfig(\%args),
);
}
#XXX seems not really a useful method.
sub revisionLimit(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => $self->_pathToDB('_revs_limit'),
$self->couch->_resultsConfig(\%args),
);
}
#XXX attribute of database creation
sub revisionLimitSet($%)
{ my ($self, $value, %args) = @_;
$self->couch->call(PUT => $self->_pathToDB('_revs_limit'),
send => int($value),
$self->couch->_resultsConfig(\%args),
);
}
#-------------
sub designs(;$%)
{ my ($self, $search, %args) = @_;
my $couch = $self->couch;
my @search = flat $search;
my ($method, $path, $send) = (GET => $self->_pathToDB('_design_docs'), undef);
if(@search)
{ $method = 'POST';
my @s = map $self->_designPrepare($method, $_), @search;
if(@search==1)
lib/Couch/DB/Database.pm view on Meta::CPAN
}
}
$self->couch->call($method => $path,
($send ? (send => $send) : ()),
$couch->_resultsConfig(\%args),
);
}
sub _designPrepare($$$)
{ my ($self, $method, $data, $where) = @_;
$method eq 'POST' or panic;
my $s = +{ %$data };
# Very close to a view search, but not equivalent. At least: according to the
# API documentation :-(
$self->couch
->toJSON($s, bool => qw/conflicts descending include_docs inclusive_end update_seq/)
->toJSON($s, int => qw/limit skip/);
$s;
}
sub createIndex($%)
{ my ($self, $filter, %args) = @_;
my $couch = $self->couch;
my $send = +{ %$filter };
if(my $design = delete $args{design})
{ $send->{ddoc} = blessed $design ? $design->id : $design;
}
$couch->toJSON($send, bool => qw/partitioned/);
$couch->call(POST => $self->_pathToDB('_index'),
send => $send,
$couch->_resultsConfig(\%args),
);
}
sub indexes(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => $self->_pathToDB('_index'),
$self->couch->_resultsConfig(\%args),
);
}
#-------------
sub doc($%)
{ my ($self, $id) = @_;
Couch::DB::Document->new(id => $id, db => $self, @_);
}
sub __bulk($$$$)
{ my ($self, $result, $saves, $deletes, $issues) = @_;
$result or return;
my %saves = map +($_->id => $_), @$saves;
my %deletes = map +($_->id => $_), @$deletes;
foreach my $report (@{$result->values})
{ my $id = $report->{id};
my $delete = exists $deletes{$id};
my $doc = delete $deletes{$id} || delete $saves{$id}
lib/Couch/DB/Database.pm view on Meta::CPAN
$issues->($result, $saves{$_},
+{ error => 'missing', reason => "The server did not report back on saving $_." }
) for keys %saves;
$issues->($result, $deletes{$_},
+{ error => 'missing', reason => "The server did not report back on deleting $_.", delete => 1 }
) for keys %deletes;
}
sub saveBulk($%)
{ my ($self, $docs, %args) = @_;
my $couch = $self->couch;
my $issues = delete $args{issues} || sub {};
my @plan;
foreach my $doc (@$docs)
{ my $rev = $doc->rev;
my %plan = %{$doc->revision($rev)};
$plan{_id} = $doc->id;
$plan{_rev} = $rev if $rev ne '_new';
lib/Couch/DB/Database.pm view on Meta::CPAN
$couch->call(POST => $self->_pathToDB('_bulk_docs'),
send => $send,
$couch->_resultsConfig(\%args,
on_final => sub { $self->__bulk($_[0], $docs, \@deletes, $issues) },
),
);
}
sub inspectDocs($%)
{ my ($self, $docs, %args) = @_;
my $couch = $self->couch;
my $query;
$query->{revs} = delete $args{revs} if exists $args{revs};
$couch->toQuery($query, bool => qw/revs/);
@$docs or error __x"need at least on document for bulk query.";
#XXX what does "conflicted documents mean?
#XXX what does "a": 1 mean in its response?
$self->couch->call(POST => $self->_pathToDB('_bulk_get'),
query => $query,
send => { docs => $docs },
$couch->_resultsConfig(\%args),
);
}
sub __toDocs($$%)
{ my ($self, $result, $data, %args) = @_;
foreach my $row (@{$data->{rows}})
{ my $doc = $row->{doc} or next;
$row->{doc} = Couch::DB::Document->_fromResponse($result, $doc, %args);
}
$data;
}
sub __searchValues($$%)
{ my ($self, $result, $raw, %args) = @_;
$args{db} = $self;
my $values = +{ %$raw };
if(my $multi = $values->{results})
{ # Multiple queries, multiple answers
$values->{results} = [ map $self->__toDocs($result, +{ %$_ }, %args), flat $multi ];
}
else
{ # Single query
$self->__toDocs($result, $values, %args);
}
$values;
}
sub search(;$%)
{ my ($self, $search, %args) = @_;
my $couch = $self->couch;
my @search = flat $search;
my $part = delete $args{partition};
my $local = delete $args{local};
my $view = delete $args{view};
my $ddoc = delete $args{design};
my $ddocid = blessed $ddoc ? $ddoc->id : $ddoc;
lib/Couch/DB/Database.pm view on Meta::CPAN
),
);
}
my @search_bools = qw/
conflicts descending group include_docs attachments att_encoding_info
inclusive_end reduce sorted stable update_seq
/;
# Handles standard view/_all_docs/_local_docs queries.
sub _viewPrepare($$$)
{ my ($self, $method, $data, $where) = @_;
my $s = +{ %$data };
my $couch = $self->couch;
# Main doc in 1.5.4. /{db}/_design/{ddoc}/_view/{view}
if($method eq 'GET')
{ $couch
->toQuery($s, bool => @search_bools)
->toQuery($s, json => qw/endkey end_key key keys start_key startkey/);
}
lib/Couch/DB/Database.pm view on Meta::CPAN
->check($s->{attachments}, introduced => '1.6.0', 'Search attribute "attachments"')
->check($s->{att_encoding_info}, introduced => '1.6.0', 'Search attribute "att_encoding_info"')
->check($s->{sorted}, introduced => '2.0.0', 'Search attribute "sorted"')
->check($s->{stable}, introduced => '2.1.0', 'Search attribute "stable"')
->check($s->{update}, introduced => '2.1.0', 'Search attribute "update"');
$s;
}
sub __findValues($$)
{ my ($self, $result, $raw) = @_;
my @docs = flat $raw->{docs};
@docs or return $raw;
my %data = %$raw;
$data{docs} = [ map Couch::DB::Document->_fromResponse($result, $_, db => $self), @docs ];
\%data;
}
sub find($%)
{ my ($self, $search, %args) = @_;
my $part = delete $args{partition};
$search->{selector} ||= {};
my $path = $self->_pathToDB;
$path .= '/_partition/'. uri_espace($part) if $part;
$self->couch->call(POST => "$path/_find",
send => $self->_findPrepare(POST => $search),
$self->couch->_resultsPaging(\%args, on_values => sub { $self->__findValues(@_) }),
);
}
sub _findPrepare($$)
{ my ($self, $method, $data, $where) = @_;
my $s = +{ %$data }; # no nesting
$method eq 'POST' or panic;
$self->couch
->toJSON($s, bool => qw/conflicts update stable execution_stats/)
->toJSON($s, int => qw/limit sip r/)
#XXX Undocumented when this got deprecated
->check(exists $s->{stale}, deprecated => '3.0.0', 'Database find(stale)');
$s;
}
sub findExplain(%)
{ my ($self, $search, %args) = @_;
my $part = delete $args{partition};
$search->{selector} ||= {};
my $path = $self->_pathToDB;
$path .= '/_partition/' . uri_escape($part) if $part;
$self->couch->call(POST => "$path/_explain",
send => $self->_findPrepare(POST => $search),
$self->couch->_resultsConfig(\%args),
lib/Couch/DB/Design.pm view on Meta::CPAN
use Couch::DB::Util;
use Log::Report 'couch-db';
use URI::Escape qw/uri_escape/;
use Scalar::Util qw/blessed/;
#-------------
sub _pathToDoc(;$) { $_[0]->db->_pathToDB('_design/' . $_[0]->id) . (defined $_[1] ? '/' . uri_escape $_[1] : '') }
#-------------
sub create($%)
{ my $self = shift;
defined $self->id
or error __x"Design documents do not generate an id by themselves.";
$self->update(@_);
}
sub update($%)
{ my ($self, $data, $args) = @_;
$self->couch
->toJSON($data, bool => qw/autoupdate/)
->check($data->{lists}, deprecated => '3.0.0', 'DesignDoc create() option list')
->check($data->{lists}, removed => '4.0.0', 'DesignDoc create() option list')
->check($data->{show}, deprecated => '3.0.0', 'DesignDoc create() option show')
->check($data->{show}, removed => '4.0.0', 'DesignDoc create() option show')
->check($data->{rewrites}, deprecated => '3.0.0', 'DesignDoc create() option rewrites');
#XXX Do we need more parameter conversions in the nested queries?
$self->SUPER::create($data, $args);
}
sub details(%)
{ my ($self, %args) = @_;
$self->couch->call(GET => $self->_pathToDoc('_info'),
$self->couch->_resultsConfig(\%args),
);
}
#-------------
#-------------
sub createIndex($%)
{ my ($self, $filter, %args) = @_;
$self->db->createIndex(%args, design => $self);
}
sub deleteIndex($%)
{ my ($self, $ddoc, $index, %args) = @_;
$self->couch->call(DELETE => $self->db->_pathToDB('_index/' . uri_escape($self->id) . '/json/' . uri_escape($index)),
$self->couch->_resultsConfig(\%args),
);
}
sub __indexValues($$%)
{ my ($self, $result, $raw, %args) = @_;
delete $args{full_docs} or return $raw;
my $values = +{ %$raw };
$values->{docs} = delete $values->{rows};
$self->db->__toDocs($result, $values, db => $self->db);
$values;
}
sub indexFind($%)
{ my ($self, $index, %args) = @_;
my $couch = $self->couch;
my $search = delete $args{search} || {};
my $query = +{ %$search };
# Everything into the query :-( Why no POST version?
$couch
->toQuery($query, json => qw/counts drilldown group_sort highlight_fields include_fields ranges sort/)
->toQuery($query, int => qw/highlight_number highlight_size limit/)
lib/Couch/DB/Design.pm view on Meta::CPAN
$couch->call(GET => $self->_pathToDDoc('_search/' . uri_escape $index),
introduced => '3.0.0',
query => $query,
$couch->_resultsPaging(\%args,
on_values => sub { $self->__indexValues($_[0], $_[1], db => $self->db, full_docs => $search->{include_docs}) },
),
);
}
sub indexDetails($%)
{ my ($self, $index, %args) = @_;
$self->couch->call(GET => $self->_pathToDDoc('_search_info/' . uri_escape($index)),
introduced => '3.0.0',
$self->couch->_resultsConfig(\%args),
);
}
#-------------
sub viewSearch($;$%)
{ my ($self, $view, $search, %args) = @_;
$self->db->search($search, view => $view, design => $self, %args);
}
#-------------
sub show($;$%)
{ my ($self, $function, $doc, %args) = @_;
my $path = $self->_pathToDoc('_show/'.uri_escape($function));
$path .= '/' . (blessed $doc ? $doc->id : $doc) if defined $doc;
$self->couch->call(GET => $path,
deprecated => '3.0.0',
removed => '4.0.0',
$self->couch->_resultsConfig(\%args),
);
}
sub list($$%)
{ my ($self, $function, $view, %args) = @_;
my $other = defined $args{view_ddoc} ? '/'.delete $args{view_ddoc} : '';
my $path = $self->_pathToDoc('_list/' . uri_escape($function) . $other . '/' . uri_escape($view));
$self->couch->call(GET => $path,
deprecated => '3.0.0',
removed => '4.0.0',
$self->couch->_resultsConfig(\%args),
);
}
#XXX The 3.3.3 doc says /{docid} version requires PUT, but shows a POST example.
#XXX The 3.3.3post4 docs make the example patch with PUT.
#XXX The code probably says: anything except GET is okay.
sub applyUpdate($%)
{ my ($self, $function, $doc, %args) = @_;
my $path = $self->_pathToDoc('_update/'.uri_escape($function));
$path .= '/' . (blessed $doc ? $doc->id : $doc) if defined $doc;
$self->couch->call(POST => $path,
deprecated => '3.0.0',
removed => '4.0.0',
send => { },
$self->couch->_resultsConfig(\%args),
);
lib/Couch/DB/Document.pm view on Meta::CPAN
$VERSION = '0.006';
use Couch::DB::Util;
use Log::Report 'couch-db';
use Scalar::Util qw/weaken/;
use MIME::Base64 qw/decode_base64/;
use Devel::GlobalDestruction qw/in_global_destruction/;
sub new(@) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
sub init($)
{ my ($self, $args) = @_;
$self->{CDD_id} = delete $args->{id};
$self->{CDD_db} = my $db = delete $args->{db};
$self->{CDD_info} = {};
$self->{CDD_batch} = exists $args->{batch} ? delete $args->{batch} : $db->batch;
$self->{CDD_revs} = my $revs = {};
$self->{CDD_local} = delete $args->{local};
$self->{CDD_couch} = $db->couch;
weaken $self->{CDD_couch};
lib/Couch/DB/Document.pm view on Meta::CPAN
{ $revs->{_new} = $content;
}
# The Document is (for now) not linked to its Result source, because
# that might consume a lot of memory. Although it may help debugging.
# weaken $self->{CDD_result} = my $result = delete $args->{result};
$self;
}
sub DESTROY()
{ my $self = shift;
$self->{CDD_revs}{_new} || ! in_global_destruction
or panic "Unsaved new document.";
}
sub _consume($$)
{ my ($self, $result, $data) = @_;
my $id = $self->{CDD_id} = delete $data->{_id};
my $rev = delete $data->{_rev};
# Add all received '_' labels to the existing info.
my $info = $self->{CDD_info} ||= {};
$info->{$_} = delete $data->{$_}
for grep /^_/, keys %$data;
my $attdata = $self->{CDD_atts} ||= {};
lib/Couch/DB/Document.pm view on Meta::CPAN
# Remove sometimes large data
$attdata->{$name} = decode_base64 delete $details->{data} #XXX need decompression?
if defined $details->{data};
}
}
$self->{CDD_revs}{$rev} = $data;
$self;
}
sub _fromResponse($$$%)
{ my ($class, $result, $data, %args) = @_;
$class->new(%args)->_consume($result, $data);
}
#-------------
sub id() { $_[0]->{CDD_id} }
sub db() { $_[0]->{CDD_db} }
sub batch() { $_[0]->{CDD_batch} }
sub couch() { $_[0]->{CDD_couch} }
sub _pathToDoc(;$)
{ my ($self, $path) = @_;
if($self->isLocal)
{ $path and panic "Local documents not supported with path '$path'";
return $self->db->_pathToDB('_local/' . $self->id);
}
$self->db->_pathToDB($self->id . (defined $path ? "/$path" : ''));
}
sub _deleted($)
{ my ($self, $rev) = @_;
$self->{CDD_revs}{$rev} = {};
$self->{CDD_deleted} = 1;
}
sub _saved($$;$)
{ my ($self, $id, $rev, $data) = @_;
$self->{CDD_id} ||= $id;
$self->{CDD_revs}{$rev} = $data || delete $self->{CDD_revs}{_new};
}
#-------------
sub isLocal() { $_[0]->{CDD_local} }
sub isDeleted() { $_[0]->{CDD_deleted} }
sub revision($) { $_[0]->{CDD_revs}{$_[1]} }
sub latest() { $_[0]->revision(($_[0]->revisions)[0]) }
sub revisions()
{ my $revs = $_[0]->{CDD_revs};
no warnings 'numeric'; # forget the "-hex" part of the rev
sort {$b <=> $a} keys %$revs;
}
sub rev() { ($_[0]->revisions)[0] }
#-------------
sub _info() { $_[0]->{CDD_info} or panic "No info yet" }
sub conflicts() { @{ $_[0]->_info->{_conflicts} || [] } }
sub deletedConflicts() { @{ $_[0]->_info->{_deleted_conflicts} || [] } }
sub updateSequence() { $_[0]->_info->{_local_seq} }
sub revisionsInfo()
{ my $self = shift;
return $self->{CDD_revinfo} if $self->{CDD_revinfo};
my $c = $self->_info->{_revs_info}
or error __x"You have requested the open_revs detail for the document yet.";
$self->{CDD_revinfo} = +{ map +($_->{rev} => $_), @$c };
}
sub revisionInfo($) { $_[0]->revisionsInfo->{$_[1]} }
#-------------
sub exists(%)
{ my ($self, %args) = @_;
$self->couch->call(HEAD => $self->_pathToDoc,
$self->couch->_resultsConfig(\%args),
);
}
sub __created($$)
{ my ($self, $result, $data) = @_;
$result or return;
my $v = $result->values;
$v->{ok} or return;
delete $data->{_id}; # do not polute the data
$self->_saved($v->{id}, $v->{rev}, $data);
}
sub create($%)
{ my ($self, $data, %args) = @_;
ref $data eq 'HASH' or panic "Attempt to create document without data.";
my %query;
$query{batch} = 'ok'
if exists $args{batch} ? delete $args{batch} : $self->batch;
# When the _id is (accidentally) undef, no new one will be picked
$data->{_id} ||= $self->id;
defined $data->{_id} or delete $data->{_id};
lib/Couch/DB/Document.pm view on Meta::CPAN
$self->couch->call(POST => $self->db->_pathToDB, # !!
send => $data,
query => \%query,
$self->couch->_resultsConfig(\%args,
on_final => sub { $self->__created($_[0], $data) },
),
);
}
sub update($%)
{ my ($self, $data, %args) = @_;
ref $data eq 'HASH' or panic "Attempt to update the document without data.";
my $couch = $self->couch;
my %query;
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$query{rev} = delete $args{rev} || $self->rev;
$query{new_edits} = delete $args{new_edits} if exists $args{new_edits};
$couch->toQuery(\%query, bool => qw/new_edits/);
$couch->call(PUT => $self->_pathToDoc,
query => \%query,
send => $data,
$couch->_resultsConfig(\%args, on_final => sub { $self->__created($_[0], $data) }),
);
}
sub __get($$)
{ my ($self, $result, $flags) = @_;
$result or return; # do nothing on unsuccessful access
$self->_consume($result, $result->answer);
# meta is a shortcut for other flags
$flags->{conflicts} = $flags->{deleted_conflicts} = $flags->{revs_info} = 1
if $flags->{meta};
$self->{CDD_flags} = $flags;
}
sub get(%)
{ my ($self, $flags, %args) = @_;
my $couch = $self->couch;
my %query = $flags ? %$flags : ();
$couch->toQuery(\%query, bool => qw/attachments att_encoding_info conflicts
deleted_conflicts latest local_seq meta revs revs_info/);
$couch->call(GET => $self->_pathToDoc,
query => \%query,
$couch->_resultsConfig(\%args,
on_final => sub { $self->__get($_[0], $flags) },
_headers => { Accept => $args{attachments} ? 'multipart/related' : 'application/json' },
),
);
}
sub __delete($)
{ my ($self, $result) = @_;
$result or return;
my $v = $result->values;
$self->_deleted($v->{rev}) if $v->{ok};
}
sub delete(%)
{ my ($self, %args) = @_;
my $couch = $self->couch;
my %query;
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$query{rev} = delete $args{rev} || $self->rev;
$couch->call(DELETE => $self->_pathToDoc,
query => \%query,
$couch->_resultsConfig(\%args, on_final => sub { $self->__delete($_[0]) }),
);
}
# Not yet implemented. I don't like chaning the headers of my generic UA.
sub cloneInto($%)
{ my ($self, $to, %args) = @_;
my $couch = $self->couch;
my %query;
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$query{rev} = delete $args{rev} || $self->rev;
#XXX still work to do on updating the admin in 'to'
$couch->call(COPY => $self->_pathToDoc,
query => \%query,
$couch->_resultsConfig(\%args,
on_final => sub { $self->__delete($_[0]) },
_headers => +{ Destination => $to->id },
),
);
}
sub appendTo($%)
{ my ($self, $to, %args) = @_;
my $couch = $self->couch;
my %query;
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$query{rev} = delete $args{rev} || $self->rev;
#XXX still work to do on updating the admin in 'to'
my $dest_rev = $to->rev or panic "No revision for destination document.";
lib/Couch/DB/Document.pm view on Meta::CPAN
$couch->_resultsConfig(\%args,
on_final => sub { $self->__delete($_[0]) },
_headers => +{ Destination => $to->id . "?rev=$dest_rev" },
),
);
}
#-------------
sub attInfo($) { $_[0]->_info->{_attachments}{$_[1]} }
sub attachments() { keys %{$_[0]->_info->{_attachments}} }
sub attachment($) { $_[0]->{CDD_atts}{$_[1]} }
sub attExists($%)
{ my ($self, $name, %args) = @_;
my %query = ( rev => delete $args{rev} || $self->rev );
$self->couch->call(HEAD => $self->_pathToDoc($name),
query => \%query,
$self->couch->_resultsConfig(\%args),
);
}
sub __attLoad($$)
{ my ($self, $result, $name) = @_;
$result or return;
my $data = $self->couch->_messageContent($result->response);
$self->_info->{_attachments}{$name} = { length => length $data };
$self->{CDD_atts}{$name} = $data;
}
sub attLoad($%)
{ my ($self, $name, %args) = @_;
my %query = ( rev => delete $args{rev} || $self->rev );
$self->couch->call(GET => $self->_pathToDoc($name),
query => \%query,
$self->couch->_resultsConfig(\%args,
on_final => sub { $self->__attLoad($_[0], $name) },
),
);
}
sub attSave($$%)
{ my ($self, $name, $data, %args) = @_;
my $type = delete $args{type} || 'application/octet-stream';
my %query = (rev => delete $args{rev} || $self->rev);
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$self->couch->call(PUT => $self->_pathToDoc($name),
query => \%query,
send => $data,
$self->couch->_resultsConfig(\%args,
_headers => { 'Content-Type' => $type },
),
);
}
sub attDelete($$$%)
{ my ($self, $name, %args) = @_;
my %query = (rev => delete $args{rev} || $self->rev);
$query{batch} = 'ok' if exists $args{batch} ? delete $args{batch} : $self->batch;
$self->couch->call(DELETE => $self->_pathToDoc($name),
query => \%query,
$self->couch->_resultsConfig(\%args),
);
}
lib/Couch/DB/Mojolicious.pm view on Meta::CPAN
use Log::Report 'couch-db';
use Couch::DB::Util qw(flat);
use Scalar::Util qw(blessed);
use Mojo::URL ();
use Mojo::UserAgent ();
use Mojo::JSON qw(decode_json);
use HTTP::Status qw(HTTP_OK);
sub init($)
{ my ($self, $args) = @_;
$args->{to_perl} =
+{ abs_uri => sub { Mojo::URL->new($_[2]) },
};
$self->SUPER::init($args);
}
#-------------
#-------------
sub createClient(%)
{ my ($self, %args) = @_;
$args{couch} = $self;
my $server = $args{server} || panic "Requires 'server'";
$args{server} = Mojo::URL->new("$server")
unless blessed $server && $server->isa('Mojo::URL');
my $ua = $args{user_agent} ||= state $ua_shared = Mojo::UserAgent->new;
blessed $ua && $ua->isa('Mojo::UserAgent') or panic "Illegal user_agent";
$self->SUPER::createClient(%args);
}
#method call
sub _callClient($$%)
{ my ($self, $result, $client, %args) = @_;
my $method = delete $args{method} or panic;
my $delay = delete $args{delay} || 0;
my $path = delete $args{path};
my $query = delete $args{query};
my $send = delete $args{send};
my $ua = $client->userAgent;
my %headers = ( %{$client->headers}, %{delete $args{headers}} );
lib/Couch/DB/Mojolicious.pm view on Meta::CPAN
if($delay)
{ $result->setResultDelay({ client => $client });
}
else
{ $plan->wait;
}
1;
}
sub _extractAnswer($)
{ my ($self, $response) = @_;
my $content = $response->content;
return $response->json
unless $response->content->is_multipart;
my $part = $response->content->parts->[0];
decode_json $part->asset->slurp;
}
sub _attachment($$)
{ my ($self, $response, $name) = @_;
my $parts = $response->content->parts || [];
foreach my $part (@$parts)
{ my $disp = $part->headers->content_disposition;
return $part->asset->slurp
if $disp && $disp =~ /filename="([^"]+)"/ && $1 eq $name;
}
undef;
}
sub _messageContent($) { $_[1]->body }
1;
lib/Couch/DB/Node.pm view on Meta::CPAN
$VERSION = '0.006';
use Couch::DB::Util;
use Log::Report 'couch-db';
use Scalar::Util qw/weaken/;
sub new(@) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
sub init($)
{ my ($self, $args) = @_;
$self->{CDN_name} = delete $args->{name} // panic "Node has no name";
$self->{CDN_couch} = delete $args->{couch} or panic "Requires couch";
weaken $self->{CDN_couch};
$self;
}
#-------------
sub name() { $_[0]->{CDN_name} }
sub couch() { $_[0]->{CDN_couch} }
#-------------
# [CouchDB API "GET /_node/{node-name}/_prometheus", UNSUPPORTED]
# This is not (yet) supported, because it is a plain-text version of the
# M<stats()> and M<server()> calls.
sub _pathToNode($) { '/_node/'. $_[0]->name . '/' . $_[1] }
sub stats(%)
{ my ($self, %args) = @_;
my $couch = $self->couch;
#XXX No idea which data transformations can be done
$couch->call(GET => $self->_pathToNode('_stats'),
$couch->_resultsConfig(\%args),
);
}
sub server(%)
{ my ($self, %args) = @_;
#XXX No idea which data transformations can be done
$self->couch->call(GET => $self->_pathToNode('_system'),
$self->couch->_resultsConfig(\%args),
);
}
sub restart(%)
{ my ($self, %args) = @_;
#XXX No idea which data transformations can be done
$self->couch->call(POST => $self->_pathToNode('_restart'),
$self->couch->_resultsConfig(\%args),
);
}
sub software(%)
{ my ($self, %args) = @_;
#XXX No idea which data transformations can be done.
#XXX Some versions would match Perl's version object, but that's uncertain.
$self->couch->call(GET => $self->_pathToNode('_versions'),
$self->couch->_resultsConfig(\%args),
);
}
sub config(%)
{ my ($self, %args) = @_;
my $path = $self->_pathToNode('_config');
if(my $section = delete $args{section})
{ $path .= "/$section";
if(my $key = delete $args{key})
{ $path .= "/$key";
}
}
$self->couch->call(GET => $path,
$self->couch->_resultsConfig(\%args),
);
}
sub configChange($$$%)
{ my ($self, $section, $key, $value, %args) = @_;
$self->couch->call(PUT => self->_pathToNode("_config/$section/$key"),
send => $value,
$self->couch->_resultsConfig(\%args),
);
}
sub configDelete($$%)
{ my ($self, $section, $key, %args) = @_;
$self->couch->call(DELETE => self->_pathToNode("_config/$section/$key"),
$self->couch->_resultsConfig(\%args),
);
}
sub configReload(%)
{ my ($self, %args) = @_;
$self->couch->call(POST => self->_pathToNode("_config/_reload"),
$self->couch->_resultsConfig(\%args),
);
}
1;
lib/Couch/DB/Result.pm view on Meta::CPAN
&HTTP_OK => 'Data collected successfully.',
&HTTP_CONTINUE => 'The data collection is delayed.',
&HTTP_MULTIPLE_CHOICES => 'The Result object does not know what to do, yet.',
);
use overload
bool => sub { $_[0]->code < 400 };
sub new(@) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
sub init($)
{ my ($self, $args) = @_;
$self->{CDR_couch} = delete $args->{couch} or panic;
weaken $self->{CDR_couch};
$self->{CDR_on_final} = pile delete $args->{on_final};
$self->{CDR_on_error} = pile delete $args->{on_error};
$self->{CDR_on_chain} = pile delete $args->{on_chain};
$self->{CDR_on_values} = pile delete $args->{on_values};
$self->{CDR_code} = HTTP_MULTIPLE_CHOICES;
$self->{CDR_page} = delete $args->{paging};
$self;
}
#-------------
sub couch() { $_[0]->{CDR_couch} }
sub isDelayed() { $_[0]->code == HTTP_CONTINUE }
sub isReady() { $_[0]->{CDR_ready} }
sub code() { $_[0]->{CDR_code} }
sub codeName(;$)
{ my ($self, $code) = @_;
$code ||= $self->code;
status_constant_name($code) || couch_code_names{$code} || $code;
}
sub message()
{ my $self = shift;
$self->{CDR_msg} || $default_code_texts{$self->code} || $self->codeName;
}
sub status($$)
{ my ($self, $code, $msg) = @_;
$self->{CDR_code} = $code;
$self->{CDR_msg} = $msg;
$self;
}
#-------------
sub client() { $_[0]->{CDR_client} }
sub request() { $_[0]->{CDR_request} }
sub response() { $_[0]->{CDR_response} }
sub answer(%)
{ my ($self, %args) = @_;
return $self->{CDR_answer}
if defined $self->{CDR_answer};
$self->isReady
or error __x"Document not ready: {err}", err => $self->message;
$self->{CDR_answer} = $self->couch->_extractAnswer($self->response),
}
sub values(@)
{ my $self = shift;
return $self->{CDR_values} if exists $self->{CDR_values};
my $values = $self->answer;
$values = $_->($self, $values) for reverse @{$self->{CDR_on_values}};
$self->{CDR_values} = $values;
}
#-------------
sub pagingState(%)
{ my ($self, %args) = @_;
my $next = $self->nextPageSettings;
$next->{harvester} = defined $next->{harvester} ? 'CODE' : 'DEFAULT';
$next->{map} = defined $next->{map} ? 'CODE' : 'NONE';
$next->{client} = $self->client->name;
if(my $maxbook = delete $args{max_bookmarks} // 10)
{ my $bookmarks = $next->{bookmarks};
$next->{bookmarks} = +{ (%$bookmarks)[0..(2*$maxbook-1)] } if keys %$bookmarks > $maxbook;
}
$next;
}
# The next is used r/w when _succeed is a result object, and when results
# have arrived.
sub _thisPage() { $_[0]->{CDR_page} or panic "Call does not support paging." }
sub nextPageSettings()
{ my $self = shift;
my %next = %{$self->_thisPage};
delete $next{harvested};
$next{start} += (delete $next{skip}) + @{$self->page};
#use Data::Dumper;
#warn "NEXT PAGE=", Dumper \%next;
\%next;
}
sub page() { $_[0]->_thisPage->{harvested} }
sub _pageAdd($@)
{ my $this = shift->_thisPage;
my $bookmark = shift;
my $page = $this->{harvested};
if(@_)
{ push @$page, @_;
$this->{bookmarks}{$this->{start} + $this->{skip} + @$page} = $bookmark
if defined $bookmark;
}
else
{ $this->{end_reached} = 1;
}
$page;
}
sub pageIsPartial()
{ my $this = shift->_thisPage;
! $this->{end_reached} && ($this->{all} || @{$this->{harvested}} < $this->{page_size});
}
sub isLastPage() { $_[0]->_thisPage->{end_reached} }
#-------------
sub setFinalResult($%)
{ my ($self, $data, %args) = @_;
my $code = delete $data->{code} || HTTP_OK;
$self->{CDR_client} = my $client = delete $data->{client} or panic "No client";
weaken $self->{CDR_client};
$self->{CDR_ready} = 1;
$self->{CDR_request} = delete $data->{request};
$self->{CDR_response} = delete $data->{response};
$self->status($code, delete $data->{message});
lib/Couch/DB/Result.pm view on Meta::CPAN
while(@chains && $tail)
{ $tail = (pop @chains)->($tail);
blessed $tail && $tail->isa('Couch::DB::Result')
or panic "Chain must return a Result object";
}
$tail;
}
sub setResultDelayed($%)
{ my ($self, $plan, %args) = @_;
$self->{CDR_delayed} = $plan;
$self->status(HTTP_CONTINUE);
$self;
}
sub delayPlan() { $_[0]->{CDR_delayed} }
#-------------
1;
lib/Couch/DB/Util.pm view on Meta::CPAN
our @EXPORT_OK = qw/flat pile apply_tree simplified/;
our %EXPORT_TAGS = ( all => \@EXPORT_OK );
sub import
{ my $class = shift;
$_->import for qw(strict warnings utf8 version);
$class->export_to_level(1, undef, @_);
}
sub flat(@) { grep defined, map +(ref eq 'ARRAY' ? @$_ : $_), @_ }
sub pile(@) { +[ flat @_ ] }
#XXX why can't I find a CPAN module which does this?
sub apply_tree($$);
sub apply_tree($$)
{ my ($tree, $code) = @_;
! ref $tree ? $code->($tree)
: ref $tree eq 'ARRAY' ? +[ map apply_tree($_, $code), @$tree ]
: ref $tree eq 'HASH' ? +{ map +($_ => apply_tree($tree->{$_}, $code)), keys %$tree }
: ref $tree eq 'CODE' ? "$tree"
: $code->($tree);
}
sub simplified($$)
{ my ($name, $data) = @_;
my $v = apply_tree $data, sub ($) {
my $e = shift;
! blessed $e ? $e
: $e->isa('DateTime') ? "DATETIME($e)"
: $e->isa('Couch::DB::Document') ? 'DOCUMENT('.$e->id.')'
: $e->isa('JSON::PP::Boolean') ? ($e ? 'BOOL(true)' : 'BOOL(false)')
: $e->isa('version') ? "VERSION($e)"
: 'OBJECT('.(ref $e).')';
t/12paging.t view on Meta::CPAN
### find, all at once
my $f5 = _result find_all => $db->find($query, _all => 1);
my $docs5 = $f5->page;
cmp_ok @$docs5, '==', 70, '.. all at once';
### find, map
ok 1, 'New call: find_all_map'; # map runs before _result reports test label
sub map6($$)
{ my ($result, $doc) = @_;
isa_ok $result, 'Couch::DB::Result', '...';
isa_ok $doc, 'Couch::DB::Document', '...';
42;
}
my $f6 = _result find_all_map => $db->find($query, _all => 1, _map => \&map6);
my $docs6 = $f6->page;
cmp_ok @$docs6, '==', 70, '.. all at once';
is $docs6->[0], 42, '... first 42';
use lib '../lib';
use Couch::DB::Util qw(simplified);
our @EXPORT_OK = qw/$dump_answers $dump_values $trace _result _framework Dumper/;
our $dump_answers = 0;
our $dump_values = 0;
our $trace = 0;
sub _result($$)
{ my ($name, $result) = @_;
ok defined $result, "New call: $name";
isa_ok $result, 'Couch::DB::Result', "... $name, result";
$dump_answers && warn Data::Dumper->Dump([$result->answer], ['$answer']);
$dump_values && warn simplified values => $result->values;
$result;
}
sub framework_mojo
ok defined $mojo, 'Created Mojolicious tester';
require_ok 'Couch::DB::Mojolicious';
my $couch = Couch::DB::Mojolicious->new(api => '3.3.3');
isa_ok $couch, 'Couch::DB::Mojolicious', '...';
isa_ok $couch, 'Couch::DB', '...';
$couch;
}
sub _framework()
{
defined $ENV{PERL_COUCH_DB_SERVER}
or plan skip_all => "PERL_COUCH_DB_SERVER not set";
framework_mojo;
}
sub import
{ my $class = shift;
$_->import for qw(strict warnings utf8 version);
( run in 3.470 seconds using v1.01-cache-2.11-cpan-65fba6d93b7 )