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 $environment->{PATH_INFO} = _uri_safe_unescape($environment->{PATH_INFO});
80 foreach my $field ( $request->headers->header_field_names ) {
82 my $key = uc("HTTP_$field");
84 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
86 unless ( exists $environment->{$key} ) {
87 $environment->{$key} = $request->headers->header($field);
91 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
92 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
93 $environment->{PATH_INFO} =~ s/^\/+/\//;
96 $self->environment($environment);
104 $self->{restore}->{environment} = {%ENV};
106 binmode( $self->stdin );
108 if ( $self->request->content_length ) {
110 $self->stdin->print($self->request->content)
111 or croak("Can't write request content to stdin handle: $!");
113 $self->stdin->seek(0, SEEK_SET)
114 or croak("Can't seek stdin handle: $!");
117 or croak("Can't flush stdin handle: $!");
120 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
121 or croak("Can't dup stdin: $!");
123 open( STDIN, '<&='. $self->stdin->fileno )
124 or croak("Can't open stdin: $!");
128 if ( $self->stdout ) {
130 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
131 or croak("Can't dup stdout: $!");
133 open( STDOUT, '>&='. $self->stdout->fileno )
134 or croak("Can't open stdout: $!");
136 binmode( $self->stdout );
140 if ( $self->stderr ) {
142 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
143 or croak("Can't dup stderr: $!");
145 open( STDERR, '>&='. $self->stderr->fileno )
146 or croak("Can't open stderr: $!");
148 binmode( $self->stderr );
153 no warnings 'uninitialized';
154 %ENV = %{ $self->environment };
157 if ( $INC{'CGI.pm'} ) {
158 CGI::initialize_globals();
167 my ( $self, $callback ) = @_;
169 return undef unless $self->stdout;
171 seek( $self->stdout, 0, SEEK_SET )
172 or croak("Can't seek stdout handle: $!");
175 while ( my $line = $self->stdout->getline ) {
177 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
180 unless ( defined $headers ) {
181 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
184 unless ( $headers =~ /^HTTP/ ) {
185 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
188 my $response = HTTP::Response->parse($headers);
189 $response->date( time() ) unless $response->date;
191 my $message = $response->message;
192 my $status = $response->header('Status');
194 if ( $message && $message =~ /^(.+)\x0d$/ ) {
195 $response->message($1);
198 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
201 my $message = $2 || HTTP::Status::status_message($code);
203 $response->code($code);
204 $response->message($message);
207 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
209 if ( $response->code == 500 && !$length ) {
211 $response->content( $response->error_as_HTML );
212 $response->content_type('text/html');
219 my $handle = $self->stdout;
221 $response->content( sub {
223 if ( $handle->read( my $buffer, 4096 ) ) {
234 while ( $self->stdout->read( my $buffer, 4096 ) ) {
235 $length += length($buffer);
236 $response->add_content($buffer);
239 if ( $length && !$response->content_length ) {
240 $response->content_length($length);
251 no warnings 'uninitialized';
252 %ENV = %{ $self->{restore}->{environment} };
255 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
256 or croak("Can't restore stdin: $!");
258 sysseek( $self->stdin, 0, SEEK_SET )
259 or croak("Can't seek stdin: $!");
261 if ( $self->{restore}->{stdout} ) {
264 or croak("Can't flush stdout: $!");
266 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
267 or croak("Can't restore stdout: $!");
269 sysseek( $self->stdout, 0, SEEK_SET )
270 or croak("Can't seek stdout: $!");
273 if ( $self->{restore}->{stderr} ) {
276 or croak("Can't flush stderr: $!");
278 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
279 or croak("Can't restore stderr: $!");
281 sysseek( $self->stderr, 0, SEEK_SET )
282 or croak("Can't seek stderr: $!");
292 $self->restore if $self->{setuped} && !$self->{restored};
303 use HTTP::Request::AsCGI;
305 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
309 my $c = HTTP::Request::AsCGI->new($request)->setup;
313 $q->start_html('Hello World'),
314 $q->h1('Hello World'),
317 $stdout = $c->stdout;
319 # environment and descriptors will automatically be restored
320 # when $c is destructed.
323 while ( my $line = $stdout->getline ) {
329 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
335 =item new ( $request [, key => value ] )
337 Constructor. The first argument must be a instance of HTTP::Request, followed
338 by optional pairs of environment key and value.
342 Returns a hashref containing the environment that will be used in setup.
343 Changing the hashref after setup has been called will have no effect.
347 Sets up the environment and descriptors.
351 Restores the environment and descriptors. Can only be called after setup.
355 Returns the request given to constructor.
359 Returns a HTTP::Response. Can only be called after restore.
363 Accessor for handle that will be used for STDIN, must be a real seekable
364 handle with an file descriptor. Defaults to a tempoary IO::File instance.
368 Accessor for handle that will be used for STDOUT, 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 STDERR, must be a real seekable
374 handle with an file descriptor.
382 =item examples directory in this distribution.
384 =item L<WWW::Mechanize::CGI>
386 =item L<Test::WWW::Mechanize::CGI>
392 Thomas L. Shinnick for his valuable win32 testing.