File Coverage

blib/lib/Dancer/Test.pm
Criterion Covered Total %
statement 234 254 92.1
branch 46 56 82.1
condition 42 69 60.8
subroutine 45 50 90.0
pod 17 19 89.4
total 384 448 85.7


line stmt bran cond sub pod time code
1             package Dancer::Test;
2             our $AUTHORITY = 'cpan:SUKRIA';
3             #ABSTRACT: Test helpers to test a Dancer application
4             $Dancer::Test::VERSION = '1.3520';
5             # test helpers for Dancer apps
6              
7 85     85   1073466 use strict;
  85         336  
  85         2677  
8 85     85   485 use warnings;
  85         257  
  85         2293  
9 85     85   5381 use Test::Builder;
  85         416985  
  85         2949  
10 85     85   5334 use Test::More import => [ '!pass' ];
  85         44969  
  85         1356  
11 85     85   73001 use Test::LongString;
  85         200455  
  85         616  
12              
13 85     85   7073 use Carp;
  85         223  
  85         4323  
14 85     85   5959 use HTTP::Headers;
  85         70641  
  85         2105  
15 85     85   482 use Scalar::Util 'blessed';
  85         233  
  85         4135  
16              
17 85     85   7521 use Dancer ':syntax', ':tests';
  85         237  
  85         659  
18 85     85   721 use Dancer::App;
  85         303  
  85         2509  
19 85     85   569 use Dancer::Deprecation;
  85         246  
  85         2318  
20 85     85   517 use Dancer::Request;
  85         231  
  85         2380  
21 85     85   504 use Dancer::Request::Upload;
  85         225  
  85         2449  
22 85     85   616 use Dancer::SharedData;
  85         232  
  85         2204  
23 85     85   546 use Dancer::Renderer;
  85         280  
  85         2362  
24 85     85   541 use Dancer::Handler;
  85         237  
  85         2475  
25 85     85   558 use Dancer::Config;
  85         216  
  85         4282  
26 85     85   605 use Dancer::FileUtils qw(open_file);
  85         239  
  85         4651  
27              
28 85     85   641 use base 'Exporter';
  85         203  
  85         12012  
29 85     85   672 use vars '@EXPORT';
  85         280  
  85         265526  
