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] )/);
28 stdin => IO::File->new_tmpfile,
29 stdout => IO::File->new_tmpfile
32 my $host = $request->header('Host');
33 my $uri = $request->uri->clone;
34 $uri->scheme('http') unless $uri->scheme;
35 $uri->host('localhost') unless $uri->host;
36 $uri->port(80) unless $uri->port;
37 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
39 $self->{enviroment} = {
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 ) {
62 $key = 'HTTP_' . $key unless $field =~ /^Content-(Length|Type)$/;
64 unless ( exists $self->{enviroment}->{$key} ) {
65 $self->{enviroment}->{$key} = $request->headers->header($field);
69 return $class->SUPER::new($self);
75 $self->{restore}->{enviroment} = {%ENV};
77 open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
78 or croak("Can't dup stdin: $!");
80 open( STDIN, '<&=', $self->stdin->fileno )
81 or croak("Can't open stdin: $!");
83 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 if ( $self->stdout ) {
97 open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
98 or croak("Can't dup stdout: $!");
100 open( STDOUT, '>&=', $self->stdout->fileno )
101 or croak("Can't open stdout: $!");
103 binmode( $self->stdout );
107 if ( $self->stderr ) {
109 open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
110 or croak("Can't dup stderr: $!");
112 open( STDERR, '>&=', $self->stderr->fileno )
113 or croak("Can't open stderr: $!");
115 binmode( $self->stderr );
120 no warnings 'uninitialized';
121 %ENV = %{ $self->enviroment };
124 if ( $INC{'CGI.pm'} ) {
125 CGI::initialize_globals();
134 my ( $self, $callback ) = @_;
136 return undef unless $self->{setuped};
137 return undef unless $self->{restored};
138 return undef unless $self->{restore}->{stdout};
140 require HTTP::Response;
142 seek( $self->stdout, 0, SEEK_SET )
143 or croak("Can't seek stdout handle: $!");
146 while ( my $line = $self->stdout->getline ) {
148 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
151 unless ( $message =~ /^HTTP/ ) {
152 $message = "HTTP/1.1 200 OK\x0d\x0a" . $message;
155 my $response = HTTP::Response->new;
156 my @headers = split( /\x0d?\x0a/, $message );
157 my $status = shift(@headers);
159 unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
160 croak( "Invalid Status-Line: '$status'" );
163 $response->protocol($1);
165 $response->message($3);
167 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
169 foreach my $header (@headers) {
171 unless( $header =~ s/^($token):[\t ]*// ) {
172 croak( "Invalid header field name : '$header'" );
175 $response->push_header( $1 => $header );
178 if ( my $code = $response->header('Status') ) {
179 $response->code($code);
180 $response->message( HTTP::Status::status_message($code) );
183 $response->headers->date( time() );
186 $response->content( sub {
187 if ( $self->stdout->read( my $buffer, 4096 ) ) {
195 while ( $self->stdout->read( my $buffer, 4096 ) ) {
196 $length += length($buffer);
197 $response->add_content($buffer);
200 if ( $length && !$response->content_length ) {
201 $response->content_length($length);
211 %ENV = %{ $self->{restore}->{enviroment} };
213 open( STDIN, '>&', $self->{restore}->{stdin} )
214 or croak("Can't restore stdin: $!");
216 sysseek( $self->stdin, 0, SEEK_SET )
217 or croak("Can't seek stdin: $!");
219 if ( $self->{restore}->{stdout} ) {
222 or croak("Can't flush stdout: $!");
224 open( STDOUT, '>&', $self->{restore}->{stdout} )
225 or croak("Can't restore stdout: $!");
227 sysseek( $self->stdout, 0, SEEK_SET )
228 or croak("Can't seek stdout: $!");
231 if ( $self->{restore}->{stderr} ) {
234 or croak("Can't flush stderr: $!");
236 open( STDERR, '>&', $self->{restore}->{stderr} )
237 or croak("Can't restore stderr: $!");
239 sysseek( $self->stderr, 0, SEEK_SET )
240 or croak("Can't seek stderr: $!");
250 $self->restore if $self->{setuped} && !$self->{restored};
259 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
265 use HTTP::Request::AsCGI;
267 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
271 my $c = HTTP::Request::AsCGI->new($request)->setup;
275 $q->start_html('Hello World'),
276 $q->h1('Hello World'),
279 $stdout = $c->stdout;
281 # enviroment and descriptors will automatically be restored
282 # when $c is destructed.
285 while ( my $line = $stdout->getline ) {
291 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
297 =item new ( $request [, key => value ] )
299 Contructor, first argument must be a instance of HTTP::Request
300 followed by optional pairs of environment keys and values.
304 Returns a hashref containing the environment that will be used in setup.
305 Changing the hashref after setup has been called will have no effect.
309 Setups the environment and descriptors.
313 Restores the enviroment and descriptors. Can only be called after setup.
317 Returns the request given to constructor.
321 Returns a HTTP::Response. Can only be called after restore.
325 Accessor for handle that will be used for STDIN, must be a real seekable
326 handle with an file descriptor. Defaults to a tempoary IO::File instance.
330 Accessor for handle that will be used for STDOUT, 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 STDERR, must be a real seekable
336 handle with an file descriptor.
342 Thomas L. Shinnick for his valuable win32 testing.
346 Christian Hansen, C<ch@ngmedia.com>
350 This library is free software. You can redistribute it and/or modify
351 it under the same terms as perl itself.