File Coverage

blib/lib/WebService/CRUST.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package WebService::CRUST;

use strict;

use LWP;
use HTTP::Cookies;
use HTTP::Request::Common;
use URI;
use URI::QueryParam;

use WebService::CRUST::Result;

our $VERSION = '0.7';




sub new {
    my ( $class, %opt ) = @_;

    # Set a default formatter
    $opt{format} or $opt{format} = [ 'XML::Simple', 'XMLin', 'XMLout' ];

    # Backwards compatibility
    $opt{query} and $opt{params} = $opt{query};

    # Only use the library we're using to format with
    eval sprintf "use %s", $opt{format}->[0];

    return bless { config => \%opt }, $class;
}


sub get {
    my ( $self, $path, %h ) = @_;
    return $self->request( 'GET', $path, %h );
}

sub head {
    my ( $self, $path, %h ) = @_;
    return $self->request( 'HEAD', $path, %h );
}

sub put {
    my ( $self, $path, %h ) = @_;
    return $self->request( 'PUT', $path, %h );
}

sub post {
    my ( $self, $path, %h ) = @_;
    return $self->request( 'POST', $path, %h );
}

sub request {
    my ( $self, $method, $path, %h ) = @_;

    $method or die "Must provide a method";
    $path   or die "Must provide an action";

    # If we have a request key, then use that instead of tacking on a path
    if ( $self->{config}->{request_key} ) {
        $self->{config}->{base}
          or die "request_key requires base option to be set";

        $h{ $self->{config}->{request_key} } = $path;
        $path = undef;
    }

    my $uri =
      $self->{config}->{base}
      ? URI->new_abs( $path, $self->{config}->{base} )
      : URI->new($path);

    my $send =
      $self->{config}->{params}
      ? { %{ $self->{config}->{params} }, %h }
      : \%h;

    my $req;
    if ( $method eq 'POST' ) {
        $self->debug( "POST: %s", $uri->as_string );

        $req = POST $uri->as_string, $send;
    }
    else {
        $self->debug( "%s: %s", $method, $uri->as_string );

        my $content = delete $send->{-content};

        # If our content is a hash, then serialize it
        if (ref $content) {
            $content = $self->_format_request($content);
        }

        $self->_add_param( $uri, $send );
        $req = HTTP::Request->new( $method, $uri );
        $content and $req->add_content($content);
    }

    if (    $self->{config}->{basic_username}
        and $self->{config}->{basic_password} )
    {
        $self->debug(
            "Sending username/passwd for user %s",
            $self->{config}->{basic_username}
        );

        $req->authorization_basic(
            $self->{config}->{basic_username},
            $self->{config}->{basic_password}
        );
    }

    my $res = $self->ua->request($req);
    $self->{response} = $res;

    $self->debug( "Request Sent: %s", $res->message );

    return WebService::CRUST::Result->new($self->_format_response($res), $self)
      if $res->is_success;

    $self->debug( "Request was not successful" );

    return undef;
}

sub response { return shift->{response} }

sub _format_response {
    my ( $self, $res, $format ) = @_;

    $format or $format = $self->{config}->{format};
    my ( $class, $method ) = @$format;

    ref $method eq 'CODE' and return &$method( $res->content );

    my $o = $class->new( %{ $self->{config}->{opts} } );
    return $o->$method( $res->content );
}
sub _format_request {
    my ( $self, $req, $format ) = @_;

    $format or $format = $self->{config}->{format};

    my ($class, $deserialize, $method) = @$format;

    ref $method eq 'CODE' and return &$method( $req );

    my $o = $class->new( %{ $self->{config}->{opts} } );
    return $o->$method( $req );
}

sub ua {
    my ( $self, $ua ) = @_;

    # If they provided a UA set it
    $ua and $self->{ua} = $ua;

    # If we already have a UA then return it
    $self->{ua} and return $self->{ua};

    $self->debug("Creating new UA");

    # Otherwise create our own UA
    $ua = LWP::UserAgent->new;
    $ua->agent( "WebService::CRUST/" . $VERSION ); # Set our User-Agent string
    $ua->cookie_jar( {} );                         # Support session cookies
    $ua->env_proxy;                                # Support proxies
    $ua->timeout( $self->{config}->{timeout} )
      if $self->{config}->{timeout};

    $self->{ua} = $ua;
    return $ua;
}

sub _add_param {
    my ( $self, $uri, $h ) = @_;

    while ( my ( $k, $v ) = each %$h ) { $uri->query_param_append( $k => $v ) }
}

sub debug {
    my ( $self, $msg, @args ) = @_;

    $self->{config}->{debug}
      and printf STDERR "%s -- %s\n", __PACKAGE__, sprintf( $msg, @args );
}

sub AUTOLOAD {
    my $self = shift;
    our $AUTOLOAD;

    # Don't override DESTROY
    return if $AUTOLOAD =~ /::DESTROY$/;

    # Only get something if we have a base
    $self->{config}->{base} or return;

    ( my $method = $AUTOLOAD ) =~ s/.*:://s;
    $method =~ /(get|head|put|post)_(.*)/
      and return $self->$1( $2, @_ );

    return $self->get( $method, @_ );
}

1;

__END__