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