view release on metacpan or  search on metacpan

lib/Couch/DB/Client.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


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


use warnings;
use strict;

use Couch::DB::Util   qw/flat/;
use Couch::DB::Result ();

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

my $seqnr = 0;

#--------------------

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_seqnr}  = ++$seqnr;

	$self->{CDC_couch}  = delete $args->{couch} or panic "Requires 'couch'";
	weaken $self->{CDC_couch};

	$self->{CDC_hdrs}   = my $headers = delete $args->{headers} || {};

	my $username        = delete $args->{username} // '';
	$self->login(
		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 seqnr() { $_[0]->{CDC_seqnr} }

#--------------------

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
	}

	$auth eq 'COOKIE'
		or error __x"Unsupport authorization '{how}'", how => $auth;

	my $send = $self->{CDC_login}  	 	=     # keep for cookie refresh (uninplemented)
+{name => $username, password => $password };