30              
31             @EXPORT = qw(
32             route_exists
33             route_doesnt_exist
34              
35             response_exists
36             response_doesnt_exist
37              
38             response_status_is
39             response_status_isnt
40              
41             response_content_is
42             response_content_isnt
43             response_content_is_deeply
44             response_content_like
45             response_content_unlike
46              
47             response_is_file
48             response_headers_are_deeply
49             response_headers_include
50             response_redirect_location_is
51             response_redirect_location_like
52              
53             dancer_response
54              
55             read_logs
56             );
57              
58             sub import {
59 85     85   797 my ($class, %options) = @_;
60 85   100     845 $options{appdir} ||= '.';
61              
62             # mimic PSGI env
63 85         843 $ENV{SERVERNAME} = 'localhost';
64 85         399 $ENV{HTTP_HOST} = 'localhost';
65 85         433 $ENV{SERVER_PORT} = 80;
66 85         377 $ENV{'psgi.url_scheme'} = 'http';
67              
68 85         382 my ($package, $script) = caller;
69 85         12306 $class->export_to_level(1, $class, @EXPORT);
70              
71 85         622 Dancer::_init_script_dir($options{appdir});
72 85         679 Dancer::Config->load;
73              
74             # set a default session engine for tests
75 85         536 setting 'session' => 'simple';
76              
77             # capture logs for testing
78 85         366 setting 'logger' => 'capture';
79 85         347 setting 'log' => 'debug';
80             }
81              
82             # Route Registry
83              
84             sub _isa {
85 1200     1200   2189 my ( $reference, $classname ) = @_;
86 1200   66     6285 return blessed $reference && $reference->isa($classname);
87             }
88              
89             sub _req_to_response {
90 427     427   1127 my $req = shift;
91              
92             # already a response object
93 427 100       913 return $req if _isa($req, 'Dancer::Response');
94              
95 419 100       1778 return dancer_response( ref $req eq 'ARRAY' ? @$req : ( 'GET', $req ) );
96             }
97              
98             sub _req_label {
99 274     274   509 my $req = shift;
100              
101 274 100       697 return _isa($req, 'Dancer::Response') ? 'response object'
    100          
102             : ref $req eq 'ARRAY' ? join( ' ', @$req )
103             : "GET $req";
104             }
105              
106             sub expand_req {
107 54     54 0 107 my $req = shift;
108 54 50       298 return ref $req eq 'ARRAY' ? @$req : ( 'GET', $req );
109             }
110              
111             sub route_exists {
112 43     43 1 9540 my ($req, $test_name) = @_;
113 43         236 my $tb = Test::Builder->new;
114              
115 43         429 my ($method, $path) = expand_req($req);
116 43   66     313 $test_name ||= "a route exists for $method $path";
117              
118 43         304 $req = Dancer::Request->new_for_request($method => $path);
119 43         219 return $tb->ok(defined(Dancer::App->find_route_through_apps($req)), $test_name);
120             }
121              
122             sub route_doesnt_exist {
123 4     4 1 2241 my ($req, $test_name) = @_;
124 4         19 my $tb = Test::Builder->new;
125              
126 4         38 my ($method, $path) = expand_req($req);
127 4   66     31 $test_name ||= "no route exists for $method $path";
128              
129 4         17 $req = Dancer::Request->new_for_request($method => $path);
130 4         28 return $tb->ok(!defined(Dancer::App->find_route_through_apps($req)), $test_name);
131             }
132              
133             # Response status
134              
135             sub response_exists {
136 0     0 1 0 Dancer::Deprecation->deprecated(
137             fatal => 1,
138             feature => 'response_exists',
139             reason => 'Use response_status_isnt and check for status 404.'
140             );
141             }
142              
143             sub response_doesnt_exist {
144 0     0 1 0 Dancer::Deprecation->deprecated(
145             fatal => 1,
146             feature => 'response_doesnt_exist',
147             reason => 'Use response_status_is and check for status 404.',
148             );
149             }
150              
151             sub response_status_is {
152 160     160 1 78279 my ($req, $status, $test_name) = @_;
153 160   66     811 $test_name ||= "response status is $status for " . _req_label($req);
154              
155 160         474 my $response = _req_to_response($req);
156 160         854 my $tb = Test::Builder->new;
157 160         1339 return $tb->is_eq($response->status, $status, $test_name);
158             }
159              
160             sub response_status_isnt {
161 4     4 1 2872 my ($req, $status, $test_name) = @_;
162 4   66     21 $test_name ||= "response status is not $status for " . _req_label($req);
163              
164 4         10 my $response = _req_to_response($req);
165 4         15 my $tb = Test::Builder->new;
166 4         35 $tb->isnt_eq( $response->{status}, $status, $test_name );
167             }
168              
169             # Response content
170              
171             sub response_content_is {
172 121     121 1 70027 my ($req, $matcher, $test_name) = @_;
173 121   66     603 $test_name ||= "response content looks good for " . _req_label($req);
174              
175 121         331 my $response = _req_to_response($req);
176 121         718 my $tb = Test::Builder->new;
177 121         1092 return $tb->is_eq( $response->{content}, $matcher, $test_name );
178             }
179              
180             sub response_content_isnt {
181 4     4 1 2585 my ($req, $matcher, $test_name) = @_;
182 4   33     26 $test_name ||= "response content looks good for " . _req_label($req);
183              
184 4         23 my $response = _req_to_response($req);
185 4         27 my $tb = Test::Builder->new;
186 4         32 return $tb->isnt_eq( $response->{content}, $matcher, $test_name );
187             }
188              
189             sub response_content_like {
190 40     40 1 15891 my ($req, $matcher, $test_name) = @_;
191 40   66     181 $test_name ||= "response content looks good for " . _req_label($req);
192              
193 40         142 my $response = _req_to_response($req);
194 40         242 return like_string( $response->{content}, $matcher, $test_name ); # better output for long content than Test::Builder
195             }
196              
197             sub response_content_unlike {
198 4     4 1 1894 my ($req, $matcher, $test_name) = @_;
199 4   50     31 $test_name ||= "response content looks good for " , _req_label($req);
200              
201 4         11 my $response = _req_to_response($req);
202 4         32 return unlike_string( $response->{content}, $matcher, $test_name ); # better for long content than Test::Builder
203             }
204              
205             sub response_content_is_deeply {
206 59     59 1 38359 my ($req, $matcher, $test_name) = @_;
207 59   66     254 $test_name ||= "response content looks good for " . _req_label($req);
208              
209 59         132 local $Test::Builder::Level = $Test::Builder::Level + 1;
210 59         122 my $response = _req_to_response($req);
211 59         274 is_deeply $response->{content}, $matcher, $test_name;
212             }
213              
214             sub response_is_file {
215 1     1 0 64 my ($req, $test_name) = @_;
216 1   33     10 $test_name ||= "a file is returned for " . _req_label($req);
217              
218 1         5 my $response = _get_file_response($req);
219 1         6 my $tb = Test::Builder->new;
220 1         12 return $tb->ok(defined($response), $test_name);
221             }
222              
223             sub response_headers_are_deeply {
224 7     7 1 1248 my ($req, $expected, $test_name) = @_;
225 7   66     34 $test_name ||= "headers are as expected for " . _req_label($req);
226              
227 7         17 local $Test::Builder::Level = $Test::Builder::Level + 1;
228 7         16 my $response = _req_to_response($req);
229              
230 7         88 is_deeply(
231             _sort_headers( $response->headers_to_array ),
232             _sort_headers( $expected ),
233             $test_name
234             );
235             }
236              
237             # Sort arrayref of headers (turn it into a list of arrayrefs, sort by the header
238             # & value, then turn it back into an arrayref)
239             sub _sort_headers {
240 14     14   34 my @originalheaders = @{ shift() }; # take a copy we can modify
  14         42  
241 14         33 my @headerpairs;
242 14         55 while (my ($header, $value) = splice @originalheaders, 0, 2) {
243 40         120 push @headerpairs, [ $header, $value ];
244             }
245              
246             # We have an array of arrayrefs holding header => value pairs; sort them by
247             # header then value, and return them flattened back into an arrayref
248             return [
249 40         132 map { @$_ }
250 14 50       51 sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] }
  35         101  
