convert repository to git
[catagits/HTTP-Request-AsCGI.git] / lib / HTTP / Request / AsCGI.pm
CommitLineData
b2e1304d 1package HTTP::Request::AsCGI;
f1dd0792 2# ABSTRACT: Set up a CGI environment from an HTTP::Request
b2e1304d 3use strict;
4use warnings;
090cc060 5use bytes;
b2e1304d 6use base 'Class::Accessor::Fast';
7
b332ee65 8use Carp;
9use HTTP::Response;
10use IO::Handle;
11use IO::File;
bb6e4a92 12use URI ();
11454d47 13use URI::Escape ();
b2e1304d 14
5e458489 15__PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]);
16
17# old typo
cfe19df0 18
5e458489 19=begin Pod::Coverage
20
21 enviroment
22
23=end Pod::Coverage
24
25=cut
26
27*enviroment = \&environment;
5889d784 28
bb6e4a92 29my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved;
30sub _uri_safe_unescape {
31 my ($s) = @_;
8596f5a5 32 $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : pack('C', hex($1))/ge;
33 $s
bb6e4a92 34}
35
b2e1304d 36sub new {
b332ee65 37 my $class = shift;
38 my $request = shift;
26e3d92b 39
b332ee65 40 unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
41 croak(qq/usage: $class->new( \$request [, key => value] )/);
26e3d92b 42 }
43
b332ee65 44 my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
45 $self->request($request);
46 $self->stdin( IO::File->new_tmpfile );
47 $self->stdout( IO::File->new_tmpfile );
b2e1304d 48
30efa07d 49 my $host = $request->header('Host');
50 my $uri = $request->uri->clone;
51 $uri->scheme('http') unless $uri->scheme;
52 $uri->host('localhost') unless $uri->host;
53 $uri->port(80) unless $uri->port;
a3875fc6 54 $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
4e0afe7d 55
b3996e05 56 # Get it before canonicalized so REQUEST_URI can be as raw as possible
57 my $request_uri = $uri->path_query;
58
ca38286c 59 $uri = $uri->canonical;
30efa07d 60
5e458489 61 my $environment = {
b2e1304d 62 GATEWAY_INTERFACE => 'CGI/1.1',
30efa07d 63 HTTP_HOST => $uri->host_port,
a3875fc6 64 HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875
8596f5a5 65 PATH_INFO => $uri->path,
a3875fc6 66 QUERY_STRING => $uri->query || '',
67 SCRIPT_NAME => '/',
68 SERVER_NAME => $uri->host,
69 SERVER_PORT => $uri->port,
70 SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
cfe19df0 71 SERVER_SOFTWARE => 'HTTP-Request-AsCGI/' . our $VERSION,
a3875fc6 72 REMOTE_ADDR => '127.0.0.1',
73 REMOTE_HOST => 'localhost',
74 REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
b3996e05 75 REQUEST_URI => $request_uri, # not in RFC 3875
b332ee65 76 REQUEST_METHOD => $request->method,
77 @_
78 };
26e3d92b 79
4d6b96d8 80 # RFC 3875 says PATH_INFO is not URI-encoded. That's really
81 # annoying for applications that you can't tell "%2F" vs "/", but
82 # doing the partial decoding then makes it impossible to tell
83 # "%252F" vs "%2F". Encoding everything is more compatible to what
84 # web servers like Apache or lighttpd do, anyways.
85 $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO});
8596f5a5 86
9c216915 87 foreach my $field ( $request->headers->header_field_names ) {
b2e1304d 88
ca38286c 89 my $key = uc("HTTP_$field");
2aaf55bc 90 $key =~ tr/-/_/;
ca38286c 91 $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
b2e1304d 92
5e458489 93 unless ( exists $environment->{$key} ) {
94 $environment->{$key} = $request->headers->header($field);
b2e1304d 95 }
96 }
97
5e458489 98 unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
99 $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
100 $environment->{PATH_INFO} =~ s/^\/+/\//;
26e3d92b 101 }
102
5e458489 103 $self->environment($environment);
b332ee65 104
105 return $self;
26e3d92b 106}
107
108sub setup {
109 my $self = shift;
110
5e458489 111 $self->{restore}->{environment} = {%ENV};
26e3d92b 112
b332ee65 113 binmode( $self->stdin );
26e3d92b 114
b332ee65 115 if ( $self->request->content_length ) {
26e3d92b 116
bd90442e 117 $self->stdin->print($self->request->content)
b332ee65 118 or croak("Can't write request content to stdin handle: $!");
b2e1304d 119
bd90442e 120 $self->stdin->seek(0, SEEK_SET)
b332ee65 121 or croak("Can't seek stdin handle: $!");
bd90442e 122
123 $self->stdin->flush
124 or croak("Can't flush stdin handle: $!");
b2e1304d 125 }
26e3d92b 126
b2c02cd0 127 open( $self->{restore}->{stdin}, '<&'. STDIN->fileno )
b332ee65 128 or croak("Can't dup stdin: $!");
b2e1304d 129
b2c02cd0 130 open( STDIN, '<&='. $self->stdin->fileno )
b332ee65 131 or croak("Can't open stdin: $!");
ca38286c 132
b332ee65 133 binmode( STDIN );
26e3d92b 134
b332ee65 135 if ( $self->stdout ) {
26e3d92b 136
b2c02cd0 137 open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno )
b332ee65 138 or croak("Can't dup stdout: $!");
26e3d92b 139
b2c02cd0 140 open( STDOUT, '>&='. $self->stdout->fileno )
b332ee65 141 or croak("Can't open stdout: $!");
76391122 142
a3875fc6 143 binmode( $self->stdout );
144 binmode( STDOUT);
145 }
30efa07d 146
b332ee65 147 if ( $self->stderr ) {
090cc060 148
b2c02cd0 149 open( $self->{restore}->{stderr}, '>&'. STDERR->fileno )
b332ee65 150 or croak("Can't dup stderr: $!");
441eeb04 151
b2c02cd0 152 open( STDERR, '>&='. $self->stderr->fileno )
b332ee65 153 or croak("Can't open stderr: $!");
26e3d92b 154
155 binmode( $self->stderr );
156 binmode( STDERR );
157 }
b2e1304d 158
9c216915 159 {
160 no warnings 'uninitialized';
903274b1 161 %ENV = (%ENV, %{ $self->environment });
5889d784 162 }
163
9c216915 164 if ( $INC{'CGI.pm'} ) {
165 CGI::initialize_globals();
166 }
167
b332ee65 168 $self->{setuped}++;
9c216915 169
170 return $self;
5889d784 171}
172
780060e5 173sub response {
b332ee65 174 my ( $self, $callback ) = @_;
780060e5 175
b332ee65 176 return undef unless $self->stdout;
780060e5 177
b332ee65 178 seek( $self->stdout, 0, SEEK_SET )
179 or croak("Can't seek stdout handle: $!");
14f243e8 180
b332ee65 181 my $headers;
182 while ( my $line = $self->stdout->getline ) {
183 $headers .= $line;
184 last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
780060e5 185 }
15e50838 186
b332ee65 187 unless ( defined $headers ) {
188 $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
780060e5 189 }
190
b332ee65 191 unless ( $headers =~ /^HTTP/ ) {
192 $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
4e0afe7d 193 }
decf17dc 194
b332ee65 195 my $response = HTTP::Response->parse($headers);
196 $response->date( time() ) unless $response->date;
decf17dc 197
b332ee65 198 my $message = $response->message;
199 my $status = $response->header('Status');
780060e5 200
b332ee65 201 if ( $message && $message =~ /^(.+)\x0d$/ ) {
202 $response->message($1);
780060e5 203 }
26e3d92b 204
b332ee65 205 if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
780060e5 206
b332ee65 207 my $code = $1;
208 my $message = $2 || HTTP::Status::status_message($code);
4e0afe7d 209
b332ee65 210 $response->code($code);
211 $response->message($message);
4e0afe7d 212 }
15e50838 213
b332ee65 214 my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
780060e5 215
b332ee65 216 if ( $response->code == 500 && !$length ) {
4e0afe7d 217
b332ee65 218 $response->content( $response->error_as_HTML );
219 $response->content_type('text/html');
4e0afe7d 220
4d6e304a 221 return $response;
780060e5 222 }
4e0afe7d 223
b332ee65 224 if ($callback) {
4d6e304a 225
b332ee65 226 my $handle = $self->stdout;
4d6e304a 227
b332ee65 228 $response->content( sub {
4e0afe7d 229
b332ee65 230 if ( $handle->read( my $buffer, 4096 ) ) {
231 return $buffer;
474703e4 232 }
b332ee65 233
234 return undef;
235 });
4d6e304a 236 }
b332ee65 237 else {
4d6e304a 238
292e2b64 239 my $length = defined $response->content ? length( $response->content ) : 0;
4d6e304a 240
b332ee65 241 while ( $self->stdout->read( my $buffer, 4096 ) ) {
242 $length += length($buffer);
243 $response->add_content($buffer);
244 }
4e0afe7d 245
b332ee65 246 if ( $length && !$response->content_length ) {
247 $response->content_length($length);
decf17dc 248 }
780060e5 249 }
250
780060e5 251 return $response;
252}
253
b2e1304d 254sub restore {
255 my $self = shift;
4e0afe7d 256
9c216915 257 {
258 no warnings 'uninitialized';
5e458489 259 %ENV = %{ $self->{restore}->{environment} };
9c216915 260 }
12852959 261
b2c02cd0 262 open( STDIN, '<&'. fileno($self->{restore}->{stdin}) )
b332ee65 263 or croak("Can't restore stdin: $!");
30efa07d 264
b332ee65 265 sysseek( $self->stdin, 0, SEEK_SET )
266 or croak("Can't seek stdin: $!");
30efa07d 267
b332ee65 268 if ( $self->{restore}->{stdout} ) {
26e3d92b 269
b332ee65 270 STDOUT->flush
271 or croak("Can't flush stdout: $!");
26e3d92b 272
b2c02cd0 273 open( STDOUT, '>&'. fileno($self->{restore}->{stdout}) )
b332ee65 274 or croak("Can't restore stdout: $!");
090cc060 275
b332ee65 276 sysseek( $self->stdout, 0, SEEK_SET )
277 or croak("Can't seek stdout: $!");
a3875fc6 278 }
26e3d92b 279
b332ee65 280 if ( $self->{restore}->{stderr} ) {
12852959 281
b332ee65 282 STDERR->flush
283 or croak("Can't flush stderr: $!");
30efa07d 284
b2c02cd0 285 open( STDERR, '>&'. fileno($self->{restore}->{stderr}) )
b332ee65 286 or croak("Can't restore stderr: $!");
090cc060 287
b332ee65 288 sysseek( $self->stderr, 0, SEEK_SET )
289 or croak("Can't seek stderr: $!");
6f5fb9a7 290 }
090cc060 291
b332ee65 292 $self->{restored}++;
9c216915 293
294 return $self;
b2e1304d 295}
296
297sub DESTROY {
298 my $self = shift;
b332ee65 299 $self->restore if $self->{setuped} && !$self->{restored};
b2e1304d 300}
301
3021;
303
304__END__
305
b2e1304d 306=head1 SYNOPSIS
307
bd7813ac 308 use CGI;
309 use HTTP::Request;
310 use HTTP::Request::AsCGI;
15e50838 311
bd7813ac 312 my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
313 my $stdout;
15e50838 314
bd7813ac 315 {
316 my $c = HTTP::Request::AsCGI->new($request)->setup;
317 my $q = CGI->new;
15e50838 318
bd7813ac 319 print $q->header,
320 $q->start_html('Hello World'),
321 $q->h1('Hello World'),
322 $q->end_html;
15e50838 323
bd7813ac 324 $stdout = $c->stdout;
15e50838 325
5e458489 326 # environment and descriptors will automatically be restored
2d51e42f 327 # when $c is destructed.
bd7813ac 328 }
15e50838 329
bd7813ac 330 while ( my $line = $stdout->getline ) {
331 print $line;
332 }
15e50838 333
b2e1304d 334=head1 DESCRIPTION
335
9a0e0b26 336Provides a convenient way of setting up an CGI environment from an HTTP::Request.
2d51e42f 337
b2e1304d 338=head1 METHODS
339
15e50838 340=over 4
14f243e8 341
b332ee65 342=item new ( $request [, key => value ] )
14f243e8 343
9a0e0b26 344Constructor. The first argument must be a instance of HTTP::Request, followed
345by optional pairs of environment key and value.
14f243e8 346
5e458489 347=item environment
14f243e8 348
15e50838 349Returns a hashref containing the environment that will be used in setup.
b332ee65 350Changing the hashref after setup has been called will have no effect.
14f243e8 351
b332ee65 352=item setup
9c216915 353
9a0e0b26 354Sets up the environment and descriptors.
9c216915 355
b332ee65 356=item restore
9c216915 357
5e458489 358Restores the environment and descriptors. Can only be called after setup.
9c216915 359
b332ee65 360=item request
9c216915 361
b332ee65 362Returns the request given to constructor.
9c216915 363
b332ee65 364=item response
9c216915 365
b332ee65 366Returns a HTTP::Response. Can only be called after restore.
9c216915 367
b332ee65 368=item stdin
9c216915 369
b332ee65 370Accessor for handle that will be used for STDIN, must be a real seekable
371handle with an file descriptor. Defaults to a tempoary IO::File instance.
14f243e8 372
b332ee65 373=item stdout
14f243e8 374
b332ee65 375Accessor for handle that will be used for STDOUT, must be a real seekable
376handle with an file descriptor. Defaults to a tempoary IO::File instance.
9c216915 377
b332ee65 378=item stderr
14f243e8 379
b332ee65 380Accessor for handle that will be used for STDERR, must be a real seekable
381handle with an file descriptor.
14f243e8 382
383=back
b2e1304d 384
74fbb9dd 385=head1 SEE ALSO
386
387=over 4
388
389=item examples directory in this distribution.
390
391=item L<WWW::Mechanize::CGI>
392
393=item L<Test::WWW::Mechanize::CGI>
394
395=back
396
2d51e42f 397=head1 THANKS TO
17b370b0 398
399Thomas L. Shinnick for his valuable win32 testing.
400
b2e1304d 401=cut