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_setup
  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     if ( $self->is_setup ) {
 183         croak("An attempt was made to setup environment variables and STD handles which has already been setup.");
 184     }
 185
 186     $self->setup_content;
 187     $self->setup_stdin;
 188     $self->setup_stdout;
 189     $self->setup_stderr;
 190     $self->setup_environment;
 191
 192     if ( $INC{'CGI.pm'} ) {
 193         CGI::initialize_globals();
 194     }
 195
 196     $self->is_setup(1);
 197
 198     return $self;
 199 }
 200
 201 sub write_content {
 202     my ( $self, $handle ) = @_;
 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 SCALAR to stdin handle: '$!'");
 212
 213             if ( $self->should_rewind ) {
 214
 215                 seek( $self->stdin, 0, SEEK_SET )
 216                   or croak("Couldn't rewind stdin handle: '$!'");
 217             }
 218         }
 219     }
 220     elsif ( ref($content) eq 'CODE' ) {
 221
 222         while () {
 223
 224             my $chunk = &$content();
 225
 226             if ( defined($chunk) && length($chunk) ) {
 227
 228                 print( { $self->stdin } $chunk )
 229                   or croak("Couldn't write request content callback to stdin handle: '$!'");
 230             }
 231             else {
 232                 last;
 233             }
 234         }
 235
 236         if ( $self->should_rewind ) {
 237
 238             seek( $self->stdin, 0, SEEK_SET )
 239               or croak("Couldn't rewind stdin handle: '$!'");
 240         }
 241     }
 242     else {
 243         croak("Couldn't write request content to stdin handle: 'Unknown request content $content'");
 244     }
 245 }
 246
 247 sub setup_content {
 248     my $self = shift;
 249
 250     if ( $self->should_setup_content && $self->has_stdin ) {
 251         $self->write_content($self->stdin);
 252     }
 253 }
 254
 255 sub setup_stdin {
 256     my $self = shift;
 257
 258     if ( $self->has_stdin ) {
 259
 260         if ( $self->should_dup ) {
 261
 262             if ( $self->should_restore ) {
 263
 264                 open( my $stdin, '<&STDIN' )
 265                   or croak("Couldn't dup STDIN: '$!'");
 266
 267                 $self->{restore}->{stdin} = $stdin;
 268             }
 269
 270             open( STDIN, '<&' . fileno($self->stdin) )
 271               or croak("Couldn't dup stdin handle to STDIN: '$!'");
 272         }
 273         else {
 274
 275             my $stdin = Symbol::qualify_to_ref('STDIN');
 276
 277             if ( $self->should_restore ) {
 278
 279                 $self->{restore}->{stdin}     = *$stdin;
 280                 $self->{restore}->{stdin_ref} = \*$stdin;
 281             }
 282
 283             *$stdin = $self->stdin;
 284         }
 285
 286         binmode( $self->stdin );
 287         binmode( STDIN );
 288     }
 289 }
 290
 291 sub setup_stdout {
 292     my $self = shift;
 293
 294     if ( $self->has_stdout ) {
 295
 296         if ( $self->should_dup ) {
 297
 298             if ( $self->should_restore ) {
 299
 300                 open( my $stdout, '>&STDOUT' )
 301                   or croak("Couldn't dup STDOUT: '$!'");
 302
 303                 $self->{restore}->{stdout} = $stdout;
 304             }
 305
 306             open( STDOUT, '>&' . fileno($self->stdout) )
 307               or croak("Couldn't dup stdout handle to STDOUT: '$!'");
 308         }
 309         else {
 310
 311             my $stdout = Symbol::qualify_to_ref('STDOUT');
 312
 313             if ( $self->should_restore ) {
 314
 315                 $self->{restore}->{stdout}     = *$stdout;
 316                 $self->{restore}->{stdout_ref} = \*$stdout;
 317             }
 318
 319             *$stdout = $self->stdout;
 320         }
 321
 322         binmode( $self->stdout );
 323         binmode( STDOUT);
 324     }
 325 }
 326
 327 sub setup_stderr {
 328     my $self = shift;
 329
 330     if ( $self->has_stderr ) {
 331
 332         if ( $self->should_dup ) {
 333
 334             if ( $self->should_restore ) {
 335
 336                 open( my $stderr, '>&STDERR' )
 337                   or croak("Couldn't dup STDERR: '$!'");
 338
 339                 $self->{restore}->{stderr} = $stderr;
 340             }
 341
 342             open( STDERR, '>&' . fileno($self->stderr) )
 343               or croak("Couldn't dup stdout handle to STDOUT: '$!'");
 344         }
 345         else {
 346
 347             my $stderr = Symbol::qualify_to_ref('STDERR');
 348
 349             if ( $self->should_restore ) {
 350
 351                 $self->{restore}->{stderr}     = *$stderr;
 352                 $self->{restore}->{stderr_ref} = \*$stderr;
 353             }
 354
 355             *$stderr = $self->stderr;
 356         }
 357
 358         binmode( $self->stderr );
 359         binmode( STDERR );
 360     }
 361 }
 362
 363 sub setup_environment {
 364     my $self = shift;
 365
 366     no warnings 'uninitialized';
 367
 368     if ( $self->should_restore ) {
 369         $self->{restore}->{environment} = { %ENV };
 370     }
 371
 372     %ENV = %{ $self->environment };
 373 }
 374
 375 my $HTTP_Token   = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
 376 my $HTTP_Version = qr/HTTP\/[0-9]+\.[0-9]+/;
 377
 378 sub response {
 379     my $self   = shift;
 380     my %params = ( headers_only => 0, sync => 0, @_ );
 381
 382     return undef unless $self->has_stdout;
 383
 384     if ( $self->should_rewind ) {
 385
 386         seek( $self->stdout, 0, SEEK_SET )
 387           or croak("Couldn't seek stdout handle: '$!'");
 388     }
 389
 390     my $message  = undef;
 391     my $response = HTTP::Response->new( 200, 'OK' );
 392        $response->protocol('HTTP/1.1');
 393
 394     while ( my $line = readline($self->stdout) ) {
 395
 396         if ( !$message && $line =~ /^\x0d?\x0a$/ ) {
 397             next;
 398         }
 399         else {
 400             $message .= $line;
 401         }
 402
 403         last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
 404     }
 405
 406     if ( !$message ) {
 407         $response->code(500);
 408         $response->message('Internal Server Error');
 409         $response->date( time() );
 410         $response->content( $response->error_as_HTML );
 411         $response->content_type('text/html');
 412         $response->content_length( length $response->content );
 413
 414         return $response;
 415     }
 416
 417     if ( $message =~ s/^($HTTP_Version)[\x09\x20]+(\d\d\d)[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
 418         $response->protocol($1);
 419         $response->code($2);
 420         $response->message($3);
 421     }
 422
 423     $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
 424
 425     foreach ( split /\x0D?\x0A/, $message ) {
 426
 427         s/[\x09\x20]*$//;
 428
 429         if ( /^($HTTP_Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)$/o ) {
 430             $response->headers->push_header( $1 => $2 );
 431         }
 432         else {
 433             # XXX what should we do on bad headers?
 434         }
 435     }
 436
 437     my $status = $response->header('Status');
 438
 439     if ( $status && $status =~ /^(\d\d\d)[\x09\x20]+([\x20-\xFF]+)$/ ) {
 440         $response->code($1);
 441         $response->message($2);
 442     }
 443
 444     if ( !$response->date ) {
 445         $response->date(time());
 446     }
 447
 448     if ( $params{headers_only} ) {
 449
 450         if ( $params{sync} ) {
 451
 452             my $position = tell( $self->stdout )
 453               or croak("Couldn't get file position from stdout handle: '$!'");
 454
 455             sysseek( $self->stdout, $position, SEEK_SET )
 456               or croak("Couldn't seek stdout handle: '$!'");
 457         }
 458
 459         return $response;
 460     }
 461
 462     my $content        = undef;
 463     my $content_length = 0;
 464
 465     while () {
 466
 467         my $r = read( $self->stdout, $content, 65536, $content_length );
 468
 469         if ( defined $r ) {
 470
 471             if ( $r == 0 ) {
 472                 last;
 473             }
 474             else {
 475                 $content_length += $r;
 476             }
 477         }
 478         else {
 479             croak("Couldn't read response content from stdin handle: '$!'");
 480         }
 481     }
 482
 483     if ( $content_length ) {
 484
 485         $response->content_ref(\$content);
 486
 487         if ( !$response->content_length ) {
 488             $response->content_length($content_length);
 489         }
 490     }
 491
 492     return $response;
 493 }
 494
 495 sub restore {
 496     my $self = shift;
 497
 498     if ( !$self->should_restore ) {
 499         croak("An attempt was made to restore environment variables and STD handles which has not been saved.");
 500     }
 501
 502     if ( !$self->is_setup ) {
 503         croak("An attempt was made to restore environment variables and STD handles which has not been setup.");
 504     }
 505
 506     if ( $self->is_restored ) {
 507         croak("An attempt was made to restore environment variables and STD handles which has already been restored.");
 508     }
 509
 510     $self->restore_environment;
 511     $self->restore_stdin;
 512     $self->restore_stdout;
 513     $self->restore_stderr;
 514
 515     $self->{restore} = {};
 516
 517     $self->is_restored(1);
 518
 519     return $self;
 520 }
 521
 522 sub restore_environment {
 523     my $self = shift;
 524
 525     no warnings 'uninitialized';
 526
 527     %ENV = %{ $self->{restore}->{environment} };
 528 }
 529
 530 sub restore_stdin {
 531     my $self = shift;
 532
 533     if ( $self->has_stdin ) {
 534
 535         my $stdin = $self->{restore}->{stdin};
 536
 537         if ( $self->should_dup ) {
 538
 539             STDIN->fdopen( fileno($stdin), '<' )
 540               or croak("Couldn't restore STDIN: '$!'");
 541         }
 542         else {
 543
 544             my $stdin_ref = $self->{restore}->{stdin_ref};
 545               *$stdin_ref = $stdin;
 546         }
 547
 548         if ( $self->should_rewind ) {
 549
 550             seek( $self->stdin, 0, SEEK_SET )
 551               or croak("Couldn't rewind stdin handle: '$!'");
 552         }
 553     }
 554 }
 555
 556 sub restore_stdout {
 557     my $self = shift;
 558
 559     if ( $self->has_stdout ) {
 560
 561         my $stdout = $self->{restore}->{stdout};
 562
 563         if ( $self->should_dup ) {
 564
 565             STDOUT->flush
 566               or croak("Couldn't flush STDOUT: '$!'");
 567
 568             STDOUT->fdopen( fileno($stdout), '>' )
 569               or croak("Couldn't restore STDOUT: '$!'");
 570         }
 571         else {
 572
 573             my $stdout_ref = $self->{restore}->{stdout_ref};
 574               *$stdout_ref = $stdout;
 575         }
 576
 577         if ( $self->should_rewind ) {
 578
 579             seek( $self->stdout, 0, SEEK_SET )
 580               or croak("Couldn't rewind stdout handle: '$!'");
 581         }
 582     }
 583 }
 584
 585 sub restore_stderr {
 586     my $self = shift;
 587
 588     if ( $self->has_stderr ) {
 589
 590         my $stderr = $self->{restore}->{stderr};
 591
 592         if ( $self->should_dup ) {
 593
 594             STDERR->flush
 595               or croak("Couldn't flush STDERR: '$!'");
 596
 597             STDERR->fdopen( fileno($stderr), '>' )
 598               or croak("Couldn't restore STDERR: '$!'");
 599         }
 600         else {
 601
 602             my $stderr_ref = $self->{restore}->{stderr_ref};
 603               *$stderr_ref = $stderr;
 604         }
 605
 606         if ( $self->should_rewind ) {
 607
 608             seek( $self->stderr, 0, SEEK_SET )
 609               or croak("Couldn't rewind stderr handle: '$!'");
 610         }
 611     }
 612 }
 613
 614 sub DESTROY {
 615     my $self = shift;
 616
 617     if ( $self->should_restore && $self->is_setup && !$self->is_restored ) {
 618         $self->restore;
 619     }
 620 }
 621
 622 1;
 623
 624 __END__
 625
 626 =head1 NAME
 627
 628 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
 629
 630 =head1 SYNOPSIS
 631
 632     use CGI;
 633     use HTTP::Request;
 634     use HTTP::Request::AsCGI;
 635
 636     my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
 637     my $stdout;
 638
 639     {
 640         my $c = HTTP::Request::AsCGI->new($request)->setup;
 641         my $q = CGI->new;
 642
 643         print $q->header,
 644               $q->start_html('Hello World'),
 645               $q->h1('Hello World'),
 646               $q->end_html;
 647
 648         $stdout = $c->stdout;
 649
 650         # environment and descriptors is automatically restored
 651         # when $c is destructed.
 652     }
 653
 654     while ( my $line = $stdout->getline ) {
 655         print $line;
 656     }
 657
 658 =head1 DESCRIPTION
 659
 660 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
 661
 662 =head1 METHODS
 663
 664 =over 4
 665
 666 =item * new
 667
 668 Contructor
 669
 670   HTTP::Request->new( $request, %environment );
 671
 672   HTTP::Request->new( request => $request, environment => \%environment );
 673
 674 =over 8
 675
 676 =item * request
 677
 678     request => HTTP::Request->new( GET => 'http://www.host.com/' )
 679
 680 =item * stdin
 681
 682 Filehandle to be used as C<STDIN>, defaults to a temporary file. If value is
 683 C<undef>, C<STDIN> will be left as is.
 684
 685     stdin => IO::File->new_tmpfile
 686     stdin => IO::String->new
 687     stdin => $fh
 688     stdin => undef
 689
 690 =item * stdout
 691
 692 Filehandle to be used as C<STDOUT>, defaults to a temporary file. If value is
 693 C<undef>, C<STDOUT> will be left as is.
 694
 695     stdout => IO::File->new_tmpfile
 696     stdout => IO::String->new
 697     stdout => $fh
 698     stdout => undef
 699
 700 =item * stderr
 701
 702 Filehandle to be used as C<STDERR>, defaults to C<undef>. If value is C<undef>,
 703 C<STDERR> will be left as is.
 704
 705     stderr => IO::File->new_tmpfile
 706     stderr => IO::String->new
 707     stderr => $fh
 708     stderr => undef
 709
 710 =item * environment
 711
 712     environment => \%ENV
 713     environment => { PATH => '/bin:/usr/bin' }
 714
 715 =item * dup
 716
 717     dup => 0
 718     dup => 1
 719
 720 =item * restore
 721
 722     restore => 0
 723     restore => 1
 724
 725 =item * rewind
 726
 727     rewind => 0
 728     rewind => 1
 729
 730 =item * content
 731
 732     content => 0
 733     content => 1
 734
 735 =back
 736
 737 =item environment
 738
 739 Returns a hashref containing the environment that will be used in setup.
 740 Changing the hashref after setup has been called will have no effect.
 741
 742 =item setup
 743
 744 Setups the environment and descriptors.
 745
 746 =item restore
 747
 748 Restores the environment and descriptors. Can only be called after setup.
 749
 750 =item request
 751
 752 Returns the request given to constructor.
 753
 754 =item response
 755
 756 Returns a HTTP::Response. Can only be called after restore.
 757
 758 =item stdin
 759
 760 Accessor for handle that will be used for STDIN, must be a real seekable
 761 handle with an file descriptor. Defaults to a temporary IO::File instance.
 762
 763 =item stdout
 764
 765 Accessor for handle that will be used for STDOUT, must be a real seekable
 766 handle with an file descriptor. Defaults to a temporary IO::File instance.
 767
 768 =item stderr
 769
 770 Accessor for handle that will be used for STDERR, must be a real seekable
 771 handle with an file descriptor.
 772
 773 =back
 774
 775 =head1 SEE ALSO
 776
 777 =over 4
 778
 779 =item examples directory in this distribution.
 780
 781 =item L<WWW::Mechanize::CGI>
 782
 783 =item L<Test::WWW::Mechanize::CGI>
 784
 785 =back
 786
 787 =head1 THANKS TO
 788
 789 Thomas L. Shinnick for his valuable win32 testing.
 790
 791 =head1 AUTHOR
 792
 793 Christian Hansen, C<ch@ngmedia.com>
 794
 795 =head1 LICENSE
 796
 797 This library is free software. You can redistribute it and/or modify
 798 it under the same terms as perl itself.
 799
 800 =cut