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