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