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" : pack('C', 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 # Get it before canonicalized so REQUEST_URI can be as raw as possible
56 my $request_uri = $uri->path_query;
58 $uri = $uri->canonical;
61 GATEWAY_INTERFACE => 'CGI/1.1',
62 HTTP_HOST => $uri->host_port,
63 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
64 PATH_INFO => $uri->path,
65 QUERY_STRING => $uri->query || '',
67 SERVER_NAME => $uri->host,
68 SERVER_PORT => $uri->port,
69 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
70 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
71 REMOTE_ADDR => '127.0.0.1',
72 REMOTE_HOST => 'localhost',
73 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
74 REQUEST_URI => $request_uri, # not in RFC 3875
75 REQUEST_METHOD => $request->method,
79 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
80 # annoying for applications that you can't tell "%2F" vs "/", but
81 # doing the partial decoding then makes it impossible to tell
82 # "%252F" vs "%2F". Encoding everything is more compatible to what
83 # web servers like Apache or lighttpd do, anyways.
84 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
86 foreach my $field ( $request->headers->header_field_names ) {
88 my $key = uc("HTTP_$field");
90 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
92 unless ( exists $environment->{$key} ) {
93 $environment->{$key} = $request->headers->header($field);
97 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
98 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
99 $environment->{PATH_INFO} =~ s/^\/+/\//;
102 $self->environment($environment);
110 $self->{restore}->{environment} = {%ENV};
112 binmode( $self->stdin );
114 if ( $self->request->content_length ) {
116 $self->stdin->print($self->request->content)
117 or croak("Can't write request content to stdin handle: $!");
119 $self->stdin->seek(0, SEEK_SET)
120 or croak("Can't seek stdin handle: $!");
123 or croak("Can't flush stdin handle: $!");
126 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
127 or croak("Can't dup stdin: $!");
129 open( STDIN, '<&='. $self->stdin->fileno )
130 or croak("Can't open stdin: $!");
134 if ( $self->stdout ) {
136 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
137 or croak("Can't dup stdout: $!");
139 open( STDOUT, '>&='. $self->stdout->fileno )
140 or croak("Can't open stdout: $!");
142 binmode( $self->stdout );
146 if ( $self->stderr ) {
148 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
149 or croak("Can't dup stderr: $!");
151 open( STDERR, '>&='. $self->stderr->fileno )
152 or croak("Can't open stderr: $!");
154 binmode( $self->stderr );
159 no warnings 'uninitialized';
160 %ENV = (%ENV, %{ $self->environment });
163 if ( $INC{'CGI.pm'} ) {
164 CGI::initialize_globals();
173 my ( $self, $callback ) = @_;
175 return undef unless $self->stdout;
177 seek( $self->stdout, 0, SEEK_SET )
178 or croak("Can't seek stdout handle: $!");
181 while ( my $line = $self->stdout->getline ) {
183 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
186 unless ( defined $headers ) {
187 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
190 unless ( $headers =~ /^HTTP/ ) {
191 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
194 my $response = HTTP::Response->parse($headers);
195 $response->date( time() ) unless $response->date;
197 my $message = $response->message;
198 my $status = $response->header('Status');
200 if ( $message && $message =~ /^(.+)\x0d$/ ) {
201 $response->message($1);
204 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
207 my $message = $2 || HTTP::Status::status_message($code);
209 $response->code($code);
210 $response->message($message);
213 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
215 if ( $response->code == 500 && !$length ) {
217 $response->content( $response->error_as_HTML );
218 $response->content_type('text/html');
225 my $handle = $self->stdout;
227 $response->content( sub {
229 if ( $handle->read( my $buffer, 4096 ) ) {
240 while ( $self->stdout->read( my $buffer, 4096 ) ) {
241 $length += length($buffer);
242 $response->add_content($buffer);
245 if ( $length && !$response->content_length ) {
246 $response->content_length($length);
257 no warnings 'uninitialized';
258 %ENV = %{ $self->{restore}->{environment} };
261 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
262 or croak("Can't restore stdin: $!");
264 sysseek( $self->stdin, 0, SEEK_SET )
265 or croak("Can't seek stdin: $!");
267 if ( $self->{restore}->{stdout} ) {
270 or croak("Can't flush stdout: $!");
272 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
273 or croak("Can't restore stdout: $!");
275 sysseek( $self->stdout, 0, SEEK_SET )
276 or croak("Can't seek stdout: $!");
279 if ( $self->{restore}->{stderr} ) {
282 or croak("Can't flush stderr: $!");
284 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
285 or croak("Can't restore stderr: $!");
287 sysseek( $self->stderr, 0, SEEK_SET )
288 or croak("Can't seek stderr: $!");
298 $self->restore if $self->{setuped} && !$self->{restored};
309 use HTTP::Request::AsCGI;
311 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
315 my $c = HTTP::Request::AsCGI->new($request)->setup;
319 $q->start_html('Hello World'),
320 $q->h1('Hello World'),
323 $stdout = $c->stdout;
325 # environment and descriptors will automatically be restored
326 # when $c is destructed.
329 while ( my $line = $stdout->getline ) {
335 Provides a convenient way of setting up an CGI environment from an HTTP::Request.
341 =item new ( $request [, key => value ] )
343 Constructor. The first argument must be a instance of HTTP::Request, followed
344 by optional pairs of environment key and value.
348 Returns a hashref containing the environment that will be used in setup.
349 Changing the hashref after setup has been called will have no effect.
353 Sets up the environment and descriptors.
357 Restores the environment and descriptors. Can only be called after setup.
361 Returns the request given to constructor.
365 Returns a HTTP::Response. Can only be called after restore.
369 Accessor for handle that will be used for STDIN, must be a real seekable
370 handle with an file descriptor. Defaults to a tempoary IO::File instance.
374 Accessor for handle that will be used for STDOUT, must be a real seekable
375 handle with an file descriptor. Defaults to a tempoary IO::File instance.
379 Accessor for handle that will be used for STDERR, must be a real seekable
380 handle with an file descriptor.
388 =item examples directory in this distribution.
390 =item L<WWW::Mechanize::CGI>
392 =item L<Test::WWW::Mechanize::CGI>
398 Thomas L. Shinnick for his valuable win32 testing.