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