File Coverage

blib/lib/JSON/API.pm

Criterion	Covered	Total	%
statement	118	128	92.1
branch	37	50	74.0
condition	10	16	62.5
subroutine	22	24	91.6
pod	10	10	100.0
total	197	228	86.4

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.1.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 = ();
}

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) = @_;

	my $json = undef;
	eval {
		$json = to_json($obj);
		$self->_debug("JSON created: $json");
	} or do {
		if ($@) {
			$self->{has_error} = 1;
			$self->{error_string} = $@;
			$self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+\.?\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 {
		$obj = from_json($json);
		$self->_debug("Deserializing successful:",Dumper($obj));
	} or do {
		if ($@) {
			$self->{has_error} = 1;
			$self->{error_string} = $@;
			$self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//;
			$self->_debug("Error deserializing: ".$self->{error_string});
		}
	};
	return $obj;
}

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

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

	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},
		}, 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 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__