File Coverage

blib/lib/Dancer2/Test.pm
Criterion Covered Total %
statement 229 283 80.9
branch 64 106 60.3
condition 7 31 22.5
subroutine 36 42 85.7
pod 15 15 100.0
total 351 477 73.5


line stmt bran cond sub pod time code
1             package Dancer2::Test;
2             # ABSTRACT: Useful routines for testing Dancer2 apps
3             $Dancer2::Test::VERSION = '0.400001';
4 2     2   1361 use strict;
  2         4  
  2         69  
5 2     2   11 use warnings;
  2         4  
  2         71  
6              
7 2     2   13 use Carp qw<carp croak>;
  2         7  
  2         134  
8 2     2   14 use Test::More;
  2         6  
  2         30  
9 2     2   602 use Test::Builder;
  2         4  
  2         44  
10 2     2   11 use URI::Escape;
  2         4  
  2         132  
11 2     2   21 use Data::Dumper;
  2         4  
  2         98  
12 2     2   11 use File::Temp;
  2         6  
  2         163  
13 2     2   14 use Ref::Util qw<is_arrayref>;
  2         4  
  2         98  
14              
15 2     2   19 use parent 'Exporter';
  2         5  
  2         21  
16             our @EXPORT = qw(
17             dancer_response
18              
19             response_content_is
20             response_content_isnt
21             response_content_is_deeply
22             response_content_like
23             response_content_unlike
24              
25             response_status_is
26             response_status_isnt
27              
28             response_headers_include
29             response_headers_are_deeply
30              
31             response_is_file
32              
33             route_exists
34             route_doesnt_exist
35              
36             is_pod_covered
37             route_pod_coverage
38              
39             );
40              
41             #dancer1 also has read_logs, response_redirect_location_is
42             #cf. https://github.com/PerlDancer2/Dancer22/issues/25
43              
44 2     2   233 use Dancer2::Core::Dispatcher;
  2         4  
  2         64  
45 2     2   11 use Dancer2::Core::Request;
  2         5  
  2         381  
