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 ]);
21 *enviroment = \&environment;
23 my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved;
24 sub _uri_safe_unescape {
26 $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : pack('C', hex($1))/ge;
34 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
35 croak(qq/usage: $class->new( \$request [, key => value] )/);
38 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
39 $self->request($request);
40 $self->stdin( IO::File->new_tmpfile );
41 $self->stdout( IO::File->new_tmpfile );
43 my $host = $request->header('Host');
44 my $uri = $request->uri->clone;
45 $uri->scheme('http') unless $uri->scheme;
46 $uri->host('localhost') unless $uri->host;
47 $uri->port(80) unless $uri->port;
48 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
50 $uri = $uri->canonical;
53 GATEWAY_INTERFACE => 'CGI/1.1',
54 HTTP_HOST => $uri->host_port,
55 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
56 PATH_INFO => $uri->path,
57 QUERY_STRING => $uri->query || '',
59 SERVER_NAME => $uri->host,
60 SERVER_PORT => $uri->port,
61 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
62 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
63 REMOTE_ADDR => '127.0.0.1',
64 REMOTE_HOST => 'localhost',
65 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
66 REQUEST_URI => $uri->path_query, # not in RFC 3875
67 REQUEST_METHOD => $request->method,
71 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
72 # annoying for applications that you can't tell "%2F" vs "/", but
73 # doing the partial decoding then makes it impossible to tell
74 # "%252F" vs "%2F". Encoding everything is more compatible to what
75 # web servers like Apache or lighttpd do, anyways.
76 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
78 foreach my $field ( $request->headers->header_field_names ) {
80 my $key = uc("HTTP_$field");
82 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
84 unless ( exists $environment->{$key} ) {
85 $environment->{$key} = $request->headers->header($field);
89 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
90 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
91 $environment->{PATH_INFO} =~ s/^\/+/\//;
94 $self->environment($environment);
102 $self->{restore}->{environment} = {%ENV};
104 binmode( $self->stdin );
106 if ( $self->request->content_length ) {
108 $self->stdin->print($self->request->content)
109 or croak("Can't write request content to stdin handle: $!");
111 $self->stdin->seek(0, SEEK_SET)
112 or croak("Can't seek stdin handle: $!");
115 or croak("Can't flush stdin handle: $!");
118 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
119 or croak("Can't dup stdin: $!");
121 open( STDIN, '<&='. $self->stdin->fileno )
122 or croak("Can't open stdin: $!");
126 if ( $self->stdout ) {
128 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
129 or croak("Can't dup stdout: $!");
131 open( STDOUT, '>&='. $self->stdout->fileno )
132 or croak("Can't open stdout: $!");
134 binmode( $self->stdout );
138 if ( $self->stderr ) {
140 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
141 or croak("Can't dup stderr: $!");
143 open( STDERR, '>&='. $self->stderr->fileno )
144 or croak("Can't open stderr: $!");
146 binmode( $self->stderr );
151 no warnings 'uninitialized';
152 %ENV = %{ $self->environment };
155 if ( $INC{'CGI.pm'} ) {
156 CGI::initialize_globals();
165 my ( $self, $callback ) = @_;
167 return undef unless $self->stdout;
169 seek( $self->stdout, 0, SEEK_SET )
170 or croak("Can't seek stdout handle: $!");
173 while ( my $line = $self->stdout->getline ) {
175 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
178 unless ( defined $headers ) {
179 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
182 unless ( $headers =~ /^HTTP/ ) {
183 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
186 my $response = HTTP::Response->parse($headers);
187 $response->date( time() ) unless $response->date;
189 my $message = $response->message;
190 my $status = $response->header('Status');
192 if ( $message && $message =~ /^(.+)\x0d$/ ) {
193 $response->message($1);
196 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
199 my $message = $2 || HTTP::Status::status_message($code);
201 $response->code($code);
202 $response->message($message);
205 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
207 if ( $response->code == 500 && !$length ) {
209 $response->content( $response->error_as_HTML );
210 $response->content_type('text/html');
217 my $handle = $self->stdout;
219 $response->content( sub {
221 if ( $handle->read( my $buffer, 4096 ) ) {
232 while ( $self->stdout->read( my $buffer, 4096 ) ) {
233 $length += length($buffer);
234 $response->add_content($buffer);
237 if ( $length && !$response->content_length ) {
238 $response->content_length($length);
249 no warnings 'uninitialized';
250 %ENV = %{ $self->{restore}->{environment} };
253 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
254 or croak("Can't restore stdin: $!");
256 sysseek( $self->stdin, 0, SEEK_SET )
257 or croak("Can't seek stdin: $!");
259 if ( $self->{restore}->{stdout} ) {
262 or croak("Can't flush stdout: $!");
264 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
265 or croak("Can't restore stdout: $!");
267 sysseek( $self->stdout, 0, SEEK_SET )
268 or croak("Can't seek stdout: $!");
271 if ( $self->{restore}->{stderr} ) {
274 or croak("Can't flush stderr: $!");
276 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
277 or croak("Can't restore stderr: $!");
279 sysseek( $self->stderr, 0, SEEK_SET )
280 or croak("Can't seek stderr: $!");
290 $self->restore if $self->{setuped} && !$self->{restored};
302 HTTP::Request::AsCGI - Set up a CGI environment from an HTTP::Request
320 use HTTP::Request::AsCGI;
322 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
326 my $c = HTTP::Request::AsCGI->new($request)->setup;
330 $q->start_html('Hello World'),
331 $q->h1('Hello World'),
334 $stdout = $c->stdout;
336 # environment and descriptors will automatically be restored
337 # when $c is destructed.
340 while ( my $line = $stdout->getline ) {
346 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
352 =item new ( $request [, key => value ] )
354 Constructor. The first argument must be a instance of HTTP::Request, followed
355 by optional pairs of environment key and value.
359 Returns a hashref containing the environment that will be used in setup.
360 Changing the hashref after setup has been called will have no effect.
364 Sets up the environment and descriptors.
368 Restores the environment and descriptors. Can only be called after setup.
372 Returns the request given to constructor.
376 Returns a HTTP::Response. Can only be called after restore.
380 Accessor for handle that will be used for STDIN, must be a real seekable
381 handle with an file descriptor. Defaults to a tempoary IO::File instance.
385 Accessor for handle that will be used for STDOUT, must be a real seekable
386 handle with an file descriptor. Defaults to a tempoary IO::File instance.
390 Accessor for handle that will be used for STDERR, must be a real seekable
391 handle with an file descriptor.
399 =item examples directory in this distribution.
401 =item L<WWW::Mechanize::CGI>
403 =item L<Test::WWW::Mechanize::CGI>
409 Thomas L. Shinnick for his valuable win32 testing.
415 Christian Hansen <ch@ngmedia.com>
416 Hans Dieter Pearcey <hdp@cpan.org>
418 =head1 COPYRIGHT AND LICENSE
420 This software is copyright (c) 2009 by Christian Hansen <ch@ngmedia.com>.
422 This is free software; you can redistribute it and/or modify it under
423 the same terms as perl itself.