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[ is_setuped
29 our $VERSION = 0.6_01;
32 my $class = ref $_[0] ? ref shift : shift;
39 $params = { request => shift, environment => { @_ } };
42 return bless( {}, $class )->initialize($params);
46 my ( $self, $params ) = @_;
48 if ( exists $params->{request} ) {
49 $self->request( $params->{request} );
52 croak("Mandatory parameter 'request' is missing.");
55 if ( exists $params->{environment} ) {
56 $self->environment( $params->{environment} );
59 $self->environment( {} );
62 if ( exists $params->{stdin} ) {
63 $self->stdin( $params->{stdin} );
66 $self->stdin( IO::File->new_tmpfile );
69 if ( exists $params->{stdout} ) {
70 $self->stdout( $params->{stdout} );
73 $self->stdout( IO::File->new_tmpfile );
76 if ( exists $params->{stderr} ) {
77 $self->stderr( $params->{stderr} );
80 if ( exists $params->{dup} ) {
81 $self->should_dup( $params->{dup} ? 1 : 0 );
87 if ( exists $params->{restore} ) {
88 $self->should_restore( $params->{restore} ? 1 : 0 );
91 $self->should_restore(1);
94 if ( exists $params->{rewind} ) {
95 $self->should_rewind( $params->{rewind} ? 1 : 0 );
98 $self->should_rewind(1);
101 if ( exists $params->{content} ) {
102 $self->should_setup_content( $params->{content} ? 1 : 0 );
105 $self->should_setup_content(1);
113 *enviroment = \&environment;
115 sub has_stdin { return defined $_[0]->stdin }
116 sub has_stdout { return defined $_[0]->stdout }
117 sub has_stderr { return defined $_[0]->stderr }
122 my $environment = $self->environment;
123 my $request = $self->request;
125 my $host = $request->header('Host');
126 my $uri = $request->uri->clone;
128 $uri->scheme('http') unless $uri->scheme;
129 $uri->host('localhost') unless $uri->host;
130 $uri->port(80) unless $uri->port;
131 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
133 $uri = $uri->canonical;
136 GATEWAY_INTERFACE => 'CGI/1.1',
137 HTTP_HOST => $uri->host_port,
138 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
139 PATH_INFO => $uri->path,
140 QUERY_STRING => $uri->query || '',
142 SERVER_NAME => $uri->host,
143 SERVER_PORT => $uri->port,
144 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
145 SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
146 REMOTE_ADDR => '127.0.0.1',
147 REMOTE_HOST => 'localhost',
148 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
149 REQUEST_URI => $uri->path_query, # not in RFC 3875
150 REQUEST_METHOD => $request->method
153 foreach my $key ( keys %cgi ) {
155 unless ( exists $environment->{ $key } ) {
156 $environment->{ $key } = $cgi{ $key };
160 foreach my $field ( $self->request->headers->header_field_names ) {
162 my $key = uc("HTTP_$field");
164 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
166 unless ( exists $environment->{ $key } ) {
167 $environment->{ $key } = $self->request->headers->header($field);
171 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
172 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
173 $environment->{PATH_INFO} =~ s/^\/+/\//;
176 $self->is_prepared(1);
182 $self->setup_content;
186 $self->setup_environment;
188 if ( $INC{'CGI.pm'} ) {
189 CGI::initialize_globals();
192 $self->is_setuped(1);
198 my ( $self, $handle ) = @_;
200 my $content = $self->request->content_ref;
202 if ( ref($content) eq 'SCALAR' ) {
204 if ( defined($$content) && length($$content) ) {
206 print( { $self->stdin } $$content )
207 or croak("Couldn't write request content to stdin handle: '$!'");
209 if ( $self->should_rewind ) {
211 seek( $self->stdin, 0, SEEK_SET )
212 or croak("Couldn't seek stdin handle: '$!'");
216 elsif ( ref($content) eq 'CODE' ) {
220 my $chunk = &$content();
222 if ( defined($chunk) && length($chunk) ) {
224 print( { $self->stdin } $chunk )
225 or croak("Couldn't write request content chunk to stdin handle: '$!'");
232 if ( $self->should_rewind ) {
234 seek( $self->stdin, 0, SEEK_SET )
235 or croak("Couldn't seek stdin handle: '$!'");
239 croak("Couldn't write request content to stdin handle: 'Unknown request content $content'");
246 if ( $self->has_stdin && $self->should_setup_content ) {
247 $self->write_content($self->stdin);
254 if ( $self->has_stdin ) {
256 if ( $self->should_dup ) {
258 if ( $self->should_restore ) {
260 open( my $stdin, '<&STDIN' )
261 or croak("Couldn't dup STDIN: '$!'");
263 $self->{restore}->{stdin} = $stdin;
266 STDIN->fdopen( $self->stdin, '<' )
267 or croak("Couldn't dup stdin handle to STDIN: '$!'");
271 my $stdin = Symbol::qualify_to_ref('STDIN');
273 if ( $self->should_restore ) {
275 $self->{restore}->{stdin} = *$stdin;
276 $self->{restore}->{stdin_ref} = \*$stdin;
279 *$stdin = $self->stdin;
282 binmode( $self->stdin );
290 if ( $self->has_stdout ) {
292 if ( $self->should_dup ) {
294 if ( $self->should_restore ) {
296 open( my $stdout, '>&STDOUT' )
297 or croak("Couldn't dup STDOUT: '$!'");
299 $self->{restore}->{stdout} = $stdout;
302 STDOUT->fdopen( $self->stdout, '>' )
303 or croak("Couldn't dup stdout handle to STDOUT: '$!'");
307 my $stdout = Symbol::qualify_to_ref('STDOUT');
309 if ( $self->should_restore ) {
311 $self->{restore}->{stdout} = *$stdout;
312 $self->{restore}->{stdout_ref} = \*$stdout;
315 *$stdout = $self->stdout;
318 binmode( $self->stdout );
326 if ( $self->has_stderr ) {
328 if ( $self->should_dup ) {
330 if ( $self->should_restore ) {
332 open( my $stderr, '>&STDERR' )
333 or croak("Couldn't dup STDERR: '$!'");
335 $self->{restore}->{stderr} = $stderr;
338 STDERR->fdopen( $self->stderr, '>' )
339 or croak("Couldn't dup stderr handle to STDERR: '$!'");
343 my $stderr = Symbol::qualify_to_ref('STDERR');
345 if ( $self->should_restore ) {
347 $self->{restore}->{stderr} = *$stderr;
348 $self->{restore}->{stderr_ref} = \*$stderr;
351 *$stderr = $self->stderr;
354 binmode( $self->stderr );
359 sub setup_environment {
362 no warnings 'uninitialized';
364 if ( $self->should_restore ) {
365 $self->{restore}->{environment} = { %ENV };
368 %ENV = %{ $self->environment };
371 my $HTTP_Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
372 my $HTTP_Version = qr/HTTP\/[0-9]+\.[0-9]+/;
376 my %params = ( headers_only => 0, sync => 0, @_ );
378 return undef unless $self->has_stdout;
380 if ( $self->should_rewind ) {
382 seek( $self->stdout, 0, SEEK_SET )
383 or croak("Couldn't seek stdout handle: '$!'");
387 my $response = HTTP::Response->new( 200, 'OK' );
388 $response->protocol('HTTP/1.1');
390 while ( my $line = readline($self->stdout) ) {
392 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
396 $response->code(500);
397 $response->message('Internal Server Error');
398 $response->date( time() );
399 $response->content( $response->error_as_HTML );
400 $response->content_type('text/html');
401 $response->content_length( length $response->content );
406 if ( $message =~ s/^($HTTP_Version)[\x09\x20]+(\d\d\d)[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
407 $response->protocol($1);
409 $response->message($3);
412 $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
414 foreach ( split /\x0D?\x0A/, $message ) {
418 if ( /^($HTTP_Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)$/o ) {
419 $response->headers->push_header( $1 => $2 );
422 # XXX what should we do on bad headers?
426 my $status = $response->header('Status');
428 if ( $status && $status =~ /^(\d\d\d)[\x09\x20]+([\x20-\xFF]+)$/ ) {
430 $response->message($2);
433 if ( !$response->date ) {
434 $response->date(time);
437 if ( $params{headers_only} ) {
439 if ( $params{sync} ) {
441 my $position = tell( $self->stdout )
442 or croak("Couldn't get file position from stdout handle: '$!'");
444 sysseek( $self->stdout, $position, SEEK_SET )
445 or croak("Couldn't seek stdout handle: '$!'");
452 my $content_length = 0;
456 my $r = read( $self->stdout, $content, 65536, $content_length );
464 $content_length += $r;
468 croak("Couldn't read response content from stdin handle: '$!'");
472 if ( $content_length ) {
474 $response->content_ref(\$content);
476 if ( !$response->content_length ) {
477 $response->content_length($content_length);
487 if ( $self->should_restore ) {
489 $self->restore_environment;
490 $self->restore_stdin;
491 $self->restore_stdout;
492 $self->restore_stderr;
494 $self->{restore} = {};
496 $self->is_restored(1);
502 sub restore_environment {
505 no warnings 'uninitialized';
507 %ENV = %{ $self->{restore}->{environment} };
513 if ( $self->has_stdin ) {
515 my $stdin = $self->{restore}->{stdin};
517 if ( $self->should_dup ) {
519 STDIN->fdopen( $stdin, '<' )
520 or croak("Couldn't restore STDIN: '$!'");
524 my $stdin_ref = $self->{restore}->{stdin_ref};
525 *$stdin_ref = $stdin;
528 if ( $self->should_rewind ) {
530 seek( $self->stdin, 0, SEEK_SET )
531 or croak("Couldn't seek stdin handle: '$!'");
539 if ( $self->has_stdout ) {
541 my $stdout = $self->{restore}->{stdout};
543 if ( $self->should_dup ) {
546 or croak("Couldn't flush STDOUT: '$!'");
548 STDOUT->fdopen( $stdout, '>' )
549 or croak("Couldn't restore STDOUT: '$!'");
553 my $stdout_ref = $self->{restore}->{stdout_ref};
554 *$stdout_ref = $stdout;
557 if ( $self->should_rewind ) {
559 seek( $self->stdout, 0, SEEK_SET )
560 or croak("Couldn't seek stdout handle: '$!'");
568 if ( $self->has_stderr ) {
570 my $stderr = $self->{restore}->{stderr};
572 if ( $self->should_dup ) {
575 or croak("Couldn't flush STDERR: '$!'");
577 STDERR->fdopen( $stderr, '>' )
578 or croak("Couldn't restore STDERR: '$!'");
582 my $stderr_ref = $self->{restore}->{stderr_ref};
583 *$stderr_ref = $stderr;
586 if ( $self->should_rewind ) {
588 seek( $self->stderr, 0, SEEK_SET )
589 or croak("Couldn't seek stderr handle: '$!'");
597 if ( $self->should_restore && $self->is_setuped && !$self->is_restored ) {
608 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
614 use HTTP::Request::AsCGI;
616 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
620 my $c = HTTP::Request::AsCGI->new($request)->setup;
624 $q->start_html('Hello World'),
625 $q->h1('Hello World'),
628 $stdout = $c->stdout;
630 # environment and descriptors will automatically be restored
631 # when $c is destructed.
634 while ( my $line = $stdout->getline ) {
640 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
646 =item new ( $request [, key => value ] )
648 Contructor, first argument must be a instance of HTTP::Request
649 followed by optional pairs of environment key and value.
653 Returns a hashref containing the environment that will be used in setup.
654 Changing the hashref after setup has been called will have no effect.
658 Setups the environment and descriptors.
662 Restores the environment and descriptors. Can only be called after setup.
666 Returns the request given to constructor.
670 Returns a HTTP::Response. Can only be called after restore.
674 Accessor for handle that will be used for STDIN, must be a real seekable
675 handle with an file descriptor. Defaults to a tempoary IO::File instance.
679 Accessor for handle that will be used for STDOUT, must be a real seekable
680 handle with an file descriptor. Defaults to a tempoary IO::File instance.
684 Accessor for handle that will be used for STDERR, must be a real seekable
685 handle with an file descriptor.
693 =item examples directory in this distribution.
695 =item L<WWW::Mechanize::CGI>
697 =item L<Test::WWW::Mechanize::CGI>
703 Thomas L. Shinnick for his valuable win32 testing.
707 Christian Hansen, C<ch@ngmedia.com>
711 This library is free software. You can redistribute it and/or modify
712 it under the same terms as perl itself.