46              
47             # singleton to store all the apps
48             my $_dispatcher = Dancer2::Core::Dispatcher->new;
49              
50             # prevent deprecation warnings
51             our $NO_WARN = 0;
52              
53             # can be called with the ($method, $path, $option) triplet,
54             # or can be fed a request object directly, or can be fed
55             # a single string, assumed to be [ GET => $string ]
56             # or can be fed a response (which is passed through without
57             # any modification)
58             sub dancer_response {
59 39 50   39 1 7225 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
60             unless $NO_WARN;
61              
62 39         108 _find_dancer_apps_for_dispatcher();
63              
64             # useful for the high-level tests
65 39 100       353 return $_[0] if ref $_[0] eq 'Dancer2::Core::Response';
66              
67 31 100       124 my ( $request, $env ) =
68             ref $_[0] eq 'Dancer2::Core::Request'
69             ? _build_env_from_request(@_)
70             : _build_request_from_env(@_);
71              
72             # override the set_request so it actually sets our request instead
73             {
74             ## no critic qw(TestingAndDebugging::ProhibitNoWarnings)
75 2     2   16 no warnings qw<redefine once>;
  2         19  
  2         7380  
  31         50  
76             *Dancer2::Core::App::set_request = sub {
77 31     31   48 my $self = shift;
78 31         457 $self->_set_request( $request );
79 31         754 $_->set_request( $request ) for @{ $self->defined_engines };
  31         66  
80 31         373 };
81             }
82              
83             # since the response is a PSGI response
84             # we create a Response object which was originally expected
85 31         1194 my $psgi_response = $_dispatcher->dispatch($env);
86 31         582 return Dancer2::Core::Response->new(
87             status => $psgi_response->[0],
88             headers => $psgi_response->[1],
89             content => $psgi_response->[2][0],
90             );
91             }
92              
93              
94              
95             sub _build_request_from_env {
96              
97             # arguments can be passed as the triplet
98             # or as a arrayref, or as a simple string
99             my ( $method, $path, $options ) =
100             @_ > 1 ? @_
101 28 100   28   127 : is_arrayref($_[0]) ? @{ $_[0] }
  10 100       28  
102             : ( GET => $_[0], {} );
103              
104 28         346 my $env = {
105             %ENV,
106             REQUEST_METHOD => uc($method),
107             PATH_INFO => $path,
108             QUERY_STRING => '',
109             'psgi.url_scheme' => 'http',
110             SERVER_PROTOCOL => 'HTTP/1.0',
111             SERVER_NAME => 'localhost',
112             SERVER_PORT => 3000,
113             HTTP_HOST => 'localhost',
114             HTTP_USER_AGENT => "Dancer2::Test simulator v " . Dancer2->VERSION,
115             };
116              
117 28 100       126 if ( defined $options->{params} ) {
118 3         7 my @params;
119 3         7 while ( my ( $p, $value ) = each %{ $options->{params} } ) {
  6         164  
120 3 100       11 if ( is_arrayref($value) ) {
121 2         5 for my $v (@$value) {
122 4         77 push @params,
123             uri_escape_utf8($p) . '=' . uri_escape_utf8($v);
124             }
125             }
126             else {
127 1         5 push @params,
128             uri_escape_utf8($p) . '=' . uri_escape_utf8($value);
129             }
130             }
131 3         14 $env->{QUERY_STRING} = join( '&', @params );
132             }
133              
134 28         131 my $request = Dancer2::Core::Request->new( env => $env );
135              
136             # body
137 28 50       76 $request->body( $options->{body} ) if exists $options->{body};
138              
139             # headers
140 28 100       71 if ( $options->{headers} ) {
141 2         5 for my $header ( @{ $options->{headers} } ) {
  2         7  
142 4         8 my ( $name, $value ) = @{$header};
  4         11  
143 4         19 $request->header( $name => $value );
144 4 100       552 if ( $name =~ /^cookie$/i ) {
145 2         9 $env->{HTTP_COOKIE} = $value;
146             }
147             }
148             }
149              
150             # files
151 28 100       73 if ( $options->{files} ) {
152 2         4 for my $file ( @{ $options->{files} } ) {
  2         5  
153 2         5 my $headers = $file->{headers};
154 2   50     13 $headers->{'Content-Type'} ||= 'text/plain';
155              
156 2         15 my $temp = File::Temp->new();
157 2 100       1064 if ( $file->{data} ) {
158 1         18 print $temp $file->{data};
159 1         61 close($temp);
160             }
161             else {
162 1         462 require File::Copy;
163 1         2066 File::Copy::copy( $file->{filename}, $temp );
164             }
165              
166             my $upload = Dancer2::Core::Request::Upload->new(
167             filename => $file->{filename},
168 2         355 size => -s $temp->filename,
169             tempname => $temp->filename,
170             headers => $headers,
171             );
172              
173             ## keep temp_fh in scope so it doesn't get deleted too early
174             ## But will get deleted by the time the test is finished.
175 2         2872 $upload->{temp_fh} = $temp;
176              
177 2         12 $request->uploads->{ $file->{name} } = $upload;
178             }
179             }
180              
181             # content-type
182 28 50       88 if ( $options->{content_type} ) {
183 0         0 $request->content_type( $options->{content_type} );
184             }
185              
186 28         69 return ( $request, $env );
187             }
188              
189             sub _build_env_from_request {
190 10     10   19 my ($request) = @_;
191              
192 10         27 my $env = {
193             REQUEST_METHOD => $request->method,
194             PATH_INFO => $request->path,
195             QUERY_STRING => '',
196             'psgi.url_scheme' => 'http',
197             SERVER_PROTOCOL => 'HTTP/1.0',
198             SERVER_NAME => 'localhost',
199             SERVER_PORT => 3000,
200             HTTP_HOST => 'localhost',
201             HTTP_USER_AGENT => "Dancer2::Test simulator v" . Dancer2->VERSION,
202             };
203              
204             # TODO
205 10 50       62 if ( my $params = $request->{_query_params} ) {
206 0         0 my @params;
207 0         0 while ( my ( $p, $value ) = each %{$params} ) {
  0         0  
208 0 0       0 if ( is_arrayref($value) ) {
209 0         0 for my $v (@$value) {
210 0         0 push @params,
211             uri_escape_utf8($p) . '=' . uri_escape_utf8($v);
212             }
213             }
214             else {
215 0         0 push @params,
216             uri_escape_utf8($p) . '=' . uri_escape_utf8($value);
217             }
218             }
219 0         0 $env->{QUERY_STRING} = join( '&', @params );
220             }
221              
222             # TODO files
223              
224 10         25 return ( $request, $env );
225             }
226              
227             sub response_status_is {
228 4     4 1 2464 my ( $req, $status, $test_name ) = @_;
229 4 50       11 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
230             unless $NO_WARN;
231              
232 4   33     22 $test_name ||= "response status is $status for " . _req_label($req);
233              
234 4         13 my $response = dancer_response($req);
235              
236 4         108 my $tb = Test::Builder->new;
237 4         23 local $Test::Builder::Level = $Test::Builder::Level + 1;
238 4         12 $tb->is_eq( $response->[0], $status, $test_name );
239             }
240              
241             sub _find_route_match {
242 7 100   7   57 my ( $request, $env ) =
243             ref $_[0] eq 'Dancer2::Core::Request'
244             ? _build_env_from_request(@_)
245             : _build_request_from_env(@_);
246              
247 7         12 for my $app (@{$_dispatcher->apps}) {
  7         143  
248 7         51 for my $route (@{$app->routes->{lc($request->method)}}) {
  7         98  
249 3 50       41 if ( $route->match($request) ) {
250 3         82 return 1;
251             }
252             }
253             }
254 4         67 return 0;
255             }
256              
257             sub route_exists {
258 3 50   3 1 1069 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
259             unless $NO_WARN;
260              
261 3         14 my $tb = Test::Builder->new;
262 3         19 local $Test::Builder::Level = $Test::Builder::Level + 1;
263 3         7 $tb->ok( _find_route_match($_[0]), $_[1]);
264             }
265              
266             sub route_doesnt_exist {
267 4 50   4 1 1471 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
268             unless $NO_WARN;
269              
270 4         16 my $tb = Test::Builder->new;
271 4         28 local $Test::Builder::Level = $Test::Builder::Level + 1;
272 4         10 $tb->ok( !_find_route_match($_[0]), $_[1]);
273             }
274              
275             sub response_status_isnt {
276 4     4 1 2488 my ( $req, $status, $test_name ) = @_;
277              
278 4 50       11 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
279             unless $NO_WARN;
280              
281 4   33     18 $test_name ||= "response status is not $status for " . _req_label($req);
282              
283 4         15 my $response = dancer_response($req);
284              
285 4         99 my $tb = Test::Builder->new;
286 4         22 local $Test::Builder::Level = $Test::Builder::Level + 1;
287 4         13 $tb->isnt_eq( $response->[0], $status, $test_name );
288             }
289              
290             {
291             # Map comparison operator names to human-friendly ones
292             my %cmp_name = (
293             is_eq => "is",
294             isnt_eq => "is not",
295             like => "matches",
296             unlike => "doesn't match",
297             );
298              
299             sub _cmp_response_content {
300 16     16   43 my ( $req, $want, $test_name, $cmp ) = @_;
301              
302 16 100       34 if ( @_ == 3 ) {
303 8         11 $cmp = $test_name;
304 8         16 $test_name = $cmp_name{$cmp};
305 8         23 $test_name =
306             "response content $test_name $want for " . _req_label($req);
307             }
308              
309 16         38 my $response = dancer_response($req);
310              
311 16         403 my $tb = Test::Builder->new;
312 16         84 local $Test::Builder::Level = $Test::Builder::Level + 1;
313 16         51 $tb->$cmp( $response->[2][0], $want, $test_name );
314             }
315             }
316              
317             sub response_content_is {
318 4 50   4 1 1791 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
319             unless $NO_WARN;
320 4         8 local $Test::Builder::Level = $Test::Builder::Level + 1;
321 4         10 _cmp_response_content( @_, 'is_eq' );
322             }
323              
324             sub response_content_isnt {
325 4 50   4 1 1757 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
326             unless $NO_WARN;
327 4         7 local $Test::Builder::Level = $Test::Builder::Level + 1;
328 4         9 _cmp_response_content( @_, 'isnt_eq' );
329             }
330              
331             sub response_content_like {
332 4 50   4 1 2351 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
333             unless $NO_WARN;
334 4         7 local $Test::Builder::Level = $Test::Builder::Level + 1;
335 4         8 _cmp_response_content( @_, 'like' );
336             }
337              
338             sub response_content_unlike {
339 4 50   4 1 2518 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
340             unless $NO_WARN;
341 4         10 local $Test::Builder::Level = $Test::Builder::Level + 1;
342 4         8 _cmp_response_content( @_, 'unlike' );
343             }
344              
345             sub response_content_is_deeply {
346 0     0 1 0 my ( $req, $matcher, $test_name ) = @_;
347 0 0       0 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
348             unless $NO_WARN;
349 0   0     0 $test_name ||= "response content looks good for " . _req_label($req);
350              
351 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
352 0         0 my $response = _req_to_response($req);
353 0         0 is_deeply $response->[2][0], $matcher, $test_name;
354             }
355              
356             sub response_is_file {
357 0     0 1 0 my ( $req, $test_name ) = @_;
358 0 0       0 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
359             unless $NO_WARN;
360 0   0     0 $test_name ||= "a file is returned for " . _req_label($req);
361              
362 0         0 my $response = _get_file_response($req);
363 0         0 my $tb = Test::Builder->new;
364 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
365 0         0 return $tb->ok( defined($response), $test_name );
366             }
367              
368             sub response_headers_are_deeply {
369 0     0 1 0 my ( $req, $expected, $test_name ) = @_;
370 0 0       0 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
371             unless $NO_WARN;
372 0   0     0 $test_name ||= "headers are as expected for " . _req_label($req);
373              
374 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
375 0         0 my $response = dancer_response( _expand_req($req) );
376              
377 0         0 is_deeply(
378             _sort_headers( $response->[1] ),
379             _sort_headers($expected), $test_name
380             );
381             }
382              
383             sub response_headers_include {
384 4     4 1 11 my ( $req, $expected, $test_name ) = @_;
385 4 50       10 carp 'DEPRECATED: Dancer2::Test. Please use Plack::Test instead'
386             unless $NO_WARN;
387 4   33     17 $test_name ||= "headers include expected data for " . _req_label($req);
388 4         18 my $tb = Test::Builder->new;
389              
390 4         23 my $response = dancer_response($req);
391 4         90 local $Test::Builder::Level = $Test::Builder::Level + 1;
392              
393 4 50       14 print STDERR "Headers are: "
394             . Dumper( $response->[1] )
395             . "\n Expected to find header: "
396             . Dumper($expected)
397             if !$tb->ok(
398             _include_in_headers( $response->[1], $expected ),
399             $test_name
400             );
401             }
402              
403             sub route_pod_coverage {
404              
405 2     2 1 2431 require Pod::Simple::Search;
406 2         6708 require Pod::Simple::SimpleTree;
407              
408 2         30171 my $all_routes = {};
409              
410 2         5 foreach my $app ( @{ $_dispatcher->apps } ) {
  2         61  
411 2         67 my $routes = $app->routes;
412 2         19 my $available_routes = [];
413 2         17 foreach my $method ( sort { $b cmp $a } keys %$routes ) {
  20         34  
414 12         16 foreach my $r ( @{ $routes->{$method} } ) {
  12         25  
415              
416             # we don't need pod coverage for head
417 16 100       35 next if $method eq 'head';
418 10         41 push @$available_routes, $method . ' ' . $r->spec_route;
419             }
420             }
421             ## copy dereferenced array
422 2 50       21 $all_routes->{ $app->name }{routes} = [@$available_routes]
423             if @$available_routes;
424              
425             # Pod::Simple v3.30 excluded the current directory even when in @INC.
426             # include the current directory as a search path; its backwards compatible
427             # with previous version.
428 2         5 my $undocumented_routes = [];
429 2         18 my $file = Pod::Simple::Search->new->find( $app->name, '.' );
430 2 50       841 if ($file) {
431 2         11 $all_routes->{ $app->name }{has_pod} = 1;
432 2         14 my $parser = Pod::Simple::SimpleTree->new->parse_file($file);
433 2         10488 my $pod_dataref = $parser->root;
434 2         18 my $found_routes = {};
435 2         9 for ( my $i = 0; $i < @$available_routes; $i++ ) {
436              
437 10         18 my $r = $available_routes->[$i];
438 10         18 my $app_string = lc $r;
439 10         22 $app_string =~ s/\*/_REPLACED_STAR_/g;
440              
441 10         24 for ( my $idx = 0; $idx < @$pod_dataref; $idx++ ) {
442 380         547 my $pod_part = $pod_dataref->[$idx];
443              
444 380 100       617 next if !is_arrayref($pod_part);
445 360         492 foreach my $ref_part (@$pod_part) {
446 1140 100       1842 is_arrayref($ref_part)
447             and push @$pod_dataref, $ref_part;
448             }
449              
450 360         533 my $pod_string = lc $pod_part->[2];
451 360         910 $pod_string =~ s/['|"|\s]+/ /g;
452 360         648 $pod_string =~ s/\s$//g;
453 360         541 $pod_string =~ s/\*/_REPLACED_STAR_/g;
454 360 100       1265 if ( $pod_string =~ m/^$app_string$/ ) {
455 34         59 $found_routes->{$app_string} = 1;
456 34         78 next;
457             }
458             }
459 10 50       70 if ( !$found_routes->{$app_string} ) {
460 0         0 push @$undocumented_routes, $r;
461             }
462             }
463             }
464             else { ### no POD found
465 0         0 $all_routes->{ $app->name }{has_pod} = 0;
466             }
467 2 50 33     28 if (@$undocumented_routes) {
    50          
468             $all_routes->{ $app->name }{undocumented_routes} =
469 0         0 $undocumented_routes;
470             }
471             elsif ( !$all_routes->{ $app->name }{has_pod}
472 0         0 && @{ $all_routes->{ $app->name }{routes} } )
473             {
474             ## copy dereferenced array
475             $all_routes->{ $app->name }{undocumented_routes} =
476 0         0 [ @{ $all_routes->{ $app->name }{routes} } ];
  0         0  
477             }
478             }
479              
480 2         12 return $all_routes;
481             }
482              
483             sub is_pod_covered {
484 1     1 1 99 my ($test_name) = @_;
485              
486 1   50     6 $test_name ||= "is pod covered";
487 1         3 my $route_pod_coverage = route_pod_coverage();
488              
489 1         11 my $tb = Test::Builder->new;
490 1         15 local $Test::Builder::Level = $Test::Builder::Level + 1;
491              
492 1         4 foreach my $app ( @{ $_dispatcher->apps } ) {
  1         25  
493             my %undocumented_route =
494 0         0 ( map { $_ => 1 }
495 1         9 @{ $route_pod_coverage->{ $app->name }{undocumented_routes} } );
  1         6  
496             $tb->subtest(
497             $app->name . $test_name,
498             sub {
499 1     1   1101 foreach my $route (
500 1         7 @{ $route_pod_coverage->{ $app->name }{routes} } )
501             {
502 5         1514 ok( !$undocumented_route{$route}, "$route is documented" );
503             }
504             }
505 1         147 );
506             }
507             }
508              
509             sub import {
510 2     2   23 my ( $class, %options ) = @_;
511              
512 2         4 my @applications;
513 2 100       14 if ( ref $options{apps} eq ref( [] ) ) {
514 1         2 @applications = @{ $options{apps} };
  1         3  
515             }
516             else {
517 1         4 my ( $caller, $script ) = caller;
518              
519             # if no app is passed, assume the caller is one.
520 1 50       13 @applications = ($caller) if $caller->can('dancer_app');
521             }
522              
523             # register the apps to the test dispatcher
524             $_dispatcher->apps( [ map {
525 2         6 $_->dancer_app->finish();
  2         12  
526 2         8 $_->dancer_app;
527             } @applications ] );
528              
529 2         207082 $class->export_to_level( 1, $class, @EXPORT );
530             }
531              
532             # private
533              
534             sub _req_label {
535 20     20   30 my $req = shift;
536              
537             return
538             ref $req eq 'Dancer2::Core::Response' ? 'response object'
539             : ref $req eq 'Dancer2::Core::Request'
540 20 100       105 ? join( ' ', map { $req->$_ } qw/ method path / )
  10 100       53  
    100          
541             : is_arrayref($req) ? join( ' ', @$req )
542             : "GET $req";
543             }
544              
545             sub _expand_req {
546 0     0   0 my $req = shift;
547 0 0       0 return is_arrayref($req) ? @$req : ( 'GET', $req );
548             }
549              
550             # Sort arrayref of headers (turn it into a list of arrayrefs, sort by the header
551             # & value, then turn it back into an arrayref)
552             sub _sort_headers {
553 0     0   0 my @originalheaders = @{ shift() }; # take a copy we can modify
  0         0  
554 0         0 my @headerpairs;
555 0         0 while ( my ( $header, $value ) = splice @originalheaders, 0, 2 ) {
556 0         0 push @headerpairs, [ $header, $value ];
557             }
558              
559             # We have an array of arrayrefs holding header => value pairs; sort them by
560             # header then value, and return them flattened back into an arrayref
561             return [
562 0         0 map {@$_}
563 0 0       0 sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @headerpairs
  0         0  
564             ];
565             }
566              
567             # make sure the given header sublist is included in the full headers array
568             sub _include_in_headers {
569 4     4   9 my ( $full_headers, $expected_subset ) = @_;
570              
571             # walk through all the expected header pairs, make sure
572             # they exist with the same value in the full_headers list
573             # return false as soon as one is not.
574 4         13 for ( my $i = 0; $i < scalar(@$expected_subset); $i += 2 ) {
575 4         11 my ( $name, $value ) =
576             ( $expected_subset->[$i], $expected_subset->[ $i + 1 ] );
577 4 50       9 return 0
578             unless _check_header( $full_headers, $name, $value );
579             }
580              
581             # we've found all the expected pairs in the $full_headers list
582 4         14 return 1;
583             }
584              
585             sub _check_header {
586 4     4   8 my ( $headers, $key, $value ) = @_;
587 4         9 for ( my $i = 0; $i < scalar(@$headers); $i += 2 ) {
588 4         8 my ( $name, $val ) = ( $headers->[$i], $headers->[ $i + 1 ] );
589 4 50 33     25 return 1 if $name eq $key && $value eq $val;
590             }
591 0         0 return 0;
592             }
593              
594             sub _req_to_response {
595 0     0   0 my $req = shift;
596              
597             # already a response object
598 0 0       0 return $req if ref $req eq 'Dancer2::Core::Response';
599              
600 0 0       0 return dancer_response( is_arrayref($req) ? @$req : ( 'GET', $req ) );
601             }
602              
603             # make sure we have at least one app in the dispatcher, and if not,
604             # we must have at this point an app within the caller
605             sub _find_dancer_apps_for_dispatcher {
606 39 50   39   63 return if scalar( @{ $_dispatcher->apps } );
  39         2131  
607              
608 0           for ( my $deep = 0; $deep < 5; $deep++ ) {
609 0           my $caller = caller($deep);
610 0 0 0       next if !$caller || !$caller->can('dancer_app');
611              
612 0           return $_dispatcher->apps( [ $caller->dancer_app ] );
613             }
614              
615 0           croak "Unable to find a Dancer2 app, did you use Dancer2 in your test?";
616             }
617              
618             1;
619              
620             __END__
621              
622             =pod
623              
624             =encoding UTF-8
625              
626             =head1 NAME
627              
628             Dancer2::Test - Useful routines for testing Dancer2 apps
629              
630             =head1 VERSION
631              
632             version 0.400001
633              
634             =head1 SYNOPSIS
635              
636             use Test::More;
637             use Plack::Test;
638             use HTTP::Request::Common; # install separately
639              
640             use YourDancerApp;
641              
642             my $app = YourDancerApp->to_app;
643             my $test = Plack::Test->create($app);
644              
645             my $res = $test->request( GET '/' );
646             is( $res->code, 200, '[GET /] Request successful' );
647             like( $res->content, qr/hello, world/, '[GET /] Correct content' );
648              
649             done_testing;
650              
651             =head1 DESCRIPTION
652              
653             B<DEPRECATED. This module and all the functions listed below are deprecated. Do
654             not use this module.> The routines provided by this module for testing Dancer2
655             apps are buggy and unnecessary. Instead, use the L<Plack::Test> module as shown
656             in the SYNOPSIS above and ignore the functions in this documentation. Consult
657             the L<Plack::Test> documentation for further details.
658              
659             This module will be removed from the Dancer2 distribution in the near future.
660             You should migrate all tests that use it over to the L<Plack::Test> module and
661             remove this module from your system. This module will throw warnings to remind
662             you.
663              
664             For now, you can silence the warnings by setting the C<NO_WARN> option:
665              
666             $Dancer::Test::NO_WARN = 1;
667              
668             In the functions below, $test_name is always optional.
669              
670             =head1 FUNCTIONS
671              
672             =head2 dancer_response ($method, $path, $params, $arg_env);
673              
674             Returns a Dancer2::Core::Response object for the given request.
675              
676             Only $method and $path are required.
677              
678             $params is a hashref with 'body' as a string; 'headers' can be an arrayref or
679             a HTTP::Headers object, 'files' can be arrayref of hashref, containing some
680             files to upload:
681              
682             dancer_response($method, $path,
683             {
684             params => $params,
685             body => $body,
686             headers => $headers,
687             files => [ { filename => '/path/to/file', name => 'my_file' } ],
688             }
689             );
690              
691             A good reason to use this function is for testing POST requests. Since POST
692             requests may not be idempotent, it is necessary to capture the content and
693             status in one shot. Calling the response_status_is and response_content_is
694             functions in succession would make two requests, each of which could alter the
695             state of the application and cause Schrodinger's cat to die.
696              
697             my $response = dancer_response POST => '/widgets';
698             is $response->status, 202, "response for POST /widgets is 202";
699             is $response->content, "Widget #1 has been scheduled for creation",
700             "response content looks good for first POST /widgets";
701              
702             $response = dancer_response POST => '/widgets';
703             is $response->status, 202, "response for POST /widgets is 202";
704             is $response->content, "Widget #2 has been scheduled for creation",
705             "response content looks good for second POST /widgets";
706              
707             It's possible to test file uploads:
708              
709             post '/upload' => sub { return upload('image')->content };
710              
711             $response = dancer_response(POST => '/upload', {files => [{name => 'image', filename => '/path/to/image.jpg'}]});
712              
713             In addition, you can supply the file contents as the C<data> key:
714              
715             my $data = 'A test string that will pretend to be file contents.';
716             $response = dancer_response(POST => '/upload', {
717             files => [{name => 'test', filename => "filename.ext", data => $data}]
718             });
719              
720             You can also supply a hashref of headers:
721              
722             headers => { 'Content-Type' => 'text/plain' }
723              
724             =head2 response_status_is ($request, $expected, $test_name);
725              
726             Asserts that Dancer2's response for the given request has a status equal to the
727             one given.
728              
729             response_status_is [GET => '/'], 200, "response for GET / is 200";
730              
731             =head2 route_exists([$method, $path], $test_name)
732              
733             Asserts that the given request matches a route handler in Dancer2's
734             registry. If the route would have returned a 404, the route still exists
735             and this test will pass.
736              
737             Note that because Dancer2 uses the default route handler
738             L<Dancer2::Handler::File> to match files in the public folder when
739             no other route matches, this test will always pass.
740             You can disable the default route handlers in the configs but you probably
741             want L<Dancer2::Test/response_status_is> or L<Dancer2::Test/dancer_response>
742              
743             route_exists [GET => '/'], "GET / is handled";
744              
745             =head2 route_doesnt_exist([$method, $path], $test_name)
746              
747             Asserts that the given request does not match any route handler
748             in Dancer2's registry.
749              
750             Note that this test is likely to always fail as any route not matched will
751             be handled by the default route handler in L<Dancer2::Handler::File>.
752             This can be disabled in the configs.
753              
754             route_doesnt_exist [GET => '/bogus_path'], "GET /bogus_path is not handled";
755              
756             =head2 response_status_isnt([$method, $path], $status, $test_name)
757              
758             Asserts that the status of Dancer2's response is not equal to the
759             one given.
760              
761             response_status_isnt [GET => '/'], 404, "response for GET / is not a 404";
762              
763             =head2 response_content_is([$method, $path], $expected, $test_name)
764              
765             Asserts that the response content is equal to the C<$expected> string.
766              
767             response_content_is [GET => '/'], "Hello, World",
768             "got expected response content for GET /";
769              
770             =head2 response_content_isnt([$method, $path], $not_expected, $test_name)
771              
772             Asserts that the response content is not equal to the C<$not_expected> string.
773              
774             response_content_isnt [GET => '/'], "Hello, World",
775             "got expected response content for GET /";
776              
777             =head2 response_content_like([$method, $path], $regexp, $test_name)
778              
779             Asserts that the response content for the given request matches the regexp
780             given.
781              
782             response_content_like [GET => '/'], qr/Hello, World/,
783             "response content looks good for GET /";
784              
785             =head2 response_content_unlike([$method, $path], $regexp, $test_name)
786              
787             Asserts that the response content for the given request does not match the regexp
788             given.
789              
790             response_content_unlike [GET => '/'], qr/Page not found/,
791             "response content looks good for GET /";
792              
793             =head2 response_content_is_deeply([$method, $path], $expected_struct, $test_name)
794              
795             Similar to response_content_is(), except that if response content and
796             $expected_struct are references, it does a deep comparison walking each data
797             structure to see if they are equivalent.
798              
799             If the two structures are different, it will display the place where they start
800             differing.
801              
802             response_content_is_deeply [GET => '/complex_struct'],
803             { foo => 42, bar => 24},
804             "got expected response structure for GET /complex_struct";
805              
806             =head2 response_is_file ($request, $test_name);
807              
808             =head2 response_headers_are_deeply([$method, $path], $expected, $test_name)
809              
810             Asserts that the response headers data structure equals the one given.
811              
812             response_headers_are_deeply [GET => '/'], [ 'X-Powered-By' => 'Dancer2 1.150' ];
813              
814             =head2 response_headers_include([$method, $path], $expected, $test_name)
815              
816             Asserts that the response headers data structure includes some of the defined ones.
817              
818             response_headers_include [GET => '/'], [ 'Content-Type' => 'text/plain' ];
819              
820             =head2 route_pod_coverage()
821              
822             Returns a structure describing pod coverage in your apps
823              
824             for one app like this:
825              
826             package t::lib::TestPod;
827             use Dancer2;
828              
829             =head1 NAME
830              
831             TestPod
832              
833             =head2 ROUTES
834              
835             =over
836              
837             =cut
838              
839             =item get "/in_testpod"
840              
841             testpod
842              
843             =cut
844              
845             get '/in_testpod' => sub {
846             return 'get in_testpod';
847             };
848              
849             get '/hello' => sub {
850             return "hello world";
851             };
852              
853             =item post '/in_testpod/*'
854              
855             post in_testpod
856              
857             =cut
858              
859             post '/in_testpod/*' => sub {
860             return 'post in_testpod';
861             };
862              
863             =back
864              
865             =head2 SPECIALS
866              
867             =head3 PUBLIC
868              
869             =over
870              
871             =item get "/me:id"
872              
873             =cut
874              
875             get "/me:id" => sub {
876             return "ME";
877             };
878              
879             =back
880              
881             =head3 PRIVAT
882              
883             =over
884              
885             =item post "/me:id"
886              
887             post /me:id
888              
889             =cut
890              
891             post "/me:id" => sub {
892             return "ME";
893             };
894              
895             =back
896              
897             =cut
898              
899             1;
900              
901             route_pod_coverage;
902              
903             would return something like:
904              
905             {
906             't::lib::TestPod' => {
907             'has_pod' => 1,
908             'routes' => [
909             "post /in_testpod/*",
910             "post /me:id",
911             "get /in_testpod",
912             "get /hello",
913             "get /me:id"
914             ],
915             'undocumented_routes' => [
916             "get /hello"
917             ]
918             }
919             }
920              
921             =head2 is_pod_covered('is pod covered')
922              
923             Asserts that your apps have pods for all routes
924              
925             is_pod_covered 'is pod covered'
926              
927             to avoid test failures, you should document all your routes with one of the following:
928             head1, head2,head3,head4, item.
929              
930             ex:
931              
932             =item get '/login'
933              
934             route to login
935              
936             =cut
937              
938             if you use:
939              
940             any '/myaction' => sub {
941             # code
942             }
943              
944             or
945              
946             any ['get', 'post'] => '/myaction' => sub {
947             # code
948             };
949              
950             you need to create pods for each one of the routes created there.
951              
952             =head2 import
953              
954             When Dancer2::Test is imported, it should be passed all the
955             applications that are supposed to be tested.
956              
957             If none passed, then the caller is supposed to be the sole application
958             to test.
959              
960             # t/sometest.t
961              
962             use t::lib::Foo;
963             use t::lib::Bar;
964              
965             use Dancer2::Test apps => ['t::lib::Foo', 't::lib::Bar'];
966              
967             =head1 AUTHOR
968              
969             Dancer Core Developers
970              
971             =head1 COPYRIGHT AND LICENSE
972              
973             This software is copyright (c) 2023 by Alexis Sukrieh.
974              
975             This is free software; you can redistribute it and/or modify it under
976             the same terms as the Perl 5 programming language system itself.
977              
978             =cut