File Coverage

blib/lib/Test/LWP/UserAgent.pm

Criterion	Covered	Total	%
statement	157	173	90.7
branch	71	90	78.8
condition	20	29	68.9
subroutine	34	38	89.4
pod	11	11	100.0
total	293	341	85.9

use strict;
use warnings;
package Test::LWP::UserAgent; # git description: v0.035-2-g1324b10
# vim: set ts=8 sts=2 sw=2 tw=115 et :
# ABSTRACT: A LWP::UserAgent suitable for simulating and testing network calls
# KEYWORDS: testing useragent networking mock server client

our $VERSION = '0.036';

use parent 'LWP::UserAgent';
use Scalar::Util qw(blessed reftype);
use Storable 'freeze';
use HTTP::Request;
use HTTP::Response;
use URI;
use HTTP::Date;
use HTTP::Status qw(:constants status_message);
use Try::Tiny;
use Safe::Isa;
use Carp;
use namespace::clean 0.19 -also => [qw(__isa_coderef __is_regexp __isa_response)];

my @response_map;
my $network_fallback;
my $last_useragent;

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

    my $_network_fallback = delete $options{network_fallback};

    my $self = $class->SUPER::new(%options);
    $self->{__last_http_request_sent} = undef;
    $self->{__last_http_response_received} = undef;
    $self->{__response_map} = [];
    $self->{__network_fallback} = $_network_fallback;

    # strips default User-Agent header added by LWP::UserAgent, to make it
    # easier to define literal HTTP::Requests to match against
    $self->agent(undef) if defined $self->agent and $self->agent eq $self->_agent;

    return $self;
}

sub map_response
{
    my ($self, $request_specification, $response) = @_;

    if (not defined $response and blessed $self)
    {
        # mask a global domain mapping
        my $matched;
        foreach my $mapping (@{$self->{__response_map}})
        {
            if ($mapping->[0] eq $request_specification)
            {
                $matched = 1;
                undef $mapping->[1];
            }
        }

        push @{$self->{__response_map}}, [ $request_specification, undef ]
            if not $matched;

        return;
    }

    my ($isa_response, $error_message) = __isa_response($response);
    if (not $isa_response)
    {
        if (try { $response->can('request') })
        {
            my $oldres = $response;
            $response = sub { $oldres->request($_[0]) };
        }
        else
        {
            carp 'map_response: ', $error_message;
        }
    }

    if (blessed $self)
    {
        push @{$self->{__response_map}}, [ $request_specification, $response ];
    }
    else
    {
        push @response_map, [ $request_specification, $response ];
    }
    return $self;
}

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

    push (
        @{ blessed($self) ? $self->{__response_map} : \@response_map },
        [ $request_specification, $self->_response_send_request ],
    );

    return $self;
}

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

    if (blessed $self)
    {
        $self->{__response_map} = [];
        @response_map = () unless $instance_only;
    }
    else
    {
        carp 'instance-only unmap requests make no sense when called globally'
            if $instance_only;
        @response_map = ();
    }
    return $self;
}

sub register_psgi
{
    my ($self, $domain, $app) = @_;

    return $self->map_response($domain, undef) if not defined $app;

    carp 'register_psgi: app is not a coderef, it\'s a ', ref($app)
        unless __isa_coderef($app);

    return $self->map_response($domain, $self->_psgi_to_response($app));
}

sub unregister_psgi
{
    my ($self, $domain, $instance_only) = @_;

    if (blessed $self)
    {
        @{$self->{__response_map}} = grep $_->[0] ne $domain, @{$self->{__response_map}};

        @response_map = grep $_->[0] ne $domain, @response_map
            unless $instance_only;
    }
    else
    {
        @response_map = grep $_->[0] ne $domain, @response_map;
    }
    return $self;
}

sub last_http_request_sent
{
    my $self = shift;
    return blessed($self)
        ? $self->{__last_http_request_sent}
        : $last_useragent
            ? $last_useragent->last_http_request_sent
            : undef;
}

sub last_http_response_received
{
    my $self = shift;
    return blessed($self)
        ? $self->{__last_http_response_received}
        : $last_useragent
            ? $last_useragent->last_http_response_received
            : undef;
}

sub last_useragent
{
    return $last_useragent;
}

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

    if (@_ == 1)
    {
        return blessed $self
            ? $self->{__network_fallback}
            : $network_fallback;
    }

    return $self->{__network_fallback} = $value if blessed $self;
    $network_fallback = $value;
}

