File Coverage

blib/lib/Gerrit/REST.pm

Criterion	Covered	Total	%
statement	27	94	28.7
branch	0	48	0.0
condition	0	3	0.0
subroutine	9	16	56.2
pod	4	4	100.0
total	40	165	24.2

package Gerrit::REST;
{
  $Gerrit::REST::VERSION = '0.011';
}
# ABSTRACT: Thin wrapper around Gerrit's REST API

use 5.010;
use utf8;
use strict;
use warnings;

use Carp;
use URI;
use JSON;
use Data::Util qw/:check/;
use REST::Client;

sub new {
    my ($class, $URL, $username, $password, $rest_client_config) = @_;

    $URL = URI->new($URL) if is_string($URL);
    is_instance($URL, 'URI')
        or croak __PACKAGE__ . "::new: URL argument must be a string or a URI object.\n";

    # If no password is set we try to lookup the credentials in the .netrc file
    if (! defined $password) {
        eval {require Net::Netrc}
            or croak "Can't require Net::Netrc module. Please, specify the USERNAME and PASSWORD.\n";
        if (my $machine = Net::Netrc->lookup($URL->host, $username)) { # $username may be undef
            $username = $machine->login;
            $password = $machine->password;
        } else {
            croak "No credentials found in the .netrc file.\n";
        }
    }

    is_string($username)
        or croak __PACKAGE__ . "::new: USERNAME argument must be a string.\n";

    is_string($password)
        or croak __PACKAGE__ . "::new: PASSWORD argument must be a string.\n";

    $rest_client_config = {} unless defined $rest_client_config;
    is_hash_ref($rest_client_config)
        or croak __PACKAGE__ . "::new: REST_CLIENT_CONFIG argument must be a hash-ref.\n";

    my $rest = REST::Client->new($rest_client_config);

    # Set default base URL
    $rest->setHost($URL);

    # Follow redirects/authentication by default
    $rest->setFollow(1);

    # Request compact JSON by default
    $rest->addHeader('Accept' => 'application/json');

    # Configure UserAgent name and password authentication
    for my $ua ($rest->getUseragent) {
        $ua->agent(__PACKAGE__);
        $ua->credentials($URL->host_port, 'Gerrit Code Review', $username, $password);
    }

    return bless {
        rest => $rest,
        json => JSON->new->utf8->allow_nonref,
    } => $class;
}

sub _error {
    my ($self, $content, $type, $code) = @_;

    $type = 'text/plain' unless $type;
    $code = 500          unless $code;

    my $msg = __PACKAGE__ . " Error[$code";

    if (eval {require HTTP::Status}) {
        if (my $status = HTTP::Status::status_message($code)) {
            $msg .= " - $status";
        }
    }

    $msg .= "]:\n";

    if ($type =~ m:text/plain:i) {
        $msg .= $content;
    } elsif ($type =~ m:text/html:i && eval {require HTML::TreeBuilder}) {
        $msg .= HTML::TreeBuilder->new_from_content($content)->as_text;
    } else {
        $msg .= "";
    };
    $msg =~ s/\n*$/\n/s;       # end message with a single newline
    return $msg;
}

sub _content {
    my ($self) = @_;

    my $rest    = $self->{rest};
    my $code    = $rest->responseCode();
    my $type    = $rest->responseHeader('Content-Type');
    my $content = $rest->responseContent();

    $code =~ /^2/
        or croak $self->_error($content, $type, $code);

    if (! defined $type) {
        return;
    } elsif ($type =~ m:^application/json:i) {
        if (substr($content, 0, 4) eq ")]}'") {
            return $self->{json}->decode(substr($content, 5));
        } else {
            croak $self->_error("Missing \")]}'\" prefix for JSON content:\n\n$content");
        }
    } elsif ($type =~ m:^text/plain:i) {
        return $content;
    } else {
        croak $self->_error("I don't understand content with Content-Type '$type'");
    }
}

sub GET {
    my ($self, $resource) = @_;

    eval { $self->{rest}->GET("/a$resource") }
        or croak $self->_error("Error in GET(/a$resource): $@");

    return $self->_content();
}

sub DELETE {
    my ($self, $resource) = @_;

    eval { $self->{rest}->DELETE("/a$resource") }
        or croak $self->_error("Error in DELETE(/a$resource): $@");

    return $self->_content();
}

sub PUT {
    my ($self, $resource, $value) = @_;

    eval { $self->{rest}->PUT(
        "/a$resource",
        $self->{json}->encode($value),
        {'Content-Type' => 'application/json;charset=UTF-8'},
    ) }
        or croak $self->_error("Error in PUT(/a$resource, ...): $@");

    return $self->_content();
}

sub POST {
    my ($self, $resource, $value) = @_;

    eval { $self->{rest}->POST(
        "/a$resource",
        $self->{json}->encode($value),
        {'Content-Type' => 'application/json;charset=UTF-8'},
    ) }
        or croak $self->_error("Error in POST(/a$resource, ...): $@");

    return $self->_content();
}

1;

__END__