File Coverage

blib/lib/Plack/Test/Agent.pm

Criterion	Covered	Total	%
statement	81	84	96.4
branch	15	18	83.3
condition	1	2	50.0
subroutine	20	21	95.2
pod	7	7	100.0
total	124	132	93.9

package Plack::Test::Agent;
# git description: v1.3-1-g41fa5a5
$Plack::Test::Agent::VERSION = '1.4';
# ABSTRACT: OO interface for testing low-level Plack/PSGI apps

use strict;
use warnings;

use Test::TCP;
use Plack::Loader;
use HTTP::Response;
use HTTP::Message::PSGI;
use HTTP::Request::Common;
use Test::WWW::Mechanize;

use Plack::Util::Accessor qw( app host port server ua );

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

    my $self = bless {}, $class;

    $self->app(  delete $args{app}  );
    $self->ua(   delete $args{ua}   );
    $self->host( delete $args{host} || 'localhost' );
    $self->port( delete $args{port} );

    $self->start_server( delete $args{server} ) if $args{server};

    return $self;
}

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

    my $app  = $self->app;
    my $host = $self->host;

    my $server = Test::TCP->new(
        code => sub
        {
            my $port = shift;
            my %args = ( host => $host, port => $port );
            return $server_class
                ? Plack::Loader->load( $server_class, %args )->run( $app )
                : Plack::Loader->auto( %args )->run( $app );
        },
    );

    $self->port( $server->port );
    $self->ua( $self->get_mech ) unless $self->ua;
    $self->server( $server );
}

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

    my $res = $self->server
            ? $self->ua->request( $req )
            : HTTP::Response->from_psgi( $self->app->( $req->to_psgi ) );

    $res->request( $req );
    return $res;
}

sub get {
    my ( $self, $uri, @args ) = @_;
    my $req                   = GET $self->normalize_uri($uri), @args;
    return $self->execute_request($req);
}

sub post
{
    my ($self, $uri, @args) = @_;
    my $req                 = POST $self->normalize_uri($uri), @args;
    return $self->execute_request( $req );
}

sub normalize_uri
{
    my ($self, $uri) = @_;
    my $normalized   = URI->new( $uri );
    my $port         = $self->port;

    $normalized->scheme( 'http' )      unless $normalized->scheme;
    $normalized->host(   'localhost' ) unless $normalized->host;
    $normalized->port( $port )         if $port;

    return $normalized;
}

sub get_mech
{
    my $self = shift;
    return Test::WWW::Mechanize::Bound->new(
        bound_uri => $self->normalize_uri( '/' )
    );
}

package
   Test::WWW::Mechanize::Bound;

    use parent 'Test::WWW::Mechanize';

    sub new
    {
        my ($class, %args) = @_;
        my $bound_uri      = delete $args{bound_uri};
        my $self           = $class->SUPER::new( %args );
        $self->bound_uri( $bound_uri );
        return $self;
    }

    sub bound_uri
    {
        my ($self, $base_uri) = @_;
        $self->_elem( bound_uri => $base_uri ) if @_ == 2;
        return $self->_elem( 'bound_uri' );
    }

    sub prepare_request
    {
        my $self  = shift;
        my ($req) = @_;
        my $uri   = $req->uri;
        my $base  = $self->bound_uri;

        unless ($uri->scheme)
        {
            $uri->scheme( $base->scheme );
            $uri->host( $base->host );
            $uri->port( $base->port );
        }
        return $self->SUPER::prepare_request( @_ );
    }

1;

__END__