1 package HTTP::Request::AsCGI;
2 # ABSTRACT: Set up a CGI environment from an HTTP::Request
6 use base 'Class::Accessor::Fast';
17 __PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]);
28 *enviroment = \&environment;
30 my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved;
31 sub _uri_safe_unescape {
33 $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : pack('C', hex($1))/ge;
41 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
42 croak(qq/usage: $class->new( \$request [, key => value] )/);
45 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
46 $self->request($request);
47 $self->stdin( IO::File->new_tmpfile );
48 $self->stdout( IO::File->new_tmpfile );
50 my $host = $request->header('Host');
51 my $uri = $request->uri->clone;
52 $uri->scheme('http') unless $uri->scheme;
53 $uri->host('localhost') unless $uri->host;
54 $uri->port(80) unless $uri->port;
55 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
57 $uri = $uri->canonical;
60 GATEWAY_INTERFACE => 'CGI/1.1',
61 HTTP_HOST => $uri->host_port,
62 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
63 PATH_INFO => $uri->path,
64 QUERY_STRING => $uri->query || '',
66 SERVER_NAME => $uri->host,
67 SERVER_PORT => $uri->port,
68 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
69 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
70 REMOTE_ADDR => '127.0.0.1',
71 REMOTE_HOST => 'localhost',
72 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
73 REQUEST_URI => $uri->path_query, # not in RFC 3875
74 REQUEST_METHOD => $request->method,
78 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
79 # annoying for applications that you can't tell "%2F" vs "/", but
80 # doing the partial decoding then makes it impossible to tell
81 # "%252F" vs "%2F". Encoding everything is more compatible to what
82 # web servers like Apache or lighttpd do, anyways.
83 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
85 foreach my $field ( $request->headers->header_field_names ) {
87 my $key = uc("HTTP_$field");
89 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
91 unless ( exists $environment->{$key} ) {
92 $environment->{$key} = $request->headers->header($field);
96 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
97 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
98 $environment->{PATH_INFO} =~ s/^\/+/\//;
101 $self->environment($environment);
109 $self->{restore}->{environment} = {%ENV};
111 binmode( $self->stdin );
113 if ( $self->request->content_length ) {
115 $self->stdin->print($self->request->content)
116 or croak("Can't write request content to stdin handle: $!");
118 $self->stdin->seek(0, SEEK_SET)
119 or croak("Can't seek stdin handle: $!");
122 or croak("Can't flush stdin handle: $!");
125 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
126 or croak("Can't dup stdin: $!");
128 open( STDIN, '<&='. $self->stdin->fileno )
129 or croak("Can't open stdin: $!");
133 if ( $self->stdout ) {
135 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
136 or croak("Can't dup stdout: $!");
138 open( STDOUT, '>&='. $self->stdout->fileno )
139 or croak("Can't open stdout: $!");
141 binmode( $self->stdout );
145 if ( $self->stderr ) {
147 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
148 or croak("Can't dup stderr: $!");
150 open( STDERR, '>&='. $self->stderr->fileno )
151 or croak("Can't open stderr: $!");
153 binmode( $self->stderr );
158 no warnings 'uninitialized';
159 %ENV = %ENV, %{ $self->environment };
162 if ( $INC{'CGI.pm'} ) {
163 CGI::initialize_globals();
172 my ( $self, $callback ) = @_;
174 return undef unless $self->stdout;
176 seek( $self->stdout, 0, SEEK_SET )
177 or croak("Can't seek stdout handle: $!");
180 while ( my $line = $self->stdout->getline ) {
182 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
185 unless ( defined $headers ) {
186 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
189 unless ( $headers =~ /^HTTP/ ) {
190 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
193 my $response = HTTP::Response->parse($headers);
194 $response->date( time() ) unless $response->date;
196 my $message = $response->message;
197 my $status = $response->header('Status');
199 if ( $message && $message =~ /^(.+)\x0d$/ ) {
200 $response->message($1);
203 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
206 my $message = $2 || HTTP::Status::status_message($code);
208 $response->code($code);
209 $response->message($message);
212 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
214 if ( $response->code == 500 && !$length ) {
216 $response->content( $response->error_as_HTML );
217 $response->content_type('text/html');
224 my $handle = $self->stdout;
226 $response->content( sub {
228 if ( $handle->read( my $buffer, 4096 ) ) {
239 while ( $self->stdout->read( my $buffer, 4096 ) ) {
240 $length += length($buffer);
241 $response->add_content($buffer);
244 if ( $length && !$response->content_length ) {
245 $response->content_length($length);
256 no warnings 'uninitialized';
257 %ENV = %{ $self->{restore}->{environment} };
260 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
261 or croak("Can't restore stdin: $!");
263 sysseek( $self->stdin, 0, SEEK_SET )
264 or croak("Can't seek stdin: $!");
266 if ( $self->{restore}->{stdout} ) {
269 or croak("Can't flush stdout: $!");
271 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
272 or croak("Can't restore stdout: $!");
274 sysseek( $self->stdout, 0, SEEK_SET )
275 or croak("Can't seek stdout: $!");
278 if ( $self->{restore}->{stderr} ) {
281 or croak("Can't flush stderr: $!");
283 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
284 or croak("Can't restore stderr: $!");
286 sysseek( $self->stderr, 0, SEEK_SET )
287 or croak("Can't seek stderr: $!");
297 $self->restore if $self->{setuped} && !$self->{restored};
308 use HTTP::Request::AsCGI;
310 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
314 my $c = HTTP::Request::AsCGI->new($request)->setup;
318 $q->start_html('Hello World'),
319 $q->h1('Hello World'),
322 $stdout = $c->stdout;
324 # environment and descriptors will automatically be restored
325 # when $c is destructed.
328 while ( my $line = $stdout->getline ) {
334 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
340 =item new ( $request [, key => value ] )
342 Constructor. The first argument must be a instance of HTTP::Request, followed
343 by optional pairs of environment key and value.
347 Returns a hashref containing the environment that will be used in setup.
348 Changing the hashref after setup has been called will have no effect.
352 Sets up the environment and descriptors.
356 Restores the environment and descriptors. Can only be called after setup.
360 Returns the request given to constructor.
364 Returns a HTTP::Response. Can only be called after restore.
368 Accessor for handle that will be used for STDIN, must be a real seekable
369 handle with an file descriptor. Defaults to a tempoary IO::File instance.
373 Accessor for handle that will be used for STDOUT, must be a real seekable
374 handle with an file descriptor. Defaults to a tempoary IO::File instance.
378 Accessor for handle that will be used for STDERR, must be a real seekable
379 handle with an file descriptor.
387 =item examples directory in this distribution.
389 =item L<WWW::Mechanize::CGI>
391 =item L<Test::WWW::Mechanize::CGI>
397 Thomas L. Shinnick for his valuable win32 testing.