scripts/benchmark.pl

   1 #!/usr/bin/perl
   2
   3 BEGIN {
   4     require FindBin;
   5 }
   6
   7 use strict;
   8 use warnings;
   9 use lib "$FindBin::Bin/../lib";
  10
  11 use Benchmark   qw[cmpthese timethese];
  12 use CGI         qw[];
  13 use CGI::Simple qw[];
  14 use HTTP::Body  qw[];
  15 use IO::Handle  qw[];
  16 use IO::File    qw[O_RDONLY SEEK_SET];
  17 use YAML        qw[LoadFile];
  18
  19 my ( $headers, $content, $message );
  20
  21 my $benchmarks = {
  22     'CGI' => sub {
  23
  24         $content->seek( 0, SEEK_SET )
  25           or die $!;
  26
  27         STDIN->fdopen( $content->fileno, 'r' );
  28
  29         CGI::_reset_globals();
  30
  31         my $cgi = CGI->new;
  32     },
  33     'HTTP::Body' => sub {
  34
  35         $content->seek( 0, SEEK_SET )
  36           or die $!;
  37
  38         my $body = HTTP::Body->new( $headers->{'Content-Type'},
  39                                     $headers->{'Content-Length'} );
  40
  41         while ( $content->read( my $buffer, 4096 ) ) {
  42             $body->add($buffer);
  43         }
  44
  45         unless ( $body->state eq 'done' ) {
  46             die 'baaaaaaaaad';
  47         }
  48     }
  49 };
  50
  51 if ( eval 'require CGI::Simple' ) {
  52     $benchmarks->{'CGI::Simple'} = sub {
  53
  54         $content->seek( 0, SEEK_SET )
  55           or die $!;
  56
  57         STDIN->fdopen( $content->fileno, 'r' );
  58
  59         CGI::Simple::_reset_globals();
  60
  61         my $cgi = CGI::Simple->new;
  62     };
  63 }
  64
  65 if ( eval 'require APR::Request' ) {
  66
  67     require APR;
  68     require APR::Pool;
  69     require APR::Request;
  70     require APR::Request::CGI;
  71     require APR::Request::Param;
  72
  73     $benchmarks->{'APR::Request'} = sub {
  74
  75         $content->seek( 0, SEEK_SET )
  76           or die $!;
  77
  78         STDIN->fdopen( $content->fileno, 'r' );
  79
  80         my $pool = APR::Pool->new;
  81         my $apr  = APR::Request::CGI->handle($pool);
  82
  83         if ( my $table = $apr->param ) {
  84             $table->do( sub { 1 } );
  85         }
  86
  87         if ( my $body = $apr->body ) {
  88             $body->param_class('APR::Request::Param');
  89             $body->uploads($pool)->do( sub { 1 } );
  90         }
  91     };
  92 }
  93
  94 my @benchmarks =  @ARGV ? @ARGV : qw[ t/data/benchmark/001
  95                                       t/data/benchmark/002
  96                                       t/data/benchmark/003 ];
  97
  98 foreach my $benchmark ( @benchmarks ) {
  99
 100     $headers  = LoadFile("$FindBin::Bin/../$benchmark-headers.yml");
 101     $content  = IO::File->new( "$FindBin::Bin/../$benchmark-content.dat", O_RDONLY )
 102       or die $!;
 103
 104     binmode($content);
 105
 106     local %ENV = (
 107         CONTENT_LENGTH => $headers->{'Content-Length'},
 108         CONTENT_TYPE   => $headers->{'Content-Type'},
 109         QUERY_STRING   => '',
 110         REQUEST_METHOD => 'POST'
 111     );
 112
 113     printf( "Content-Type   : %s\n", $headers->{'Content-Type'} =~ m/^([^;]+)/ );
 114     printf( "Content-Length : %s\n", $headers->{'Content-Length'} );
 115     printf( "Benchmark      : %s\n", $headers->{'Benchmark'} ) if $headers->{'Benchmark'};
 116     print "\n";
 117
 118     cmpthese( -1, $benchmarks );
 119
 120     printf( "%s\n", "-" x 80 ) if @benchmarks > 1;
 121 }