view release on metacpan or  search on metacpan

lib/Test/Mojo/Plack.pm  view on Meta::CPAN

use List::MoreUtils;
use Scalar::Util  qw(blessed);

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

    my $t = $class->SUPER::new();

    return $t unless $app_class;

    $ENV{PLACK_ENV} = 1;

    if (ref $app_class eq 'CODE') {
        $t->{psgi_app} = sub { my $res = $app_class->(shift); sub { shift->($res); } };
    } else {
        load_class($app_class) unless is_class_loaded($app_class);
        $app_class->import;
        if ($app_class->can("_finalized_psgi_app") ) { # Catalyst
            $t->{psgi_app} = $app_class->_finalized_psgi_app;
        }
        elsif ($app_class->can("dance") ) { # Dancer 
            $t->{psgi_app} = sub {
                my $request = Dancer::Request->new( env => shift );
                my $res = Dancer->dance( $request );
                sub { shift->($res); };
            }
        }
    }
    die "Unable to instantiate application as a PSGI application: '$app_class'" unless $t->{psgi_app};

    return $t;
}

sub _request_ok {
    my ($self, $tx, $url) = @_;

    # Let Mojo::Test handle it if no app has been instantiated
    return $self->SUPER::_request_ok(@_[1..2]) unless $self->{psgi_app};

    $url = Mojo::URL->new($url);

    my $env = {
        PATH_INFO         => url_unescape($url->path || '/'),
        QUERY_STRING      => $url->query || '',
        SCRIPT_NAME       => '',
        SERVER_NAME       => $url->host,
        SERVER_PORT       => $url->port,
        SERVER_PROTOCOL   => $tx->req->version ? ('HTTP/' . $tx->req->version ) : 'HTTP/1.1',
        REMOTE_ADDR       => '127.0.0.1',
        REMOTE_HOST       => 'localhost',
        REMOTE_PORT       => int( rand(64000) + 1000 ),                   # not in RFC 3875
        REQUEST_URI       => (join '?', $url->path, $url->query) || '/',  # not in RFC 3875
        REQUEST_METHOD    => $tx->req->method,
        'psgi.version'      => [ 1, 1 ],
        'psgi.url_scheme'   => $url->scheme && $url->scheme eq 'https' ? 'https' : 'http',
        'psgi.input'        => IO::String->new($tx->req->body . "\r\n"),
        'psgi.errors'       => *STDERR,
        'psgi.multithread'  => 0,
        'psgi.multiprocess' => 0,
        'psgi.run_once'     => 1,
        'psgi.streaming'    => 1,
        'psgi.nonblocking'  => 0,
        'HTTP_CONTENT_LENGTH' => length($tx->req->body),
    };

    for my $field ( @{ $tx->req->headers->names || [] }) {
        my $key = uc("HTTP_$field");
        $key =~ tr/-/_/;
        $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;

        unless ( exists $env->{$key} ) {
            $env->{$key} = $tx->req->headers->header($field);
        }
    }

    if ($env->{SCRIPT_NAME}) {
        $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//;
        $env->{PATH_INFO} =~ s/^\/+/\//;
    }

    if (!defined($env->{HTTP_HOST}) && $url->host) {
        $env->{HTTP_HOST} = $url->host;
        $env->{HTTP_HOST} .= ':' . $url->port
            if $url->port;
    }
    $env->{HTTP_HOST} ||= 'localhost';

    my $ret = $self->{psgi_app}->($env);
    my $res = Mojo::Message::Response->new();

    $ret->(sub {
        my ($code, $headers, $body) = @{+shift};
        my $header_hash;
        my $it = List::MoreUtils::natatime 2, @{$headers};
        while (my($k, $v) = $it->()) {
            $res->headers->append($k, $v);
        }
        $res->code($code);

        my $body_str = '';
        if (defined $body && blessed($body)) {
            if ($body->can('getline')) {
                while (my $line = $body->getline) {
                    $body_str .= ($line || '');
                }
            }
        } elsif(my $type = ref $body) {
            if ($type eq 'ARRAY') {
                $body_str = join '', @{$body};
            } elsif ($type eq 'GLOB') {
                local $/;
                $body_str = <$body>;
            }
        };

        $body_str //= $body;

        $res->body($body_str);
    });

    $self->tx(Mojo::Transaction::HTTP->new);