1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
13 __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
15 our $VERSION = 0.5_03;
21 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
22 croak(qq/usage: $class->new( \$request [, key => value] )/);
25 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
26 $self->request($request);
27 $self->stdin( IO::File->new_tmpfile );
28 $self->stdout( IO::File->new_tmpfile );
30 my $host = $request->header('Host');
31 my $uri = $request->uri->clone;
32 $uri->scheme('http') unless $uri->scheme;
33 $uri->host('localhost') unless $uri->host;
34 $uri->port(80) unless $uri->port;
35 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
37 $uri = $uri->canonical;
40 GATEWAY_INTERFACE => 'CGI/1.1',
41 HTTP_HOST => $uri->host_port,
42 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
43 PATH_INFO => $uri->path,
44 QUERY_STRING => $uri->query || '',
46 SERVER_NAME => $uri->host,
47 SERVER_PORT => $uri->port,
48 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
49 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
50 REMOTE_ADDR => '127.0.0.1',
51 REMOTE_HOST => 'localhost',
52 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
53 REQUEST_URI => $uri->path_query, # not in RFC 3875
54 REQUEST_METHOD => $request->method,
58 foreach my $field ( $request->headers->header_field_names ) {
60 my $key = uc("HTTP_$field");
62 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
64 unless ( exists $enviroment->{$key} ) {
65 $enviroment->{$key} = $request->headers->header($field);
69 unless ( $enviroment->{SCRIPT_NAME} eq '/' && $enviroment->{PATH_INFO} ) {
70 $enviroment->{PATH_INFO} =~ s/^\Q$enviroment->{SCRIPT_NAME}\E/\//;
71 $enviroment->{PATH_INFO} =~ s/^\/+/\//;
74 $self->enviroment($enviroment);
82 $self->{restore}->{enviroment} = {%ENV};
84 binmode( $self->stdin );
86 if ( $self->request->content_length ) {
88 $self->stdin->print($self->request->content)
89 or croak("Can't write request content to stdin handle: $!");
91 $self->stdin->seek(0, SEEK_SET)
92 or croak("Can't seek stdin handle: $!");
95 or croak("Can't flush stdin handle: $!");
98 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
99 or croak("Can't dup stdin: $!");
101 open( STDIN, '<&='. $self->stdin->fileno )
102 or croak("Can't open stdin: $!");
106 if ( $self->stdout ) {
108 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
109 or croak("Can't dup stdout: $!");
111 open( STDOUT, '>&='. $self->stdout->fileno )
112 or croak("Can't open stdout: $!");
114 binmode( $self->stdout );
118 if ( $self->stderr ) {
120 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
121 or croak("Can't dup stderr: $!");
123 open( STDERR, '>&='. $self->stderr->fileno )
124 or croak("Can't open stderr: $!");
126 binmode( $self->stderr );
131 no warnings 'uninitialized';
132 %ENV = %{ $self->enviroment };
135 if ( $INC{'CGI.pm'} ) {
136 CGI::initialize_globals();
145 my ( $self, $callback ) = @_;
147 return undef unless $self->stdout;
149 seek( $self->stdout, 0, SEEK_SET )
150 or croak("Can't seek stdout handle: $!");
153 while ( my $line = $self->stdout->getline ) {
155 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
158 unless ( defined $headers ) {
159 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
162 unless ( $headers =~ /^HTTP/ ) {
163 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
166 my $response = HTTP::Response->parse($headers);
167 $response->date( time() ) unless $response->date;
169 my $message = $response->message;
170 my $status = $response->header('Status');
172 if ( $message && $message =~ /^(.+)\x0d$/ ) {
173 $response->message($1);
176 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
179 my $message = $2 || HTTP::Status::status_message($code);
181 $response->code($code);
182 $response->message($message);
185 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
187 if ( $response->code == 500 && !$length ) {
189 $response->content( $response->error_as_HTML );
190 $response->content_type('text/html');
197 my $handle = $self->stdout;
199 $response->content( sub {
201 if ( $handle->read( my $buffer, 4096 ) ) {
212 while ( $self->stdout->read( my $buffer, 4096 ) ) {
213 $length += length($buffer);
214 $response->add_content($buffer);
217 if ( $length && !$response->content_length ) {
218 $response->content_length($length);
229 no warnings 'uninitialized';
230 %ENV = %{ $self->{restore}->{enviroment} };
233 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
234 or croak("Can't restore stdin: $!");
236 sysseek( $self->stdin, 0, SEEK_SET )
237 or croak("Can't seek stdin: $!");
239 if ( $self->{restore}->{stdout} ) {
242 or croak("Can't flush stdout: $!");
244 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
245 or croak("Can't restore stdout: $!");
247 sysseek( $self->stdout, 0, SEEK_SET )
248 or croak("Can't seek stdout: $!");
251 if ( $self->{restore}->{stderr} ) {
254 or croak("Can't flush stderr: $!");
256 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
257 or croak("Can't restore stderr: $!");
259 sysseek( $self->stderr, 0, SEEK_SET )
260 or croak("Can't seek stderr: $!");
270 $self->restore if $self->{setuped} && !$self->{restored};
279 HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request
285 use HTTP::Request::AsCGI;
287 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
291 my $c = HTTP::Request::AsCGI->new($request)->setup;
295 $q->start_html('Hello World'),
296 $q->h1('Hello World'),
299 $stdout = $c->stdout;
301 # enviroment and descriptors will automatically be restored
302 # when $c is destructed.
305 while ( my $line = $stdout->getline ) {
311 Provides a convinient way of setting up an CGI enviroment from a HTTP::Request.
317 =item new ( $request [, key => value ] )
319 Contructor, first argument must be a instance of HTTP::Request
320 followed by optional pairs of environment key and value.
324 Returns a hashref containing the environment that will be used in setup.
325 Changing the hashref after setup has been called will have no effect.
329 Setups the environment and descriptors.
333 Restores the enviroment and descriptors. Can only be called after setup.
337 Returns the request given to constructor.
341 Returns a HTTP::Response. Can only be called after restore.
345 Accessor for handle that will be used for STDIN, must be a real seekable
346 handle with an file descriptor. Defaults to a tempoary IO::File instance.
350 Accessor for handle that will be used for STDOUT, must be a real seekable
351 handle with an file descriptor. Defaults to a tempoary IO::File instance.
355 Accessor for handle that will be used for STDERR, must be a real seekable
356 handle with an file descriptor.
364 =item examples directory in this distribution.
366 =item L<WWW::Mechanize::CGI>
368 =item L<Test::WWW::Mechanize::CGI>
374 Thomas L. Shinnick for his valuable win32 testing.
378 Christian Hansen, C<ch@ngmedia.com>
382 This library is free software. You can redistribute it and/or modify
383 it under the same terms as perl itself.