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 write_content {
 198     my ( $self, $handle ) = @_;
 199
 200     my $content = $self->request->content_ref;
 201
 202     if ( ref($content) eq 'SCALAR' ) {
 203
 204         if ( defined($$content) && length($$content) ) {
 205
 206             print( { $self->stdin } $$content )
 207               or croak("Couldn't write request content to stdin handle: '$!'");
 208
 209             if ( $self->should_rewind ) {
 210
 211                 seek( $self->stdin, 0, SEEK_SET )
 212                   or croak("Couldn't seek stdin handle: '$!'");
 213             }
 214         }
 215     }
 216     elsif ( ref($content) eq 'CODE' ) {
 217
 218         while () {
 219
 220             my $chunk = &$content();
 221
 222             if ( defined($chunk) && length($chunk) ) {
 223
 224                 print( { $self->stdin } $chunk )
 225                   or croak("Couldn't write request content chunk to stdin handle: '$!'");
 226             }
 227             else {
 228                 last;
 229             }
 230         }
 231
 232         if ( $self->should_rewind ) {
 233
 234             seek( $self->stdin, 0, SEEK_SET )
 235               or croak("Couldn't seek stdin handle: '$!'");
 236         }
 237     }
 238     else {
 239         croak("Couldn't write request content to stdin handle: 'Unknown request content $content'");
 240     }
 241 }
 242
 243 sub setup_content {
 244     my $self = shift;
 245
 246     if ( $self->has_stdin && $self->should_setup_content ) {
 247         $self->write_content($self->stdin);
 248     }
 249 }
 250
 251 sub setup_stdin {
 252     my $self = shift;
 253
 254     if ( $self->has_stdin ) {
 255
 256         if ( $self->should_dup ) {
 257
 258             if ( $self->should_restore ) {
 259
 260                 open( my $stdin, '<&STDIN' )
 261                   or croak("Couldn't dup STDIN: '$!'");
 262
 263                 $self->{restore}->{stdin} = $stdin;
 264             }
 265
 266             STDIN->fdopen( $self->stdin, '<' )
 267               or croak("Couldn't dup stdin handle to STDIN: '$!'");
 268         }
 269         else {
 270
 271             my $stdin = Symbol::qualify_to_ref('STDIN');
 272
 273             if ( $self->should_restore ) {
 274
 275                 $self->{restore}->{stdin}     = *$stdin;
 276                 $self->{restore}->{stdin_ref} = \*$stdin;
 277             }
 278
 279             *$stdin = $self->stdin;
 280         }
 281
 282         binmode( $self->stdin );
 283         binmode( STDIN );
 284     }
 285 }
 286
 287 sub setup_stdout {
 288     my $self = shift;
 289
 290     if ( $self->has_stdout ) {
 291
 292         if ( $self->should_dup ) {
 293
 294             if ( $self->should_restore ) {
 295
 296                 open( my $stdout, '>&STDOUT' )
 297                   or croak("Couldn't dup STDOUT: '$!'");
 298
 299                 $self->{restore}->{stdout} = $stdout;
 300             }
 301
 302             STDOUT->fdopen( $self->stdout, '>' )
 303               or croak("Couldn't dup stdout handle to STDOUT: '$!'");
 304         }
 305         else {
 306
 307             my $stdout = Symbol::qualify_to_ref('STDOUT');
 308
 309             if ( $self->should_restore ) {
 310
 311                 $self->{restore}->{stdout}     = *$stdout;
 312                 $self->{restore}->{stdout_ref} = \*$stdout;
 313             }
 314
 315             *$stdout = $self->stdout;
 316         }
 317
 318         binmode( $self->stdout );
 319         binmode( STDOUT);
 320     }
 321 }
 322
 323 sub setup_stderr {
 324     my $self = shift;
 325
 326     if ( $self->has_stderr ) {
 327
 328         if ( $self->should_dup ) {
 329
 330             if ( $self->should_restore ) {
 331
 332                 open( my $stderr, '>&STDERR' )
 333                   or croak("Couldn't dup STDERR: '$!'");
 334
 335                 $self->{restore}->{stderr} = $stderr;
 336             }
 337
 338             STDERR->fdopen( $self->stderr, '>' )
 339               or croak("Couldn't dup stderr handle to STDERR: '$!'");
 340         }
 341         else {
 342
 343             my $stderr = Symbol::qualify_to_ref('STDERR');
 344
 345             if ( $self->should_restore ) {
 346
 347                 $self->{restore}->{stderr}     = *$stderr;
 348                 $self->{restore}->{stderr_ref} = \*$stderr;
 349             }
 350
 351             *$stderr = $self->stderr;
 352         }
 353
 354         binmode( $self->stderr );
 355         binmode( STDERR );
 356     }
 357 }
 358
 359 sub setup_environment {
 360     my $self = shift;
 361
 362     no warnings 'uninitialized';
 363
 364     if ( $self->should_restore ) {
 365         $self->{restore}->{environment} = { %ENV };
 366     }
 367
 368     %ENV = %{ $self->environment };
 369 }
 370
 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]+/;
 373
 374 sub response {
 375     my $self   = shift;
 376     my %params = ( headers_only => 0, sync => 0, @_ );
 377
 378     return undef unless $self->has_stdout;
 379
 380     if ( $self->should_rewind ) {
 381
 382         seek( $self->stdout, 0, SEEK_SET )
 383           or croak("Couldn't seek stdout handle: '$!'");
 384     }
 385
 386     my $message  = undef;
 387     my $response = HTTP::Response->new( 200, 'OK' );
 388        $response->protocol('HTTP/1.1');
 389
 390     while ( my $line = readline($self->stdout) ) {
 391         $message .= $line;
 392         last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
 393     }
 394
 395     if ( !$message ) {
 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 );
 402
 403         return $response;
 404     }
 405
 406     if ( $message =~ s/^($HTTP_Version)[\x09\x20]+(\d\d\d)[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
 407         $response->protocol($1);
 408         $response->code($2);
 409         $response->message($3);
 410     }
 411
 412     $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
 413
 414     foreach ( split /\x0D?\x0A/, $message ) {
 415
 416         s/[\x09\x20]*$//;
 417
 418         if ( /^($HTTP_Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)$/o ) {
 419             $response->headers->push_header( $1 => $2 );
 420         }
 421         else {
 422             # XXX what should we do on bad headers?
 423         }
 424     }
 425
 426     my $status = $response->header('Status');
 427
 428     if ( $status && $status =~ /^(\d\d\d)[\x09\x20]+([\x20-\xFF]+)$/ ) {
 429         $response->code($1);
 430         $response->message($2);
 431     }
 432
 433     if ( !$response->date ) {
 434         $response->date(time);
 435     }
 436
 437     if ( $params{headers_only} ) {
 438
 439         if ( $params{sync} ) {
 440
 441             my $position = tell( $self->stdout )
 442               or croak("Couldn't get file position from stdout handle: '$!'");
 443
 444             sysseek( $self->stdout, $position, SEEK_SET )
 445               or croak("Couldn't seek stdout handle: '$!'");
 446         }
 447
 448         return $response;
 449     }
 450
 451     my $content        = undef;
 452     my $content_length = 0;
 453
 454     while () {
 455
 456         my $r = read( $self->stdout, $content, 65536, $content_length );
 457
 458         if ( defined $r ) {
 459
 460             if ( $r == 0 ) {
 461                 last;
 462             }
 463             else {
 464                 $content_length += $r;
 465             }
 466         }
 467         else {
 468             croak("Couldn't read response content from stdin handle: '$!'");
 469         }
 470     }
 471
 472     if ( $content_length ) {
 473
 474         $response->content_ref(\$content);
 475
 476         if ( !$response->content_length ) {
 477             $response->content_length($content_length);
 478         }
 479     }
 480
 481     return $response;
 482 }
 483
 484 sub restore {
 485     my $self = shift;
 486
 487     if ( $self->should_restore ) {
 488
 489         $self->restore_environment;
 490         $self->restore_stdin;
 491         $self->restore_stdout;
 492         $self->restore_stderr;
 493
 494         $self->{restore} = {};
 495
 496         $self->is_restored(1);
 497     }
 498
 499     return $self;
 500 }
 501
 502 sub restore_environment {
 503     my $self = shift;
 504
 505     no warnings 'uninitialized';
 506
 507     %ENV = %{ $self->{restore}->{environment} };
 508 }
 509
 510 sub restore_stdin {
 511     my $self = shift;
 512
 513     if ( $self->has_stdin ) {
 514
 515         my $stdin = $self->{restore}->{stdin};
 516
 517         if ( $self->should_dup ) {
 518
 519             STDIN->fdopen( $stdin, '<' )
 520               or croak("Couldn't restore STDIN: '$!'");
 521         }
 522         else {
 523
 524             my $stdin_ref = $self->{restore}->{stdin_ref};
 525               *$stdin_ref = $stdin;
 526         }
 527
 528         if ( $self->should_rewind ) {
 529
 530             seek( $self->stdin, 0, SEEK_SET )
 531               or croak("Couldn't seek stdin handle: '$!'");
 532         }
 533     }
 534 }
 535
 536 sub restore_stdout {
 537     my $self = shift;
 538
 539     if ( $self->has_stdout ) {
 540
 541         my $stdout = $self->{restore}->{stdout};
 542
 543         if ( $self->should_dup ) {
 544
 545             STDOUT->flush
 546               or croak("Couldn't flush STDOUT: '$!'");
 547
 548             STDOUT->fdopen( $stdout, '>' )
 549               or croak("Couldn't restore STDOUT: '$!'");
 550         }
 551         else {
 552
 553             my $stdout_ref = $self->{restore}->{stdout_ref};
 554               *$stdout_ref = $stdout;
 555         }
 556
 557         if ( $self->should_rewind ) {
 558
 559             seek( $self->stdout, 0, SEEK_SET )
 560               or croak("Couldn't seek stdout handle: '$!'");
 561         }
 562     }
 563 }
 564
 565 sub restore_stderr {
 566     my $self = shift;
 567
 568     if ( $self->has_stderr ) {
 569
 570         my $stderr = $self->{restore}->{stderr};
 571
 572         if ( $self->should_dup ) {
 573
 574             STDERR->flush
 575               or croak("Couldn't flush STDERR: '$!'");
 576
 577             STDERR->fdopen( $stderr, '>' )
 578               or croak("Couldn't restore STDERR: '$!'");
 579         }
 580         else {
 581
 582             my $stderr_ref = $self->{restore}->{stderr_ref};
 583               *$stderr_ref = $stderr;
 584         }
 585
 586         if ( $self->should_rewind ) {
 587
 588             seek( $self->stderr, 0, SEEK_SET )
 589               or croak("Couldn't seek stderr handle: '$!'");
 590         }
 591     }
 592 }
 593
 594 sub DESTROY {
 595     my $self = shift;
 596
 597     if ( $self->should_restore && $self->is_setuped && !$self->is_restored ) {
 598         $self->restore;
 599     }
 600 }
 601
 602 1;
 603
 604 __END__
 605
 606 =head1 NAME
 607
 608 HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request
 609
 610 =head1 SYNOPSIS
 611
 612     use CGI;
 613     use HTTP::Request;
 614     use HTTP::Request::AsCGI;
 615
 616     my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
 617     my $stdout;
 618
 619     {
 620         my $c = HTTP::Request::AsCGI->new($request)->setup;
 621         my $q = CGI->new;
 622
 623         print $q->header,
 624               $q->start_html('Hello World'),
 625               $q->h1('Hello World'),
 626               $q->end_html;
 627
 628         $stdout = $c->stdout;
 629
 630         # environment and descriptors will automatically be restored
 631         # when $c is destructed.
 632     }
 633
 634     while ( my $line = $stdout->getline ) {
 635         print $line;
 636     }
 637
 638 =head1 DESCRIPTION
 639
 640 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
 641
 642 =head1 METHODS
 643
 644 =over 4
 645
 646 =item new ( $request [, key => value ] )
 647
 648 Contructor, first argument must be a instance of HTTP::Request
 649 followed by optional pairs of environment key and value.
 650
 651 =item environment
 652
 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.
 655
 656 =item setup
 657
 658 Setups the environment and descriptors.
 659
 660 =item restore
 661
 662 Restores the environment and descriptors. Can only be called after setup.
 663
 664 =item request
 665
 666 Returns the request given to constructor.
 667
 668 =item response
 669
 670 Returns a HTTP::Response. Can only be called after restore.
 671
 672 =item stdin
 673
 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.
 676
 677 =item stdout
 678
 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.
 681
 682 =item stderr
 683
 684 Accessor for handle that will be used for STDERR, must be a real seekable
 685 handle with an file descriptor.
 686
 687 =back
 688
 689 =head1 SEE ALSO
 690
 691 =over 4
 692
 693 =item examples directory in this distribution.
 694
 695 =item L<WWW::Mechanize::CGI>
 696
 697 =item L<Test::WWW::Mechanize::CGI>
 698
 699 =back
 700
 701 =head1 THANKS TO
 702
 703 Thomas L. Shinnick for his valuable win32 testing.
 704
 705 =head1 AUTHOR
 706
 707 Christian Hansen, C<ch@ngmedia.com>
 708
 709 =head1 LICENSE
 710
 711 This library is free software. You can redistribute it and/or modify
 712 it under the same terms as perl itself.
 713
 714 =cut