sub send_request
{
    my ($self, $request, $arg, $size) = @_;

    $self->progress('begin', $request);
    my $matched_response = $self->run_handlers('request_send', $request);

    my $uri = $request->uri;

    foreach my $entry (@{$self->{__response_map}}, @response_map)
    {
        last if $matched_response;
        next if not defined $entry;
        my ($request_desc, $response) = @$entry;

        if ($request_desc->$_isa('HTTP::Request'))
        {
            local $Storable::canonical = 1;
            $matched_response = $response, last
                if freeze($request) eq freeze($request_desc);
        }
        elsif (__is_regexp($request_desc))
        {
            $matched_response = $response, last
                if $uri =~ $request_desc;
        }
        elsif (__isa_coderef($request_desc))
        {
            $matched_response = $response, last
                if $request_desc->($request);
        }
        else
        {
            $uri = URI->new($uri) if not $uri->$_isa('URI');
            $matched_response = $response, last
                if $uri->host eq $request_desc;
        }
    }

    $last_useragent = $self;
    $self->{__last_http_request_sent} = $request;

    if (not defined $matched_response and
        ($self->{__network_fallback} or $network_fallback))
    {
        my $response = $self->SUPER::send_request($request, $arg, $size);
        $self->{__last_http_response_received} = $response;
        return $response;
    }

    my $response = defined $matched_response
        ? $matched_response
        : HTTP::Response->new('404');

    if (__isa_coderef($response))
    {
        # emulates handling in LWP::UserAgent::send_request
        if ($self->use_eval)
        {
            $response = try { $response->($request) }
            catch {
                my $exception = $_;
                if ($exception->$_isa('HTTP::Response'))
                {
                    $response = $exception;
                }
                else
                {
                    my $full = $exception;
                    (my $status = $exception) =~ s/\n.*//s;
                    $status =~ s/ at .* line \d+.*//s;  # remove file/line number
                    my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : HTTP_INTERNAL_SERVER_ERROR;
                    # note that _new_response did not always take a fourth
                    # parameter - content used to always be "$code $message"
                    $response = LWP::UserAgent::_new_response($request, $code, $status, $full);
                }
            }
        }
        else
        {
            $response = $response->($request);
        }
    }

    if (not $response->$_isa('HTTP::Response'))
    {
        carp 'response from coderef is not a HTTP::Response, it\'s a ',
            (blessed($response) || ( ref($response) ? ('unblessed ' . ref($response)) : 'non-reference' ));

        $response = LWP::UserAgent::_new_response($request, HTTP_INTERNAL_SERVER_ERROR, status_message(HTTP_INTERNAL_SERVER_ERROR));
    }
    else
    {
        $response->request($request);  # record request for reference
        $response->header('Client-Date' => HTTP::Date::time2str(time));
    }

    # handle any additional arguments that were provided, such as saving the
    # content to a file.  this also runs additional handlers for us.
    my $protocol = LWP::Protocol->new('no-schemes-from-TLWPUA', $self);
    my $complete;
    $response = $protocol->collect($arg, $response, sub {
        # remove content from $response and stream it back
        return \'' if $complete;
        my $content = $response->content;
        $response->content('');
        $complete++;
        \$content;
    });

    $self->run_handlers('response_done', $response);
    $self->progress('end', $response);

    $self->{__last_http_response_received} = $response;

    return $response;
}

# turns a PSGI app into a subref returning an HTTP::Response
sub _psgi_to_response
{
    my ($self, $app) = @_;

    carp 'register_psgi: did you forget to load HTTP::Message::PSGI?'
        unless HTTP::Request->can('to_psgi') and HTTP::Response->can('from_psgi');

    return sub { HTTP::Response->from_psgi($app->($_[0]->to_psgi)) };
}

# returns a subref that returns an HTTP::Response from a real network request
sub _response_send_request
{
    my $self = shift;

    # we cannot call ::request here, or we end up in an infinite loop
    return sub { $self->SUPER::send_request($_[0]) } if blessed $self;
    return sub { LWP::UserAgent->new->send_request($_[0]) };
}

sub __isa_coderef
{
    ref $_[0] eq 'CODE'
        or (reftype($_[0]) || '') eq 'CODE'
        or overload::Method($_[0], '&{}')
}

sub __is_regexp
{
    re->can('is_regexp') ? re::is_regexp($_[0]) : ref($_[0]) eq 'Regexp';
}

# returns true if is expected type for all response mappings,
# or (false, error message);
sub __isa_response
{
    __isa_coderef($_[0]) || $_[0]->$_isa('HTTP::Response')
        ? (1)
        : (0, 'response is not a coderef or an HTTP::Response, it\'s a '
                . (blessed($_[0]) || ( ref($_[0]) ? 'unblessed ' . ref($_[0]) : 'non-reference' )));
}

1;

__END__