REST::Client - A simple client for interacting with RESTful http/https resources

 use REST::Client;

 #The basic use case
 my $client = REST::Client->new();
 $client->GET('http://example.com/dir/file.xml');
 print $client->responseContent();

 #A host can be set for convienience
 $client->setHost('http://example.com');
 $client->PUT('/dir/file.xml', '<example>new content</example>');
 if( $client->responseCode() eq '200' ){
     print "Updated\n";
 }

 #custom request headers may be added
 $client->addHeader('CustomHeader', 'Value');

 #response headers may be gathered
 print $client->responseHeader('ResponseHeader');

 #X509 client authentication
 $client->setCert('/path/to/ssl.crt');
 $client->setKey('/path/to/ssl.key');

 #add a CA to verify server certificates
 $client->setCa('/path/to/ca.file');

 #you may set a timeout on requests, in seconds
 $client->setTimeout(10);

 #options may be passed as well as set
 $client = REST::Client->new({
         host    => 'https://example.com',
         cert    => '/path/to/ssl.crt',
         key     => '/path/to/ssl.key',
         ca      => '/path/to/ca.file',
         timeout => 10,
     });
 $client->GET('/dir/file', {CustomHeader => 'Value'});

 # Requests can be specificed directly as well
 $client->request('GET', '/dir/file', 'request body content', {CustomHeader => 'Value'});

 # Requests can optionally automatically follow redirects and auth, defaults to
 # false 
 $client->setFollow(1);

 #It is possible to access the L<LWP::UserAgent> object REST::Client is using to
 #make requests, and set advanced options on it, for instance:
 $client->getUseragent()->proxy(['http'], 'http://proxy.example.com/');

 print $client->GET('/search/?q=foobar')->responseContent();

package REST::Client;

use strict;
use warnings;
use 5.008_000;

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

our ($VERSION) = ('$Rev: 217 $' =~ /(\d+)/);

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

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 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: First argument to request must be one of GET, PUT, POST, DELETE, OPTIONS, HEAD" unless $method =~ /^(get|put|post|delete|options|head)$/i;
    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);

    #to ensure we use our desired SSL lib
    my $tmp_socket_ssl_version = $IO::Socket::SSL::VERSION;
    $IO::Socket::SSL::VERSION = undef;

    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($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;

        $ENV{'HTTPS_CERT_FILE'} = $self->getCert;
        $ENV{'HTTPS_KEY_FILE'}  = $self->getKey; 
        if(my $ca = $self->getCa){
            croak "REST::Client exception: Cannot read CA file" unless -f $ca;
            $ENV{'HTTPS_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) : $ua->simple_request($req);
    $IO::Socket::SSL::VERSION = $tmp_socket_ssl_version;

    $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;

    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);

    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;