view release on metacpan or  search on metacpan

lib/Couch/DB/Database.pm  view on Meta::CPAN

# This code is part of Perl distribution Couch-DB version 0.201.
# The POD got stripped from this file by OODoc version 3.06.
# For contributors see file ChangeLog.

# This software is copyright (c) 2024-2026 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oorestyle: not found P for method saveBulk(%details)

package Couch::DB::Database;{
our $VERSION = '0.201';
}


use warnings;
use strict;

use Log::Report 'couch-db';

use Couch::DB::Util   qw/flat/;
use Couch::DB::Document ();
use Couch::DB::Design   ();

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 ($self, $result, $raw) = @_;
	my %values = %$raw;   # deep not needed;
	$self->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 => sub { $self->__detailsValues(@_) },
		),
	);
}


sub create(%)
{	my ($self, %args) = @_;
	my $couch = $self->couch;