File Coverage

blib/lib/Dancer2/Test.pm

Criterion	Covered	Total	%
statement	216	286	75.5
branch	60	106	56.6
condition	5	31	16.1
subroutine	34	43	79.0
pod	15	15	100.0
total	330	481	68.6

package Dancer2::Test;
# ABSTRACT: Useful routines for testing Dancer2 apps
$Dancer2::Test::VERSION = '2.1.0';
use strict;
use warnings;

use Carp qw;
use Test::More;
use Test::Builder;
use URI::Escape;
use Data::Dumper;
use File::Temp;
use Ref::Util qw;

use parent 'Exporter';
our @EXPORT = qw(
  dancer_response

  response_content_is
  response_content_isnt
  response_content_is_deeply
  response_content_like
  response_content_unlike

  response_status_is
  response_status_isnt

  response_headers_include
  response_headers_are_deeply

  response_is_file

  route_exists
  route_doesnt_exist

  is_pod_covered
  route_pod_coverage

);

#dancer1 also has read_logs, response_redirect_location_is
#cf. https://github.com/PerlDancer2/Dancer22/issues/25

use Dancer2::Core::MIME;
use Dancer2::Core::Dispatcher;
use Dancer2::Core::Request;

# singleton to store all the apps
my $_dispatcher = Dancer2::Core::Dispatcher->new;

# prevent deprecation warnings
our $NO_WARN = 0;

# can be called with the ($method, $path, $option) triplet,
# or can be fed a request object directly, or can be fed
# a single string, assumed to be [ GET => $string ]
# or can be fed a response (which is passed through without
# any modification)
sub dancer_response {
    croak 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;

    _find_dancer_apps_for_dispatcher();

    # useful for the high-level tests
    return $_[0] if ref $_[0] eq 'Dancer2::Core::Response';

    my ( $request, $env ) =
      ref $_[0] eq 'Dancer2::Core::Request'
      ? _build_env_from_request(@_)
      : _build_request_from_env(@_);

    # override the set_request so it actually sets our request instead
    {
        ## no critic qw(TestingAndDebugging::ProhibitNoWarnings)
        no warnings qw;
        *Dancer2::Core::App::set_request = sub {
            my $self = shift;
            $self->_set_request( $request );
            $_->set_request( $request ) for @{ $self->defined_engines };
        };
    }

    # since the response is a PSGI response
    # we create a Response object which was originally expected
    my $psgi_response = $_dispatcher->dispatch($env);
    return Dancer2::Core::Response->new(
        status  => $psgi_response->[0],
        headers => $psgi_response->[1],
        content => $psgi_response->[2][0],
        mime_type => Dancer2::Core::MIME->new(),
    );
}



sub _build_request_from_env {

    # arguments can be passed as the triplet
    # or as a arrayref, or as a simple string
    my ( $method, $path, $options ) =
        @_ > 1 ? @_
      : is_arrayref($_[0]) ? @{ $_[0] }
      :                      ( GET => $_[0], {} );

    my $env = {
        %ENV,
        REQUEST_METHOD    => uc($method),
        PATH_INFO         => $path,
        QUERY_STRING      => '',
        'psgi.url_scheme' => 'http',
        SERVER_PROTOCOL   => 'HTTP/1.0',
        SERVER_NAME       => 'localhost',
        SERVER_PORT       => 3000,
        HTTP_HOST         => 'localhost',
        HTTP_USER_AGENT   => "Dancer2::Test simulator v " . Dancer2->VERSION,
    };

    if ( defined $options->{params} ) {
        my @params;
        while ( my ( $p, $value ) = each %{ $options->{params} } ) {
            if ( is_arrayref($value) ) {
                for my $v (@$value) {
                    push @params,
                      uri_escape_utf8($p) . '=' . uri_escape_utf8($v);
                }
            }
            else {
                push @params,
                  uri_escape_utf8($p) . '=' . uri_escape_utf8($value);
            }
        }
        $env->{QUERY_STRING} = join( '&', @params );
    }

    my $request = Dancer2::Core::Request->new( env => $env );

    # body
    $request->body( $options->{body} ) if exists $options->{body};

    # headers
    if ( $options->{headers} ) {
        for my $header ( @{ $options->{headers} } ) {
            my ( $name, $value ) = @{$header};
            $request->header( $name => $value );
            if ( $name =~ /^cookie$/i ) {
                $env->{HTTP_COOKIE} = $value;
            }
        }
    }

    # files
    if ( $options->{files} ) {
        for my $file ( @{ $options->{files} } ) {
            my $headers = $file->{headers};
            $headers->{'Content-Type'} ||= 'text/plain';

            my $temp = File::Temp->new();
            if ( $file->{data} ) {
                print $temp $file->{data};
                close($temp);
            }
            else {
                require File::Copy;
                File::Copy::copy( $file->{filename}, $temp );
            }

            my $upload = Dancer2::Core::Request::Upload->new(
                filename => $file->{filename},
                size     => -s $temp->filename,
                tempname => $temp->filename,
                headers  => $headers,
            );

            ## keep temp_fh in scope so it doesn't get deleted too early
            ## But will get deleted by the time the test is finished.
            $upload->{temp_fh} = $temp;

            $request->uploads->{ $file->{name} } = $upload;
        }
    }

    # content-type
    if ( $options->{content_type} ) {
        $request->content_type( $options->{content_type} );
    }

    return ( $request, $env );
}

sub _build_env_from_request {
    my ($request) = @_;

    my $env = {
        REQUEST_METHOD    => $request->method,
        PATH_INFO         => $request->path,
        QUERY_STRING      => '',
        'psgi.url_scheme' => 'http',
        SERVER_PROTOCOL   => 'HTTP/1.0',
        SERVER_NAME       => 'localhost',
        SERVER_PORT       => 3000,
        HTTP_HOST         => 'localhost',
        HTTP_USER_AGENT   => "Dancer2::Test simulator v" . Dancer2->VERSION,
    };

    # TODO
    if ( my $params = $request->{_query_params} ) {
        my @params;
        while ( my ( $p, $value ) = each %{$params} ) {
            if ( is_arrayref($value) ) {
                for my $v (@$value) {
                    push @params,
                      uri_escape_utf8($p) . '=' . uri_escape_utf8($v);
                }
            }
            else {
                push @params,
                  uri_escape_utf8($p) . '=' . uri_escape_utf8($value);
            }
        }
        $env->{QUERY_STRING} = join( '&', @params );
    }

    # TODO files

    return ( $request, $env );
}

sub response_status_is {
    my ( $req, $status, $test_name ) = @_;
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;

    $test_name ||= "response status is $status for " . _req_label($req);

    my $response = dancer_response($req);

    my $tb = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $tb->is_eq( $response->[0], $status, $test_name );
}

sub _find_route_match {
    my ( $request, $env ) =
      ref $_[0] eq 'Dancer2::Core::Request'
      ? _build_env_from_request(@_)
      : _build_request_from_env(@_);

    for my $app (@{$_dispatcher->apps}) {
        for my $route (@{$app->routes->{lc($request->method)}}) {
            if ( $route->match($request) ) {
                return 1;
            }
        }
    }
    return 0;
}

sub route_exists {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;

    my $tb = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $tb->ok( _find_route_match($_[0]), $_[1]);
}

sub route_doesnt_exist {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;

    my $tb = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $tb->ok( !_find_route_match($_[0]), $_[1]);
}

sub response_status_isnt {
    my ( $req, $status, $test_name ) = @_;

    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;

    $test_name ||= "response status is not $status for " . _req_label($req);

    my $response = dancer_response($req);

    my $tb = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $tb->isnt_eq( $response->[0], $status, $test_name );
}

{
    # Map comparison operator names to human-friendly ones
    my %cmp_name = (
        is_eq   => "is",
        isnt_eq => "is not",
        like    => "matches",
        unlike  => "doesn't match",
    );

    sub _cmp_response_content {
        my ( $req, $want, $test_name, $cmp ) = @_;

        if ( @_ == 3 ) {
            $cmp       = $test_name;
            $test_name = $cmp_name{$cmp};
            $test_name =
              "response content $test_name $want for " . _req_label($req);
        }

        my $response = dancer_response($req);

        my $tb = Test::Builder->new;
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        $tb->$cmp( $response->[2][0], $want, $test_name );
    }
}

sub response_content_is {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    _cmp_response_content( @_, 'is_eq' );
}

sub response_content_isnt {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    _cmp_response_content( @_, 'isnt_eq' );
}

sub response_content_like {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    _cmp_response_content( @_, 'like' );
}

sub response_content_unlike {
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    _cmp_response_content( @_, 'unlike' );
}

sub response_content_is_deeply {
    my ( $req, $matcher, $test_name ) = @_;
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    $test_name ||= "response content looks good for " . _req_label($req);

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $response = _req_to_response($req);
    is_deeply $response->[2][0], $matcher, $test_name;
}

sub response_is_file {
    my ( $req, $test_name ) = @_;
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    $test_name ||= "a file is returned for " . _req_label($req);

    my $response = _get_file_response($req);
    my $tb       = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return $tb->ok( defined($response), $test_name );
}

sub response_headers_are_deeply {
    my ( $req, $expected, $test_name ) = @_;
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    $test_name ||= "headers are as expected for " . _req_label($req);

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $response = dancer_response( _expand_req($req) );

    is_deeply(
        _sort_headers( $response->[1] ),
        _sort_headers($expected), $test_name
    );
}

sub response_headers_include {
    my ( $req, $expected, $test_name ) = @_;
    carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
        unless $NO_WARN;
    $test_name ||= "headers include expected data for " . _req_label($req);
    my $tb = Test::Builder->new;

    my $response = dancer_response($req);
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    print STDERR "Headers are: "
      . Dumper( $response->[1] )
      . "\n Expected to find header: "
      . Dumper($expected)
      if !$tb->ok(
        _include_in_headers( $response->[1], $expected ),
        $test_name
      );
}

sub route_pod_coverage {

    require Pod::Simple::Search;
    require Pod::Simple::SimpleTree;

    my $all_routes = {};

    foreach my $app ( @{ $_dispatcher->apps } ) {
        my $routes           = $app->routes;
        my $available_routes = [];
        foreach my $method ( sort { $b cmp $a } keys %$routes ) {
            foreach my $r ( @{ $routes->{$method} } ) {

                # we don't need pod coverage for head
                next if $method eq 'head';
                push @$available_routes, $method . ' ' . $r->spec_route;
            }
        }
        ## copy dereferenced array
        $all_routes->{ $app->name }{routes} = [@$available_routes]
          if @$available_routes;

        # Pod::Simple v3.30 excluded the current directory even when in @INC.
        # include the current directory as a search path; its backwards compatible
        # with previous version.
        my $undocumented_routes = [];
        my $file                = Pod::Simple::Search->new->find( $app->name, '.' );
        if ($file) {
            $all_routes->{ $app->name }{has_pod} = 1;
            my $parser       = Pod::Simple::SimpleTree->new->parse_file($file);
            my $pod_dataref  = $parser->root;
            my $found_routes = {};
            for ( my $i = 0; $i < @$available_routes; $i++ ) {

                my $r          = $available_routes->[$i];
                my $app_string = lc $r;
                $app_string =~ s/\*/_REPLACED_STAR_/g;

                for ( my $idx = 0; $idx < @$pod_dataref; $idx++ ) {
                    my $pod_part = $pod_dataref->[$idx];

                    next if !is_arrayref($pod_part);
                    foreach my $ref_part (@$pod_part) {
                        is_arrayref($ref_part)
                            and push @$pod_dataref, $ref_part;
                    }

                    my $pod_string = lc $pod_part->[2];
                    $pod_string =~ s/['|"|\s]+/ /g;
                    $pod_string =~ s/\s$//g;
                    $pod_string =~ s/\*/_REPLACED_STAR_/g;
                    if ( $pod_string =~ m/^$app_string$/ ) {
                        $found_routes->{$app_string} = 1;
                        next;
                    }
                }
                if ( !$found_routes->{$app_string} ) {
                    push @$undocumented_routes, $r;
                }
            }
        }
        else {    ### no POD found
            $all_routes->{ $app->name }{has_pod} = 0;
        }
        if (@$undocumented_routes) {
            $all_routes->{ $app->name }{undocumented_routes} =
              $undocumented_routes;
        }
        elsif ( !$all_routes->{ $app->name }{has_pod}
            && @{ $all_routes->{ $app->name }{routes} } )
        {
            ## copy dereferenced array
            $all_routes->{ $app->name }{undocumented_routes} =
              [ @{ $all_routes->{ $app->name }{routes} } ];
        }
    }

    return $all_routes;
}

sub is_pod_covered {
    my ($test_name) = @_;

    $test_name ||= "is pod covered";
    my $route_pod_coverage = route_pod_coverage();

    my $tb = Test::Builder->new;
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    foreach my $app ( @{ $_dispatcher->apps } ) {
        my %undocumented_route =
          ( map { $_ => 1 }
              @{ $route_pod_coverage->{ $app->name }{undocumented_routes} } );
        $tb->subtest(
            $app->name . $test_name,
            sub {
                foreach my $route (
                    @{ $route_pod_coverage->{ $app->name }{routes} } )
                {
                    ok( !$undocumented_route{$route}, "$route is documented" );
                }
            }
        );
    }
}

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

    my @applications;
    if ( ref $options{apps} eq ref( [] ) ) {
        @applications = @{ $options{apps} };
    }
    else {
        my ( $caller, $script ) = caller;

        # if no app is passed, assume the caller is one.
        @applications = ($caller) if $caller->can('dancer_app');
    }

    # register the apps to the test dispatcher
    $_dispatcher->apps( [ map {
        $_->dancer_app->finish();
        $_->dancer_app;
    } @applications ] );

    $class->export_to_level( 1, $class, @EXPORT );
}

