1 package HTTP::Request::AsCGI;
2 # ABSTRACT: Set up a CGI environment from an HTTP::Request
6 use base 'Class::Accessor::Fast';
15 __PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]);
26 *enviroment = \&environment;
28 my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved;
29 sub _uri_safe_unescape {
31 $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : chr(hex($1))/ge;
39 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
40 croak(qq/usage: $class->new( \$request [, key => value] )/);
43 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
44 $self->request($request);
45 $self->stdin( IO::File->new_tmpfile );
46 $self->stdout( IO::File->new_tmpfile );
48 my $host = $request->header('Host');
49 my $uri = $request->uri->clone;
50 $uri->scheme('http') unless $uri->scheme;
51 $uri->host('localhost') unless $uri->host;
52 $uri->port(80) unless $uri->port;
53 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
55 $uri = $uri->canonical;
58 GATEWAY_INTERFACE => 'CGI/1.1',
59 HTTP_HOST => $uri->host_port,
60 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
61 PATH_INFO => _uri_safe_unescape($uri->path),
62 QUERY_STRING => $uri->query || '',
64 SERVER_NAME => $uri->host,
65 SERVER_PORT => $uri->port,
66 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
67 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
68 REMOTE_ADDR => '127.0.0.1',
69 REMOTE_HOST => 'localhost',
70 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
71 REQUEST_URI => $uri->path_query, # not in RFC 3875
72 REQUEST_METHOD => $request->method,
76 foreach my $field ( $request->headers->header_field_names ) {
78 my $key = uc("HTTP_$field");
80 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
82 unless ( exists $environment->{$key} ) {
83 $environment->{$key} = $request->headers->header($field);
87 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
88 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
89 $environment->{PATH_INFO} =~ s/^\/+/\//;
92 $self->environment($environment);
100 $self->{restore}->{environment} = {%ENV};
102 binmode( $self->stdin );
104 if ( $self->request->content_length ) {
106 $self->stdin->print($self->request->content)
107 or croak("Can't write request content to stdin handle: $!");
109 $self->stdin->seek(0, SEEK_SET)
110 or croak("Can't seek stdin handle: $!");
113 or croak("Can't flush stdin handle: $!");
116 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
117 or croak("Can't dup stdin: $!");
119 open( STDIN, '<&='. $self->stdin->fileno )
120 or croak("Can't open stdin: $!");
124 if ( $self->stdout ) {
126 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
127 or croak("Can't dup stdout: $!");
129 open( STDOUT, '>&='. $self->stdout->fileno )
130 or croak("Can't open stdout: $!");
132 binmode( $self->stdout );
136 if ( $self->stderr ) {
138 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
139 or croak("Can't dup stderr: $!");
141 open( STDERR, '>&='. $self->stderr->fileno )
142 or croak("Can't open stderr: $!");
144 binmode( $self->stderr );
149 no warnings 'uninitialized';
150 %ENV = %{ $self->environment };
153 if ( $INC{'CGI.pm'} ) {
154 CGI::initialize_globals();
163 my ( $self, $callback ) = @_;
165 return undef unless $self->stdout;
167 seek( $self->stdout, 0, SEEK_SET )
168 or croak("Can't seek stdout handle: $!");
171 while ( my $line = $self->stdout->getline ) {
173 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
176 unless ( defined $headers ) {
177 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
180 unless ( $headers =~ /^HTTP/ ) {
181 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
184 my $response = HTTP::Response->parse($headers);
185 $response->date( time() ) unless $response->date;
187 my $message = $response->message;
188 my $status = $response->header('Status');
190 if ( $message && $message =~ /^(.+)\x0d$/ ) {
191 $response->message($1);
194 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
197 my $message = $2 || HTTP::Status::status_message($code);
199 $response->code($code);
200 $response->message($message);
203 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
205 if ( $response->code == 500 && !$length ) {
207 $response->content( $response->error_as_HTML );
208 $response->content_type('text/html');
215 my $handle = $self->stdout;
217 $response->content( sub {
219 if ( $handle->read( my $buffer, 4096 ) ) {
230 while ( $self->stdout->read( my $buffer, 4096 ) ) {
231 $length += length($buffer);
232 $response->add_content($buffer);
235 if ( $length && !$response->content_length ) {
236 $response->content_length($length);
247 no warnings 'uninitialized';
248 %ENV = %{ $self->{restore}->{environment} };
251 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
252 or croak("Can't restore stdin: $!");
254 sysseek( $self->stdin, 0, SEEK_SET )
255 or croak("Can't seek stdin: $!");
257 if ( $self->{restore}->{stdout} ) {
260 or croak("Can't flush stdout: $!");
262 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
263 or croak("Can't restore stdout: $!");
265 sysseek( $self->stdout, 0, SEEK_SET )
266 or croak("Can't seek stdout: $!");
269 if ( $self->{restore}->{stderr} ) {
272 or croak("Can't flush stderr: $!");
274 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
275 or croak("Can't restore stderr: $!");
277 sysseek( $self->stderr, 0, SEEK_SET )
278 or croak("Can't seek stderr: $!");
288 $self->restore if $self->{setuped} && !$self->{restored};
299 use HTTP::Request::AsCGI;
301 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
305 my $c = HTTP::Request::AsCGI->new($request)->setup;
309 $q->start_html('Hello World'),
310 $q->h1('Hello World'),
313 $stdout = $c->stdout;
315 # environment and descriptors will automatically be restored
316 # when $c is destructed.
319 while ( my $line = $stdout->getline ) {
325 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
331 =item new ( $request [, key => value ] )
333 Constructor. The first argument must be a instance of HTTP::Request, followed
334 by optional pairs of environment key and value.
338 Returns a hashref containing the environment that will be used in setup.
339 Changing the hashref after setup has been called will have no effect.
343 Sets up the environment and descriptors.
347 Restores the environment and descriptors. Can only be called after setup.
351 Returns the request given to constructor.
355 Returns a HTTP::Response. Can only be called after restore.
359 Accessor for handle that will be used for STDIN, must be a real seekable
360 handle with an file descriptor. Defaults to a tempoary IO::File instance.
364 Accessor for handle that will be used for STDOUT, must be a real seekable
365 handle with an file descriptor. Defaults to a tempoary IO::File instance.
369 Accessor for handle that will be used for STDERR, must be a real seekable
370 handle with an file descriptor.
378 =item examples directory in this distribution.
380 =item L<WWW::Mechanize::CGI>
382 =item L<Test::WWW::Mechanize::CGI>
388 Thomas L. Shinnick for his valuable win32 testing.