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 PATH_INFO => $uri->path,
55 QUERY_STRING => $uri->query || '',
57 SERVER_NAME => $uri->host,
58 SERVER_PORT => $uri->port,
59 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
60 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
61 REMOTE_ADDR => '127.0.0.1',
62 REMOTE_HOST => 'localhost',
63 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
64 REQUEST_URI => $uri->path_query, # not in RFC 3875
65 REQUEST_METHOD => $request->method,
69 foreach my $field ( $request->headers->header_field_names ) {
71 my $key = uc("HTTP_$field");
73 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
75 unless ( exists $environment->{$key} ) {
76 $environment->{$key} = $request->headers->header($field);
80 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
81 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
82 $environment->{PATH_INFO} =~ s/^\/+/\//;
85 $self->environment($environment);
93 $self->{restore}->{environment} = {%ENV};
95 binmode( $self->stdin );
97 if ( $self->request->content_length ) {
99 $self->stdin->print($self->request->content)
100 or croak("Can't write request content to stdin handle: $!");
102 $self->stdin->seek(0, SEEK_SET)
103 or croak("Can't seek stdin handle: $!");
106 or croak("Can't flush stdin handle: $!");
109 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
110 or croak("Can't dup stdin: $!");
112 open( STDIN, '<&='. $self->stdin->fileno )
113 or croak("Can't open stdin: $!");
117 if ( $self->stdout ) {
119 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
120 or croak("Can't dup stdout: $!");
122 open( STDOUT, '>&='. $self->stdout->fileno )
123 or croak("Can't open stdout: $!");
125 binmode( $self->stdout );
129 if ( $self->stderr ) {
131 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
132 or croak("Can't dup stderr: $!");
134 open( STDERR, '>&='. $self->stderr->fileno )
135 or croak("Can't open stderr: $!");
137 binmode( $self->stderr );
142 no warnings 'uninitialized';
143 %ENV = %{ $self->environment };
146 if ( $INC{'CGI.pm'} ) {
147 CGI::initialize_globals();
156 my ( $self, $callback ) = @_;
158 return undef unless $self->stdout;
160 seek( $self->stdout, 0, SEEK_SET )
161 or croak("Can't seek stdout handle: $!");
164 while ( my $line = $self->stdout->getline ) {
166 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
169 unless ( defined $headers ) {
170 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
173 unless ( $headers =~ /^HTTP/ ) {
174 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
177 my $response = HTTP::Response->parse($headers);
178 $response->date( time() ) unless $response->date;
180 my $message = $response->message;
181 my $status = $response->header('Status');
183 if ( $message && $message =~ /^(.+)\x0d$/ ) {
184 $response->message($1);
187 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
190 my $message = $2 || HTTP::Status::status_message($code);
192 $response->code($code);
193 $response->message($message);
196 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
198 if ( $response->code == 500 && !$length ) {
200 $response->content( $response->error_as_HTML );
201 $response->content_type('text/html');
208 my $handle = $self->stdout;
210 $response->content( sub {
212 if ( $handle->read( my $buffer, 4096 ) ) {
223 while ( $self->stdout->read( my $buffer, 4096 ) ) {
224 $length += length($buffer);
225 $response->add_content($buffer);
228 if ( $length && !$response->content_length ) {
229 $response->content_length($length);
240 no warnings 'uninitialized';
241 %ENV = %{ $self->{restore}->{environment} };
244 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
245 or croak("Can't restore stdin: $!");
247 sysseek( $self->stdin, 0, SEEK_SET )
248 or croak("Can't seek stdin: $!");
250 if ( $self->{restore}->{stdout} ) {
253 or croak("Can't flush stdout: $!");
255 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
256 or croak("Can't restore stdout: $!");
258 sysseek( $self->stdout, 0, SEEK_SET )
259 or croak("Can't seek stdout: $!");
262 if ( $self->{restore}->{stderr} ) {
265 or croak("Can't flush stderr: $!");
267 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
268 or croak("Can't restore stderr: $!");
270 sysseek( $self->stderr, 0, SEEK_SET )
271 or croak("Can't seek stderr: $!");
281 $self->restore if $self->{setuped} && !$self->{restored};
292 use HTTP::Request::AsCGI;
294 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
298 my $c = HTTP::Request::AsCGI->new($request)->setup;
302 $q->start_html('Hello World'),
303 $q->h1('Hello World'),
306 $stdout = $c->stdout;
308 # environment and descriptors will automatically be restored
309 # when $c is destructed.
312 while ( my $line = $stdout->getline ) {
318 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
324 =item new ( $request [, key => value ] )
326 Constructor. The first argument must be a instance of HTTP::Request, followed
327 by optional pairs of environment key and value.
331 Returns a hashref containing the environment that will be used in setup.
332 Changing the hashref after setup has been called will have no effect.
336 Sets up the environment and descriptors.
340 Restores the environment and descriptors. Can only be called after setup.
344 Returns the request given to constructor.
348 Returns a HTTP::Response. Can only be called after restore.
352 Accessor for handle that will be used for STDIN, must be a real seekable
353 handle with an file descriptor. Defaults to a tempoary IO::File instance.
357 Accessor for handle that will be used for STDOUT, must be a real seekable
358 handle with an file descriptor. Defaults to a tempoary IO::File instance.
362 Accessor for handle that will be used for STDERR, must be a real seekable
363 handle with an file descriptor.
371 =item examples directory in this distribution.
373 =item L<WWW::Mechanize::CGI>
375 =item L<Test::WWW::Mechanize::CGI>
381 Thomas L. Shinnick for his valuable win32 testing.