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);
217 no warnings 'uninitialized';
218 %ENV = %{ $self->{restore}->{enviroment} };
221 open( STDIN, '>&', $self->{restore}->{stdin} )
222 or croak("Can't restore stdin: $!");
224 sysseek( $self->stdin, 0, SEEK_SET )
225 or croak("Can't seek stdin: $!");
227 if ( $self->{restore}->{stdout} ) {
230 or croak("Can't flush stdout: $!");
232 open( STDOUT, '>&', $self->{restore}->{stdout} )
233 or croak("Can't restore stdout: $!");
235 sysseek( $self->stdout, 0, SEEK_SET )
236 or croak("Can't seek stdout: $!");
239 if ( $self->{restore}->{stderr} ) {
242 or croak("Can't flush stderr: $!");
244 open( STDERR, '>&', $self->{restore}->{stderr} )
245 or croak("Can't restore stderr: $!");
247 sysseek( $self->stderr, 0, SEEK_SET )
248 or croak("Can't seek stderr: $!");
258 $self->restore if $self->{setuped} && !$self->{restored};
267 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
273 use HTTP::Request::AsCGI;
275 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
279 my $c = HTTP::Request::AsCGI->new($request)->setup;
283 $q->start_html('Hello World'),
284 $q->h1('Hello World'),
287 $stdout = $c->stdout;
289 # enviroment and descriptors will automatically be restored
290 # when $c is destructed.
293 while ( my $line = $stdout->getline ) {
299 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
305 =item new ( $request [, key => value ] )
307 Contructor, first argument must be a instance of HTTP::Request
308 followed by optional pairs of environment key and value.
312 Returns a hashref containing the environment that will be used in setup.
313 Changing the hashref after setup has been called will have no effect.
317 Setups the environment and descriptors.
321 Restores the enviroment and descriptors. Can only be called after setup.
325 Returns the request given to constructor.
329 Returns a HTTP::Response. Can only be called after restore.
333 Accessor for handle that will be used for STDIN, must be a real seekable
334 handle with an file descriptor. Defaults to a tempoary IO::File instance.
338 Accessor for handle that will be used for STDOUT, must be a real seekable
339 handle with an file descriptor. Defaults to a tempoary IO::File instance.
343 Accessor for handle that will be used for STDERR, must be a real seekable
344 handle with an file descriptor.
352 =item examples directory in this distribution.
354 =item L<WWW::Mechanize::CGI>
356 =item L<Test::WWW::Mechanize::CGI>
362 Thomas L. Shinnick for his valuable win32 testing.
366 Christian Hansen, C<ch@ngmedia.com>
370 This library is free software. You can redistribute it and/or modify
371 it under the same terms as perl itself.