File Coverage

blib/lib/Test/WWW/Mechanize/Mojo.pm

Criterion	Covered	Total	%
statement	92	130	70.7
branch	26	52	50.0
condition	10	17	58.8
subroutine	17	20	85.0
pod	8	8	100.0
total	153	227	67.4

package Test::WWW::Mechanize::Mojo;
$Test::WWW::Mechanize::Mojo::VERSION = '0.0.21';
use strict;
use warnings;

use 5.012;

use Carp qw/croak/;
use Encode qw();
use HTML::Entities;

use base 'Test::WWW::Mechanize';

use Test::Mojo;

our $APP_CLASS;
my $Test = Test::Builder->new();

sub mojo_app
{
    my $self = shift;

    return $self->{mojo_app};
}

sub has_mojo_app
{
    my $self = shift;

    return exists( $self->{mojo_app} );
}

sub allow_external
{
    my $self = shift;

    if (@_)
    {
        $self->{allow_external} = shift;
    }

    return $self->{allow_external};
}

sub host
{
    my $self = shift;

    if (@_)
    {
        $self->{host} = shift;
    }

    return $self->{host};
}

sub clear_host
{
    my $self = shift;

    delete( $self->{host} );

    return ();
}

sub has_host
{
    my $self = shift;

    return exists( $self->{host} );
}

sub tester
{
    my $self = shift;

    if (@_)
    {
        $self->{tester} = shift;
    }

    return $self->{tester};
}

sub new
{
    my $class = shift;

    my $args = ref $_[0] ? $_[0] : {@_};

    my $tester = delete( $args->{tester} );

    my $self = $class->SUPER::new(%$args);

    if ($tester)
    {
        $self->tester($tester);
    }
    else
    {
        $self->tester( Test::Mojo->new() );
    }

    $self->{allow_external} = 0;

    return $self;
}

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

    my $response = $self->_do_mojo_request($request);
    $response->header( 'Content-Base', $response->request->uri )
        unless $response->header('Content-Base');

    $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;

    # fail tests under the Catalyst debug screen
    if (  !$self->{catalyst_debug}
        && $response->code == 500
        && $response->content =~ /on Catalyst \d+\.\d+/ )
    {
        my ($error) =
            ( $response->content =~ /(.*?)<\/code>/s );
        $error ||= "unknown error";
        decode_entities($error);
        $Test->diag("Catalyst error screen: $error");
        $response->content('');
        $response->content_type('');
    }

    # check if that was a redirect
    if (   $response->header('Location')
        && $response->is_redirect
        && $self->redirect_ok( $request, $response ) )
    {

        # remember the old response
        my $old_response = $response;

        # *where* do they want us to redirect to?
        my $location = $old_response->header('Location');

        # no-one *should* be returning non-absolute URLs, but if they
        # are then we'd better cope with it.  Let's create a new URI, using
        # our request as the base.
        my $uri = URI->new_abs( $location, $request->uri )->as_string;

        # make a new response, and save the old response in it
        $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
        my $end_of_chain = $response;
        while ( $end_of_chain->previous )    # keep going till the end
        {
            $end_of_chain = $end_of_chain->previous;
        }                                    #   of the chain...
        $end_of_chain->previous($old_response);    # ...and add us to it
    }
    else
    {
        $response->{_raw_content} = $response->content;
    }

    return $response;
}

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

    my $uri = $request->uri;
    $uri->scheme('http')    unless defined $uri->scheme;
    $uri->host('localhost') unless defined $uri->host;

    $request = $self->prepare_request($request);
    $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;

    # Woe betide anyone who unsets MOJO_SERVER
    return $self->_do_remote_request($request)
        if $ENV{MOJO_SERVER};

    # If there's no Host header, set one.
    unless ( $request->header('Host') )
    {
        my $host =
              $self->has_host
            ? $self->host
            : $uri->host;

        $request->header( 'Host', $host );
    }

    my $res = $self->_check_external_request($request);
    return $res if $res;

    my @creds = $self->get_basic_credentials( "Basic", $uri );
    $request->authorization_basic(@creds) if @creds;

    my $t = $self->tester;

    # Client
    my $client = $t->ua;
    $client->server->app( $t->app );

    my $method = lc( $request->method() );

    my %headers =
        ( map { $_ => $request->header($_) } $request->header_field_names() );

    my $mojo_res =
        $client->$method( $uri->path_query(), {%headers}, $request->content, )
        ->res;

    my $response =
        HTTP::Response->new( $mojo_res->code(), $mojo_res->message(),
        [ %{ $mojo_res->headers->to_hash() } ],
        $mojo_res->body() );

    # LWP would normally do this, but we dont get down that far.
    $response->request($request);

    return $response;
}

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

    # If there's no host then definitely not an external request.
    if ( not $request->uri->can('host_port') )
    {
        return undef;
    }

    if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' )
    {
        return $self->SUPER::_make_request($request);
    }
    return undef;
}

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

    my $res = $self->_check_external_request($request);
    return $res if $res;

    my $server = URI->new( $ENV{MOJO_SERVER} );

    if ( $server->path =~ m|^(.+)?/$| )
    {
        my $path = $1;
        $server->path("$path") if $path;    # need to be quoted
    }

    # the request path needs to be sanitised if $server is using a
    # non-root path due to potential overlap between request path and
    # response path.
    if ( $server->path )
    {
        # If request path is '/', we have to add a trailing slash to the
        # final request URI
        my $add_trailing = $request->uri->path eq '/';

        my @sp = split '/', $server->path;
        my @rp = split '/', $request->uri->path;
        shift @sp;
        shift @rp;    # leading /
        if (@rp)
        {
            foreach my $sp (@sp)
            {
                $sp eq $rp[0] ? shift @rp : last;
            }
        }
        $request->uri->path( join '/', @rp );

        if ($add_trailing)
        {
            $request->uri->path( $request->uri->path . '/' );
        }
    }

    $request->uri->scheme( $server->scheme );
    $request->uri->host( $server->host );
    $request->uri->port( $server->port );
    $request->uri->path( $server->path . $request->uri->path );
    return $self->SUPER::_make_request($request);
}

1;

__END__