1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
12 __PACKAGE__->mk_accessors(
13 qw[ enviroment request rawhandles 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);
28 my $host = $request->header('Host');
29 my $uri = $request->uri->clone;
30 $uri->scheme('http') unless $uri->scheme;
31 $uri->host('localhost') unless $uri->host;
32 $uri->port(80) unless $uri->port;
33 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
35 $uri = $uri->canonical;
38 GATEWAY_INTERFACE => 'CGI/1.1',
39 HTTP_HOST => $uri->host_port,
40 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
41 PATH_INFO => $uri->path,
42 QUERY_STRING => $uri->query || '',
44 SERVER_NAME => $uri->host,
45 SERVER_PORT => $uri->port,
46 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
47 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
48 REMOTE_ADDR => '127.0.0.1',
49 REMOTE_HOST => 'localhost',
50 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
51 REQUEST_URI => $uri->path_query, # not in RFC 3875
52 REQUEST_METHOD => $request->method,
56 foreach my $field ( $request->headers->header_field_names ) {
58 my $key = uc("HTTP_$field");
60 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
62 unless ( exists $enviroment->{$key} ) {
63 $enviroment->{$key} = $request->headers->header($field);
67 unless ( $enviroment->{SCRIPT_NAME} eq '/' && $enviroment->{PATH_INFO} ) {
68 $enviroment->{PATH_INFO} =~ s/^\Q$enviroment->{SCRIPT_NAME}\E/\//;
69 $enviroment->{PATH_INFO} =~ s/^\/+/\//;
72 $self->enviroment($enviroment);
80 $self->{restore}->{enviroment} = {%ENV};
82 if ( $self->rawhandles ) {
83 $self->stdin( \*STDIN );
84 $self->stdout( \*STDOUT );
87 $self->stdin( IO::File->new_tmpfile );
88 $self->stdout( IO::File->new_tmpfile );
91 binmode( $self->stdin );
93 if ( $self->request->content_length ) {
95 syswrite( $self->stdin, $self->request->content )
96 or croak("Can't write request content to stdin handle: $!");
98 sysseek( $self->stdin, 0, SEEK_SET )
99 or croak("Can't seek stdin handle: $!");
102 unless ( $self->rawhandles ) {
104 open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
105 or croak("Can't dup stdin: $!");
107 open( STDIN, '<&=', $self->stdin->fileno )
108 or croak("Can't open stdin: $!");
112 if ( $self->stdout ) {
114 open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
115 or croak("Can't dup stdout: $!");
117 open( STDOUT, '>&=', $self->stdout->fileno )
118 or croak("Can't open stdout: $!");
120 binmode( $self->stdout );
124 if ( $self->stderr ) {
126 open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
127 or croak("Can't dup stderr: $!");
129 open( STDERR, '>&=', $self->stderr->fileno )
130 or croak("Can't open stderr: $!");
132 binmode( $self->stderr );
139 no warnings 'uninitialized';
140 %ENV = %{ $self->enviroment };
143 if ( $INC{'CGI.pm'} ) {
144 CGI::initialize_globals();
153 my ( $self, $callback ) = @_;
155 return undef unless $self->stdout;
157 require HTTP::Response;
159 seek( $self->stdout, 0, SEEK_SET )
160 or croak("Can't seek stdout handle: $!");
163 while ( my $line = $self->stdout->getline ) {
165 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
168 unless ( $message =~ /^HTTP/ ) {
169 $message = "HTTP/1.1 200 OK\x0d\x0a" . $message;
172 my $response = HTTP::Response->new;
173 my @headers = split( /\x0d?\x0a/, $message );
174 my $status = shift(@headers);
176 unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
177 croak("Invalid Status-Line: '$status'");
180 $response->protocol($1);
182 $response->message($3);
184 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
186 foreach my $header (@headers) {
188 unless ( $header =~ s/^($token):[\t ]*// ) {
189 croak("Invalid header field name : '$header'");
192 $response->push_header( $1 => $header );
195 if ( my $code = $response->header('Status') ) {
196 $response->code($code);
197 $response->message( HTTP::Status::status_message($code) );
200 $response->headers->date( time() );
205 if ( $self->stdout->read( my $buffer, 4096 ) ) {
214 while ( $self->stdout->read( my $buffer, 4096 ) ) {
215 $length += length($buffer);
216 $response->add_content($buffer);
219 if ( $length && !$response->content_length ) {
220 $response->content_length($length);
231 no warnings 'uninitialized';
232 %ENV = %{ $self->{restore}->{enviroment} };
235 unless ( $self->rawhandles ) {
237 open( STDIN, '>&', $self->{restore}->{stdin} )
238 or croak("Can't restore stdin: $!");
240 sysseek( $self->stdin, 0, SEEK_SET )
241 or croak("Can't seek stdin: $!");
243 if ( $self->{restore}->{stdout} ) {
246 or croak("Can't flush stdout: $!");
248 open( STDOUT, '>&', $self->{restore}->{stdout} )
249 or croak("Can't restore stdout: $!");
251 sysseek( $self->stdout, 0, SEEK_SET )
252 or croak("Can't seek stdout: $!");
255 if ( $self->{restore}->{stderr} ) {
258 or croak("Can't flush stderr: $!");
260 open( STDERR, '>&', $self->{restore}->{stderr} )
261 or croak("Can't restore stderr: $!");
263 sysseek( $self->stderr, 0, SEEK_SET )
264 or croak("Can't seek stderr: $!");
276 $self->restore if $self->{setuped} && !$self->{restored};
285 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
291 use HTTP::Request::AsCGI;
293 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
297 my $c = HTTP::Request::AsCGI->new($request)->setup;
301 $q->start_html('Hello World'),
302 $q->h1('Hello World'),
305 $stdout = $c->stdout;
307 # enviroment and descriptors will automatically be restored
308 # when $c is destructed.
311 while ( my $line = $stdout->getline ) {
317 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
323 =item new ( $request [, key => value ] )
325 Contructor, first argument must be a instance of HTTP::Request
326 followed by optional pairs of environment key and value.
330 Returns a hashref containing the environment that will be used in setup.
331 Changing the hashref after setup has been called will have no effect.
335 Setups the environment and descriptors.
339 Don't redefine STDIN/STDOUT/STDERR internally.
343 Restores the enviroment and descriptors. Can only be called after setup.
347 Returns the request given to constructor.
351 Returns a HTTP::Response. Can only be called after restore.
355 Accessor for handle that will be used for STDIN, 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 STDOUT, must be a real seekable
361 handle with an file descriptor. Defaults to a tempoary IO::File instance.
365 Accessor for handle that will be used for STDERR, must be a real seekable
366 handle with an file descriptor.
374 =item examples directory in this distribution.
376 =item L<WWW::Mechanize::CGI>
378 =item L<Test::WWW::Mechanize::CGI>
384 Thomas L. Shinnick for his valuable win32 testing.
388 Christian Hansen, C<ch@ngmedia.com>
392 This library is free software. You can redistribute it and/or modify
393 it under the same terms as perl itself.