1 package HTTP::Request::AsCGI;
6 use base 'Class::Accessor::Fast';
9 use HTTP::Response qw[];
11 use IO::File qw[SEEK_SET SEEK_END];
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 dup stdin handle to 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 dup stdout handle to 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 dup stderr handle to 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->has_stdout;
312 seek( $self->stdout, 0, SEEK_SET )
313 or croak("Couldn't seek stdout handle: '$!'");
316 my $response = HTTP::Response->new( 200, 'OK' );
317 $response->protocol('HTTP/1.1');
319 while ( my $line = $self->stdout->getline ) {
321 last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
326 $response->code(500);
327 $response->message('Internal Server Error');
328 $response->date( time );
329 $response->content( $response->error_as_HTML );
330 $response->content_type('text/html');
331 $response->content_length( length $response->content );
336 my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
337 my $Version = qr/HTTP\/[0-9]+\.[0-9]+/;
339 if ( $message =~ s/^($Version)[\x09\x20]+(\d{3})[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
341 $response->protocol($1);
343 $response->message($3);
346 $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
348 foreach ( split /\x0D?\x0A/, $message ) {
350 if ( /^($Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)[\x09\x20]*$/o ) {
351 $response->headers->push_header( $1 => $2 );
354 # XXX what should we do on bad headers?
358 my $status = $response->header('Status');
360 if ( $status && $status =~ /^(\d{3})[\x09\x20]+([\x20-\xFF]+)$/ ) {
362 $response->message($2);
365 if ( !$response->date ) {
366 $response->date(time);
369 if ( $params{headers_only} ) {
371 if ( $params{sync} ) {
373 my $position = tell( $self->stdout )
374 or croak("Couldn't get file position from stdout handle: '$!'");
376 sysseek( $self->stdout, $position, SEEK_SET )
377 or croak("Couldn't seek stdout handle: '$!'");
384 my $content_length = 0;
388 my $r = $self->stdout->read( $content, 65536, $content_length );
392 $content_length += $r;
397 croak("Couldn't read response content from stdin handle: '$!'");
401 if ( $content_length ) {
403 $response->content_ref(\$content);
405 if ( !$response->content_length ) {
406 $response->content_length($content_length);
416 if ( $self->should_restore ) {
418 $self->restore_environment;
419 $self->restore_stdin;
420 $self->restore_stdout;
421 $self->restore_stderr;
423 $self->{restore} = {};
425 $self->is_restored(1);
431 sub restore_environment {
434 no warnings 'uninitialized';
436 %ENV = %{ $self->{restore}->{environment} };
442 if ( $self->has_stdin ) {
444 my $stdin = $self->{restore}->{stdin};
446 if ( $self->should_dup ) {
448 STDIN->fdopen( $stdin, '<' )
449 or croak("Couldn't restore STDIN: '$!'");
453 my $stdin_ref = $self->{restore}->{stdin_ref};
455 *{ $stdin_ref } = $stdin;
458 if ( $self->should_rewind ) {
460 seek( $self->stdin, 0, SEEK_SET )
461 or croak("Couldn't seek stdin handle: '$!'");
469 if ( $self->has_stdout ) {
471 my $stdout = $self->{restore}->{stdout};
473 if ( $self->should_dup ) {
476 or croak("Couldn't flush STDOUT: '$!'");
478 STDOUT->fdopen( $stdout, '>' )
479 or croak("Couldn't restore STDOUT: '$!'");
483 my $stdout_ref = $self->{restore}->{stdout_ref};
485 *{ $stdout_ref } = $stdout;
488 if ( $self->should_rewind ) {
490 seek( $self->stdout, 0, SEEK_SET )
491 or croak("Couldn't seek stdout handle: '$!'");
499 if ( $self->has_stderr ) {
501 my $stderr = $self->{restore}->{stderr};
503 if ( $self->should_dup ) {
506 or croak("Couldn't flush STDERR: '$!'");
508 STDERR->fdopen( $stderr, '>' )
509 or croak("Couldn't restore STDERR: '$!'");
513 my $stderr_ref = $self->{restore}->{stderr_ref};
515 *{ $stderr_ref } = $stderr;
518 if ( $self->should_rewind ) {
520 seek( $self->stderr, 0, SEEK_SET )
521 or croak("Couldn't seek stderr handle: '$!'");
529 if ( $self->should_restore && $self->is_setuped && !$self->is_restored ) {
540 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
546 use HTTP::Request::AsCGI;
548 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
552 my $c = HTTP::Request::AsCGI->new($request)->setup;
556 $q->start_html('Hello World'),
557 $q->h1('Hello World'),
560 $stdout = $c->stdout;
562 # environment and descriptors will automatically be restored
563 # when $c is destructed.
566 while ( my $line = $stdout->getline ) {
572 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
578 =item new ( $request [, key => value ] )
580 Contructor, first argument must be a instance of HTTP::Request
581 followed by optional pairs of environment key and value.
585 Returns a hashref containing the environment that will be used in setup.
586 Changing the hashref after setup has been called will have no effect.
590 Setups the environment and descriptors.
594 Restores the environment and descriptors. Can only be called after setup.
598 Returns the request given to constructor.
602 Returns a HTTP::Response. Can only be called after restore.
606 Accessor for handle that will be used for STDIN, must be a real seekable
607 handle with an file descriptor. Defaults to a tempoary IO::File instance.
611 Accessor for handle that will be used for STDOUT, must be a real seekable
612 handle with an file descriptor. Defaults to a tempoary IO::File instance.
616 Accessor for handle that will be used for STDERR, must be a real seekable
617 handle with an file descriptor.
625 =item examples directory in this distribution.
627 =item L<WWW::Mechanize::CGI>
629 =item L<Test::WWW::Mechanize::CGI>
635 Thomas L. Shinnick for his valuable win32 testing.
639 Christian Hansen, C<ch@ngmedia.com>
643 This library is free software. You can redistribute it and/or modify
644 it under the same terms as perl itself.