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 # Get it before canonicalized so REQUEST_URI can be as raw as possible
58 my $request_uri = $uri->path_query;
60 $uri = $uri->canonical;
63 GATEWAY_INTERFACE => 'CGI/1.1',
64 HTTP_HOST => $uri->host_port,
65 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
66 PATH_INFO => $uri->path,
67 QUERY_STRING => $uri->query || '',
69 SERVER_NAME => $uri->host,
70 SERVER_PORT => $uri->port,
71 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
72 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
73 REMOTE_ADDR => '127.0.0.1',
74 REMOTE_HOST => 'localhost',
75 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
76 REQUEST_URI => $request_uri, # not in RFC 3875
77 REQUEST_METHOD => $request->method,
81 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
82 # annoying for applications that you can't tell "%2F" vs "/", but
83 # doing the partial decoding then makes it impossible to tell
84 # "%252F" vs "%2F". Encoding everything is more compatible to what
85 # web servers like Apache or lighttpd do, anyways.
86 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
88 foreach my $field ( $request->headers->header_field_names ) {
90 my $key = uc("HTTP_$field");
92 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
94 unless ( exists $environment->{$key} ) {
95 $environment->{$key} = $request->headers->header($field);
99 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
100 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
101 $environment->{PATH_INFO} =~ s/^\/+/\//;
104 $self->environment($environment);
112 $self->{restore}->{environment} = {%ENV};
114 binmode( $self->stdin );
116 if ( $self->request->content_length ) {
118 $self->stdin->print($self->request->content)
119 or croak("Can't write request content to stdin handle: $!");
121 $self->stdin->seek(0, SEEK_SET)
122 or croak("Can't seek stdin handle: $!");
125 or croak("Can't flush stdin handle: $!");
128 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
129 or croak("Can't dup stdin: $!");
131 open( STDIN, '<&='. $self->stdin->fileno )
132 or croak("Can't open stdin: $!");
136 if ( $self->stdout ) {
138 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
139 or croak("Can't dup stdout: $!");
141 open( STDOUT, '>&='. $self->stdout->fileno )
142 or croak("Can't open stdout: $!");
144 binmode( $self->stdout );
148 if ( $self->stderr ) {
150 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
151 or croak("Can't dup stderr: $!");
153 open( STDERR, '>&='. $self->stderr->fileno )
154 or croak("Can't open stderr: $!");
156 binmode( $self->stderr );
161 no warnings 'uninitialized';
162 %ENV = (%ENV, %{ $self->environment });
165 if ( $INC{'CGI.pm'} ) {
166 CGI::initialize_globals();
175 my ( $self, $callback ) = @_;
177 return undef unless $self->stdout;
179 seek( $self->stdout, 0, SEEK_SET )
180 or croak("Can't seek stdout handle: $!");
183 while ( my $line = $self->stdout->getline ) {
185 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
188 unless ( defined $headers ) {
189 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
192 unless ( $headers =~ /^HTTP/ ) {
193 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
196 my $response = HTTP::Response->parse($headers);
197 $response->date( time() ) unless $response->date;
199 my $message = $response->message;
200 my $status = $response->header('Status');
202 if ( $message && $message =~ /^(.+)\x0d$/ ) {
203 $response->message($1);
206 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
209 my $message = $2 || HTTP::Status::status_message($code);
211 $response->code($code);
212 $response->message($message);
215 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
217 if ( $response->code == 500 && !$length ) {
219 $response->content( $response->error_as_HTML );
220 $response->content_type('text/html');
227 my $handle = $self->stdout;
229 $response->content( sub {
231 if ( $handle->read( my $buffer, 4096 ) ) {
242 while ( $self->stdout->read( my $buffer, 4096 ) ) {
243 $length += length($buffer);
244 $response->add_content($buffer);
247 if ( $length && !$response->content_length ) {
248 $response->content_length($length);
259 no warnings 'uninitialized';
260 %ENV = %{ $self->{restore}->{environment} };
263 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
264 or croak("Can't restore stdin: $!");
266 sysseek( $self->stdin, 0, SEEK_SET )
267 or croak("Can't seek stdin: $!");
269 if ( $self->{restore}->{stdout} ) {
272 or croak("Can't flush stdout: $!");
274 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
275 or croak("Can't restore stdout: $!");
277 sysseek( $self->stdout, 0, SEEK_SET )
278 or croak("Can't seek stdout: $!");
281 if ( $self->{restore}->{stderr} ) {
284 or croak("Can't flush stderr: $!");
286 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
287 or croak("Can't restore stderr: $!");
289 sysseek( $self->stderr, 0, SEEK_SET )
290 or croak("Can't seek stderr: $!");
300 $self->restore if $self->{setuped} && !$self->{restored};
311 use HTTP::Request::AsCGI;
313 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
317 my $c = HTTP::Request::AsCGI->new($request)->setup;
321 $q->start_html('Hello World'),
322 $q->h1('Hello World'),
325 $stdout = $c->stdout;
327 # environment and descriptors will automatically be restored
328 # when $c is destructed.
331 while ( my $line = $stdout->getline ) {
337 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
343 =item new ( $request [, key => value ] )
345 Constructor. The first argument must be a instance of HTTP::Request, followed
346 by optional pairs of environment key and value.
350 Returns a hashref containing the environment that will be used in setup.
351 Changing the hashref after setup has been called will have no effect.
355 Sets up the environment and descriptors.
359 Restores the environment and descriptors. Can only be called after setup.
363 Returns the request given to constructor.
367 Returns a HTTP::Response. Can only be called after restore.
371 Accessor for handle that will be used for STDIN, must be a real seekable
372 handle with an file descriptor. Defaults to a tempoary IO::File instance.
376 Accessor for handle that will be used for STDOUT, must be a real seekable
377 handle with an file descriptor. Defaults to a tempoary IO::File instance.
381 Accessor for handle that will be used for STDERR, must be a real seekable
382 handle with an file descriptor.
390 =item examples directory in this distribution.
392 =item L<WWW::Mechanize::CGI>
394 =item L<Test::WWW::Mechanize::CGI>
400 Thomas L. Shinnick for his valuable win32 testing.