251             @headerpairs
252             ];
253             }
254              
255              
256             sub response_headers_include {
257 27     27 1 11541 my ($req, $expected, $test_name) = @_;
258 27   66     127 $test_name ||= "headers include expected data for " . _req_label($req);
259 27         130 my $tb = Test::Builder->new;
260              
261 27         257 my $response = _req_to_response($req);
262 27         137 return $tb->ok(_include_in_headers($response->headers_to_array, $expected), $test_name);
263             }
264              
265             sub response_redirect_location_is {
266 0     0 1 0 my ($req, $expected, $test_name) = @_;
267 0   0     0 $test_name ||= "redirect location looks good for " . _req_label($req);
268 0         0 my $tb = Test::Builder->new;
269              
270 0         0 my $response = _req_to_response($req);
271 0         0 return $tb->is_eq($response->header('location'), $expected, $test_name);
272             }
273              
274             sub response_redirect_location_like {
275 0     0 1 0 my ($req, $matcher, $test_name) = @_;
276 0   0     0 $test_name ||= "redirect location looks good for " . _req_label($req);
277 0         0 my $tb = Test::Builder->new;
278              
279 0         0 my $response = _req_to_response($req);
280 0         0 return $tb->like($response->header('location'), $matcher, $test_name);
281             }
282              
283              
284             # make sure the given header sublist is included in the full headers array
285             sub _include_in_headers {
286 27     27   90 my ($full_headers, $expected_subset) = @_;
287              
288             # walk through all the expected header pairs, make sure
289             # they exist with the same value in the full_headers list
290             # return false as soon as one is not.
291 27         138 for (my $i=0; $i
292 45         170 my ($name, $value) = ($expected_subset->[$i], $expected_subset->[$i + 1]);
293 45 50       100 return 0
294             unless _check_header($full_headers, $name, $value);
295             }
296              
297             # we've found all the expected pairs in the $full_headers list
298 27         266 return 1;
299             }
300              
301             sub _check_header {
302 45     45   101 my ($headers, $key, $value) = @_;
303 45         139 for (my $i=0; $i
304 112         211 my ($name, $val) = ($headers->[$i], $headers->[$i + 1]);
305 112 100 100     810 return 1 if $name eq $key && $value eq $val;
306             }
307 0         0 return 0;
308             }
309              
310             sub dancer_response {
311 499     499 1 41697 my ($method, $path, $args) = @_;
312 499   100     2320 $args ||= {};
313 499         1017 my $extra_env = {};
314              
315 499 100       1692 if ($method =~ /^(?:PUT|POST)$/) {
316              
317 28         65 my ($content, $content_type);
318              
319 28 50 66     207 if ( $args->{body} and $args->{files} ) {
    100          
    100          
320             # XXX: When fixing this, update this method's POD
321 0         0 croak 'dancer_response() does not support both body and files';
322             }
323             elsif ( $args->{body} ) {
324 13         36 $content = $args->{body};
325             $content_type = $args->{content_type}
326 13   100     61 || 'text/plain';
327              
328             # coerce hashref into an url-encoded string
329 13 100 66     55 if ( ref($content) && ( ref($content) eq 'HASH' ) ) {
330 3         6 my @tokens;
331 3         7 while ( my ( $name, $value ) = each %{$content} ) {
  6         24  
332 3         12 $name = _url_encode($name);
333 3 100       16 my @values = ref $value eq 'ARRAY' ? @$value : ($value);
334 3         8 for my $value (@values) {
335 4         11 $value = _url_encode($value);
336 4         16 push @tokens, "${name}=${value}";
337             }
338             }
339 3         12 $content = join( '&', @tokens );
340 3         10 $content_type = 'application/x-www-form-urlencoded';
341             }
342             }
343             elsif ( $args->{files} ) {
344 3         17 $content_type = 'multipart/form-data; boundary=----BOUNDARY';
345 3         5 foreach my $file (@{$args->{files}}){
  3         12  
346 5   50     27 $file->{content_type} ||= 'text/plain';
347 5         14 $content .= qq/------BOUNDARY\r\n/;
348 5         17 $content .= qq/Content-Disposition: form-data; name="$file->{name}"; filename="$file->{filename}"\r\n/;
349 5         15 $content .= qq/Content-Type: $file->{content_type}\r\n\r\n/;
350 5 100       13 if ( $file->{data} ) {
351 1         6 $content .= $file->{data};
352             } else {
353             open my $fh, '<', $file->{filename}
354 4 50       135 or die "Failed to open $file->{filename} - $!";
355 4 50       160 if ( -B $file->{filename} ) {
356 0         0 binmode $fh;
357             }
358 4         65 while (<$fh>) {
359 4         54 $content .= $_;
360             }
361             }
362 5         17 $content .= "\r\n";
363             }
364 3         8 $content .= "------BOUNDARY";
365             }
366              
367 28         59 my $l = 0;
368 28 100       76 $l = length $content if defined $content;
369 28     10   779 open my $in, '<', \$content;
  10         90  
  10         21  
  10         94  
370 28         9121 $extra_env->{'CONTENT_LENGTH'} = $l;
371 28   100     183 $extra_env->{'CONTENT_TYPE'} = $content_type || "";
372 28         85 $extra_env->{'psgi.input'} = $in;
373             }
374              
375 499         1408 my ($params, $body, $headers) = @$args{qw(params body headers)};
376              
377 499 100       1037 $headers = HTTP::Headers->new(@{$headers||[]})
  497 100       3167  
378             unless _isa($headers, "HTTP::Headers");
379              
380 499 100       5987 if ($headers->header('Content-Type')) {
381 16         614 $extra_env->{'CONTENT_TYPE'} = $headers->header('Content-Type');
382             }
383              
384             # handle all the keys of Request::_build_request_env():
385 499         21342 for my $key (qw( user_agent host accept_language accept_charset
386             accept_encoding keep_alive connection accept accept_type referer
387             x_requested_with )) {
388 5489         10876 my $k = sprintf("HTTP_%s", uc $key);
389             $extra_env->{$k} = $headers->{$key}
390 5489 100       10734 if exists $headers->{$key};
391             }
392              
393             # fake the REQUEST_URI
394             # TODO deal with the params
395 499 50       1547 unless( $extra_env->{REQUEST_URI} ) {
396 499         1189 $extra_env->{REQUEST_URI} = $path;
397 499 100 100     2198 if ( $method eq 'GET' and $params ) {
398             $extra_env->{REQUEST_URI} .=
399 8         55 '?' . join '&', map { join '=', $_, $params->{$_} }
  7         46  
400             sort keys %$params;
401             }
402             }
403              
404 499         2470 my $request = Dancer::Request->new_for_request(
405             $method => $path,
406             $params, $body, $headers, $extra_env
407             );
408              
409             # first, reset the current state
410 499         2086 Dancer::SharedData->reset_all();
411              
412             # then store the request
413 499         1558 Dancer::SharedData->request($request);
414              
415             # XXX this is a hack!!
416 499 100       1618 $request = Dancer::Serializer->process_request($request)
417             if Dancer::App->current->setting('serializer');
418              
419 499         1804 my $get_action = Dancer::Handler::render_request($request);
420 499         1650 my $response = Dancer::SharedData->response();
421              
422 499 100       1376 $response->content('') if $method eq 'HEAD';
423 499         1407 Dancer::SharedData->reset_response();
424 499 50       2581 return $response if $get_action;
425 0 0 0     0 (defined $response && $response->exists) ? return $response : return undef;
426             }
427              
428             # private
429              
430             sub _url_encode {
431 7     7   10 my $string = shift;
432 7         20 $string =~ s/([\W])/"%" . uc(sprintf("%2.2x",ord($1)))/eg;
  1         9  
433 7         15 return $string;
434             }
435              
436             sub _get_file_response {
437 7     7   2062 my ($req) = @_;
438              
439 7         19 my ($method, $path, $params) = expand_req($req);
440 7         54 my $request = Dancer::Request->new_for_request($method => $path, $params);
441 7         30 Dancer::SharedData->request($request);
442 7         127 return Dancer::Renderer::get_file_response();
443             }
444              
445             sub _get_handler_response {
446 0     0   0 my ($req) = @_;
447 0         0 my ($method, $path, $params) = expand_req($req);
448 0         0 my $request = Dancer::Request->new_for_request($method => $path, $params);
449 0         0 return Dancer::Handler->handle_request($request);
450             }
451              
452             sub read_logs {
453 2     2 1 12 return Dancer::Logger::Capture->trap->read;
454             }
455              
456              
457             1;
458              
459             __END__