Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Test; |
2 | |
3 | use strict; |
b39840da |
4 | use warnings; |
d837e1a7 |
5 | |
a2f2cde9 |
6 | use Catalyst::Exception; |
d837e1a7 |
7 | use Catalyst::Utils; |
fc7ec1d9 |
8 | use UNIVERSAL::require; |
b39840da |
9 | use HTTP::Headers; |
fc7ec1d9 |
10 | |
e05c5e3c |
11 | $ENV{CATALYST_ENGINE} = 'Test'; |
fc7ec1d9 |
12 | |
b39840da |
13 | # Bypass a HTTP::Headers bug |
14 | { |
15 | no warnings 'redefine'; |
16 | |
17 | sub HTTP::Headers::new { |
18 | my $class = shift; |
19 | my $self = bless {}, $class; |
20 | if (@_) { |
21 | while ( my ( $field, $val ) = splice( @_, 0, 2 ) ) { |
22 | $self->push_header( $field, $val ); |
23 | } |
24 | } |
25 | return $self; |
26 | } |
27 | } |
28 | |
fc7ec1d9 |
29 | =head1 NAME |
30 | |
31 | Catalyst::Test - Test Catalyst applications |
32 | |
33 | =head1 SYNOPSIS |
34 | |
49faa307 |
35 | # Helper |
49faa307 |
36 | script/test.pl |
37 | |
fc7ec1d9 |
38 | # Tests |
39 | use Catalyst::Test 'TestApp'; |
40 | request('index.html'); |
41 | get('index.html'); |
42 | |
45374ac6 |
43 | # Run tests against a remote server |
21465c88 |
44 | CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/ |
45374ac6 |
45 | |
b6898a9f |
46 | # Tests with inline apps need to use Catalyst::Engine::Test |
47 | package TestApp; |
48 | |
49 | use Catalyst qw[-Engine=Test]; |
50 | |
c46c32fa |
51 | sub foo : Global { |
b6898a9f |
52 | my ( $self, $c ) = @_; |
53 | $c->res->output('bar'); |
c46c32fa |
54 | } |
55 | |
56 | __PACKAGE__->setup(); |
b6898a9f |
57 | |
58 | package main; |
59 | |
60 | use Test::More tests => 1; |
61 | use Catalyst::Test 'TestApp'; |
62 | |
63 | ok( get('/foo') =~ /bar/ ); |
64 | |
fc7ec1d9 |
65 | =head1 DESCRIPTION |
66 | |
67 | Test Catalyst applications. |
68 | |
69 | =head2 METHODS |
70 | |
bea4160a |
71 | =over 4 |
72 | |
73 | =item get |
fc7ec1d9 |
74 | |
75 | Returns the content. |
76 | |
77 | my $content = get('foo/bar?test=1'); |
78 | |
bea4160a |
79 | =item request |
fc7ec1d9 |
80 | |
81 | Returns a C<HTTP::Response> object. |
82 | |
795117cf |
83 | my $res = request('foo/bar?test=1'); |
fc7ec1d9 |
84 | |
85 | =cut |
86 | |
fc7ec1d9 |
87 | sub import { |
66d9e175 |
88 | my $self = shift; |
45374ac6 |
89 | my $class = shift; |
90 | |
91 | my ( $get, $request ); |
92 | |
d96e14c2 |
93 | if ( $ENV{CATALYST_SERVER} ) { |
45374ac6 |
94 | $request = sub { remote_request(@_) }; |
95 | $get = sub { remote_request(@_)->content }; |
96 | } |
97 | |
98 | else { |
bc024080 |
99 | $class->require; |
795117cf |
100 | die if $@ && $@ !~ /^Can't locate /; |
d96e14c2 |
101 | $class->import; |
102 | |
45374ac6 |
103 | $request = sub { $class->run(@_) }; |
104 | $get = sub { $class->run(@_)->content }; |
49faa307 |
105 | } |
45374ac6 |
106 | |
107 | no strict 'refs'; |
108 | my $caller = caller(0); |
109 | *{"$caller\::request"} = $request; |
110 | *{"$caller\::get"} = $get; |
111 | } |
112 | |
523d44ec |
113 | my $agent; |
114 | |
bea4160a |
115 | =item remote_request |
116 | |
b77e7869 |
117 | Do an actual remote request using LWP. |
bea4160a |
118 | |
119 | =cut |
120 | |
45374ac6 |
121 | sub remote_request { |
45374ac6 |
122 | |
68eb5874 |
123 | require LWP::UserAgent; |
124 | |
d837e1a7 |
125 | my $request = Catalyst::Utils::request( shift(@_) ); |
45374ac6 |
126 | |
68eb5874 |
127 | my $server = URI->new( $ENV{CATALYST_SERVER} ); |
523d44ec |
128 | |
129 | if ( $server->path =~ m|^(.+)?/$| ) { |
9ffadf88 |
130 | $server->path("$1"); # need to be quoted |
523d44ec |
131 | } |
132 | |
133 | $request->uri->scheme( $server->scheme ); |
134 | $request->uri->host( $server->host ); |
135 | $request->uri->port( $server->port ); |
136 | $request->uri->path( $server->path . $request->uri->path ); |
137 | |
68eb5874 |
138 | unless ($agent) { |
9ffadf88 |
139 | |
d837e1a7 |
140 | $agent = LWP::UserAgent->new( |
523d44ec |
141 | keep_alive => 1, |
142 | max_redirect => 0, |
143 | timeout => 60, |
144 | ); |
d837e1a7 |
145 | |
523d44ec |
146 | $agent->env_proxy; |
147 | } |
45374ac6 |
148 | |
149 | return $agent->request($request); |
fc7ec1d9 |
150 | } |
151 | |
bea4160a |
152 | =back |
153 | |
fc7ec1d9 |
154 | =head1 SEE ALSO |
155 | |
156 | L<Catalyst>. |
157 | |
158 | =head1 AUTHOR |
159 | |
160 | Sebastian Riedel, C<sri@cpan.org> |
161 | |
162 | =head1 COPYRIGHT |
163 | |
164 | This program is free software, you can redistribute it and/or modify it under |
165 | the same terms as Perl itself. |
166 | |
167 | =cut |
168 | |
169 | 1; |