1#@!#!123s

: / usr / share / perl5 / vendor_perl / REST /
Filename : Client.pm
back
package REST::Client;

=head1 NAME

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

=head1 SYNOPSIS

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

=head1 DESCRIPTION

REST::Client provides a simple way to interact with HTTP RESTful resources.

=cut

=head1 METHODS

=cut

use strict;
use warnings;
use 5.008_000;

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

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

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

=head2 Construction and setup

=head3 new ( [%$config] )

Construct a new REST::Client. Takes an optional hash or hash reference or
config flags.  Each config flag also has get/set accessors of the form
getHost/setHost, getUseragent/setUseragent, etc.  These can be called on the
instantiated object to change or check values.

The config flags are:

=over 4

=item host

A default host that will be prepended to all requests.  Allows you to just
specify the path when making requests.

The default is undef - you must include the host in your requests.

=item timeout

A timeout in seconds for requests made with the client.  After the timeout the
client will return a 500.

The default is 5 minutes.

=item cert

The path to a X509 certificate file to be used for client authentication.

The default is to not use a certificate/key pair.

=item key

The path to a X509 key file to be used for client authentication.

The default is to not use a certificate/key pair.

=item ca

The path to a certificate authority file to be used to verify host
certificates.

The default is to not use a certificates authority.

=item pkcs12

The path to a PKCS12 certificate to be used for client authentication.

=item pkcs12password

The password for the PKCS12 certificate specified with 'pkcs12'.

=item follow

Boolean that determins whether REST::Client attempts to automatically follow
redirects/authentication.  

The default is false.

=item useragent

An L<LWP::UserAgent> object, ready to make http requests.  

REST::Client will provide a default for you if you do not set this.

=back

=cut

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

=head3 addHeader ( $header_name, $value )

Add a custom header to any requests made by this client.

=cut

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

=head3 buildQuery ( [...] )

A convienience wrapper around URI::query_form for building query strings from a
variety of data structures. See L<URI>

Returns a scalar query string for use in URLs.

=cut

sub buildQuery {
    my $self = shift;

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



=head2 Request Methods

Each of these methods makes an HTTP request, sets the internal state of the
object, and returns the object.

They can be combined with the response methods, such as:

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

=head3 GET ( $url, [%$headers] )

Preform an HTTP GET to the resource specified. Takes an optional hashref of custom request headers.

=cut

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

=head3 PUT ($url, [$body_content, %$headers] )

Preform an HTTP PUT to the resource specified. Takes an optional body content and hashref of custom request headers.

=cut

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

=head3 PATCH ( $url, [$body_content, %$headers] )

Preform an HTTP PATCH to the resource specified. Takes an optional body content and hashref of custom request headers.

=cut

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

=head3 POST ( $url, [$body_content, %$headers] )

Preform an HTTP POST to the resource specified. Takes an optional body content and hashref of custom request headers.

=cut

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

=head3 DELETE ( $url, [%$headers] )

Preform an HTTP DELETE to the resource specified. Takes an optional hashref of custom request headers.

=cut

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

=head3 OPTIONS ( $url, [%$headers] )

Preform an HTTP OPTIONS to the resource specified. Takes an optional hashref of custom request headers.

=cut

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

=head3 HEAD ( $url, [%$headers] )

Preform an HTTP HEAD to the resource specified. Takes an optional hashref of custom request headers.

=cut

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

=head3 request ( $method, $url, [$body_content, %$headers] )

Issue a custom request, providing all possible values.

=cut

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, PATCH, PUT, POST, DELETE, OPTIONS, HEAD" unless $method =~ /^(get|patch|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(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); 
        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) : $ua->simple_request($req);
    $IO::Socket::SSL::VERSION = $tmp_socket_ssl_version;

    $self->{_res} = $res;

    return $self;
}

=head2 Response Methods

Use these methods to gather information about the last requset
performed.

=head3 responseCode ()

Return the HTTP response code of the last request

=cut

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

=head3 responseContent ()

Return the response body content of the last request

=cut

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

=head3 responseHeaders()

Returns a list of HTTP header names from the last response

=cut

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



=head3 responseHeader ( $header )

Return a HTTP header from the last response

=cut

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

=head3 responseXpath ()

A convienience wrapper that returns a L<XML::LibXML> xpath context for the body content.  Assumes the content is XML.

=cut

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;


=head1 TODO

Caching, content-type negotiation, readable handles for body content.

=head1 AUTHOR

Miles Crawford, E<lt>mcrawfor@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright 2008 - 2010 by Miles Crawford

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut