Dancer::Test - Test helpers to test a Dancer application

    use strict;
    use warnings;
    use Test::More tests => 2;

    use MyWebApp;
    use Dancer::Test;

    response_status_is [GET => '/'], 200, "GET / is found";
    response_content_like [GET => '/'], qr/hello, world/, "content looks good for /";

    # all 3 are equivalent
    response_status_is [ GET => '/' ], 200, 'GET / status is ok';

    response_status_is '/', 200, 'GET / status is ok';

    my $resp = dancer_response GET => '/';
    response_status_is $resp => 200, 'GET / status is ok';

    route_exists [GET => '/'], "GET / is handled";

    route_doesnt_exist [GET => '/bogus_path'], "GET /bogus_path is not handled";

    response_exists [GET => '/path_that_gets_redirected_to_home'],
        "response found for unknown path";

    response_doesnt_exist [GET => '/unknown_path'],
        "response not found for unknown path";

    response_status_is [GET => '/'], 200, "response for GET / is 200";

    response_status_isnt [GET => '/'], 404, "response for GET / is not a 404";

    response_content_is [GET => '/'], "Hello, World", 
        "got expected response content for GET /";

    response_content_isnt [GET => '/'], "Hello, World", 
        "got expected response content for GET /";

    response_content_is_deeply [GET => '/complex_struct'], 
        { foo => 42, bar => 24}, 
        "got expected response structure for GET /complex_struct";

    response_content_like [GET => '/'], qr/Hello, World/, 
        "response content looks good for GET /";

    response_content_unlike [GET => '/'], qr/Page not found/, 
        "response content looks good for GET /";

    response_headers_are_deeply [GET => '/'], [ 'X-Powered-By' => 'Dancer 1.150' ];

    response_headers_include [GET => '/'], [ 'Content-Type' => 'text/plain' ];

    my $response = dancer_response POST => '/widgets';
    is $response->{status}, 202, "response for POST /widgets is 202";
    is $response->{content}, "Widget #1 has been scheduled for creation",
        "response content looks good for first POST /widgets";

    $response = dancer_response POST => '/widgets';
    is $response->{status}, 202, "response for POST /widgets is 202";
    is $response->{content}, "Widget #2 has been scheduled for creation",
        "response content looks good for second POST /widgets";

    post '/upload' => sub { return upload('image')->content };

    $response = dancer_reponse(POST => '/upload', {files => [{name => 'image', filename => '/path/to/image.jpg}]});

    my $logs = read_logs;

    warning "Danger!  Warning!";
    debug   "I like pie.";

    is_deeply read_logs, [
        { level => "warning", message => "Danger!  Warning!" },
        { level => "debug",   message => "I like pie.", }
    ];

    error "Put out the light.";

    is_deeply read_logs, [
        { level => "error", message => "Put out the light." },
    ];

package Dancer::Test;

# test helpers for Dancer apps

use strict;
use warnings;
use Test::Builder;
use Test::More import => [ '!pass' ];

use Carp;
use HTTP::Headers;
use Dancer ':syntax', ':tests';
use Dancer::App;
use Dancer::Deprecation;
use Dancer::Request;
use Dancer::SharedData;
use Dancer::Renderer;
use Dancer::Handler;
use Dancer::Config;
use Dancer::FileUtils qw(open_file);

use base 'Exporter';
use vars '@EXPORT';

@EXPORT = qw(
  route_exists
  route_doesnt_exist

  response_exists
  response_doesnt_exist

  response_status_is
  response_status_isnt

  response_content_is
  response_content_isnt
  response_content_is_deeply
  response_content_like
  response_content_unlike
  response_is_file
  response_headers_are_deeply
  response_headers_include

  dancer_response
  get_response

  read_logs
);

sub import {
    my ($class, %options) = @_;
    $options{appdir} ||= '.';

    # mimic PSGI env
    $ENV{SERVERNAME}        = 'localhost';
    $ENV{HTTP_HOST}         = 'localhost';
    $ENV{SERVER_PORT}       = 80;
    $ENV{'psgi.url_scheme'} = 'http';

    my ($package, $script) = caller;
    $class->export_to_level(1, $class, @EXPORT);

    Dancer::_init_script_dir($options{appdir});
    Dancer::Config->load;

    # set a default session engine for tests
    setting 'session' => 'simple';

    # capture logs for testing
    setting 'logger'  => 'capture';
    setting 'log'     => 'debug';
}

# Route Registry

sub _req_to_response {
    my $req = shift;

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

    return dancer_response( ref $req eq 'ARRAY' ? @$req : ( 'GET', $req ) );
}

sub _req_label {
    my $req = shift;

    return ref $req eq 'Dancer::Response' ? 'response object'
         : ref $req eq 'ARRAY' ? join( ' ', @$req )
         : "GET $req"
         ;
}

sub expand_req {
    my $req = shift;
    return ref $req eq 'ARRAY' ? @$req : ( 'GET', $req );
}

sub route_exists {
    my ($req, $test_name) = @_;
    my $tb = Test::Builder->new;

    my ($method, $path) = expand_req($req);
    $test_name ||= "a route exists for $method $path";

    $req = Dancer::Request->new_for_request($method => $path);

    return $tb->ok(Dancer::App->find_route_through_apps($req), $test_name);
}

sub route_doesnt_exist {
    my ($req, $test_name) = @_;
    my $tb = Test::Builder->new;

    my ($method, $path) = expand_req($req);
    $test_name ||= "no route exists for $method $path";

    $req = Dancer::Request->new_for_request($method => $path);
    return $tb->ok(!defined(Dancer::App->find_route_through_apps($req)), $test_name);
}

# Response status

sub response_exists {
    Dancer::Deprecation->deprecated(
       fatal   => 0,
       feature => 'response_exists',
       reason  => 'Use response_status_isnt and check for status 404.'
    );
    my ($req, $test_name) = @_;

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

    my $response = _req_to_response( $req );

    # goto used so that the test reports
    # the correct test line
    @_ = ( $response, 404, $test_name );
    goto &response_status_isnt;
}

sub response_doesnt_exist {
    Dancer::Deprecation->deprecated(
       fatal   => 0,
       feature => 'response_doesnt_exist',
       reason  => 'Use response_status_is and check for status 404.',
    );
    my ($req, $test_name) = @_;

    $test_name ||= "no response found for " . _req_label($req);

    my $response = _req_to_response($req);

    # goto used so that the test reports
    # the correct test line
    @_ = ( $response, 404, $test_name );
    goto &response_status_is;
}

sub response_status_is {
    my ($req, $status, $test_name) = @_;
    $test_name ||= "response status is $status for " . _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    return $tb->is_eq($response->status, $status, $test_name);
}

sub response_status_isnt {
    my ($req, $status, $test_name) = @_;
    $test_name ||= "response status is not $status for " . _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    $tb->isnt_eq( $response->{status}, $status, $test_name );
}

# Response content

sub response_content_is {
    my ($req, $matcher, $test_name) = @_;
    $test_name ||= "response content looks good for " . _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    return $tb->is_eq( $response->{content}, $matcher, $test_name );
}

sub response_content_isnt {
    my ($req, $matcher, $test_name) = @_;
    $test_name ||= "response content looks good for " . _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    return $tb->isnt_eq( $response->{content}, $matcher, $test_name );
}

sub response_content_like {
    my ($req, $matcher, $test_name) = @_;
    $test_name ||= "response content looks good for " . _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    return $tb->like( $response->{content}, $matcher, $test_name );
}

sub response_content_unlike {
    my ($req, $matcher, $test_name) = @_;
    $test_name ||= "response content looks good for " , _req_label($req);

    my $response = _req_to_response($req);
    my $tb = Test::Builder->new;
    return $tb->unlike( $response->{content}, $matcher, $test_name );
}

sub response_content_is_deeply {
    my ($req, $matcher, $test_name) = @_;
    $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->{content}, $matcher, $test_name;
}

sub response_is_file {
    my ($req, $test_name) = @_;
    $test_name ||= "a file is returned for " . _req_label($req);

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

sub response_headers_are_deeply {
    my ($req, $expected, $test_name) = @_;
    $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($response->headers_to_array, $expected, $test_name);
}

sub response_headers_include {
    my ($req, $expected, $test_name) = @_;
    $test_name ||= "headers include expected data for @$req";
    my $tb = Test::Builder->new;

    my $response = dancer_response(expand_req($req));
    return $tb->ok(_include_in_headers($response->headers_to_array, $expected), $test_name);
}


# 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 dancer_response {
    my ($method, $path, $args) = @_;
    $args ||= {};

    if ($method =~ /^(?:PUT|POST)$/) {

        my ($content, $content_type);

        if ( $args->{body} ) {
            $content      = $args->{body};
            $content_type = $args->{content_type}
                || 'application/x-www-form-urlencoded';

            # coerce hashref into an url-encoded string
            if ( ref($content) && ( ref($content) eq 'HASH' ) ) {
                my @tokens;
                while ( my ( $name, $value ) = each %{$content} ) {
                    $name  = _url_encode($name);
                    $value = _url_encode($value);
                    push @tokens, "${name}=${value}";
                }
                $content = join( '&', @tokens );
            }
        }
        elsif ( $args->{files} ) {
            $content_type = 'multipart/form-data; boundary=----BOUNDARY';
            foreach my $file (@{$args->{files}}){
                $content .= qq{------BOUNDARY
Content-Disposition: form-data; name="$file->{name}"; filename="$file->{filename}"
Content-Type: text/plain

};
                open my $fh, '<', $file->{filename};
                while (<$fh>){
                    $content .= $_;
                }
                $content .= "\n";
            }
            $content .= "------BOUNDARY";
            $content =~ s/\r\n/\n/g;
            $content =~ s/\n/\r\n/g;
        }

        my $l = 0;
        $l = length $content if defined $content;
        open my $in, '<', \$content;
        $ENV{'CONTENT_LENGTH'} = $l;
        $ENV{'CONTENT_TYPE'}   = $content_type || "";
        $ENV{'psgi.input'}     = $in;
    }

    my ($params, $body, $headers) = @$args{qw(params body headers)};

    if ($headers and (my @headers = @$headers)) {
        while (my $h = shift @headers) {
            if ($h =~ /content-type/i) {
                $ENV{'CONTENT_TYPE'} = shift @headers;
            }
        }
    }

    my $request = Dancer::Request->new_for_request(
        $method => $path,
        $params, $body, HTTP::Headers->new(@$headers)
    );

    # first, reset the current state
    Dancer::SharedData->reset_all();

    # then store the request
    Dancer::SharedData->request($request);

    # XXX this is a hack!!
    $request = Dancer::Serializer->process_request($request)
      if Dancer::App->current->setting('serializer');

    my $get_action = Dancer::Handler::render_request($request);
    my $response = Dancer::SharedData->response();

    $response->content('') if $method eq 'HEAD';
    Dancer::SharedData->reset_response();
    return $response if $get_action;
    (defined $response && $response->exists) ? return $response : return undef;
}

sub get_response {
    Dancer::Deprecation->deprecated(
        fatal   => 1,
        feature => 'get_response',
        reason  => 'Use dancer_response() instead.',
    );
}

# private

sub _url_encode {
    my $string = shift;
    $string =~ s/([\W])/"%" . uc(sprintf("%2.2x",ord($1)))/eg;
    return $string;
}

sub _get_file_response {
    my ($req) = @_;

    my ($method, $path, $params) = expand_req($req);
    my $request = Dancer::Request->new_for_request($method => $path, $params);
    Dancer::SharedData->request($request);
    return Dancer::Renderer::get_file_response();
}

sub _get_handler_response {
    my ($req) = @_;
    my ($method, $path, $params) = expand_req($req);
    my $request = Dancer::Request->new_for_request($method => $path, $params);
    return Dancer::Handler->handle_request($request);
}

sub read_logs {
    return Dancer::Logger::Capture->trap->read;
}


1;
__END__