1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
9 use HTTP::Response qw[];
11 use IO::File qw[SEEK_SET];
14 __PACKAGE__->mk_accessors(qw[environment request is_restored is_setuped is_prepared should_dup should_restore should_rewind stdin stdout stderr]);
16 our $VERSION = 0.6_01;
19 my $class = ref $_[0] ? ref shift : shift;
26 $params = { request => shift, environment => { @_ } };
29 return bless( {}, $class )->initialize($params);
33 my ( $self, $params ) = @_;
35 if ( exists $params->{request} ) {
36 $self->request( $params->{request} );
39 croak("Mandatory parameter 'request' is missing.");
42 if ( exists $params->{environment} ) {
43 $self->environment( $params->{environment} );
46 $self->environment( {} );
49 if ( exists $params->{stdin} ) {
50 $self->stdin( $params->{stdin} );
53 $self->stdin( IO::File->new_tmpfile );
56 if ( exists $params->{stdout} ) {
57 $self->stdout( $params->{stdout} );
60 $self->stdout( IO::File->new_tmpfile );
63 if ( exists $params->{stderr} ) {
64 $self->stderr( $params->{stderr} );
67 if ( exists $params->{dup} ) {
68 $self->should_dup( $params->{dup} ? 1 : 0 );
74 if ( exists $params->{restore} ) {
75 $self->should_restore( $params->{restore} ? 1 : 0 );
78 $self->should_restore(1);
81 if ( exists $params->{rewind} ) {
82 $self->should_rewind( $params->{rewind} ? 1 : 0 );
85 $self->should_rewind(1);
93 *enviroment = \&environment;
95 sub has_stdin { return defined $_[0]->stdin }
96 sub has_stdout { return defined $_[0]->stdout }
97 sub has_stderr { return defined $_[0]->stderr }
102 my $environment = $self->environment;
103 my $request = $self->request;
105 my $host = $request->header('Host');
106 my $uri = $request->uri->clone;
108 $uri->scheme('http') unless $uri->scheme;
109 $uri->host('localhost') unless $uri->host;
110 $uri->port(80) unless $uri->port;
111 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
113 $uri = $uri->canonical;
116 GATEWAY_INTERFACE => 'CGI/1.1',
117 HTTP_HOST => $uri->host_port,
118 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
119 PATH_INFO => $uri->path,
120 QUERY_STRING => $uri->query || '',
122 SERVER_NAME => $uri->host,
123 SERVER_PORT => $uri->port,
124 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
125 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
126 REMOTE_ADDR => '127.0.0.1',
127 REMOTE_HOST => 'localhost',
128 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
129 REQUEST_URI => $uri->path_query, # not in RFC 3875
130 REQUEST_METHOD => $request->method
133 foreach my $key ( keys %cgi ) {
135 unless ( exists $environment->{ $key } ) {
136 $environment->{ $key } = $cgi{ $key };
140 foreach my $field ( $self->request->headers->header_field_names ) {
142 my $key = uc("HTTP_$field");
144 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
146 unless ( exists $environment->{ $key } ) {
147 $environment->{ $key } = $self->request->headers->header($field);
151 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
152 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
153 $environment->{PATH_INFO} =~ s/^\/+/\//;
156 $self->is_prepared(1);
165 $self->setup_environment;
167 if ( $INC{'CGI.pm'} ) {
168 CGI::initialize_globals();
171 $self->is_setuped(1);
176 sub setup_environment {
179 no warnings 'uninitialized';
181 if ( $self->should_restore ) {
182 $self->{restore}->{environment} = { %ENV };
185 %ENV = %{ $self->environment };
191 if ( $self->has_stdin ) {
193 binmode( $self->stdin );
195 if ( $self->request->content_length ) {
197 syswrite( $self->stdin, $self->request->content )
198 or croak("Couldn't write request content to stdin handle: '$!'");
200 sysseek( $self->stdin, 0, SEEK_SET )
201 or croak("Couldn't seek stdin handle: '$!'");
204 if ( $self->should_dup ) {
206 if ( $self->should_restore ) {
208 open( my $stdin, '<&STDIN' )
209 or croak("Couldn't dup STDIN: '$!'");
211 $self->{restore}->{stdin} = $stdin;
214 STDIN->fdopen( $self->stdin, '<' )
215 or croak("Couldn't redirect STDIN: '$!'");
219 my $stdin = Symbol::qualify_to_ref('STDIN');
221 if ( $self->should_restore ) {
223 $self->{restore}->{stdin} = *$stdin;
224 $self->{restore}->{stdin_ref} = \*$stdin;
227 *{ $stdin } = $self->stdin;
237 if ( $self->has_stdout ) {
239 if ( $self->should_dup ) {
241 if ( $self->should_restore ) {
243 open( my $stdout, '>&STDOUT' )
244 or croak("Couldn't dup STDOUT: '$!'");
246 $self->{restore}->{stdout} = $stdout;
249 STDOUT->fdopen( $self->stdout, '>' )
250 or croak("Couldn't redirect STDOUT: '$!'");
254 my $stdout = Symbol::qualify_to_ref('STDOUT');
256 if ( $self->should_restore ) {
258 $self->{restore}->{stdout} = *$stdout;
259 $self->{restore}->{stdout_ref} = \*$stdout;
262 *{ $stdout } = $self->stdout;
265 binmode( $self->stdout );
273 if ( $self->has_stderr ) {
275 if ( $self->should_dup ) {
277 if ( $self->should_restore ) {
279 open( my $stderr, '>&STDERR' )
280 or croak("Couldn't dup STDERR: '$!'");
282 $self->{restore}->{stderr} = $stderr;
285 STDERR->fdopen( $self->stderr, '>' )
286 or croak("Couldn't redirect STDERR: '$!'");
290 my $stderr = Symbol::qualify_to_ref('STDERR');
292 if ( $self->should_restore ) {
294 $self->{restore}->{stderr} = *$stderr;
295 $self->{restore}->{stderr_ref} = \*$stderr;
298 *{ $stderr } = $self->stderr;
301 binmode( $self->stderr );
307 my ( $self, $callback ) = @_;
309 return undef unless $self->stdout;
311 seek( $self->stdout, 0, SEEK_SET )
312 or croak("Couldn't seek stdout handle: '$!'");
315 while ( my $line = $self->stdout->getline ) {
317 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
320 unless ( defined $headers ) {
321 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
324 unless ( $headers =~ /^HTTP/ ) {
325 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
328 my $response = HTTP::Response->parse($headers);
329 $response->date( time() ) unless $response->date;
331 my $message = $response->message;
332 my $status = $response->header('Status');
334 if ( $message && $message =~ /^(.+)\x0d$/ ) {
335 $response->message($1);
338 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
341 my $message = $2 || HTTP::Status::status_message($code);
343 $response->code($code);
344 $response->message($message);
347 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
349 if ( $response->code == 500 && !$length ) {
351 $response->content( $response->error_as_HTML );
352 $response->content_type('text/html');
359 my $handle = $self->stdout;
361 $response->content( sub {
363 if ( $handle->read( my $buffer, 4096 ) ) {
374 while ( $self->stdout->read( my $buffer, 4096 ) ) {
375 $length += length($buffer);
376 $response->add_content($buffer);
379 if ( $length && !$response->content_length ) {
380 $response->content_length($length);
390 if ( $self->should_restore ) {
392 $self->restore_environment;
393 $self->restore_stdin;
394 $self->restore_stdout;
395 $self->restore_stderr;
397 $self->{restore} = {};
399 $self->is_restored(1);
405 sub restore_environment {
408 no warnings 'uninitialized';
410 %ENV = %{ $self->{restore}->{environment} };
416 if ( $self->has_stdin ) {
418 my $stdin = $self->{restore}->{stdin};
420 if ( $self->should_dup ) {
422 STDIN->fdopen( $stdin, '<' )
423 or croak("Couldn't restore STDIN: '$!'");
427 my $stdin_ref = $self->{restore}->{stdin_ref};
429 *{ $stdin_ref } = $stdin;
432 if ( $self->should_rewind ) {
434 seek( $self->stdin, 0, SEEK_SET )
435 or croak("Couldn't seek stdin handle: '$!'");
443 if ( $self->has_stdout ) {
445 my $stdout = $self->{restore}->{stdout};
447 if ( $self->should_dup ) {
450 or croak("Couldn't flush STDOUT: '$!'");
452 STDOUT->fdopen( $stdout, '>' )
453 or croak("Couldn't restore STDOUT: '$!'");
457 my $stdout_ref = $self->{restore}->{stdout_ref};
459 *{ $stdout_ref } = $stdout;
462 if ( $self->should_rewind ) {
464 seek( $self->stdout, 0, SEEK_SET )
465 or croak("Couldn't seek stdout handle: '$!'");
473 if ( $self->has_stderr ) {
475 my $stderr = $self->{restore}->{stderr};
477 if ( $self->should_dup ) {
480 or croak("Couldn't flush STDERR: '$!'");
482 STDERR->fdopen( $stderr, '>' )
483 or croak("Couldn't restore STDERR: '$!'");
487 my $stderr_ref = $self->{restore}->{stderr_ref};
489 *{ $stderr_ref } = $stderr;
492 if ( $self->should_rewind ) {
494 seek( $self->stderr, 0, SEEK_SET )
495 or croak("Couldn't seek stderr handle: '$!'");
503 if ( $self->should_restore ) {
505 if ( $self->is_setuped && !$self->is_restored ) {
517 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
523 use HTTP::Request::AsCGI;
525 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
529 my $c = HTTP::Request::AsCGI->new($request)->setup;
533 $q->start_html('Hello World'),
534 $q->h1('Hello World'),
537 $stdout = $c->stdout;
539 # environment and descriptors will automatically be restored
540 # when $c is destructed.
543 while ( my $line = $stdout->getline ) {
549 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
555 =item new ( $request [, key => value ] )
557 Contructor, first argument must be a instance of HTTP::Request
558 followed by optional pairs of environment key and value.
562 Returns a hashref containing the environment that will be used in setup.
563 Changing the hashref after setup has been called will have no effect.
567 Setups the environment and descriptors.
571 Restores the environment and descriptors. Can only be called after setup.
575 Returns the request given to constructor.
579 Returns a HTTP::Response. Can only be called after restore.
583 Accessor for handle that will be used for STDIN, must be a real seekable
584 handle with an file descriptor. Defaults to a tempoary IO::File instance.
588 Accessor for handle that will be used for STDOUT, must be a real seekable
589 handle with an file descriptor. Defaults to a tempoary IO::File instance.
593 Accessor for handle that will be used for STDERR, must be a real seekable
594 handle with an file descriptor.
602 =item examples directory in this distribution.
604 =item L<WWW::Mechanize::CGI>
606 =item L<Test::WWW::Mechanize::CGI>
612 Thomas L. Shinnick for his valuable win32 testing.
616 Christian Hansen, C<ch@ngmedia.com>
620 This library is free software. You can redistribute it and/or modify
621 it under the same terms as perl itself.