lib/HTTP/Request/AsCGI.pm

   1 package HTTP::Request::AsCGI;
   2
   3 use strict;
   4 use warnings;
   5 use bytes;
   6 use base 'Class::Accessor::Fast';
   7
   8 use Carp            qw[croak];
   9 use HTTP::Response  qw[];
  10 use IO::Handle      qw[];
  11 use IO::File        qw[SEEK_SET];
  12 use Symbol          qw[];
  13
  14 __PACKAGE__->mk_accessors( qw[ is_setuped
  15                                is_prepared
  16                                is_restored
  17
  18                                should_dup
  19                                should_restore
  20                                should_rewind
  21                                should_setup_content
  22
  23                                environment
  24                                request
  25                                stdin
  26                                stdout
  27                                stderr ] );
  28
  29 our $VERSION = 0.6_01;
  30
  31 sub new {
  32     my $class  = ref $_[0] ? ref shift : shift;
  33     my $params = {};
  34
  35     if ( @_ % 2 == 0 ) {
  36         $params = { @_ };
  37     }
  38     else {
  39         $params = { request => shift, environment => { @_ } };
  40     }
  41
  42     return bless( {}, $class )->initialize($params);
  43 }
  44
  45 sub initialize {
  46     my ( $self, $params ) = @_;
  47
  48     if ( exists $params->{request} ) {
  49         $self->request( $params->{request} );
  50     }
  51     else {
  52         croak("Mandatory parameter 'request' is missing.");
  53     }
  54
  55     if ( exists $params->{environment} ) {
  56         $self->environment( $params->{environment} );
  57     }
  58     else {
  59         $self->environment( {} );
  60     }
  61
  62     if ( exists $params->{stdin} ) {
  63         $self->stdin( $params->{stdin} );
  64     }
  65     else {
  66         $self->stdin( IO::File->new_tmpfile );
  67     }
  68
  69     if ( exists $params->{stdout} ) {
  70         $self->stdout( $params->{stdout} );
  71     }
  72     else {
  73         $self->stdout( IO::File->new_tmpfile );
  74     }
  75
  76     if ( exists $params->{stderr} ) {
  77         $self->stderr( $params->{stderr} );
  78     }
  79
  80     if ( exists $params->{dup} ) {
  81         $self->should_dup( $params->{dup} ? 1 : 0 );
  82     }
  83     else {
  84         $self->should_dup(1);
  85     }
  86
  87     if ( exists $params->{restore} ) {
  88         $self->should_restore( $params->{restore} ? 1 : 0 );
  89     }
  90     else {
  91         $self->should_restore(1);
  92     }
  93
  94     if ( exists $params->{rewind} ) {
  95         $self->should_rewind( $params->{rewind} ? 1 : 0 );
  96     }
  97     else {
  98         $self->should_rewind(1);
  99     }
 100
 101     if ( exists $params->{content} ) {
 102         $self->should_setup_content( $params->{content} ? 1 : 0 );
 103     }
 104     else {
 105         $self->should_setup_content(1);
 106     }
 107
 108     $self->prepare;
 109
 110     return $self;
 111 }
 112
 113 *enviroment = \&environment;
 114
 115 sub has_stdin  { return defined $_[0]->stdin  }
 116 sub has_stdout { return defined $_[0]->stdout }
 117 sub has_stderr { return defined $_[0]->stderr }
 118
 119 sub prepare {
 120     my $self = shift;
 121
 122     my $environment = $self->environment;
 123     my $request     = $self->request;
 124
 125     my $host = $request->header('Host');
 126     my $uri  = $request->uri->clone;
 127
 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 );
 132
 133     $uri = $uri->canonical;
 134
 135     my %cgi = (
 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 || '',
 141         SCRIPT_NAME       => '/',
 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
 151     );
 152
 153     foreach my $key ( keys %cgi ) {
 154
 155         unless ( exists $environment->{ $key } ) {
 156             $environment->{ $key } = $cgi{ $key };
 157         }
 158     }
 159
 160     foreach my $field ( $self->request->headers->header_field_names ) {
 161
 162         my $key = uc("HTTP_$field");
 163         $key =~ tr/-/_/;
 164         $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
 165
 166         unless ( exists $environment->{ $key } ) {
 167             $environment->{ $key } = $self->request->headers->header($field);
 168         }
 169     }
 170
 171     unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) {
 172         $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
 173         $environment->{PATH_INFO} =~ s/^\/+/\//;
 174     }
 175
 176     $self->is_prepared(1);
 177 }
 178
 179 sub setup {
 180     my $self = shift;
 181
 182     $self->setup_content;
 183     $self->setup_stdin;
 184     $self->setup_stdout;
 185     $self->setup_stderr;
 186     $self->setup_environment;
 187
 188     if ( $INC{'CGI.pm'} ) {
 189         CGI::initialize_globals();
 190     }
 191
 192     $self->is_setuped(1);
 193
 194     return $self;
 195 }
 196
 197 sub setup_content {
 198     my $self = shift;
 199
 200     if ( $self->should_setup_content && $self->has_stdin ) {
 201
 202         if ( $self->request->content_length ) {
 203
 204             my $content = $self->request->content_ref;
 205
 206             if ( ref $content eq 'SCALAR' ) {
 207
 208                 if ( defined $$content && length $$content ) {
 209
 210                     print( { $self->stdin } $$content )
 211                       or croak("Couldn't write request content to stdin handle: '$!'");
 212
 213                     if ( $self->should_rewind ) {
 214
 215                         seek( $self->stdin, 0, SEEK_SET )
 216                           or croak("Couldn't seek stdin handle: '$!'");
 217                     }
 218                 }
 219             }
 220             else {
 221                 croak("Can't handle request content of '$content'");
 222             }
 223         }
 224     }
 225 }
 226
 227 sub setup_stdin {
 228     my $self = shift;
 229
 230     if ( $self->has_stdin ) {
 231
 232         if ( $self->should_dup ) {
 233
 234             if ( $self->should_restore ) {
 235
 236                 open( my $stdin, '<&STDIN' )
 237                   or croak("Couldn't dup STDIN: '$!'");
 238
 239                 $self->{restore}->{stdin} = $stdin;
 240             }
 241
 242             STDIN->fdopen( $self->stdin, '<' )
 243               or croak("Couldn't dup stdin handle to STDIN: '$!'");
 244         }
 245         else {
 246
 247             my $stdin = Symbol::qualify_to_ref('STDIN');
 248
 249             if ( $self->should_restore ) {
 250
 251                 $self->{restore}->{stdin}     = *$stdin;
 252                 $self->{restore}->{stdin_ref} = \*$stdin;
 253             }
 254
 255             *$stdin = $self->stdin;
 256         }
 257
 258         binmode( $self->stdin );
 259         binmode( STDIN );
 260     }
 261 }
 262
 263 sub setup_stdout {
 264     my $self = shift;
 265
 266     if ( $self->has_stdout ) {
 267
 268         if ( $self->should_dup ) {
 269
 270             if ( $self->should_restore ) {
 271
 272                 open( my $stdout, '>&STDOUT' )
 273                   or croak("Couldn't dup STDOUT: '$!'");
 274
 275                 $self->{restore}->{stdout} = $stdout;
 276             }
 277
 278             STDOUT->fdopen( $self->stdout, '>' )
 279               or croak("Couldn't dup stdout handle to STDOUT: '$!'");
 280         }
 281         else {
 282
 283             my $stdout = Symbol::qualify_to_ref('STDOUT');
 284
 285             if ( $self->should_restore ) {
 286
 287                 $self->{restore}->{stdout}     = *$stdout;
 288                 $self->{restore}->{stdout_ref} = \*$stdout;
 289             }
 290
 291             *$stdout = $self->stdout;
 292         }
 293
 294         binmode( $self->stdout );
 295         binmode( STDOUT);
 296     }
 297 }
 298
 299 sub setup_stderr {
 300     my $self = shift;
 301
 302     if ( $self->has_stderr ) {
 303
 304         if ( $self->should_dup ) {
 305
 306             if ( $self->should_restore ) {
 307
 308                 open( my $stderr, '>&STDERR' )
 309                   or croak("Couldn't dup STDERR: '$!'");
 310
 311                 $self->{restore}->{stderr} = $stderr;
 312             }
 313
 314             STDERR->fdopen( $self->stderr, '>' )
 315               or croak("Couldn't dup stderr handle to STDERR: '$!'");
 316         }
 317         else {
 318
 319             my $stderr = Symbol::qualify_to_ref('STDERR');
 320
 321             if ( $self->should_restore ) {
 322
 323                 $self->{restore}->{stderr}     = *$stderr;
 324                 $self->{restore}->{stderr_ref} = \*$stderr;
 325             }
 326
 327             *$stderr = $self->stderr;
 328         }
 329
 330         binmode( $self->stderr );
 331         binmode( STDERR );
 332     }
 333 }
 334
 335 sub setup_environment {
 336     my $self = shift;
 337
 338     no warnings 'uninitialized';
 339
 340     if ( $self->should_restore ) {
 341         $self->{restore}->{environment} = { %ENV };
 342     }
 343
 344     %ENV = %{ $self->environment };
 345 }
 346
 347 sub response {
 348     my $self   = shift;
 349     my %params = ( headers_only => 0, sync => 0, @_ );
 350
 351     return undef unless $self->has_stdout;
 352
 353     if ( $self->should_rewind ) {
 354
 355         seek( $self->stdout, 0, SEEK_SET )
 356           or croak("Couldn't seek stdout handle: '$!'");
 357     }
 358
 359     my $message  = undef;
 360     my $response = HTTP::Response->new( 200, 'OK' );
 361        $response->protocol('HTTP/1.1');
 362
 363     while ( my $line = $self->stdout->getline ) {
 364         $message .= $line;
 365         last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
 366     }
 367
 368     if ( !$message ) {
 369
 370         $response->code(500);
 371         $response->message('Internal Server Error');
 372         $response->date( time );
 373         $response->content( $response->error_as_HTML );
 374         $response->content_type('text/html');
 375         $response->content_length( length $response->content );
 376
 377         return $response;
 378     }
 379
 380     my $Token   = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
 381     my $Version = qr/HTTP\/[0-9]+\.[0-9]+/;
 382
 383     if ( $message =~ s/^($Version)[\x09\x20]+(\d{3})[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
 384
 385         $response->protocol($1);
 386         $response->code($2);
 387         $response->message($3);
 388     }
 389
 390     $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
 391
 392     foreach ( split /\x0D?\x0A/, $message ) {
 393
 394         if ( /^($Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)[\x09\x20]*$/o ) {
 395             $response->headers->push_header( $1 => $2 );
 396         }
 397         else {
 398             # XXX what should we do on bad headers?
 399         }
 400     }
 401
 402     my $status = $response->header('Status');
 403
 404     if ( $status && $status =~ /^(\d{3})[\x09\x20]+([\x20-\xFF]+)$/ ) {
 405         $response->code($1);
 406         $response->message($2);
 407     }
 408
 409     if ( !$response->date ) {
 410         $response->date(time);
 411     }
 412
 413     if ( $params{headers_only} ) {
 414
 415         if ( $params{sync} ) {
 416
 417             my $position = tell( $self->stdout )
 418               or croak("Couldn't get file position from stdout handle: '$!'");
 419
 420             sysseek( $self->stdout, $position, SEEK_SET )
 421               or croak("Couldn't seek stdout handle: '$!'");
 422         }
 423
 424         return $response;
 425     }
 426
 427     my $content        = undef;
 428     my $content_length = 0;
 429
 430     while () {
 431
 432         my $r = $self->stdout->read( $content, 65536, $content_length );
 433
 434         if ( defined $r ) {
 435
 436             $content_length += $r;
 437
 438             last unless $r;
 439         }
 440         else {
 441             croak("Couldn't read response content from stdin handle: '$!'");
 442         }
 443     }
 444
 445     if ( $content_length ) {
 446
 447         $response->content_ref(\$content);
 448
 449         if ( !$response->content_length ) {
 450             $response->content_length($content_length);
 451         }
 452     }
 453
 454     return $response;
 455 }
 456
 457 sub restore {
 458     my $self = shift;
 459
 460     if ( $self->should_restore ) {
 461
 462         $self->restore_environment;
 463         $self->restore_stdin;
 464         $self->restore_stdout;
 465         $self->restore_stderr;
 466
 467         $self->{restore} = {};
 468
 469         $self->is_restored(1);
 470     }
 471
 472     return $self;
 473 }
 474
 475 sub restore_environment {
 476     my $self = shift;
 477
 478     no warnings 'uninitialized';
 479
 480     %ENV = %{ $self->{restore}->{environment} };
 481 }
 482
 483 sub restore_stdin {
 484     my $self = shift;
 485
 486     if ( $self->has_stdin ) {
 487
 488         my $stdin = $self->{restore}->{stdin};
 489
 490         if ( $self->should_dup ) {
 491
 492             STDIN->fdopen( $stdin, '<' )
 493               or croak("Couldn't restore STDIN: '$!'");
 494         }
 495         else {
 496
 497             my $stdin_ref = $self->{restore}->{stdin_ref};
 498               *$stdin_ref = $stdin;
 499         }
 500
 501         if ( $self->should_rewind ) {
 502
 503             seek( $self->stdin, 0, SEEK_SET )
 504               or croak("Couldn't seek stdin handle: '$!'");
 505         }
 506     }
 507 }
 508
 509 sub restore_stdout {
 510     my $self = shift;
 511
 512     if ( $self->has_stdout ) {
 513
 514         my $stdout = $self->{restore}->{stdout};
 515
 516         if ( $self->should_dup ) {
 517
 518             STDOUT->flush
 519               or croak("Couldn't flush STDOUT: '$!'");
 520
 521             STDOUT->fdopen( $stdout, '>' )
 522               or croak("Couldn't restore STDOUT: '$!'");
 523         }
 524         else {
 525
 526             my $stdout_ref = $self->{restore}->{stdout_ref};
 527               *$stdout_ref = $stdout;
 528         }
 529
 530         if ( $self->should_rewind ) {
 531
 532             seek( $self->stdout, 0, SEEK_SET )
 533               or croak("Couldn't seek stdout handle: '$!'");
 534         }
 535     }
 536 }
 537
 538 sub restore_stderr {
 539     my $self = shift;
 540
 541     if ( $self->has_stderr ) {
 542
 543         my $stderr = $self->{restore}->{stderr};
 544
 545         if ( $self->should_dup ) {
 546
 547             STDERR->flush
 548               or croak("Couldn't flush STDERR: '$!'");
 549
 550             STDERR->fdopen( $stderr, '>' )
 551               or croak("Couldn't restore STDERR: '$!'");
 552         }
 553         else {
 554
 555             my $stderr_ref = $self->{restore}->{stderr_ref};
 556               *$stderr_ref = $stderr;
 557         }
 558
 559         if ( $self->should_rewind ) {
 560
 561             seek( $self->stderr, 0, SEEK_SET )
 562               or croak("Couldn't seek stderr handle: '$!'");
 563         }
 564     }
 565 }
 566
 567 sub DESTROY {
 568     my $self = shift;
 569
 570     if ( $self->should_restore && $self->is_setuped && !$self->is_restored ) {
 571         $self->restore;
 572     }
 573 }
 574
 575 1;
 576
 577 __END__
 578
 579 =head1 NAME
 580
 581 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
 582
 583 =head1 SYNOPSIS
 584
 585     use CGI;
 586     use HTTP::Request;
 587     use HTTP::Request::AsCGI;
 588
 589     my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
 590     my $stdout;
 591
 592     {
 593         my $c = HTTP::Request::AsCGI->new($request)->setup;
 594         my $q = CGI->new;
 595
 596         print $q->header,
 597               $q->start_html('Hello World'),
 598               $q->h1('Hello World'),
 599               $q->end_html;
 600
 601         $stdout = $c->stdout;
 602
 603         # environment and descriptors will automatically be restored
 604         # when $c is destructed.
 605     }
 606
 607     while ( my $line = $stdout->getline ) {
 608         print $line;
 609     }
 610
 611 =head1 DESCRIPTION
 612
 613 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
 614
 615 =head1 METHODS
 616
 617 =over 4
 618
 619 =item new ( $request [, key => value ] )
 620
 621 Contructor, first argument must be a instance of HTTP::Request
 622 followed by optional pairs of environment key and value.
 623
 624 =item environment
 625
 626 Returns a hashref containing the environment that will be used in setup.
 627 Changing the hashref after setup has been called will have no effect.
 628
 629 =item setup
 630
 631 Setups the environment and descriptors.
 632
 633 =item restore
 634
 635 Restores the environment and descriptors. Can only be called after setup.
 636
 637 =item request
 638
 639 Returns the request given to constructor.
 640
 641 =item response
 642
 643 Returns a HTTP::Response. Can only be called after restore.
 644
 645 =item stdin
 646
 647 Accessor for handle that will be used for STDIN, must be a real seekable
 648 handle with an file descriptor. Defaults to a tempoary IO::File instance.
 649
 650 =item stdout
 651
 652 Accessor for handle that will be used for STDOUT, must be a real seekable
 653 handle with an file descriptor. Defaults to a tempoary IO::File instance.
 654
 655 =item stderr
 656
 657 Accessor for handle that will be used for STDERR, must be a real seekable
 658 handle with an file descriptor.
 659
 660 =back
 661
 662 =head1 SEE ALSO
 663
 664 =over 4
 665
 666 =item examples directory in this distribution.
 667
 668 =item L<WWW::Mechanize::CGI>
 669
 670 =item L<Test::WWW::Mechanize::CGI>
 671
 672 =back
 673
 674 =head1 THANKS TO
 675
 676 Thomas L. Shinnick for his valuable win32 testing.
 677
 678 =head1 AUTHOR
 679
 680 Christian Hansen, C<ch@ngmedia.com>
 681
 682 =head1 LICENSE
 683
 684 This library is free software. You can redistribute it and/or modify
 685 it under the same terms as perl itself.
 686
 687 =cut