1 package HTTP::Request::AsCGI;
2 # ABSTRACT: Set up a CGI environment from an HTTP::Request
6 use base 'Class::Accessor::Fast';
14 __PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]);
25 *enviroment = \&environment;
31 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
32 croak(qq/usage: $class->new( \$request [, key => value] )/);
35 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
36 $self->request($request);
37 $self->stdin( IO::File->new_tmpfile );
38 $self->stdout( IO::File->new_tmpfile );
40 my $host = $request->header('Host');
41 my $uri = $request->uri->clone;
42 $uri->scheme('http') unless $uri->scheme;
43 $uri->host('localhost') unless $uri->host;
44 $uri->port(80) unless $uri->port;
45 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
47 $uri = $uri->canonical;
50 GATEWAY_INTERFACE => 'CGI/1.1',
51 HTTP_HOST => $uri->host_port,
52 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
53 PATH_INFO => URI::Escape::uri_unescape($uri->path),
54 QUERY_STRING => $uri->query || '',
56 SERVER_NAME => $uri->host,
57 SERVER_PORT => $uri->port,
58 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
59 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
60 REMOTE_ADDR => '127.0.0.1',
61 REMOTE_HOST => 'localhost',
62 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
63 REQUEST_URI => $uri->path_query, # not in RFC 3875
64 REQUEST_METHOD => $request->method,
68 foreach my $field ( $request->headers->header_field_names ) {
70 my $key = uc("HTTP_$field");
72 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
74 unless ( exists $environment->{$key} ) {
75 $environment->{$key} = $request->headers->header($field);
79 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
80 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
81 $environment->{PATH_INFO} =~ s/^\/+/\//;
84 $self->environment($environment);
92 $self->{restore}->{environment} = {%ENV};
94 binmode( $self->stdin );
96 if ( $self->request->content_length ) {
98 $self->stdin->print($self->request->content)
99 or croak("Can't write request content to stdin handle: $!");
101 $self->stdin->seek(0, SEEK_SET)
102 or croak("Can't seek stdin handle: $!");
105 or croak("Can't flush stdin handle: $!");
108 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
109 or croak("Can't dup stdin: $!");
111 open( STDIN, '<&='. $self->stdin->fileno )
112 or croak("Can't open stdin: $!");
116 if ( $self->stdout ) {
118 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
119 or croak("Can't dup stdout: $!");
121 open( STDOUT, '>&='. $self->stdout->fileno )
122 or croak("Can't open stdout: $!");
124 binmode( $self->stdout );
128 if ( $self->stderr ) {
130 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
131 or croak("Can't dup stderr: $!");
133 open( STDERR, '>&='. $self->stderr->fileno )
134 or croak("Can't open stderr: $!");
136 binmode( $self->stderr );
141 no warnings 'uninitialized';
142 %ENV = %{ $self->environment };
145 if ( $INC{'CGI.pm'} ) {
146 CGI::initialize_globals();
155 my ( $self, $callback ) = @_;
157 return undef unless $self->stdout;
159 seek( $self->stdout, 0, SEEK_SET )
160 or croak("Can't seek stdout handle: $!");
163 while ( my $line = $self->stdout->getline ) {
165 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
168 unless ( defined $headers ) {
169 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
172 unless ( $headers =~ /^HTTP/ ) {
173 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
176 my $response = HTTP::Response->parse($headers);
177 $response->date( time() ) unless $response->date;
179 my $message = $response->message;
180 my $status = $response->header('Status');
182 if ( $message && $message =~ /^(.+)\x0d$/ ) {
183 $response->message($1);
186 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
189 my $message = $2 || HTTP::Status::status_message($code);
191 $response->code($code);
192 $response->message($message);
195 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
197 if ( $response->code == 500 && !$length ) {
199 $response->content( $response->error_as_HTML );
200 $response->content_type('text/html');
207 my $handle = $self->stdout;
209 $response->content( sub {
211 if ( $handle->read( my $buffer, 4096 ) ) {
222 while ( $self->stdout->read( my $buffer, 4096 ) ) {
223 $length += length($buffer);
224 $response->add_content($buffer);
227 if ( $length && !$response->content_length ) {
228 $response->content_length($length);
239 no warnings 'uninitialized';
240 %ENV = %{ $self->{restore}->{environment} };
243 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
244 or croak("Can't restore stdin: $!");
246 sysseek( $self->stdin, 0, SEEK_SET )
247 or croak("Can't seek stdin: $!");
249 if ( $self->{restore}->{stdout} ) {
252 or croak("Can't flush stdout: $!");
254 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
255 or croak("Can't restore stdout: $!");
257 sysseek( $self->stdout, 0, SEEK_SET )
258 or croak("Can't seek stdout: $!");
261 if ( $self->{restore}->{stderr} ) {
264 or croak("Can't flush stderr: $!");
266 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
267 or croak("Can't restore stderr: $!");
269 sysseek( $self->stderr, 0, SEEK_SET )
270 or croak("Can't seek stderr: $!");
280 $self->restore if $self->{setuped} && !$self->{restored};
291 use HTTP::Request::AsCGI;
293 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
297 my $c = HTTP::Request::AsCGI->new($request)->setup;
301 $q->start_html('Hello World'),
302 $q->h1('Hello World'),
305 $stdout = $c->stdout;
307 # environment and descriptors will automatically be restored
308 # when $c is destructed.
311 while ( my $line = $stdout->getline ) {
317 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
323 =item new ( $request [, key => value ] )
325 Constructor. The first argument must be a instance of HTTP::Request, followed
326 by optional pairs of environment key and value.
330 Returns a hashref containing the environment that will be used in setup.
331 Changing the hashref after setup has been called will have no effect.
335 Sets up the environment and descriptors.
339 Restores the environment and descriptors. Can only be called after setup.
343 Returns the request given to constructor.
347 Returns a HTTP::Response. Can only be called after restore.
351 Accessor for handle that will be used for STDIN, must be a real seekable
352 handle with an file descriptor. Defaults to a tempoary IO::File instance.
356 Accessor for handle that will be used for STDOUT, must be a real seekable
357 handle with an file descriptor. Defaults to a tempoary IO::File instance.
361 Accessor for handle that will be used for STDERR, must be a real seekable
362 handle with an file descriptor.
370 =item examples directory in this distribution.
372 =item L<WWW::Mechanize::CGI>
374 =item L<Test::WWW::Mechanize::CGI>
380 Thomas L. Shinnick for his valuable win32 testing.