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::File        qw[SEEK_SET];
  11 use Symbol          qw[];
  12 use URI::Escape     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 my $HTTP_Token   = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
 120 my $HTTP_Version = qr/HTTP\/[0-9]+\.[0-9]+/;
 121
 122 sub prepare {
 123     my $self = shift;
 124
 125     my $environment = $self->environment;
 126     my $request     = $self->request;
 127
 128     my $host = $request->header('Host');
 129     my $uri  = $request->uri->clone;
 130
 131     $uri->scheme('http')    unless $uri->scheme;
 132     $uri->host('localhost') unless $uri->host;
 133     $uri->port(80)          unless $uri->port;
 134     $uri->host_port($host)  unless !$host || ( $host eq $uri->host_port );
 135
 136     $uri = $uri->canonical;
 137
 138     my %cgi = (
 139         GATEWAY_INTERFACE => 'CGI/1.1',
 140         HTTP_HOST         => $uri->host_port,
 141         HTTPS             => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF',  # not in RFC 3875
 142         PATH_INFO         => URI::Escape::uri_unescape($uri->path),
 143         QUERY_STRING      => $uri->query || '',
 144         SCRIPT_NAME       => '/',
 145         SERVER_NAME       => $uri->host,
 146         SERVER_PORT       => $uri->port,
 147         SERVER_PROTOCOL   => $request->protocol || 'HTTP/1.1',
 148         SERVER_SOFTWARE   => "HTTP-Request-AsCGI/$VERSION",
 149         REMOTE_ADDR       => '127.0.0.1',
 150         REMOTE_HOST       => 'localhost',
 151         REMOTE_PORT       => int( rand(64000) + 1000 ),                   # not in RFC 3875
 152         REQUEST_URI       => $uri->path_query,                            # not in RFC 3875
 153         REQUEST_METHOD    => $request->method
 154     );
 155
 156     if ( my $authorization = $request->header('Authorization') ) {
 157
 158         ( my $scheme ) = $authorization =~ /^($HTTP_Token+)/o;
 159
 160         if ( $scheme =~ /^Basic/i ) {
 161
 162             if ( ( my $username ) = $request->headers->authorization_basic ) {
 163                 $cgi{AUTH_TYPE}   = 'Basic';
 164                 $cgi{REMOTE_USER} = $username;
 165             }
 166         }
 167         elsif ( $scheme =~ /^Digest/i ) {
 168
 169             if ( ( my $username ) = $authorization =~ /username="([^"]+)"/ ) {
 170                 $cgi{AUTH_TYPE}   = 'Digest';
 171                 $cgi{REMOTE_USER} = $username;
 172             }
 173         }
 174     }
 175
 176     foreach my $key ( keys %cgi ) {
 177
 178         unless ( exists $environment->{ $key } ) {
 179             $environment->{ $key } = $cgi{ $key };
 180         }
 181     }
 182
 183     foreach my $field ( $request->headers->header_field_names ) {
 184
 185         my $key = uc("HTTP_$field");
 186         $key =~ tr/-/_/;
 187         $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
 188
 189         unless ( exists $environment->{ $key } ) {
 190             $environment->{ $key } = $request->headers->header($field);
 191         }
 192     }
 193
 194     if ( $environment->{SCRIPT_NAME} ne '/' && $environment->{PATH_INFO} ) {
 195         $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//;
 196         $environment->{PATH_INFO} =~ s/^\/+/\//;
 197     }
 198
 199     $self->is_prepared(1);
 200 }
 201
 202 sub setup {
 203     my $self = shift;
 204
 205     if ( $self->is_setup ) {
 206         croak(   'An attempt was made to setup environment variables and '
 207                . 'standard filehandles which has already been setup.' );
 208     }
 209
 210     if ( $self->should_setup_content && $self->has_stdin ) {
 211         $self->setup_content;
 212     }
 213
 214     if ( $self->has_stdin ) {
 215
 216         if ( $self->should_dup ) {
 217
 218             if ( $self->should_restore ) {
 219
 220                 open( my $stdin, '<&STDIN' )
 221                   or croak("Couldn't dup STDIN: '$!'");
 222
 223                 $self->{restore}->{stdin} = $stdin;
 224             }
 225
 226             open( STDIN, '<&' . fileno($self->stdin) )
 227               or croak("Couldn't dup stdin filehandle to STDIN: '$!'");
 228         }
 229         else {
 230
 231             my $stdin = Symbol::qualify_to_ref('STDIN');
 232
 233             if ( $self->should_restore ) {
 234
 235                 $self->{restore}->{stdin}     = *$stdin;
 236                 $self->{restore}->{stdin_ref} = \*$stdin;
 237             }
 238
 239             *$stdin = $self->stdin;
 240         }
 241
 242         binmode( $self->stdin );
 243         binmode( STDIN );
 244     }
 245
 246     if ( $self->has_stdout ) {
 247
 248         if ( $self->should_dup ) {
 249
 250             if ( $self->should_restore ) {
 251
 252                 open( my $stdout, '>&STDOUT' )
 253                   or croak("Couldn't dup STDOUT: '$!'");
 254
 255                 $self->{restore}->{stdout} = $stdout;
 256             }
 257
 258             open( STDOUT, '>&' . fileno($self->stdout) )
 259               or croak("Couldn't dup stdout filehandle to STDOUT: '$!'");
 260         }
 261         else {
 262
 263             my $stdout = Symbol::qualify_to_ref('STDOUT');
 264
 265             if ( $self->should_restore ) {
 266
 267                 $self->{restore}->{stdout}     = *$stdout;
 268                 $self->{restore}->{stdout_ref} = \*$stdout;
 269             }
 270
 271             *$stdout = $self->stdout;
 272         }
 273
 274         binmode( $self->stdout );
 275         binmode( STDOUT);
 276     }
 277
 278     if ( $self->has_stderr ) {
 279
 280         if ( $self->should_dup ) {
 281
 282             if ( $self->should_restore ) {
 283
 284                 open( my $stderr, '>&STDERR' )
 285                   or croak("Couldn't dup STDERR: '$!'");
 286
 287                 $self->{restore}->{stderr} = $stderr;
 288             }
 289
 290             open( STDERR, '>&' . fileno($self->stderr) )
 291               or croak("Couldn't dup stdout filehandle to STDOUT: '$!'");
 292         }
 293         else {
 294
 295             my $stderr = Symbol::qualify_to_ref('STDERR');
 296
 297             if ( $self->should_restore ) {
 298
 299                 $self->{restore}->{stderr}     = *$stderr;
 300                 $self->{restore}->{stderr_ref} = \*$stderr;
 301             }
 302
 303             *$stderr = $self->stderr;
 304         }
 305
 306         binmode( $self->stderr );
 307         binmode( STDERR );
 308     }
 309
 310     {
 311         no warnings 'uninitialized';
 312
 313         if ( $self->should_restore ) {
 314             $self->{restore}->{environment} = { %ENV };
 315         }
 316
 317         %ENV = %{ $self->environment };
 318     }
 319
 320     if ( $INC{'CGI.pm'} ) {
 321         CGI::initialize_globals();
 322     }
 323
 324     $self->is_setup(1);
 325
 326     return $self;
 327 }
 328
 329 sub setup_content {
 330     my $self  = shift;
 331     my $stdin = shift || $self->stdin;
 332
 333     my $content = $self->request->content_ref;
 334
 335     if ( ref($content) eq 'SCALAR' ) {
 336
 337         if ( defined($$content) && length($$content) ) {
 338
 339             print( { $stdin } $$content )
 340               or croak("Couldn't write request content SCALAR to stdin filehandle: '$!'");
 341
 342             if ( $self->should_rewind ) {
 343
 344                 seek( $stdin, 0, SEEK_SET )
 345                   or croak("Couldn't rewind stdin filehandle: '$!'");
 346             }
 347         }
 348     }
 349     elsif ( ref($content) eq 'CODE' ) {
 350
 351         while () {
 352
 353             my $chunk = &$content();
 354
 355             if ( defined($chunk) && length($chunk) ) {
 356
 357                 print( { $stdin } $chunk )
 358                   or croak("Couldn't write request content callback to stdin filehandle: '$!'");
 359             }
 360             else {
 361                 last;
 362             }
 363         }
 364
 365         if ( $self->should_rewind ) {
 366
 367             seek( $stdin, 0, SEEK_SET )
 368               or croak("Couldn't rewind stdin filehandle: '$!'");
 369         }
 370     }
 371     else {
 372         croak("Couldn't write request content to stdin filehandle: 'Unknown request content $content'");
 373     }
 374 }
 375
 376 sub response {
 377     my $self   = shift;
 378     my %params = ( headers_only => 0, sync => 0, @_ );
 379
 380     return undef unless $self->has_stdout;
 381
 382     if ( $self->should_rewind ) {
 383
 384         seek( $self->stdout, 0, SEEK_SET )
 385           or croak("Couldn't rewind stdout filehandle: '$!'");
 386     }
 387
 388     my $message  = undef;
 389     my $response = HTTP::Response->new( 200, 'OK' );
 390        $response->protocol('HTTP/1.1');
 391
 392     while ( my $line = readline($self->stdout) ) {
 393
 394         if ( !$message && $line =~ /^\x0d?\x0a$/ ) {
 395             next;
 396         }
 397         else {
 398             $message .= $line;
 399         }
 400
 401         last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
 402     }
 403
 404     if ( !$message ) {
 405         $response->code(500);
 406         $response->message('Internal Server Error');
 407         $response->date( time() );
 408         $response->content( $response->error_as_HTML );
 409         $response->content_type('text/html');
 410         $response->content_length( length $response->content );
 411
 412         return $response;
 413     }
 414
 415     if ( $message =~ s/^($HTTP_Version)[\x09\x20]+(\d\d\d)[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
 416         $response->protocol($1);
 417         $response->code($2);
 418         $response->message($3);
 419     }
 420
 421     $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
 422
 423     foreach ( split /\x0D?\x0A/, $message ) {
 424
 425         s/[\x09\x20]*$//;
 426
 427         if ( /^($HTTP_Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)$/o ) {
 428             $response->headers->push_header( $1 => $2 );
 429         }
 430         else {
 431             # XXX what should we do on bad headers?
 432         }
 433     }
 434
 435     my $status = $response->header('Status');
 436
 437     if ( $status && $status =~ /^(\d\d\d)[\x09\x20]+([\x20-\xFF]+)$/ ) {
 438         $response->code($1);
 439         $response->message($2);
 440     }
 441
 442     if ( !$response->date ) {
 443         $response->date(time());
 444     }
 445
 446     if ( $params{headers_only} ) {
 447
 448         if ( $params{sync} ) {
 449
 450             my $position = tell( $self->stdout )
 451               or croak("Couldn't get file position from stdout filehandle: '$!'");
 452
 453             sysseek( $self->stdout, $position, SEEK_SET )
 454               or croak("Couldn't seek stdout filehandle: '$!'");
 455         }
 456
 457         return $response;
 458     }
 459
 460     my $content        = undef;
 461     my $content_length = 0;
 462
 463     while () {
 464
 465         my $r = read( $self->stdout, $content, 65536, $content_length );
 466
 467         if ( defined $r ) {
 468
 469             if ( $r == 0 ) {
 470                 last;
 471             }
 472             else {
 473                 $content_length += $r;
 474             }
 475         }
 476         else {
 477             croak("Couldn't read response content from stdin filehandle: '$!'");
 478         }
 479     }
 480
 481     if ( $content_length ) {
 482
 483         $response->content_ref(\$content);
 484
 485         if ( !$response->content_length ) {
 486             $response->content_length($content_length);
 487         }
 488     }
 489
 490     return $response;
 491 }
 492
 493 sub restore {
 494     my $self = shift;
 495
 496     if ( !$self->should_restore ) {
 497         croak(   'An attempt was made to restore environment variables and '
 498                . 'standard filehandles which has not been saved.' );
 499     }
 500
 501     if ( !$self->is_setup ) {
 502         croak(   'An attempt was made to restore environment variables and '
 503                . 'standard filehandles which has not been setup.' );
 504     }
 505
 506     if ( $self->is_restored ) {
 507         croak(   'An attempt was made to restore environment variables and '
 508                . 'standard filehandles which has already been restored.' );
 509     }
 510
 511     {
 512         no warnings 'uninitialized';
 513         %ENV = %{ $self->{restore}->{environment} };
 514     }
 515
 516     if ( $self->has_stdin ) {
 517
 518         my $stdin = $self->{restore}->{stdin};
 519
 520         if ( $self->should_dup ) {
 521
 522             STDIN->fdopen( fileno($stdin), '<' )
 523               or croak("Couldn't restore STDIN: '$!'");
 524         }
 525         else {
 526
 527             my $stdin_ref = $self->{restore}->{stdin_ref};
 528               *$stdin_ref = $stdin;
 529         }
 530
 531         if ( $self->should_rewind ) {
 532
 533             seek( $self->stdin, 0, SEEK_SET )
 534               or croak("Couldn't rewind stdin filehandle: '$!'");
 535         }
 536     }
 537
 538     if ( $self->has_stdout ) {
 539
 540         my $stdout = $self->{restore}->{stdout};
 541
 542         if ( $self->should_dup ) {
 543
 544             STDOUT->flush
 545               or croak("Couldn't flush STDOUT: '$!'");
 546
 547             STDOUT->fdopen( fileno($stdout), '>' )
 548               or croak("Couldn't restore STDOUT: '$!'");
 549         }
 550         else {
 551
 552             my $stdout_ref = $self->{restore}->{stdout_ref};
 553               *$stdout_ref = $stdout;
 554         }
 555
 556         if ( $self->should_rewind ) {
 557
 558             seek( $self->stdout, 0, SEEK_SET )
 559               or croak("Couldn't rewind stdout filehandle: '$!'");
 560         }
 561     }
 562
 563     if ( $self->has_stderr ) {
 564
 565         my $stderr = $self->{restore}->{stderr};
 566
 567         if ( $self->should_dup ) {
 568
 569             STDERR->flush
 570               or croak("Couldn't flush STDERR: '$!'");
 571
 572             STDERR->fdopen( fileno($stderr), '>' )
 573               or croak("Couldn't restore STDERR: '$!'");
 574         }
 575         else {
 576
 577             my $stderr_ref = $self->{restore}->{stderr_ref};
 578               *$stderr_ref = $stderr;
 579         }
 580
 581         if ( $self->should_rewind ) {
 582
 583             seek( $self->stderr, 0, SEEK_SET )
 584               or croak("Couldn't rewind stderr filehandle: '$!'");
 585         }
 586     }
 587
 588     $self->{restore} = {};
 589
 590     $self->is_restored(1);
 591
 592     return $self;
 593 }
 594
 595 sub DESTROY {
 596     my $self = shift;
 597
 598     if ( $self->should_restore && $self->is_setup && !$self->is_restored ) {
 599         $self->restore;
 600     }
 601 }
 602
 603 1;
 604
 605 __END__
 606
 607 =head1 NAME
 608
 609 HTTP::Request::AsCGI - Setup a Common Gateway Interface environment from a HTTP::Request
 610
 611 =head1 SYNOPSIS
 612
 613     use CGI;
 614     use HTTP::Request;
 615     use HTTP::Request::AsCGI;
 616
 617     my $request = HTTP::Request->new( GET => 'http://www.host.com/' );
 618     my $stdout;
 619
 620     {
 621         my $c = HTTP::Request::AsCGI->new($request)->setup;
 622         my $q = CGI->new;
 623
 624         print $q->header,
 625               $q->start_html('Hello World'),
 626               $q->h1('Hello World'),
 627               $q->end_html;
 628
 629         $stdout = $c->stdout;
 630
 631         # environment and descriptors is automatically restored
 632         # when $c is destructed.
 633     }
 634
 635     while ( my $line = $stdout->getline ) {
 636         print $line;
 637     }
 638
 639 =head1 DESCRIPTION
 640
 641 Provides a convinient way of setting up an CGI environment from a HTTP::Request.
 642
 643 =head1 METHODS
 644
 645 =over 4
 646
 647 =item * new
 648
 649 Contructor, this method takes a hash of parameters. The following parameters are
 650 valid:
 651
 652 =over 8
 653
 654 =item * request
 655
 656     request => HTTP::Request->new( GET => 'http://www.host.com/' )
 657
 658 =item * stdin
 659
 660 A filehandle to be used as standard input, defaults to a temporary filehandle.
 661 If C<stdin> is C<undef>, standard input will be left as is.
 662
 663     stdin => IO::File->new_tmpfile
 664     stdin => IO::String->new
 665     stdin => $fh
 666     stdin => undef
 667
 668 =item * stdout
 669
 670 A filehandle to be used as standard output, defaults to a temporary filehandle.
 671 If C<stdout> is C<undef>, standard output will be left as is.
 672
 673     stdout => IO::File->new_tmpfile
 674     stdout => IO::String->new
 675     stdout => $fh
 676     stdout => undef
 677
 678 =item * stderr
 679
 680 A filehandle to be used as standard error, defaults to C<undef>. If C<stderr> is
 681 C<undef>, standard error will be left as is.
 682
 683     stderr => IO::File->new_tmpfile
 684     stderr => IO::String->new
 685     stderr => $fh
 686     stderr => undef
 687
 688 =item * environment
 689
 690 A C<HASH> of additional environment variables to be used in CGI.
 691 C<HTTP::Request::AsCGI> doesn't autmatically merge C<%ENV>, it has to be
 692 explicitly given if that is desired. Environment variables given in this
 693 C<HASH> isn't overridden by C<HTTP::Request::AsCGI>.
 694
 695     environment => \%ENV
 696     environment => { PATH => '/bin:/usr/bin', SERVER_SOFTWARE => 'Apache/1.3' }
 697
 698 Following standard meta-variables (in addition to protocol-specific) is setup:
 699
 700     AUTH_TYPE
 701     CONTENT_LENGTH
 702     CONTENT_TYPE
 703     GATEWAY_INTERFACE
 704     PATH_INFO
 705     SCRIPT_NAME
 706     SERVER_NAME
 707     SERVER_PORT
 708     SERVER_PROTOCOL
 709     SERVER_SOFTWARE
 710     REMOTE_ADDR
 711     REMOTE_HOST
 712     REMOTE_USER
 713     REQUEST_METHOD
 714     QUERY_STRING
 715
 716 Following non-standard but common meta-variables is setup:
 717
 718     HTTPS
 719     REMOTE_PORT
 720     REQUEST_URI
 721
 722 Following meta-variables is B<not> setup but B<must> be provided in CGI:
 723
 724     PATH_TRANSLATED
 725
 726 Following meta-variables is B<not> setup but common in CGI:
 727
 728     DOCUMENT_ROOT
 729     SCRIPT_FILENAME
 730     SERVER_ROOT
 731
 732 =item * dup
 733
 734 Boolean to indicate whether to C<dup> standard filehandle or to assign the
 735 typeglob representing the standard filehandle. Defaults to C<true>.
 736
 737     dup => 0
 738     dup => 1
 739
 740 =item * restore
 741
 742 Boolean to indicate whether or not to restore environment variables and standard
 743 filehandles. Defaults to C<true>.
 744
 745     restore => 0
 746     restore => 1
 747
 748 If C<true> standard filehandles and environment variables will be saved duiring
 749 C<setup> for later use in C<restore>.
 750
 751 =item * rewind
 752
 753 Boolean to indicate whether or not to rewind standard filehandles. Defaults
 754 to C<true>.
 755
 756     rewind => 0
 757     rewind => 1
 758
 759 =item * content
 760
 761 Boolean to indicate whether or not to request content should be written to
 762 C<stdin> filehandle when C<setup> is invoked. Defaults to C<true>.
 763
 764     content => 0
 765     content => 1
 766
 767 =back
 768
 769 =item * setup
 770
 771 Attempts to setup standard filehandles and environment variables.
 772
 773 =item * restore
 774
 775 Attempts to restore standard filehandles and environment variables.
 776
 777 =item * response
 778
 779 Attempts to parse C<stdout> filehandle into a L<HTTP::Response>.
 780
 781 =item * request
 782
 783 Accessor for L<HTTP::Request> that was given to constructor.
 784
 785 =item * environment
 786
 787 Accessor for environment variables to be used in C<setup>.
 788
 789 =item * stdin
 790
 791 Accessor/Mutator for standard input filehandle.
 792
 793 =item * stdout
 794
 795 Accessor/Mutator for standard output filehandle.
 796
 797 =item * stderr
 798
 799 Accessor/Mutator for standard error filehandle.
 800
 801 =back
 802
 803 =head1 DEPRECATED
 804
 805 XXX Constructor
 806
 807 =head1 SEE ALSO
 808
 809 =over 4
 810
 811 =item examples directory in this distribution.
 812
 813 =item L<WWW::Mechanize::CGI>
 814
 815 =item L<Test::WWW::Mechanize::CGI>
 816
 817 =back
 818
 819 =head1 THANKS TO
 820
 821 Thomas L. Shinnick for his valuable win32 testing.
 822
 823 =head1 AUTHOR
 824
 825 Christian Hansen, C<ch@ngmedia.com>
 826
 827 =head1 LICENSE
 828
 829 This library is free software. You can redistribute it and/or modify
 830 it under the same terms as perl itself.
 831
 832 =cut