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 );
308 my %params = ( headers_only => 0, sync => 0, @_ );
310 return undef unless $self->stdout;
312 seek( $self->stdout, 0, SEEK_SET )
313 or croak("Couldn't seek stdout handle: '$!'");
316 while ( my $line = $self->stdout->getline ) {
318 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
321 unless ( defined $headers ) {
322 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
325 unless ( $headers =~ /^HTTP/ ) {
326 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
329 my $response = HTTP::Response->parse($headers);
330 $response->date( time() ) unless $response->date;
332 my $message = $response->message;
333 my $status = $response->header('Status');
335 if ( $message && $message =~ /^(.+)\x0d$/ ) {
336 $response->message($1);
339 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
342 my $message = $2 || HTTP::Status::status_message($code);
344 $response->code($code);
345 $response->message($message);
348 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
350 if ( $response->code == 500 && !$length ) {
352 $response->content( $response->error_as_HTML );
353 $response->content_type('text/html');
358 if ( $params{headers_only} ) {
360 if ( $params{sync} ) {
362 my $position = tell( $self->stdout )
363 or croak("Couldn't get file position from stdout handle: '$!'");
365 sysseek( $self->stdout, $position, SEEK_SET )
366 or croak("Couldn't seek stdout handle: '$!'");
373 my $content_length = 0;
377 my $r = $self->stdout->read( $content, 4096, $content_length );
381 $content_length += $r;
386 croak("Couldn't read from stdin handle: '$!'");
390 if ( $content_length ) {
392 $response->content_ref(\$content);
394 if ( !$response->content_length ) {
395 $response->content_length($content_length);
405 if ( $self->should_restore ) {
407 $self->restore_environment;
408 $self->restore_stdin;
409 $self->restore_stdout;
410 $self->restore_stderr;
412 $self->{restore} = {};
414 $self->is_restored(1);
420 sub restore_environment {
423 no warnings 'uninitialized';
425 %ENV = %{ $self->{restore}->{environment} };
431 if ( $self->has_stdin ) {
433 my $stdin = $self->{restore}->{stdin};
435 if ( $self->should_dup ) {
437 STDIN->fdopen( $stdin, '<' )
438 or croak("Couldn't restore STDIN: '$!'");
442 my $stdin_ref = $self->{restore}->{stdin_ref};
444 *{ $stdin_ref } = $stdin;
447 if ( $self->should_rewind ) {
449 seek( $self->stdin, 0, SEEK_SET )
450 or croak("Couldn't seek stdin handle: '$!'");
458 if ( $self->has_stdout ) {
460 my $stdout = $self->{restore}->{stdout};
462 if ( $self->should_dup ) {
465 or croak("Couldn't flush STDOUT: '$!'");
467 STDOUT->fdopen( $stdout, '>' )
468 or croak("Couldn't restore STDOUT: '$!'");
472 my $stdout_ref = $self->{restore}->{stdout_ref};
474 *{ $stdout_ref } = $stdout;
477 if ( $self->should_rewind ) {
479 seek( $self->stdout, 0, SEEK_SET )
480 or croak("Couldn't seek stdout handle: '$!'");
488 if ( $self->has_stderr ) {
490 my $stderr = $self->{restore}->{stderr};
492 if ( $self->should_dup ) {
495 or croak("Couldn't flush STDERR: '$!'");
497 STDERR->fdopen( $stderr, '>' )
498 or croak("Couldn't restore STDERR: '$!'");
502 my $stderr_ref = $self->{restore}->{stderr_ref};
504 *{ $stderr_ref } = $stderr;
507 if ( $self->should_rewind ) {
509 seek( $self->stderr, 0, SEEK_SET )
510 or croak("Couldn't seek stderr handle: '$!'");
518 if ( $self->should_restore ) {
520 if ( $self->is_setuped && !$self->is_restored ) {
532 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
538 use HTTP::Request::AsCGI;
540 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
544 my $c = HTTP::Request::AsCGI->new($request)->setup;
548 $q->start_html('Hello World'),
549 $q->h1('Hello World'),
552 $stdout = $c->stdout;
554 # environment and descriptors will automatically be restored
555 # when $c is destructed.
558 while ( my $line = $stdout->getline ) {
564 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
570 =item new ( $request [, key => value ] )
572 Contructor, first argument must be a instance of HTTP::Request
573 followed by optional pairs of environment key and value.
577 Returns a hashref containing the environment that will be used in setup.
578 Changing the hashref after setup has been called will have no effect.
582 Setups the environment and descriptors.
586 Restores the environment and descriptors. Can only be called after setup.
590 Returns the request given to constructor.
594 Returns a HTTP::Response. Can only be called after restore.
598 Accessor for handle that will be used for STDIN, must be a real seekable
599 handle with an file descriptor. Defaults to a tempoary IO::File instance.
603 Accessor for handle that will be used for STDOUT, must be a real seekable
604 handle with an file descriptor. Defaults to a tempoary IO::File instance.
608 Accessor for handle that will be used for STDERR, must be a real seekable
609 handle with an file descriptor.
617 =item examples directory in this distribution.
619 =item L<WWW::Mechanize::CGI>
621 =item L<Test::WWW::Mechanize::CGI>
627 Thomas L. Shinnick for his valuable win32 testing.
631 Christian Hansen, C<ch@ngmedia.com>
635 This library is free software. You can redistribute it and/or modify
636 it under the same terms as perl itself.