1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
13 __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
21 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
22 croak(qq/usage: $class->new( \$request [, key => value] )/);
25 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
26 $self->request($request);
27 $self->stdin( IO::File->new_tmpfile );
28 $self->stdout( IO::File->new_tmpfile );
30 my $host = $request->header('Host');
31 my $uri = $request->uri->clone;
32 $uri->scheme('http') unless $uri->scheme;
33 $uri->host('localhost') unless $uri->host;
34 $uri->port(80) unless $uri->port;
35 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
37 $uri = $uri->canonical;
40 GATEWAY_INTERFACE => 'CGI/1.1',
41 HTTP_HOST => $uri->host_port,
42 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
43 PATH_INFO => $uri->path,
44 QUERY_STRING => $uri->query || '',
46 SERVER_NAME => $uri->host,
47 SERVER_PORT => $uri->port,
48 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
49 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
50 REMOTE_ADDR => '127.0.0.1',
51 REMOTE_HOST => 'localhost',
52 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
53 REQUEST_URI => $uri->path_query, # not in RFC 3875
54 REQUEST_METHOD => $request->method,
58 foreach my $field ( $request->headers->header_field_names ) {
60 my $key = uc("HTTP_$field");
62 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
64 unless ( exists $enviroment->{$key} ) {
65 $enviroment->{$key} = $request->headers->header($field);
69 unless ( $enviroment->{SCRIPT_NAME} eq '/' && $enviroment->{PATH_INFO} ) {
70 $enviroment->{PATH_INFO} =~ s/^\Q$enviroment->{SCRIPT_NAME}\E/\//;
71 $enviroment->{PATH_INFO} =~ s/^\/+/\//;
74 $self->enviroment($enviroment);
82 $self->{restore}->{enviroment} = {%ENV};
84 binmode( $self->stdin );
86 if ( $self->request->content_length ) {
88 syswrite( $self->stdin, $self->request->content )
89 or croak("Can't write request content to stdin handle: $!");
91 sysseek( $self->stdin, 0, SEEK_SET )
92 or croak("Can't seek stdin handle: $!");
95 open( $self->{restore}->{stdin}, '<&', STDIN->fileno )
96 or croak("Can't dup stdin: $!");
98 open( STDIN, '<&=', $self->stdin->fileno )
99 or croak("Can't open stdin: $!");
103 if ( $self->stdout ) {
105 open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
106 or croak("Can't dup stdout: $!");
108 open( STDOUT, '>&=', $self->stdout->fileno )
109 or croak("Can't open stdout: $!");
111 binmode( $self->stdout );
115 if ( $self->stderr ) {
117 open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
118 or croak("Can't dup stderr: $!");
120 open( STDERR, '>&=', $self->stderr->fileno )
121 or croak("Can't open stderr: $!");
123 binmode( $self->stderr );
128 no warnings 'uninitialized';
129 %ENV = %{ $self->enviroment };
132 if ( $INC{'CGI.pm'} ) {
133 CGI::initialize_globals();
142 my ( $self, $callback ) = @_;
144 return undef unless $self->stdout;
146 seek( $self->stdout, 0, SEEK_SET )
147 or croak("Can't seek stdout handle: $!");
150 while ( my $line = $self->stdout->getline ) {
152 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
155 unless ( defined $headers ) {
156 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
159 unless ( $headers =~ /^HTTP/ ) {
160 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
163 my $response = HTTP::Response->parse($headers);
164 $response->date( time() ) unless $response->date;
166 my $message = $response->message;
167 my $status = $response->header('Status');
169 if ( $message && $message =~ /^(.+)\x0d$/ ) {
170 $response->message($1);
173 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
176 my $message = $2 || HTTP::Status::status_message($code);
178 $response->code($code);
179 $response->message($message);
182 if ( $response->code == 500 && !$response->content ) {
184 $response->content( $response->error_as_HTML );
185 $response->content_type('text/html');
192 my $handle = $self->stdout;
194 $response->content( sub {
196 if ( $handle->read( my $buffer, 4096 ) ) {
207 while ( $self->stdout->read( my $buffer, 4096 ) ) {
208 $length += length($buffer);
209 $response->add_content($buffer);
212 if ( $length && !$response->content_length ) {
213 $response->content_length($length);
224 no warnings 'uninitialized';
225 %ENV = %{ $self->{restore}->{enviroment} };
228 open( STDIN, '<&', $self->{restore}->{stdin} )
229 or croak("Can't restore stdin: $!");
231 sysseek( $self->stdin, 0, SEEK_SET )
232 or croak("Can't seek stdin: $!");
234 if ( $self->{restore}->{stdout} ) {
237 or croak("Can't flush stdout: $!");
239 open( STDOUT, '>&', $self->{restore}->{stdout} )
240 or croak("Can't restore stdout: $!");
242 sysseek( $self->stdout, 0, SEEK_SET )
243 or croak("Can't seek stdout: $!");
246 if ( $self->{restore}->{stderr} ) {
249 or croak("Can't flush stderr: $!");
251 open( STDERR, '>&', $self->{restore}->{stderr} )
252 or croak("Can't restore stderr: $!");
254 sysseek( $self->stderr, 0, SEEK_SET )
255 or croak("Can't seek stderr: $!");
265 $self->restore if $self->{setuped} && !$self->{restored};
274 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
280 use HTTP::Request::AsCGI;
282 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
286 my $c = HTTP::Request::AsCGI->new($request)->setup;
290 $q->start_html('Hello World'),
291 $q->h1('Hello World'),
294 $stdout = $c->stdout;
296 # enviroment and descriptors will automatically be restored
297 # when $c is destructed.
300 while ( my $line = $stdout->getline ) {
306 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
312 =item new ( $request [, key => value ] )
314 Contructor, first argument must be a instance of HTTP::Request
315 followed by optional pairs of environment key and value.
319 Returns a hashref containing the environment that will be used in setup.
320 Changing the hashref after setup has been called will have no effect.
324 Setups the environment and descriptors.
328 Restores the enviroment and descriptors. Can only be called after setup.
332 Returns the request given to constructor.
336 Returns a HTTP::Response. Can only be called after restore.
340 Accessor for handle that will be used for STDIN, must be a real seekable
341 handle with an file descriptor. Defaults to a tempoary IO::File instance.
345 Accessor for handle that will be used for STDOUT, must be a real seekable
346 handle with an file descriptor. Defaults to a tempoary IO::File instance.
350 Accessor for handle that will be used for STDERR, must be a real seekable
351 handle with an file descriptor.
359 =item examples directory in this distribution.
361 =item L<WWW::Mechanize::CGI>
363 =item L<Test::WWW::Mechanize::CGI>
369 Thomas L. Shinnick for his valuable win32 testing.
373 Christian Hansen, C<ch@ngmedia.com>
377 This library is free software. You can redistribute it and/or modify
378 it under the same terms as perl itself.