Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Test; |
2 | |
3 | use strict; |
4 | use UNIVERSAL::require; |
49faa307 |
5 | use IO::File; |
6 | use HTTP::Request; |
fc7ec1d9 |
7 | use HTTP::Response; |
8 | use Socket; |
9 | use URI; |
10 | |
bc024080 |
11 | require Catalyst; |
12 | |
fc7ec1d9 |
13 | my $class; |
14 | $ENV{CATALYST_ENGINE} = 'CGI'; |
15 | $ENV{CATALYST_TEST} = 1; |
16 | |
17 | =head1 NAME |
18 | |
19 | Catalyst::Test - Test Catalyst applications |
20 | |
21 | =head1 SYNOPSIS |
22 | |
49faa307 |
23 | # Helper |
49faa307 |
24 | script/test.pl |
25 | |
fc7ec1d9 |
26 | # Tests |
27 | use Catalyst::Test 'TestApp'; |
28 | request('index.html'); |
29 | get('index.html'); |
30 | |
31 | # Request |
32 | perl -MCatalyst::Test=MyApp -e1 index.html |
33 | |
fc7ec1d9 |
34 | =head1 DESCRIPTION |
35 | |
36 | Test Catalyst applications. |
37 | |
38 | =head2 METHODS |
39 | |
40 | =head3 get |
41 | |
42 | Returns the content. |
43 | |
44 | my $content = get('foo/bar?test=1'); |
45 | |
46 | =head3 request |
47 | |
48 | Returns a C<HTTP::Response> object. |
49 | |
50 | my $res =request('foo/bar?test=1'); |
51 | |
52 | =cut |
53 | |
54 | { |
55 | no warnings; |
56 | CHECK { |
57 | if ( ( caller(0) )[1] eq '-e' ) { |
585893b9 |
58 | print request( $ARGV[0] || 'http://localhost' )->content; |
fc7ec1d9 |
59 | } |
60 | } |
61 | } |
62 | |
63 | sub import { |
64 | my $self = shift; |
bc024080 |
65 | if ( $class = shift ) { |
66 | $class->require; |
67 | unless ( $INC{'Test/Builder.pm'} ) { |
68 | die qq/Couldn't load "$class", "$@"/ if $@; |
69 | } |
70 | my $caller = caller(0); |
71 | no strict 'refs'; |
72 | *{"$caller\::request"} = \&request; |
73 | *{"$caller\::get"} = sub { request(@_)->content }; |
fc7ec1d9 |
74 | } |
fc7ec1d9 |
75 | } |
76 | |
77 | sub request { |
49faa307 |
78 | my $request = shift; |
79 | unless ( ref $request ) { |
80 | $request = URI->new( $request, 'http' ); |
81 | } |
82 | unless ( ref $request eq 'HTTP::Request' ) { |
83 | $request = HTTP::Request->new( 'GET', $request ); |
84 | } |
85 | local ( *STDIN, *STDOUT ); |
e0431ee5 |
86 | my %clean = %ENV; |
87 | my $output = ''; |
49faa307 |
88 | $ENV{CONTENT_TYPE} ||= $request->header('Content-Type') || ''; |
89 | $ENV{CONTENT_LENGTH} ||= $request->header('Content-Length') || ''; |
90 | $ENV{GATEWAY_INTERFACE} ||= 'CGI/1.1'; |
7c48ba15 |
91 | $ENV{HTTP_USER_AGENT} ||= 'Catalyst'; |
49faa307 |
92 | $ENV{HTTP_HOST} ||= $request->uri->host || 'localhost'; |
93 | $ENV{QUERY_STRING} ||= $request->uri->query || ''; |
94 | $ENV{REQUEST_METHOD} ||= $request->method; |
8b4483b3 |
95 | $ENV{PATH_INFO} ||= $request->uri->path || '/'; |
49faa307 |
96 | $ENV{SCRIPT_NAME} ||= $request->uri->path || '/'; |
97 | $ENV{SERVER_NAME} ||= $request->uri->host || 'localhost'; |
98 | $ENV{SERVER_PORT} ||= $request->uri->port; |
99 | $ENV{SERVER_PROTOCOL} ||= 'HTTP/1.1'; |
100 | |
101 | for my $field ( $request->header_field_names ) { |
102 | if ( $field =~ /^Content-(Length|Type)$/ ) { |
103 | next; |
104 | } |
105 | $field =~ s/-/_/g; |
106 | $ENV{ 'HTTP_' . uc($field) } = $request->header($field); |
107 | } |
108 | if ( $request->content_length ) { |
109 | my $body = IO::File->new_tmpfile; |
110 | $body->print( $request->content ) or die $!; |
111 | $body->seek( 0, SEEK_SET ) or die $!; |
112 | open( STDIN, "<&=", $body->fileno ) |
113 | or die("Failed to dup \$body: $!"); |
114 | } |
115 | open( STDOUT, '>', \$output ); |
fc7ec1d9 |
116 | $class->handler; |
117 | %ENV = %clean; |
118 | return HTTP::Response->parse($output); |
119 | } |
120 | |
fc7ec1d9 |
121 | =head1 SEE ALSO |
122 | |
123 | L<Catalyst>. |
124 | |
125 | =head1 AUTHOR |
126 | |
127 | Sebastian Riedel, C<sri@cpan.org> |
128 | |
129 | =head1 COPYRIGHT |
130 | |
131 | This program is free software, you can redistribute it and/or modify it under |
132 | the same terms as Perl itself. |
133 | |
134 | =cut |
135 | |
136 | 1; |