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