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->{setuped};
144 return undef unless $self->{restored};
145 return undef unless $self->{restore}->{stdout};
147 require HTTP::Response;
149 seek( $self->stdout, 0, SEEK_SET )
150 or croak("Can't seek stdout handle: $!");
153 while ( my $line = $self->stdout->getline ) {
155 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
158 unless ( $message =~ /^HTTP/ ) {
159 $message = "HTTP/1.1 200 OK\x0d\x0a" . $message;
162 my $response = HTTP::Response->new;
163 my @headers = split( /\x0d?\x0a/, $message );
164 my $status = shift(@headers);
166 unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
167 croak( "Invalid Status-Line: '$status'" );
170 $response->protocol($1);
172 $response->message($3);
174 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
176 foreach my $header (@headers) {
178 unless( $header =~ s/^($token):[\t ]*// ) {
179 croak( "Invalid header field name : '$header'" );
182 $response->push_header( $1 => $header );
185 if ( my $code = $response->header('Status') ) {
186 $response->code($code);
187 $response->message( HTTP::Status::status_message($code) );
190 $response->headers->date( time() );
193 $response->content( sub {
194 if ( $self->stdout->read( my $buffer, 4096 ) ) {
202 while ( $self->stdout->read( my $buffer, 4096 ) ) {
203 $length += length($buffer);
204 $response->add_content($buffer);
207 if ( $length && !$response->content_length ) {
208 $response->content_length($length);
218 %ENV = %{ $self->{restore}->{enviroment} };
220 open( STDIN, '>&', $self->{restore}->{stdin} )
221 or croak("Can't restore stdin: $!");
223 sysseek( $self->stdin, 0, SEEK_SET )
224 or croak("Can't seek stdin: $!");
226 if ( $self->{restore}->{stdout} ) {
229 or croak("Can't flush stdout: $!");
231 open( STDOUT, '>&', $self->{restore}->{stdout} )
232 or croak("Can't restore stdout: $!");
234 sysseek( $self->stdout, 0, SEEK_SET )
235 or croak("Can't seek stdout: $!");
238 if ( $self->{restore}->{stderr} ) {
241 or croak("Can't flush stderr: $!");
243 open( STDERR, '>&', $self->{restore}->{stderr} )
244 or croak("Can't restore stderr: $!");
246 sysseek( $self->stderr, 0, SEEK_SET )
247 or croak("Can't seek stderr: $!");
257 $self->restore if $self->{setuped} && !$self->{restored};
266 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
272 use HTTP::Request::AsCGI;
274 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
278 my $c = HTTP::Request::AsCGI->new($request)->setup;
282 $q->start_html('Hello World'),
283 $q->h1('Hello World'),
286 $stdout = $c->stdout;
288 # enviroment and descriptors will automatically be restored
289 # when $c is destructed.
292 while ( my $line = $stdout->getline ) {
298 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
304 =item new ( $request [, key => value ] )
306 Contructor, first argument must be a instance of HTTP::Request
307 followed by optional pairs of environment key and value.
311 Returns a hashref containing the environment that will be used in setup.
312 Changing the hashref after setup has been called will have no effect.
316 Setups the environment and descriptors.
320 Restores the enviroment and descriptors. Can only be called after setup.
324 Returns the request given to constructor.
328 Returns a HTTP::Response. Can only be called after restore.
332 Accessor for handle that will be used for STDIN, must be a real seekable
333 handle with an file descriptor. Defaults to a tempoary IO::File instance.
337 Accessor for handle that will be used for STDOUT, must be a real seekable
338 handle with an file descriptor. Defaults to a tempoary IO::File instance.
342 Accessor for handle that will be used for STDERR, must be a real seekable
343 handle with an file descriptor.
349 Thomas L. Shinnick for his valuable win32 testing.
353 Christian Hansen, C<ch@ngmedia.com>
357 This library is free software. You can redistribute it and/or modify
358 it under the same terms as perl itself.