File Coverage

blib/lib/Couch/DB/Mojolicious.pm

Criterion	Covered	Total	%
statement	27	72	37.5
branch	0	18	0.0
condition	0	22	0.0
subroutine	9	17	52.9
pod	1	2	50.0
total	37	131	28.2

# 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: no "use strict"
#oorestyle: no "use warnings"

# SPDX-FileCopyrightText: 2024 Mark Overmeer <[e-mail]>
# SPDX-License-Identifier: Artistic-2.0

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

use parent 'Couch::DB';
use feature 'state';

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}} );
#warn "HEADERS = ", join ';', %headers;

	my $url     = $client->server->clone->path($path);
	$url->query($query) if $query;

	my @body
	= ! defined $send ? ()
	: $headers{'Content-Type'} eq 'application/json' ? (json => $send)
	:    $send;

	# $tx is a Mojo::Transaction::HTTP
	my $tx   = $ua->build_tx($method => $url, \%headers, @body);

	my $plan = $ua->start_p($tx)->then(sub ($) {
		my $tx = shift;
		my $response = $tx->res;
		$result->setFinalResult({
			client   => $client,
			request  => $tx->req,
			response => $response,
			code     => $response->code,
			message  => $response->message,
		});
	});

	if($delay)
	{	$result->setResultDelayed({ client => $client });
	}
	else
	{	$plan->wait;
	}

	1;
}

sub _extractAnswer($)
{	my ($self, $response) = @_;
	my $content = $response->content;

	$response->content->is_multipart
		or return $response->json;

	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;