1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
12 __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
20 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
21 croak(qq/usage: $class->new( \$request [, key => value] )/);
24 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
25 $self->request($request);
26 $self->stdin( IO::File->new_tmpfile );
27 $self->stdout( IO::File->new_tmpfile );
29 my $host = $request->header('Host');
30 my $uri = $request->uri->clone;
31 $uri->scheme('http') unless $uri->scheme;
32 $uri->host('localhost') unless $uri->host;
33 $uri->port(80) unless $uri->port;
34 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
36 $uri = $uri->canonical;
39 GATEWAY_INTERFACE => 'CGI/1.1',
40 HTTP_HOST => $uri->host_port,
41 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
42 PATH_INFO => $uri->path,
43 QUERY_STRING => $uri->query || '',
45 SERVER_NAME => $uri->host,
46 SERVER_PORT => $uri->port,
47 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
48 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
49 REMOTE_ADDR => '127.0.0.1',
50 REMOTE_HOST => 'localhost',
51 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
52 REQUEST_URI => $uri->path_query, # not in RFC 3875
53 REQUEST_METHOD => $request->method,
57 foreach my $field ( $request->headers->header_field_names ) {
59 my $key = uc("HTTP_$field");
61 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
63 unless ( exists $enviroment->{$key} ) {
64 $enviroment->{$key} = $request->headers->header($field);
68 unless ( $enviroment->{SCRIPT_NAME} eq '/' && $enviroment->{PATH_INFO} ) {
69 $enviroment->{PATH_INFO} =~ s/^\Q$enviroment->{SCRIPT_NAME}\E/\//;
70 $enviroment->{PATH_INFO} =~ s/^\/+/\//;
73 $self->enviroment($enviroment);
81 $self->{restore}->{enviroment} = {%ENV};
83 binmode( $self->stdin );
85 if ( $self->request->content_length ) {
87 syswrite( $self->stdin, $self->request->content )
88 or croak("Can't write request content to stdin handle: $!");
90 sysseek( $self->stdin, 0, SEEK_SET )
91 or croak("Can't seek stdin handle: $!");
94 open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
95 or croak("Can't dup stdin: $!");
97 open( STDIN, '<&=', $self->stdin->fileno )
98 or croak("Can't open stdin: $!");
102 if ( $self->stdout ) {
104 open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
105 or croak("Can't dup stdout: $!");
107 open( STDOUT, '>&=', $self->stdout->fileno )
108 or croak("Can't open stdout: $!");
110 binmode( $self->stdout );
114 if ( $self->stderr ) {
116 open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
117 or croak("Can't dup stderr: $!");
119 open( STDERR, '>&=', $self->stderr->fileno )
120 or croak("Can't open stderr: $!");
122 binmode( $self->stderr );
127 no warnings 'uninitialized';
128 %ENV = %{ $self->enviroment };
131 if ( $INC{'CGI.pm'} ) {
132 CGI::initialize_globals();
141 my ( $self, $callback ) = @_;
143 return undef unless $self->stdout;
145 require HTTP::Response;
147 seek( $self->stdout, 0, SEEK_SET )
148 or croak("Can't seek stdout handle: $!");
151 while ( my $line = $self->stdout->getline ) {
153 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
156 unless ( $message =~ /^HTTP/ ) {
157 $message = "HTTP/1.1 200 OK\x0d\x0a" . $message;
160 my $response = HTTP::Response->new;
161 my @headers = split( /\x0d?\x0a/, $message );
162 my $status = shift(@headers);
164 unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
165 croak( "Invalid Status-Line: '$status'" );
168 $response->protocol($1);
170 $response->message($3);
172 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
174 foreach my $header (@headers) {
176 unless( $header =~ s/^($token):[\t ]*// ) {
177 croak( "Invalid header field name : '$header'" );
180 $response->push_header( $1 => $header );
183 if ( my $code = $response->header('Status') ) {
184 $response->code($code);
185 $response->message( HTTP::Status::status_message($code) );
188 $response->headers->date( time() );
191 $response->content( sub {
192 if ( $self->stdout->read( my $buffer, 4096 ) ) {
200 while ( $self->stdout->read( my $buffer, 4096 ) ) {
201 $length += length($buffer);
202 $response->add_content($buffer);
205 if ( $length && !$response->content_length ) {
206 $response->content_length($length);
216 %ENV = %{ $self->{restore}->{enviroment} };
218 open( STDIN, '>&', $self->{restore}->{stdin} )
219 or croak("Can't restore stdin: $!");
221 sysseek( $self->stdin, 0, SEEK_SET )
222 or croak("Can't seek stdin: $!");
224 if ( $self->{restore}->{stdout} ) {
227 or croak("Can't flush stdout: $!");
229 open( STDOUT, '>&', $self->{restore}->{stdout} )
230 or croak("Can't restore stdout: $!");
232 sysseek( $self->stdout, 0, SEEK_SET )
233 or croak("Can't seek stdout: $!");
236 if ( $self->{restore}->{stderr} ) {
239 or croak("Can't flush stderr: $!");
241 open( STDERR, '>&', $self->{restore}->{stderr} )
242 or croak("Can't restore stderr: $!");
244 sysseek( $self->stderr, 0, SEEK_SET )
245 or croak("Can't seek stderr: $!");
255 $self->restore if $self->{setuped} && !$self->{restored};
264 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
270 use HTTP::Request::AsCGI;
272 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
276 my $c = HTTP::Request::AsCGI->new($request)->setup;
280 $q->start_html('Hello World'),
281 $q->h1('Hello World'),
284 $stdout = $c->stdout;
286 # enviroment and descriptors will automatically be restored
287 # when $c is destructed.
290 while ( my $line = $stdout->getline ) {
296 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
302 =item new ( $request [, key => value ] )
304 Contructor, first argument must be a instance of HTTP::Request
305 followed by optional pairs of environment key and value.
309 Returns a hashref containing the environment that will be used in setup.
310 Changing the hashref after setup has been called will have no effect.
314 Setups the environment and descriptors.
318 Restores the enviroment and descriptors. Can only be called after setup.
322 Returns the request given to constructor.
326 Returns a HTTP::Response. Can only be called after restore.
330 Accessor for handle that will be used for STDIN, must be a real seekable
331 handle with an file descriptor. Defaults to a tempoary IO::File instance.
335 Accessor for handle that will be used for STDOUT, must be a real seekable
336 handle with an file descriptor. Defaults to a tempoary IO::File instance.
340 Accessor for handle that will be used for STDERR, must be a real seekable
341 handle with an file descriptor.
349 =item examples directory in this distribution.
351 =item L<WWW::Mechanize::CGI>
353 =item L<Test::WWW::Mechanize::CGI>
359 Thomas L. Shinnick for his valuable win32 testing.
363 Christian Hansen, C<ch@ngmedia.com>
367 This library is free software. You can redistribute it and/or modify
368 it under the same terms as perl itself.