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 ]);
27 *enviroment = \&environment;
29 my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved;
30 sub _uri_safe_unescape {
32 $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : pack('C', hex($1))/ge;
40 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
41 croak(qq/usage: $class->new( \$request [, key => value] )/);
44 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
45 $self->request($request);
46 $self->stdin( IO::File->new_tmpfile );
47 $self->stdout( IO::File->new_tmpfile );
49 my $host = $request->header('Host');
50 my $uri = $request->uri->clone;
51 $uri->scheme('http') unless $uri->scheme;
52 $uri->host('localhost') unless $uri->host;
53 $uri->port(80) unless $uri->port;
54 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
56 # Get it before canonicalized so REQUEST_URI can be as raw as possible
57 my $request_uri = $uri->path_query;
59 $uri = $uri->canonical;
62 GATEWAY_INTERFACE => 'CGI/1.1',
63 HTTP_HOST => $uri->host_port,
64 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
65 PATH_INFO => $uri->path,
66 QUERY_STRING => $uri->query || '',
68 SERVER_NAME => $uri->host,
69 SERVER_PORT => $uri->port,
70 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
71 SERVER_SOFTWARE => 'HTTP-Request-AsCGI/' . our $VERSION,
72 REMOTE_ADDR => '127.0.0.1',
73 REMOTE_HOST => 'localhost',
74 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
75 REQUEST_URI => $request_uri, # not in RFC 3875
76 REQUEST_METHOD => $request->method,
80 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
81 # annoying for applications that you can't tell "%2F" vs "/", but
82 # doing the partial decoding then makes it impossible to tell
83 # "%252F" vs "%2F". Encoding everything is more compatible to what
84 # web servers like Apache or lighttpd do, anyways.
85 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
87 foreach my $field ( $request->headers->header_field_names ) {
89 my $key = uc("HTTP_$field");
91 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
93 unless ( exists $environment->{$key} ) {
94 $environment->{$key} = $request->headers->header($field);
98 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
99 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
100 $environment->{PATH_INFO} =~ s/^\/+/\//;
103 $self->environment($environment);
111 $self->{restore}->{environment} = {%ENV};
113 binmode( $self->stdin );
115 if ( $self->request->content_length ) {
117 $self->stdin->print($self->request->content)
118 or croak("Can't write request content to stdin handle: $!");
120 $self->stdin->seek(0, SEEK_SET)
121 or croak("Can't seek stdin handle: $!");
124 or croak("Can't flush stdin handle: $!");
127 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
128 or croak("Can't dup stdin: $!");
130 open( STDIN, '<&='. $self->stdin->fileno )
131 or croak("Can't open stdin: $!");
135 if ( $self->stdout ) {
137 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
138 or croak("Can't dup stdout: $!");
140 open( STDOUT, '>&='. $self->stdout->fileno )
141 or croak("Can't open stdout: $!");
143 binmode( $self->stdout );
147 if ( $self->stderr ) {
149 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
150 or croak("Can't dup stderr: $!");
152 open( STDERR, '>&='. $self->stderr->fileno )
153 or croak("Can't open stderr: $!");
155 binmode( $self->stderr );
160 no warnings 'uninitialized';
161 %ENV = (%ENV, %{ $self->environment });
164 if ( $INC{'CGI.pm'} ) {
165 CGI::initialize_globals();
174 my ( $self, $callback ) = @_;
176 return undef unless $self->stdout;
178 seek( $self->stdout, 0, SEEK_SET )
179 or croak("Can't seek stdout handle: $!");
182 while ( my $line = $self->stdout->getline ) {
184 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
187 unless ( defined $headers ) {
188 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
191 unless ( $headers =~ /^HTTP/ ) {
192 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
195 my $response = HTTP::Response->parse($headers);
196 $response->date( time() ) unless $response->date;
198 my $message = $response->message;
199 my $status = $response->header('Status');
201 if ( $message && $message =~ /^(.+)\x0d$/ ) {
202 $response->message($1);
205 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
208 my $message = $2 || HTTP::Status::status_message($code);
210 $response->code($code);
211 $response->message($message);
214 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
216 if ( $response->code == 500 && !$length ) {
218 $response->content( $response->error_as_HTML );
219 $response->content_type('text/html');
226 my $handle = $self->stdout;
228 $response->content( sub {
230 if ( $handle->read( my $buffer, 4096 ) ) {
239 my $length = defined $response->content ? length( $response->content ) : 0;
241 while ( $self->stdout->read( my $buffer, 4096 ) ) {
242 $length += length($buffer);
243 $response->add_content($buffer);
246 if ( $length && !$response->content_length ) {
247 $response->content_length($length);
258 no warnings 'uninitialized';
259 %ENV = %{ $self->{restore}->{environment} };
262 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
263 or croak("Can't restore stdin: $!");
265 sysseek( $self->stdin, 0, SEEK_SET )
266 or croak("Can't seek stdin: $!");
268 if ( $self->{restore}->{stdout} ) {
271 or croak("Can't flush stdout: $!");
273 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
274 or croak("Can't restore stdout: $!");
276 sysseek( $self->stdout, 0, SEEK_SET )
277 or croak("Can't seek stdout: $!");
280 if ( $self->{restore}->{stderr} ) {
283 or croak("Can't flush stderr: $!");
285 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
286 or croak("Can't restore stderr: $!");
288 sysseek( $self->stderr, 0, SEEK_SET )
289 or croak("Can't seek stderr: $!");
299 $self->restore if $self->{setuped} && !$self->{restored};
310 use HTTP::Request::AsCGI;
312 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
316 my $c = HTTP::Request::AsCGI->new($request)->setup;
320 $q->start_html('Hello World'),
321 $q->h1('Hello World'),
324 $stdout = $c->stdout;
326 # environment and descriptors will automatically be restored
327 # when $c is destructed.
330 while ( my $line = $stdout->getline ) {
336 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
342 =item new ( $request [, key => value ] )
344 Constructor. The first argument must be a instance of HTTP::Request, followed
345 by optional pairs of environment key and value.
349 Returns a hashref containing the environment that will be used in setup.
350 Changing the hashref after setup has been called will have no effect.
354 Sets up the environment and descriptors.
358 Restores the environment and descriptors. Can only be called after setup.
362 Returns the request given to constructor.
366 Returns a HTTP::Response. Can only be called after restore.
370 Accessor for handle that will be used for STDIN, must be a real seekable
371 handle with an file descriptor. Defaults to a tempoary IO::File instance.
375 Accessor for handle that will be used for STDOUT, must be a real seekable
376 handle with an file descriptor. Defaults to a tempoary IO::File instance.
380 Accessor for handle that will be used for STDERR, must be a real seekable
381 handle with an file descriptor.
389 =item examples directory in this distribution.
391 =item L<WWW::Mechanize::CGI>
393 =item L<Test::WWW::Mechanize::CGI>
399 Thomas L. Shinnick for his valuable win32 testing.