File Coverage

blib/lib/Test/Mojo/Plack.pm
Criterion Covered Total %
statement 84 100 84.0
branch 18 42 42.8
condition 10 28 35.7
subroutine 15 16 93.7
pod 1 1 100.0
total 128 187 68.4


line stmt bran cond sub pod time code
1             package Test::Mojo::Plack;
2              
3 3     3   68680 use strict;
  3         18  
  3         85  
4 3     3   15 use warnings;
  3         6  
  3         79  
5              
6 3     3   1445 use Mojo::Base 'Test::Mojo';
  3         578661  
  3         20  
7 3     3   942969 use Mojo::Headers;
  3         9  
  3         24  
8 3     3   141 use Mojo::Transaction::HTTP;
  3         10  
  3         24  
9 3     3   79 use Mojo::URL;
  3         7  
  3         18  
10 3     3   93 use Mojo::Util qw(encode decode url_unescape);
  3         6  
  3         195  
11              
12 3     3   1662 use Class::Load qw(load_class is_class_loaded);
  3         54022  
  3         286  
13 3     3   1489 use IO::String;
  3         8092  
  3         105  
14 3     3   1797 use List::MoreUtils;
  3         38478  
  3         19  
15 3     3   3165 use Scalar::Util qw(blessed);
  3         9  
  3         3798  
