1 package HTTP::Request::AsCGI;
2 # ABSTRACT: Set up a CGI environment from an HTTP::Request
6 use base 'Class::Accessor::Fast';
13 __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
19 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
20 croak(qq/usage: $class->new( \$request [, key => value] )/);
23 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
24 $self->request($request);
25 $self->stdin( IO::File->new_tmpfile );
26 $self->stdout( IO::File->new_tmpfile );
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 binmode( $self->stdin );
84 if ( $self->request->content_length ) {
86 $self->stdin->print($self->request->content)
87 or croak("Can't write request content to stdin handle: $!");
89 $self->stdin->seek(0, SEEK_SET)
90 or croak("Can't seek stdin handle: $!");
93 or croak("Can't flush stdin handle: $!");
96 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
97 or croak("Can't dup stdin: $!");
99 open( STDIN, '<&='. $self->stdin->fileno )
100 or croak("Can't open stdin: $!");
104 if ( $self->stdout ) {
106 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
107 or croak("Can't dup stdout: $!");
109 open( STDOUT, '>&='. $self->stdout->fileno )
110 or croak("Can't open stdout: $!");
112 binmode( $self->stdout );
116 if ( $self->stderr ) {
118 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
119 or croak("Can't dup stderr: $!");
121 open( STDERR, '>&='. $self->stderr->fileno )
122 or croak("Can't open stderr: $!");
124 binmode( $self->stderr );
129 no warnings 'uninitialized';
130 %ENV = %{ $self->enviroment };
133 if ( $INC{'CGI.pm'} ) {
134 CGI::initialize_globals();
143 my ( $self, $callback ) = @_;
145 return undef unless $self->stdout;
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 $headers =~ /\x0d?\x0a\x0d?\x0a$/;
156 unless ( defined $headers ) {
157 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
160 unless ( $headers =~ /^HTTP/ ) {
161 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
164 my $response = HTTP::Response->parse($headers);
165 $response->date( time() ) unless $response->date;
167 my $message = $response->message;
168 my $status = $response->header('Status');
170 if ( $message && $message =~ /^(.+)\x0d$/ ) {
171 $response->message($1);
174 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
177 my $message = $2 || HTTP::Status::status_message($code);
179 $response->code($code);
180 $response->message($message);
183 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
185 if ( $response->code == 500 && !$length ) {
187 $response->content( $response->error_as_HTML );
188 $response->content_type('text/html');
195 my $handle = $self->stdout;
197 $response->content( sub {
199 if ( $handle->read( my $buffer, 4096 ) ) {
210 while ( $self->stdout->read( my $buffer, 4096 ) ) {
211 $length += length($buffer);
212 $response->add_content($buffer);
215 if ( $length && !$response->content_length ) {
216 $response->content_length($length);
227 no warnings 'uninitialized';
228 %ENV = %{ $self->{restore}->{enviroment} };
231 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
232 or croak("Can't restore stdin: $!");
234 sysseek( $self->stdin, 0, SEEK_SET )
235 or croak("Can't seek stdin: $!");
237 if ( $self->{restore}->{stdout} ) {
240 or croak("Can't flush stdout: $!");
242 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
243 or croak("Can't restore stdout: $!");
245 sysseek( $self->stdout, 0, SEEK_SET )
246 or croak("Can't seek stdout: $!");
249 if ( $self->{restore}->{stderr} ) {
252 or croak("Can't flush stderr: $!");
254 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
255 or croak("Can't restore stderr: $!");
257 sysseek( $self->stderr, 0, SEEK_SET )
258 or croak("Can't seek stderr: $!");
268 $self->restore if $self->{setuped} && !$self->{restored};
279 use HTTP::Request::AsCGI;
281 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
285 my $c = HTTP::Request::AsCGI->new($request)->setup;
289 $q->start_html('Hello World'),
290 $q->h1('Hello World'),
293 $stdout = $c->stdout;
295 # enviroment and descriptors will automatically be restored
296 # when $c is destructed.
299 while ( my $line = $stdout->getline ) {
305 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
311 =item new ( $request [, key => value ] )
313 Constructor, first argument must be a instance of HTTP::Request
314 followed by optional pairs of environment key and value.
318 Returns a hashref containing the environment that will be used in setup.
319 Changing the hashref after setup has been called will have no effect.
323 Setups the environment and descriptors.
327 Restores the enviroment and descriptors. Can only be called after setup.
331 Returns the request given to constructor.
335 Returns a HTTP::Response. Can only be called after restore.
339 Accessor for handle that will be used for STDIN, must be a real seekable
340 handle with an file descriptor. Defaults to a tempoary IO::File instance.
344 Accessor for handle that will be used for STDOUT, must be a real seekable
345 handle with an file descriptor. Defaults to a tempoary IO::File instance.
349 Accessor for handle that will be used for STDERR, must be a real seekable
350 handle with an file descriptor.
358 =item examples directory in this distribution.
360 =item L<WWW::Mechanize::CGI>
362 =item L<Test::WWW::Mechanize::CGI>
368 Thomas L. Shinnick for his valuable win32 testing.