Commit | Line | Data |
e646f111 |
1 | package Catalyst::Engine::Test; |
2 | |
3 | use strict; |
fbcc39ad |
4 | use base 'Catalyst::Engine::CGI'; |
d837e1a7 |
5 | use Catalyst::Utils; |
fbcc39ad |
6 | use HTTP::Response; |
7 | use HTTP::Status; |
8 | use NEXT; |
d837e1a7 |
9 | |
e646f111 |
10 | =head1 NAME |
11 | |
12 | Catalyst::Engine::Test - Catalyst Test Engine |
13 | |
14 | =head1 SYNOPSIS |
15 | |
c9afa5fc |
16 | A script using the Catalyst::Engine::Test module might look like: |
17 | |
18 | #!/usr/bin/perl -w |
19 | |
20 | BEGIN { |
21 | $ENV{CATALYST_ENGINE} = 'Test'; |
22 | } |
23 | |
24 | use strict; |
25 | use lib '/path/to/MyApp/lib'; |
26 | use MyApp; |
27 | |
28 | MyApp->run('/a/path'); |
e646f111 |
29 | |
30 | =head1 DESCRIPTION |
31 | |
32 | This is the Catalyst engine specialized for testing. |
33 | |
34 | =head1 OVERLOADED METHODS |
35 | |
fbcc39ad |
36 | This class overloads some methods from C<Catalyst::Engine::CGI>. |
e646f111 |
37 | |
38 | =over 4 |
39 | |
fbcc39ad |
40 | =item finalize_headers |
41 | |
42 | =cut |
43 | |
44 | sub finalize_headers { |
45 | my ( $self, $c ) = @_; |
46 | my $protocol = $c->request->protocol; |
47 | my $status = $c->response->status; |
48 | my $message = status_message($status); |
49 | print "$protocol $status $message\n"; |
50 | $c->response->headers->date(time); |
51 | $self->NEXT::finalize_headers($c); |
52 | } |
53 | |
54 | =item $self->run($c) |
e646f111 |
55 | |
56 | =cut |
57 | |
58 | sub run { |
fbcc39ad |
59 | my ( $self, $class, $request ) = @_; |
60 | |
d837e1a7 |
61 | $request = Catalyst::Utils::request($request); |
e646f111 |
62 | |
fbcc39ad |
63 | $request->header( |
d837e1a7 |
64 | 'Host' => sprintf( '%s:%d', $request->uri->host, $request->uri->port ) |
65 | ); |
4716267f |
66 | |
fbcc39ad |
67 | # We emulate CGI |
68 | local %ENV = ( |
4f5ebacd |
69 | PATH_INFO => $request->uri->path || '', |
70 | QUERY_STRING => $request->uri->query || '', |
71 | REMOTE_ADDR => '127.0.0.1', |
72 | REMOTE_HOST => 'localhost', |
fbcc39ad |
73 | REQUEST_METHOD => $request->method, |
74 | SERVER_NAME => 'localhost', |
75 | SERVER_PORT => $request->uri->port, |
76 | SERVER_PROTOCOL => 'HTTP/1.1', |
77 | %ENV, |
45374ac6 |
78 | ); |
e646f111 |
79 | |
fbcc39ad |
80 | # Headers |
81 | for my $header ( $request->header_field_names ) { |
82 | my $name = uc $header; |
83 | $name = 'COOKIE' if $name eq 'COOKIES'; |
84 | $name =~ tr/-/_/; |
85 | $name = 'HTTP_' . $name |
4f5ebacd |
86 | unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; |
fbcc39ad |
87 | my $value = $request->header($header); |
88 | if ( exists $ENV{$name} ) { |
89 | $ENV{$name} .= "; $value"; |
90 | } |
91 | else { |
92 | $ENV{$name} = $value; |
93 | } |
94 | } |
95 | |
96 | # STDIN |
97 | local *STDIN; |
98 | my $input = $request->content; |
99 | open STDIN, '<', \$input; |
100 | |
101 | # STDOUT |
102 | local *STDOUT; |
103 | my $output = ''; |
104 | open STDOUT, '>', \$output; |
b26df351 |
105 | |
fbcc39ad |
106 | # Process |
107 | $class->handle_request; |
e646f111 |
108 | |
fbcc39ad |
109 | # Response |
110 | return HTTP::Response->parse($output); |
e646f111 |
111 | } |
112 | |
fbcc39ad |
113 | =item $self->read_chunk($c, $buffer, $length) |
114 | |
115 | =cut |
116 | |
4f5ebacd |
117 | sub read_chunk { shift; shift; *STDIN->read(@_); } |
fbcc39ad |
118 | |
e646f111 |
119 | =back |
120 | |
121 | =head1 SEE ALSO |
122 | |
123 | L<Catalyst>. |
124 | |
fbcc39ad |
125 | =head1 AUTHORS |
126 | |
127 | Sebastian Riedel, <sri@cpan.org> |
128 | |
129 | Christian Hansen, <ch@ngmedia.com> |
e646f111 |
130 | |
fbcc39ad |
131 | Andy Grundman, <andy@hybridized.org> |
e646f111 |
132 | |
133 | =head1 COPYRIGHT |
134 | |
135 | This program is free software, you can redistribute it and/or modify it under |
136 | the same terms as Perl itself. |
137 | |
138 | =cut |
139 | |
140 | 1; |