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 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
184 if ( $response->code == 500 && !$length ) {
186 $response->content( $response->error_as_HTML );
187 $response->content_type('text/html');
194 my $handle = $self->stdout;
196 $response->content( sub {
198 if ( $handle->read( my $buffer, 4096 ) ) {
209 while ( $self->stdout->read( my $buffer, 4096 ) ) {
210 $length += length($buffer);
211 $response->add_content($buffer);
214 if ( $length && !$response->content_length ) {
215 $response->content_length($length);
226 no warnings 'uninitialized';
227 %ENV = %{ $self->{restore}->{enviroment} };
230 open( STDIN, '<&', $self->{restore}->{stdin} )
231 or croak("Can't restore stdin: $!");
233 sysseek( $self->stdin, 0, SEEK_SET )
234 or croak("Can't seek stdin: $!");
236 if ( $self->{restore}->{stdout} ) {
239 or croak("Can't flush stdout: $!");
241 open( STDOUT, '>&', $self->{restore}->{stdout} )
242 or croak("Can't restore stdout: $!");
244 sysseek( $self->stdout, 0, SEEK_SET )
245 or croak("Can't seek stdout: $!");
248 if ( $self->{restore}->{stderr} ) {
251 or croak("Can't flush stderr: $!");
253 open( STDERR, '>&', $self->{restore}->{stderr} )
254 or croak("Can't restore stderr: $!");
256 sysseek( $self->stderr, 0, SEEK_SET )
257 or croak("Can't seek stderr: $!");
267 $self->restore if $self->{setuped} && !$self->{restored};
276 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
282 use HTTP::Request::AsCGI;
284 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
288 my $c = HTTP::Request::AsCGI->new($request)->setup;
292 $q->start_html('Hello World'),
293 $q->h1('Hello World'),
296 $stdout = $c->stdout;
298 # enviroment and descriptors will automatically be restored
299 # when $c is destructed.
302 while ( my $line = $stdout->getline ) {
308 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
314 =item new ( $request [, key => value ] )
316 Contructor, first argument must be a instance of HTTP::Request
317 followed by optional pairs of environment key and value.
321 Returns a hashref containing the environment that will be used in setup.
322 Changing the hashref after setup has been called will have no effect.
326 Setups the environment and descriptors.
330 Restores the enviroment and descriptors. Can only be called after setup.
334 Returns the request given to constructor.
338 Returns a HTTP::Response. Can only be called after restore.
342 Accessor for handle that will be used for STDIN, must be a real seekable
343 handle with an file descriptor. Defaults to a tempoary IO::File instance.
347 Accessor for handle that will be used for STDOUT, must be a real seekable
348 handle with an file descriptor. Defaults to a tempoary IO::File instance.
352 Accessor for handle that will be used for STDERR, must be a real seekable
353 handle with an file descriptor.
361 =item examples directory in this distribution.
363 =item L<WWW::Mechanize::CGI>
365 =item L<Test::WWW::Mechanize::CGI>
371 Thomas L. Shinnick for his valuable win32 testing.
375 Christian Hansen, C<ch@ngmedia.com>
379 This library is free software. You can redistribute it and/or modify
380 it under the same terms as perl itself.