1 package HTTP::Request::AsCGI;
2 # ABSTRACT: Set up a CGI environment from an HTTP::Request
6 use base 'Class::Accessor::Fast';
13 __PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]);
24 *enviroment = \&environment;
30 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
31 croak(qq/usage: $class->new( \$request [, key => value] )/);
34 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
35 $self->request($request);
36 $self->stdin( IO::File->new_tmpfile );
37 $self->stdout( IO::File->new_tmpfile );
39 my $host = $request->header('Host');
40 my $uri = $request->uri->clone;
41 $uri->scheme('http') unless $uri->scheme;
42 $uri->host('localhost') unless $uri->host;
43 $uri->port(80) unless $uri->port;
44 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
46 $uri = $uri->canonical;
49 GATEWAY_INTERFACE => 'CGI/1.1',
50 HTTP_HOST => $uri->host_port,
51 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
52 PATH_INFO => $uri->path,
53 QUERY_STRING => $uri->query || '',
55 SERVER_NAME => $uri->host,
56 SERVER_PORT => $uri->port,
57 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
58 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
59 REMOTE_ADDR => '127.0.0.1',
60 REMOTE_HOST => 'localhost',
61 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
62 REQUEST_URI => $uri->path_query, # not in RFC 3875
63 REQUEST_METHOD => $request->method,
67 foreach my $field ( $request->headers->header_field_names ) {
69 my $key = uc("HTTP_$field");
71 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
73 unless ( exists $environment->{$key} ) {
74 $environment->{$key} = $request->headers->header($field);
78 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
79 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
80 $environment->{PATH_INFO} =~ s/^\/+/\//;
83 $self->environment($environment);
91 $self->{restore}->{environment} = {%ENV};
93 binmode( $self->stdin );
95 if ( $self->request->content_length ) {
97 $self->stdin->print($self->request->content)
98 or croak("Can't write request content to stdin handle: $!");
100 $self->stdin->seek(0, SEEK_SET)
101 or croak("Can't seek stdin handle: $!");
104 or croak("Can't flush stdin handle: $!");
107 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
108 or croak("Can't dup stdin: $!");
110 open( STDIN, '<&='. $self->stdin->fileno )
111 or croak("Can't open stdin: $!");
115 if ( $self->stdout ) {
117 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
118 or croak("Can't dup stdout: $!");
120 open( STDOUT, '>&='. $self->stdout->fileno )
121 or croak("Can't open stdout: $!");
123 binmode( $self->stdout );
127 if ( $self->stderr ) {
129 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
130 or croak("Can't dup stderr: $!");
132 open( STDERR, '>&='. $self->stderr->fileno )
133 or croak("Can't open stderr: $!");
135 binmode( $self->stderr );
140 no warnings 'uninitialized';
141 %ENV = %{ $self->environment };
144 if ( $INC{'CGI.pm'} ) {
145 CGI::initialize_globals();
154 my ( $self, $callback ) = @_;
156 return undef unless $self->stdout;
158 seek( $self->stdout, 0, SEEK_SET )
159 or croak("Can't seek stdout handle: $!");
162 while ( my $line = $self->stdout->getline ) {
164 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
167 unless ( defined $headers ) {
168 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
171 unless ( $headers =~ /^HTTP/ ) {
172 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
175 my $response = HTTP::Response->parse($headers);
176 $response->date( time() ) unless $response->date;
178 my $message = $response->message;
179 my $status = $response->header('Status');
181 if ( $message && $message =~ /^(.+)\x0d$/ ) {
182 $response->message($1);
185 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
188 my $message = $2 || HTTP::Status::status_message($code);
190 $response->code($code);
191 $response->message($message);
194 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
196 if ( $response->code == 500 && !$length ) {
198 $response->content( $response->error_as_HTML );
199 $response->content_type('text/html');
206 my $handle = $self->stdout;
208 $response->content( sub {
210 if ( $handle->read( my $buffer, 4096 ) ) {
221 while ( $self->stdout->read( my $buffer, 4096 ) ) {
222 $length += length($buffer);
223 $response->add_content($buffer);
226 if ( $length && !$response->content_length ) {
227 $response->content_length($length);
238 no warnings 'uninitialized';
239 %ENV = %{ $self->{restore}->{environment} };
242 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
243 or croak("Can't restore stdin: $!");
245 sysseek( $self->stdin, 0, SEEK_SET )
246 or croak("Can't seek stdin: $!");
248 if ( $self->{restore}->{stdout} ) {
251 or croak("Can't flush stdout: $!");
253 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
254 or croak("Can't restore stdout: $!");
256 sysseek( $self->stdout, 0, SEEK_SET )
257 or croak("Can't seek stdout: $!");
260 if ( $self->{restore}->{stderr} ) {
263 or croak("Can't flush stderr: $!");
265 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
266 or croak("Can't restore stderr: $!");
268 sysseek( $self->stderr, 0, SEEK_SET )
269 or croak("Can't seek stderr: $!");
279 $self->restore if $self->{setuped} && !$self->{restored};
290 use HTTP::Request::AsCGI;
292 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
296 my $c = HTTP::Request::AsCGI->new($request)->setup;
300 $q->start_html('Hello World'),
301 $q->h1('Hello World'),
304 $stdout = $c->stdout;
306 # environment and descriptors will automatically be restored
307 # when $c is destructed.
310 while ( my $line = $stdout->getline ) {
316 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
322 =item new ( $request [, key => value ] )
324 Constructor, first argument must be a instance of HTTP::Request
325 followed by optional pairs of environment key and value.
329 Returns a hashref containing the environment that will be used in setup.
330 Changing the hashref after setup has been called will have no effect.
334 Setups the environment and descriptors.
338 Restores the environment and descriptors. Can only be called after setup.
342 Returns the request given to constructor.
346 Returns a HTTP::Response. Can only be called after restore.
350 Accessor for handle that will be used for STDIN, must be a real seekable
351 handle with an file descriptor. Defaults to a tempoary IO::File instance.
355 Accessor for handle that will be used for STDOUT, must be a real seekable
356 handle with an file descriptor. Defaults to a tempoary IO::File instance.
360 Accessor for handle that will be used for STDERR, must be a real seekable
361 handle with an file descriptor.
369 =item examples directory in this distribution.
371 =item L<WWW::Mechanize::CGI>
373 =item L<Test::WWW::Mechanize::CGI>
379 Thomas L. Shinnick for his valuable win32 testing.