gistfile1.pl

use strict;
use warnings;
use Plack::Request;
use Benchmark qw(cmpthese :hireswallclock);

package Plack::Request::Fast {
    use parent 'Plack::Request';

    use HTTP::Headers::Fast;
    use URI::Escape::XS;
    use WWW::Form::UrlEncoded::XS;
    use HTTP::Entity::Parser;

    my $parser = HTTP::Entity::Parser->new;
    $parser->register('application/x-www-form-urlencoded', 'HTTP::Entity::Parser::UrlEncoded');
    $parser->register('multipart/form-data', 'HTTP::Entity::Parser::MultiPart');
#    $parser->register('application/json', 'HTTP::Entity::Parser::JSON');

    sub _parse_query {
        my $self = shift;

        my @query;
        my $query_string = $self->env->{QUERY_STRING};
        if (defined $query_string) {
            if ($query_string =~ /=/) {
                # Handle  ?foo=bar&bar=foo type of query
                @query =
                    map { s/\+/ /g; URI::Escape::XS::uri_unescape($_) }
                    map { /=/ ? split(/=/, $_, 2) : ($_ => '')}
                    split(/[&;]/, $query_string);
            } else {
                # Handle ...?dog+bones type of query
                @query =
                    map { (URI::Escape::XS::uri_unescape($_), '') }
                    split(/\+/, $query_string, -1);
            }
        }

        Hash::MultiValue->new(@query);
    }

    sub _parse_request_body {
        my $self = shift;

        my $ct = $self->env->{CONTENT_TYPE};
        my $cl = $self->env->{CONTENT_LENGTH};
        if (!$ct && !$cl) {
            # No Content-Type nor Content-Length -> GET/HEAD
            $self->env->{'plack.request.body'}   = Hash::MultiValue->new;
            $self->env->{'plack.request.upload'} = Hash::MultiValue->new;
            return;
        }

        my ($params, $uploads) = $parser->parse($self->env);
        $self->env->{'plack.request.body'} = Hash::MultiValue->new(@$params);
        $self->{_uploads} = $uploads,

        return 1;
    }

    sub uploads {
        my $self = shift;

        if ($self->env->{'plack.request.upload'}) {
            return $self->env->{'plack.request.upload'};
        }

        $self->_parse_request_body unless $self->{_uploads};

        my $uploads = delete $self->{_uploads};
        my $upload_hmv = Hash::MultiValue->new();
        while (my ($k,$v) = splice @$uploads, 0, 2) {
            my %copy = %$v;
            $copy{headers} = HTTP::Headers::Fast->new(@{$v->{headers}});
            $upload_hmv->add($k, Plack::Request::Upload->new(%copy));
        }

        return $self->env->{'plack.request.upload'} = $upload_hmv;
    }

    sub DESTROY {
        my $self = shift;
        if (my $upload_hmv = $self->env->{'plack.request.upload'}) {
            my @temps = ();
            for my $upload (values %{ $upload_hmv }) {
                push @temps, map { $_->{tempname} // () }
                    ref $upload eq 'ARRAY' ? @$upload : $upload;
            }
            unlink map { $_ } grep { -e $_ } @temps;
        }
    }
};

package main {
    my $content1 = 'xxx=hogehoge&yyy=aaaaaaaaaaaaaaaaaaaaa';
    my $content2 = 'xxx=hogehoge&yyy=aaaaaaaaaaaaaaaaaaaaa&%E6%97%A5%E6%9C%AC%E8%AA%9E=%E3%81%AB%E3%81%BB%E3%82%93%E3%81%94&%E3%81%BB%E3%81%92%E3%81%BB%E3%81%92=%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C';
    my $content3 = join '&', map { "$_=%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C%E3%81%B5%E3%81%8C" } 'A'..'R';

    for my $content ($content1, $content2, $content3) {
        print "\n## body_parameters (content length => ", length($content) . ")\n\n";
        cmpthese -1, {
            'fast' => sub {
                open my $input, '<', \$content;
                my $env = {
                    'psgi.input'           => $input,
                    'psgix.input.buffered' => 1,
                    CONTENT_LENGTH         => length($content),
                    CONTENT_TYPE           => 'application/x-www-form-urlencoded',
                };
                my $req = Plack::Request::Fast->new($env);
                my $params = $req->body_parameters;
            },
            'original' => sub {
                open my $input, '<', \$content;
                my $env = {
                    'psgi.input'           => $input,
                    'psgix.input.buffered' => 1,
                    CONTENT_LENGTH         => length($content),
                    CONTENT_TYPE           => 'application/x-www-form-urlencoded',
                };
                my $req = Plack::Request->new($env);
                my $params = $req->body_parameters;
            }
        }, 'all';
    }

    print "-" x 80, "\n";

    for my $content ($content1, $content2, $content3) {
        print "\n## query_parameters (content length => ", length($content) . ")\n\n";
        cmpthese -1, {
            'fast' => sub {
                my $env = {
                    'QUERY_STRING' => $content,
                };
                my $req = Plack::Request::Fast->new($env);
                my $params = $req->query_parameters;
            },
            'original' => sub {
                my $env = {
                    'QUERY_STRING' => $content,
                };
                my $req = Plack::Request->new($env);
                my $params = $req->query_parameters;
            }
        }, 'all';
    }
};

__DATA__

## body_parameters (content length => 38)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.11663 wallclock secs ( 1.07 usr  0.01 sys +  0.00 cusr  0.00 csys =  1.08 CPU) @ 18100.93/s (n=19549)
  original: 1.14458 wallclock secs ( 1.10 usr  0.01 sys +  0.00 cusr  0.00 csys =  1.11 CPU) @ 7840.54/s (n=8703)
            Rate original     fast
original  7841/s       --     -57%
fast     18101/s     131%       --

## body_parameters (content length => 177)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.10127 wallclock secs ( 1.09 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.09 CPU) @ 16440.37/s (n=17920)
  original: 1.20091 wallclock secs ( 1.18 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.18 CPU) @ 5009.32/s (n=5911)
            Rate original     fast
original  5009/s       --     -70%
fast     16440/s     228%       --

## body_parameters (content length => 1997)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.06687 wallclock secs ( 1.02 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.02 CPU) @ 9582.35/s (n=9774)
  original: 1.11147 wallclock secs ( 1.09 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.09 CPU) @ 997.25/s (n=1087)
           Rate original     fast
original  997/s       --     -90%
fast     9582/s     861%       --
--------------------------------------------------------------------------------

## query_parameters (content length => 38)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.14357 wallclock secs ( 1.13 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.13 CPU) @ 25372.57/s (n=28671)
  original: 1.18189 wallclock secs ( 1.16 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.16 CPU) @ 28519.83/s (n=33083)
            Rate     fast original
fast     25373/s       --     -11%
original 28520/s      12%       --

## query_parameters (content length => 177)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.18275 wallclock secs ( 1.14 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.14 CPU) @ 17148.25/s (n=19549)
  original: 1.15653 wallclock secs ( 1.09 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.09 CPU) @ 9158.72/s (n=9983)
            Rate original     fast
original  9159/s       --     -47%
fast     17148/s      87%       --

## query_parameters (content length => 1997)

Benchmark: running fast, original for at least 1 CPU seconds...
      fast: 1.12652 wallclock secs ( 1.11 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.11 CPU) @ 5097.30/s (n=5658)
  original: 1.1952 wallclock secs ( 1.16 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.16 CPU) @ 1157.76/s (n=1343)
           Rate original     fast
original 1158/s       --     -77%
fast     5097/s     340%       --