Commit | Line | Data |
e646f111 |
1 | package Catalyst::Engine::Test; |
2 | |
3 | use strict; |
fbcc39ad |
4 | use base 'Catalyst::Engine::CGI'; |
41ca9ba7 |
5 | use HTTP::Request; |
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 | |
41ca9ba7 |
61 | # Construct request |
62 | unless ( ref $request ) { |
63 | if ( $request =~ m/http/i ) { |
64 | $request = URI->new($request)->canonical; |
65 | } |
66 | else { |
67 | $request = URI->new( 'http://localhost' . $request )->canonical; |
68 | } |
69 | } |
70 | unless ( ref $request eq 'HTTP::Request' ) { |
71 | $request = HTTP::Request->new( 'GET', $request ); |
72 | } |
e646f111 |
73 | |
fbcc39ad |
74 | $request->header( |
d837e1a7 |
75 | 'Host' => sprintf( '%s:%d', $request->uri->host, $request->uri->port ) |
76 | ); |
4716267f |
77 | |
fbcc39ad |
78 | # We emulate CGI |
79 | local %ENV = ( |
4f5ebacd |
80 | PATH_INFO => $request->uri->path || '', |
81 | QUERY_STRING => $request->uri->query || '', |
82 | REMOTE_ADDR => '127.0.0.1', |
83 | REMOTE_HOST => 'localhost', |
fbcc39ad |
84 | REQUEST_METHOD => $request->method, |
85 | SERVER_NAME => 'localhost', |
86 | SERVER_PORT => $request->uri->port, |
87 | SERVER_PROTOCOL => 'HTTP/1.1', |
88 | %ENV, |
45374ac6 |
89 | ); |
e646f111 |
90 | |
fbcc39ad |
91 | # Headers |
92 | for my $header ( $request->header_field_names ) { |
93 | my $name = uc $header; |
94 | $name = 'COOKIE' if $name eq 'COOKIES'; |
95 | $name =~ tr/-/_/; |
96 | $name = 'HTTP_' . $name |
4f5ebacd |
97 | unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; |
fbcc39ad |
98 | my $value = $request->header($header); |
99 | if ( exists $ENV{$name} ) { |
100 | $ENV{$name} .= "; $value"; |
101 | } |
102 | else { |
103 | $ENV{$name} = $value; |
104 | } |
105 | } |
106 | |
107 | # STDIN |
108 | local *STDIN; |
109 | my $input = $request->content; |
110 | open STDIN, '<', \$input; |
111 | |
112 | # STDOUT |
113 | local *STDOUT; |
114 | my $output = ''; |
115 | open STDOUT, '>', \$output; |
b26df351 |
116 | |
fbcc39ad |
117 | # Process |
118 | $class->handle_request; |
e646f111 |
119 | |
fbcc39ad |
120 | # Response |
121 | return HTTP::Response->parse($output); |
e646f111 |
122 | } |
123 | |
fbcc39ad |
124 | =item $self->read_chunk($c, $buffer, $length) |
125 | |
126 | =cut |
127 | |
4f5ebacd |
128 | sub read_chunk { shift; shift; *STDIN->read(@_); } |
fbcc39ad |
129 | |
e646f111 |
130 | =back |
131 | |
132 | =head1 SEE ALSO |
133 | |
134 | L<Catalyst>. |
135 | |
fbcc39ad |
136 | =head1 AUTHORS |
137 | |
138 | Sebastian Riedel, <sri@cpan.org> |
139 | |
140 | Christian Hansen, <ch@ngmedia.com> |
e646f111 |
141 | |
fbcc39ad |
142 | Andy Grundman, <andy@hybridized.org> |
e646f111 |
143 | |
144 | =head1 COPYRIGHT |
145 | |
146 | This program is free software, you can redistribute it and/or modify it under |
147 | the same terms as Perl itself. |
148 | |
149 | =cut |
150 | |
151 | 1; |