File Coverage

blib/lib/JSON/API.pm

Criterion	Covered	Total	%
statement	129	139	92.8
branch	40	54	74.0
condition	18	25	72.0
subroutine	24	26	92.3
pod	11	11	100.0
total	222	255	87.0

package JSON::API;
use strict;
use HTTP::Status qw/:constants/;
use LWP::UserAgent;
use JSON;
use Data::Dumper;
use URI::Encode qw/uri_encode/;

BEGIN {
	use Exporter ();
	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION = v1.2.0;
	@ISA         = qw(Exporter);
	#Give a hoot don't pollute, do not export more than needed by default
	@EXPORT      = qw();
	@EXPORT_OK   = qw();
	%EXPORT_TAGS = ();
}

# not an object metohd
# build JSON object for encode/decode, disallow nonref
# to match previous non object usage, APIs should be returning
# JSON arrays or JSON objects
sub _build_json {
	# utf8: encode/decode operates on byte strings. HTTP::Request requires
	# bytes; without this, non-ASCII payloads carry the utf8 flag and trip
	# "HTTP::Message content must be bytes".
	JSON->new->utf8->allow_nonref(0);
}
sub _debug
{
	my ($self, @lines) = @_;
	my $output = join('\n', @lines);
	print STDERR $output . "\n" if ($self->{debug});
}