# private

sub _req_label {
    my $req = shift;

    return
        ref $req eq 'Dancer2::Core::Response' ? 'response object'
      : ref $req eq 'Dancer2::Core::Request'
      ? join( ' ', map { $req->$_ } qw/ method path / )
      : is_arrayref($req) ? join( ' ', @$req )
      :                     "GET $req";
}

sub _expand_req {
    my $req = shift;
    return is_arrayref($req) ? @$req : ( 'GET', $req );
}

# Sort arrayref of headers (turn it into a list of arrayrefs, sort by the header
# & value, then turn it back into an arrayref)
sub _sort_headers {
    my @originalheaders = @{ shift() };    # take a copy we can modify
    my @headerpairs;
    while ( my ( $header, $value ) = splice @originalheaders, 0, 2 ) {
        push @headerpairs, [ $header, $value ];
    }

    # We have an array of arrayrefs holding header => value pairs; sort them by
    # header then value, and return them flattened back into an arrayref
    return [
        map {@$_}
        sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @headerpairs
    ];
}

# make sure the given header sublist is included in the full headers array
sub _include_in_headers {
    my ( $full_headers, $expected_subset ) = @_;

    # walk through all the expected header pairs, make sure
    # they exist with the same value in the full_headers list
    # return false as soon as one is not.
    for ( my $i = 0; $i < scalar(@$expected_subset); $i += 2 ) {
        my ( $name, $value ) =
          ( $expected_subset->[$i], $expected_subset->[ $i + 1 ] );
        return 0
          unless _check_header( $full_headers, $name, $value );
    }

    # we've found all the expected pairs in the $full_headers list
    return 1;
}

sub _check_header {
    my ( $headers, $key, $value ) = @_;
    for ( my $i = 0; $i < scalar(@$headers); $i += 2 ) {
        my ( $name, $val ) = ( $headers->[$i], $headers->[ $i + 1 ] );
        return 1 if $name eq $key && $value eq $val;
    }
    return 0;
}

sub _req_to_response {
    my $req = shift;

    # already a response object
    return $req if ref $req eq 'Dancer2::Core::Response';

    return dancer_response( is_arrayref($req) ? @$req : ( 'GET', $req ) );
}

# make sure we have at least one app in the dispatcher, and if not,
# we must have at this point an app within the caller
sub _find_dancer_apps_for_dispatcher {
    return if scalar( @{ $_dispatcher->apps } );

    for ( my $deep = 0; $deep < 5; $deep++ ) {
        my $caller = caller($deep);
        next if !$caller || !$caller->can('dancer_app');

        return $_dispatcher->apps( [ $caller->dancer_app ] );
    }

    croak "Unable to find a Dancer2 app, did you use Dancer2 in your test?";
}

1;

__END__