File Coverage

blib/lib/REST/Client.pm

Criterion	Covered	Total	%
statement	160	206	77.6
branch	21	50	42.0
condition	6	16	37.5
subroutine	26	30	86.6
pod	15	15	100.0
total	228	317	71.9

package REST::Client;
#ABSTRACT: A simple client for interacting with RESTful http/https resources

our $VERSION = '281';



use strict;
use warnings;
use 5.008_000;

use constant TRUE => 1;
use constant FALSE => 0;

use URI;
use LWP::UserAgent;
use Carp qw(croak carp);


sub new {
    my $class = shift;
    my $config;

    $class->_buildAccessors();

    if(ref $_[0] eq 'HASH'){
        $config = shift;
    }elsif(scalar @_ && scalar @_ % 2 == 0){
        $config = {@_};
    }else{
        $config = {};
    }

    my $self = bless({}, $class);
    $self->{'_config'} = $config;

    $self->_buildUseragent();

    return $self;
}


sub addHeader {
    my $self = shift;
    my $header = shift;
    my $value = shift;

    my $headers = $self->{'_headers'} || {};
    $headers->{$header} = $value;
    $self->{'_headers'} = $headers;
    return;
}


sub buildQuery {
    my $self = shift;

    my $uri = URI->new();
    $uri->query_form(@_);
    return $uri->as_string();
}




sub GET {
    my $self = shift;
    my $url = shift;
    my $headers = shift;
    return $self->request('GET', $url, undef, $headers);
}


sub PUT {
    my $self = shift;
    return $self->request('PUT', @_);
}


sub PATCH {
    my $self = shift;
    return $self->request('PATCH', @_);
}


sub POST {
    my $self = shift;
    return $self->request('POST', @_);
}


sub DELETE {
    my $self = shift;
    my $url = shift;
    my $headers = shift;
    return $self->request('DELETE', $url, undef, $headers);
}


sub OPTIONS {
    my $self = shift;
    my $url = shift;
    my $headers = shift;
    return $self->request('OPTIONS', $url, undef, $headers);
}


sub HEAD {
    my $self = shift;
    my $url = shift;
    my $headers = shift;
    return $self->request('HEAD', $url, undef, $headers);
}


sub request {
    my $self = shift;
    my $method  = shift;
    my $url     = shift;
    my $content = shift;
    my $headers = shift;

    $self->{'_res'} = undef;
    $self->_buildUseragent();


    #error check
    croak "REST::Client exception: Must provide a url to $method" unless $url;
    croak "REST::Client exception: headers must be presented as a hashref" if $headers && ref $headers ne 'HASH';


    $url = $self->_prepareURL($url);

    my $ua = $self->getUseragent();
    if(defined $self->getTimeout()){
        $ua->timeout($self->getTimeout);
    }else{
        $ua->timeout(300);
    }
    my $req = HTTP::Request->new( $method => $url );

    #build headers
    if(defined $content && length($content)){
        $req->content($content);
        $req->header('Content-Length', length($content));
    }else{
        $req->header('Content-Length', 0);
    }

    my $custom_headers = $self->{'_headers'} || {};
    for my $header (keys %$custom_headers){
        $req->header($header, $custom_headers->{$header});
    }

    for my $header (keys %$headers){
        $req->header($header, $headers->{$header});
    }


    #prime LWP with ssl certfile if we have values
    if($self->getCert){
        carp "REST::Client exception: Certs defined but not using https" unless $url =~ /^https/;
        croak "REST::Client exception: Cannot read cert and key file" unless -f $self->getCert && -f $self->getKey;

        $ua->ssl_opts(SSL_cert_file => $self->getCert);
        $ua->ssl_opts(SSL_key_file => $self->getKey);
    }

    #prime LWP with CA file if we have one
    if(my $ca = $self->getCa){
        croak "REST::Client exception: Cannot read CA file" unless -f $ca;
        $ua->ssl_opts(SSL_ca_file => $ca);
    }

    #prime LWP with PKCS12 certificate if we have one
    if($self->getPkcs12){
        carp "REST::Client exception: PKCS12 cert defined but not using https" unless $url =~ /^https/;
        croak "REST::Client exception: Cannot read PKCS12 cert" unless -f $self->getPkcs12;

        $ENV{HTTPS_PKCS12_FILE}     = $self->getPkcs12;
        if($self->getPkcs12password){
            $ENV{HTTPS_PKCS12_PASSWORD} = $self->getPkcs12password;
        }
    }

    my $res = $self->getFollow ?
        $ua->request( $req, $self->getContentFile ) :
        $ua->simple_request( $req, $self->getContentFile );

    $self->{_res} = $res;

    return $self;
}


sub responseCode {
    my $self = shift;
    return $self->{_res}->code;
}


sub responseContent {
    my $self = shift;
    return $self->{_res}->content;
}


sub responseHeaders {
    my $self = shift;
    return $self->{_res}->headers()->header_field_names();
}




sub responseHeader {
    my $self = shift;
    my $header = shift;
    croak "REST::Client exception: no header provided to responseHeader" unless $header;
    return $self->{_res}->header($header);
}


sub responseXpath {
    my $self = shift;

    require XML::LibXML;

    my $xml= XML::LibXML->new();
    $xml->load_ext_dtd(0);

    if($self->responseHeader('Content-type') =~ /html/){
        return XML::LibXML::XPathContext->new($xml->parse_html_string( $self->responseContent() ));
    }else{
        return XML::LibXML::XPathContext->new($xml->parse_string( $self->responseContent() ));
    }
}

# Private methods

sub _prepareURL {
    my $self = shift;
    my $url = shift;

    # Do not prepend default host to absolute URLs.
    return $url if $url =~ /^https?:/;

    my $host = $self->getHost;
    if($host){
        $url = '/'.$url unless $url =~ /^\//;
        $url = $host . $url;
    }
    unless($url =~ /^\w+:\/\//){
        $url = ($self->getCert ? 'https://' : 'http://') . $url;
    }

    return $url;
}

sub _buildUseragent {
    my $self = shift;

    return if $self->getUseragent();

    my $ua = LWP::UserAgent->new;
    $ua->agent("REST::Client/$VERSION");
    $self->setUseragent($ua);

    return;
}

sub _buildAccessors {
    my $self = shift;

    return if $self->can('setHost');

    my @attributes = qw(Host Key Cert Ca Timeout Follow Useragent Pkcs12 Pkcs12password ContentFile);

    for my $attribute (@attributes){
        my $set_method = "
        sub {
        my \$self = shift;
        \$self->{'_config'}{lc('$attribute')} = shift;
        return \$self->{'_config'}{lc('$attribute')};
        }";

        my $get_method = "
        sub {
        my \$self = shift;
        return \$self->{'_config'}{lc('$attribute')};
        }";


        {
            no strict 'refs';
            *{'REST::Client::set'.$attribute} = eval $set_method ;
            *{'REST::Client::get'.$attribute} = eval $get_method ;
        }

    }

    return;
}

1;

__END__