File Coverage

blib/lib/WWW/JSON.pm

Criterion	Covered	Total	%
statement	73	82	89.0
branch	23	28	82.1
condition	9	16	56.2
subroutine	19	24	79.1
pod	6	7	85.7
total	130	157	82.8

package WWW::JSON;
use 5.008005;
use strict;
use warnings;

our $VERSION = "1.02";
use LWP::UserAgent;
use Moo;
use Try::Tiny;
use URI;
use WWW::JSON::Response;
use Safe::Isa;
use JSON::XS;
use HTTP::Request::Common;

has ua => (
    is      => 'lazy',
    handles => [qw/timeout default_header/],
    default => sub { LWP::UserAgent->new( %{ $_[0]->ua_options } ) }
);
has base_url => (
    is     => 'rw',
    coerce => sub {
        my $base_url = shift;
        my $u;
        if ( ref($base_url) eq 'ARRAY' ) {
            my ( $url, $params ) = @{$base_url};
            $u = URI->new($url);
            $u->query_form(%$params);
        }
        else {
            $u = URI->new($base_url);
        }
        if ( my $path = $u->path ) {
            unless ( $path =~ m|/$| ) {
                $path =~ s|$|/|;
                $u->path($path);
            }
        }
        return $u;
    }
);
has body_params => ( is => 'rw', default => sub { +{} } );
has query_params => ( is => 'rw', default => sub { +{} } );
has post_body_format => (
    is      => 'rw',
    default => sub { 'serialized' },
    clearer => 1,
    isa     => sub {
        die "Invalid post_body_format $_[0]"
          unless ( $_[0] eq 'serialized' || $_[0] eq 'JSON' );
    }
);
has json =>
  ( is => 'ro', default => sub { JSON::XS->new->utf8->allow_nonref } );

has content_type => ( is => 'rw', clearer => 1 );

has default_response_transform => (
    is      => 'rw',
    clearer => 1,
    isa     => sub {
        die "default_response_transform takes a coderef"
          unless ref( $_[0] ) eq 'CODE';
    }
);

has ua_options => ( is => 'lazy', default => sub { +{} } );

with 'WWW::JSON::Role::Authentication';
my %METHOD_DISPATCH = (
    GET    => \&HTTP::Request::Common::GET,
    POST   => \&HTTP::Request::Common::POST,
    PUT    => \&HTTP::Request::Common::PUT,
    DELETE => \&HTTP::Request::Common::DELETE,
    HEAD   => \&HTTP::Request::Common::HEAD
);

sub get    { shift->req( 'GET',    @_ ) }
sub post   { shift->req( 'POST',   @_ ) }
sub put    { shift->req( 'PUT',    @_ ) }
sub delete { shift->req( 'DELETE', @_ ) }
sub head   { shift->req( 'HEAD',   @_ ) }


sub _http_method_uses_post_body {
    my ($self,$method) = @_;
    return ($method eq 'POST' || $method eq 'PUT');
}

sub req {
    my ( $self, $method, $path, $params, $opts ) = @_;
    $params = {} unless defined($params);
    $opts = {} unless defined($opts);
    ( $path, $params ) = $self->_do_templating( $path, $params )
      if ( $path =~ /\[\%.*\%\]/ );
    my $body_params;
    $body_params = { %{ $self->body_params }, %{$params} }
      if $self->_http_method_uses_post_body($method);
    unless ( $path->$_isa('URI') && $path->scheme ) {
        $path =~ s|^/|./|;
        $path = URI->new($path);
    }

    my $abs_uri =
      ( $path->scheme ) ? $path : URI->new_abs( $path, $self->base_url );

    $abs_uri->query_form(
        $self->_determine_query_params( $method, $path, $params,
            $opts->{query_params} )
    );

    my $request_obj = $self->_create_request_obj( $method, $abs_uri, $body_params );

    return $self->http_request( $request_obj);
}

sub _determine_query_params {
    my ( $self, $method, $path, $params, $opt_params ) = @_;
    my %query_params = (
        $self->base_url->query_form,
        ($self->query_params) ? %{$self->query_params} : (),
        $path->query_form,
        ( $params && ! $self->_http_method_uses_post_body($method) ) ? %$params : (),
        ($opt_params) ? (%$opt_params) : ()
    );
    return %query_params;
}

sub _do_templating {
    my ( $self, $path, $params ) = @_;
    my %modified_params = %$params;
    for my $key ( grep { $_ =~ /^-/ } keys(%$params) ) {
        (my $search_key = $key) =~ s/^-//;
        delete $modified_params{$key}
          if ( $path =~ s/\[\%\s*$search_key\s*\%\]/$params->{$key}/g );
    }
    return ( $path, \%modified_params );
}

sub body_param {
    my ( $self, $k, $v ) = @_;
    $self->body_param->{$k} = $v;
}

sub _create_post_body {
    my ( $self, $method, $p ) = @_;
    if ( $self->post_body_format eq 'JSON' ) {
        return (
            'Content-Type' => $self->content_type || 'application/json',
            Content => $self->json->encode($p)
        );
    }
    return (
        # If this is a POST, let HTTP::Request::Common take care of it
        # for the sake of form uploads.
        Content => ($method eq 'POST') ? $p : $self->_encode_content_body($p),
        'Content-Type' => $self->content_type || 'application/x-www-form-urlencoded'
    );
}

sub _encode_content_body {
    my ($self,$p) = @_;
    my $u = URI->new;
    $u->query_form(%$p);
    return $u->query;
}

sub _create_request_obj {
    my ( $self, $method, $uri, $p ) = @_;
    my $dispatch = $METHOD_DISPATCH{$method}
      or die "Method $method not implemented";

    my %payload;

    if ( $p && $self->_http_method_uses_post_body($method)) {
        %payload = $self->_create_post_body($method,$p);
    }
    return $dispatch->( $uri->as_string, %payload );
}

sub http_request {
    my ( $self, $request_obj ) = @_;
    my $resp = $self->ua->request($request_obj);

    return WWW::JSON::Response->new(
        {
            http_response       => $resp,
            _response_transform => $self->default_response_transform,
            json                => $self->json,
            request_object      => $request_obj,
        }
    );
}

1;
__END__