sub _server
{
	my ($self, $input) = @_;
	$input =~ s|^(https?://)?||;
	$input =~ m|^([^\s:/]+)(:\d+)?.*|;
	$input = $1 . ($2 || '');
	return $input;
}

sub _http_req
{
	my ($self, $method, $path, $data, $apphdr) = @_;
	$self->_debug('_http_req called with the following:',Dumper($method,$path,$data, $apphdr));

	my $url = $self->url($path);
	$self->_debug("URL calculated to be: $url");
        delete $self->{response};

	my $headers = HTTP::Headers->new(
			'Accept'       => 'application/json',
			'Content-Type' => 'application/json',
	);
        if( $apphdr && ref $apphdr ) {
            $headers->header( $_, $apphdr->{$_} ) foreach (keys %$apphdr);
        }
	my $json;
	if (defined $data) {
		$json = $self->_encode($data);
		return (wantarray ? (500, {}) : {}) unless defined $json;
	}

	my $req = HTTP::Request->new($method, $url, $headers, $json);
	$self->_debug("Requesting: ",Dumper($req));
	my $res = $self->{user_agent}->request($req);

	$self->_debug("Response: ",Dumper($res));
        $self->{response} = $res;
	if ($res->is_success) {
		$self->{has_error}    = 0;
		$self->{error_string} = '';
		$self->_debug("Successful request detected");
        } elsif ($res->code == HTTP_NOT_MODIFIED) {
            return wantarray ?
                             ($res->code, {}) :
                             {};
        } else {
		$self->{has_error} = 1;
		$self->{error_string} = $res->content;
		$self->_debug("Error detected: ".$self->{error_string});
		# If internal warning, return before decoding, as it will fail + overwrite the error_string
		if ($res->header('client-warning') =~ m/internal response/i) {
			return wantarray ? ($res->code, {}) : {};
		}
	}
	my $decoded = $res->content ? ($self->_decode($res->content) || {}) : {};

	#FIXME: should we auto-populate an error key in the {} if error detected but no content?
	return wantarray ?
			($res->code, $decoded) :
			$decoded;
}

sub _encode
{
	my ($self, $obj) = @_;

	# Validate input ourselves rather than relying on JSON backend's
	# allow_nonref(0). Modern JSON::PP/JSON::XS default allow_nonref to
	# true and may ignore allow_nonref(0); error message text also varies
	# across backends. Guarantee consistent behavior + errstr here.
	unless (ref($obj) eq 'HASH' || ref($obj) eq 'ARRAY') {
		$self->{has_error}    = 1;
		$self->{error_string} = 'hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)';
		$self->_debug("Error serializing json from \$obj:" . $self->{error_string});
		return undef; ## no critic (ProhibitExplicitReturnUndef)
	}

	my $json = undef;
	eval {
		$self->{_json} ||= _build_json();
		$json = $self->{_json}->encode($obj);
		$self->_debug("JSON created: $json");
	} or do {
		if ($@) {
			$self->{has_error} = 1;
			$self->{error_string} = $@;
			# Strip Perl's "at FILE line N" location, optional ",  line/chunk N"
			# suffix Perl appends when <> was active, and any multi-line carp
			# stack trace that follows. /s lets .* span newlines.
			$self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+(?:,\s+\S+\s+(?:line|chunk)\s+\d+)?\..*\z//s;
			$self->_debug("Error serializing json from \$obj:" . $self->{error_string});
		}
	};
	return $json;
}

sub _decode
{
	my ($self, $json) = @_;

	$self->_debug("Deserializing JSON");
	my $obj = undef;
	eval {
		$json = $self->{predecodehook}->($json)
			 if defined($self->{predecodehook});
		$self->{_json} ||= _build_json();
		$obj = $self->{_json}->decode($json);
		$self->_debug("Deserializing successful:",Dumper($obj));
	} or do {
		if ($@) {
			$self->{has_error} = 1;
			$self->{error_string} = $@;
			# Strip Perl's "at FILE line N" location, optional ",  line/chunk N"
			# suffix Perl appends when <> was active, and any multi-line carp
			# stack trace that follows. /s lets .* span newlines.
			$self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+(?:,\s+\S+\s+(?:line|chunk)\s+\d+)?\..*\z//s;
			$self->_debug("Error deserializing: ".$self->{error_string});
		}
	};
	return $obj;
}

sub new
{
	my ($class, $base_url, %parameters) = @_;
	return undef unless $base_url; ## no critic (ProhibitExplicitReturnUndef)

	my %ua_opts = %parameters;
	map { delete $parameters{$_}; } qw(user pass realm debug predecodehook);

	my $ua = LWP::UserAgent->new(%parameters);

	my $self = bless ({
				base_url     => $base_url,
				user_agent   => $ua,
				has_error    => 0,
				error_string => '',
				debug        => $ua_opts{debug},
				predecodehook => $ua_opts{predecodehook},
		}, ref ($class) || $class);

	my $server = $self->_server($base_url);
	my $default_port = $base_url =~ m|^https://| ? 443 : 80;
	$server .= ":$default_port" unless $server =~ /:\d+$/;
	$ua->credentials($server, $ua_opts{realm}, $ua_opts{user}, $ua_opts{pass})
		if ($ua_opts{realm} && $ua_opts{user} && $ua_opts{pass});

	return $self;
}

sub get
{
	my ($self, $path, $data, $apphdr) = @_;
	if ($data) {
		my @qp = map { "$_=".uri_encode($data->{$_}, { encode_reserved => 1 }) } sort keys %$data;
		$path .= "?".join("&", @qp);
	}
	$self->_http_req("GET", $path, undef, $apphdr);
}

sub patch
{
	my ($self, $path, $data, $apphdr) = @_;
	$self->_http_req("PATCH", $path, $data, $apphdr);
}

sub put
{
	my ($self, $path, $data, $apphdr) = @_;
	$self->_http_req("PUT", $path, $data, $apphdr);
}

sub post
{
	my ($self, $path, $data, $apphdr) = @_;
	$self->_http_req("POST", $path, $data, $apphdr);
}

sub del
{
	my ($self, $path, $apphdr) = @_;
	$self->_http_req("DELETE", $path, undef, $apphdr);
}

sub url
{
	my ($self, $path) = @_;
	my $url = $self->{base_url} . "/$path";
	# REGEX-FU: look through the URL, replace any matches of /+ with '/',
	# as long as the previous character was not a ':'
	# (e.g. http://example.com//api//mypath/ becomes http://example.com/api/mypath/
	$url =~ s|(?
	return $url;
}

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

    return $self->{response};
}

sub header
{
    my ($self, $name) = @_;

    return unless( $self->{response} );

    unless( $name ) {
        return $self->{response}->header_field_names;
    }
    return $self->{response}->header( $name );
}

sub errstr
{
	my ($self) = @_;
	return ! $self->was_success ? $self->{error_string} : '';
}

sub was_success
{
	my ($self) = @_;
	return $self->{has_error} ? 0 : 1;
}

1;

__END__