16              
17             sub new {
18 2     2 1 17665 my ($class, $app_class) = @_;
19              
20 2         17 my $t = $class->SUPER::new();
21              
22 2 100       49 return $t unless $app_class;
23              
24 1         10 $ENV{PLACK_ENV} = 1;
25              
26 1 50       6 if (ref $app_class eq 'CODE') {
27 1     1   6 $t->{psgi_app} = sub { my $res = $app_class->(shift); sub { shift->($res); } };
  1         4  
  1         13  
  1         3  
28             } else {
29 0 0       0 load_class($app_class) unless is_class_loaded($app_class);
30 0         0 $app_class->import;
31 0 0       0 if ($app_class->can("_finalized_psgi_app") ) { # Catalyst
    0          
32 0         0 $t->{psgi_app} = $app_class->_finalized_psgi_app;
33             }
34             elsif ($app_class->can("dance") ) { # Dancer
35             $t->{psgi_app} = sub {
36 0     0   0 my $request = Dancer::Request->new( env => shift );
37 0         0 my $res = Dancer->dance( $request );
38 0         0 sub { shift->($res); };
  0         0  
39             }
40 0         0 }
41             }
42 1 50       5 die "Unable to instantiate application as a PSGI application: '$app_class'" unless $t->{psgi_app};
43              
44 1         3 return $t;
45             }
46              
47             sub _request_ok {
48 2     2   86676 my ($self, $tx, $url) = @_;
49              
50             # Let Mojo::Test handle it if no app has been instantiated
51 2 100       16 return $self->SUPER::_request_ok(@_[1..2]) unless $self->{psgi_app};
52              
53 1         6 $url = Mojo::URL->new($url);
54              
55 1 50 50     52 my $env = {
    50 50        
      50        
      33        
56             PATH_INFO => url_unescape($url->path || '/'),
57             QUERY_STRING => $url->query || '',
58             SCRIPT_NAME => '',
59             SERVER_NAME => $url->host,
60             SERVER_PORT => $url->port,
61             SERVER_PROTOCOL => $tx->req->version ? ('HTTP/' . $tx->req->version ) : 'HTTP/1.1',
62             REMOTE_ADDR => '127.0.0.1',
63             REMOTE_HOST => 'localhost',
64             REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
65             REQUEST_URI => (join '?', $url->path, $url->query) || '/', # not in RFC 3875
66             REQUEST_METHOD => $tx->req->method,
67             'psgi.version' => [ 1, 1 ],
68             'psgi.url_scheme' => $url->scheme && $url->scheme eq 'https' ? 'https' : 'http',
69             'psgi.input' => IO::String->new($tx->req->body . "\r\n"),
70             'psgi.errors' => *STDERR,
71             'psgi.multithread' => 0,
72             'psgi.multiprocess' => 0,
73             'psgi.run_once' => 1,
74             'psgi.streaming' => 1,
75             'psgi.nonblocking' => 0,
76             'HTTP_CONTENT_LENGTH' => length($tx->req->body),
77             };
78              
79 1 50       607 for my $field ( @{ $tx->req->headers->names || [] }) {
  1         5  
80 2         59 my $key = uc("HTTP_$field");
81 2         5 $key =~ tr/-/_/;
82 2 50       8 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
83              
84 2 50       7 unless ( exists $env->{$key} ) {
85 2         7 $env->{$key} = $tx->req->headers->header($field);
86             }
87             }
88              
89 1 50       21 if ($env->{SCRIPT_NAME}) {
90 0         0 $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//;
91 0         0 $env->{PATH_INFO} =~ s/^\/+/\//;
92             }
93              
94 1 50 33     7 if (!defined($env->{HTTP_HOST}) && $url->host) {
95 0         0 $env->{HTTP_HOST} = $url->host;
96 0 0       0 $env->{HTTP_HOST} .= ':' . $url->port
97             if $url->port;
98             }
99 1   50     13 $env->{HTTP_HOST} ||= 'localhost';
100              
101 1         4 my $ret = $self->{psgi_app}->($env);
102 1         8 my $res = Mojo::Message::Response->new();
103              
104             $ret->(sub {
105 1     1   3 my ($code, $headers, $body) = @{+shift};
  1         3  
106 1         12 my $header_hash;
107 1         4 my $it = List::MoreUtils::natatime 2, @{$headers};
  1         20  
108 1         13 while (my($k, $v) = $it->()) {
109 1         6 $res->headers->append($k, $v);
110             }
111 1         111 $res->code($code);
112              
113 1         6 my $body_str = '';
114 1 50 33     11 if (defined $body && blessed($body)) {
    50          
115 0 0       0 if ($body->can('getline')) {
116 0         0 while (my $line = $body->getline) {
117 0   0     0 $body_str .= ($line || '');
118             }
119             }
120             } elsif(ref $body) {
121 1 50       4 if (ref($body) eq 'ARRAY') {
122 1         3 $body_str = join '', @{$body};
  1         3  
123             }
124             };
125              
126 1   33     3 $body_str //= $body;
127              
128 1         4 $res->body($body_str);
129 1         13 });
130              
131 1         72 $self->tx(Mojo::Transaction::HTTP->new);
132 1         12 $self->tx->req->env($env);
133 1         27 $self->tx->res($res);
134              
135 1         9 my $err = $self->tx->error;
136             Test::More::diag $err->{message}
137 1 50 33     25 if !(my $ok = !$err->{message} || $err->{code}) && $err;
      33        
138 1         3 my $desc = encode 'UTF-8', "@{[uc $tx->req->method]} $url";
  1         4  
139 1 50       194 return $self->can('_test') ? $self->_test('ok', $ok, $desc) : $self->test('ok', $ok, $desc);
140             }
141              
142             =head1 NAME
143              
144             Test::Mojo::Plack - Test Plack-compatible applications with Test:Mojo
145              
146             =head1 VERSION
147              
148             Version 0.10
149              
150             =cut
151              
152             our $VERSION = '0.11';
153              
154             =head1 SYNOPSIS
155              
156             use Test::Mojo::Plack;
157             use Test::More;
158              
159             my $foo = Test::Mojo::Plack->new('My::Catalyst::App');
160             my $foo = Test::Mojo::Plack->new('My::Dancer::App');
161              
162             $foo->get_ok("/")
163             ->status_is(200)
164             ->content_type_is('text/html')
165             ->text_is('#footer a.author', 'mendoza@pvv.ntnu.no');
166              
167             done_testing;
168              
169             =head1 SUBROUTINES/METHODS
170              
171             =head2 new
172              
173             =head2 new($app)
174              
175             Returns a L object that is a subclass of L
176              
177             If $app is provided, it tries to set app a PSGI application by guessing the framework of it.
178              
179             =head1 METHODS
180              
181             L inherits all methods from L and overrides the following:
182              
183             =head2 _request_ok
184              
185             Hijacks the setup and sending of a request to send it to a pre-defined PSGI application.
186              
187             =head1 AUTHOR
188              
189             Nicolas Mendoza, C<< >>
190              
191             =head1 BUGS
192              
193             =head1 SUPPORT
194              
195             You can find documentation for this module with the perldoc command.
196              
197             perldoc Test::Mojo::Plack
198              
199             =head1 SEE ALSO
200              
201             =over
202              
203             =item L
204              
205             =item L
206              
207             =item L
208              
209             =item L - Newer alternative approach
210              
211             =back
212              
213             =head1 REPOSITORY
214              
215             L
216              
217             =head1 ACKNOWLEDGEMENTS
218              
219             Heavily inspired by L and L and of course L
220              
221             =head1 LICENSE AND COPYRIGHT
222              
223             Copyright 2014 Nicolas Mendoza.
224              
225             This program is free software; you can redistribute it and/or modify it
226             under the terms of either: the GNU General Public License as published
227             by the Free Software Foundation; or the Artistic License.
228              
229             See http://dev.perl.org/licenses/ for more information.
230              
231              
232             =cut
233              
234             1; # End of Test::Mojo::Plack
235              
236