view release on metacpan or  search on metacpan

script/benchmark.pl  view on Meta::CPAN

#! /usr/bin/perl
#
# Copyright (C) 2007-2008 Tomash Brechko.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself, either Perl version 5.8.8
# or, at your option, any later version of Perl 5 you may have
# available.
#
use v5.12;
use warnings;

# NOTE: at least on Linux (kernel 2.6.18.2) there is a certain
# artifact that affects wallclock time (but not CPU time) of some
# benchmarks: when send/receive rate changes dramatically, the system
# doesn't adopt to it right away.  Instead, for some time a lot of
# small-range ACK packets are being sent, and this increases the
# latency.  Because of this '*_multi (%h)', which comes first, has
# bigger wallclock time than '*_multi (@h)', which comes next.  I
# tried pre-warming the connection, but this doesn't help in all
# cases.  Seems like 'noreply' mode is also affected, and maybe
# 'nowait'.

use constant default_iteration_count => 1_000;
use constant key_count               => 100;
use constant NOWAIT                  => 1;
use constant NOREPLY                 => 1;

my $value = 'x' x 40;

use Cache::Memcached::Fast;
use Benchmark qw(:hireswallclock timethese cmpthese timeit timesum timestr);
use FindBin;

die <<HELP unless @ARGV;
Usage: $FindBin::Script HOST:PORT... [COUNT] ["compare"]

HOST:PORT...  - list of memcached server addresses.
COUNT         - number of iterations (default ${\default_iteration_count})
                (each iteration will process ${\key_count} keys).
"compare"     - literal string to enable comparison with
                Cache::Memcached.
HELP

pop @ARGV if my $compare = $ARGV[-1] eq 'compare';

my $count    = $ARGV[-1] =~ /^\d+$/ ? pop @ARGV : default_iteration_count;
my $max_keys = $count * key_count / 2;

my @addrs = @ARGV;

my $old;
my $old_method       = qr/^(?:add|set|replace|incr|decr|delete|get)$/;
my $old_method_multi = qr/^get$/;
if ($compare) {
    require Cache::Memcached;

    $old = new Cache::Memcached {
        servers         => [@addrs],
        namespace       => "Cache::Memcached::bench/$$/",
        connect_timeout => 5,
        select_timeout  => 5,
    };
    $old->enable_compress(0);
}

my $new = new Cache::Memcached::Fast {
    servers         => [@addrs],
    namespace       => "Cache::Memcached::bench/$$/",
    ketama_points   => 150,
    nowait          => NOWAIT,
    connect_timeout => 5,
    io_timeout      => 5,
};

my $version = $new->server_versions;
if ( keys %$version != @addrs ) {
    my @servers = map {
        if ( ref($_) eq 'HASH' ) {
            $_->{address};
        }
        elsif ( ref($_) eq 'ARRAY' ) {
            $_->[0];
        }
        else {
            $_;
        }
    } @addrs;
    warn "No server is running at "
        . join( ', ', grep { not exists $version->{$_} } @servers ) . "\n";
    exit 1;
}

my $min_version = 2**31;
while ( my ( $s, $v ) = each %$version ) {
    if ( $v =~ /(\d+)\.(\d+)\.(\d+)/ ) {
        my $n = $1 * 10000 + $2 * 100 + $3;
        $min_version = $n if $n < $min_version;
    }
    else {
        warn "Can't parse version of $s: $v";
        exit 1;
    }
}

my $noreply = NOREPLY && $min_version >= 10205;

@addrs = map { +{ address => $_, noreply => $noreply } } @addrs;

my $new_noreply = new Cache::Memcached::Fast {
    servers         => [@addrs],
    namespace       => "Cache::Memcached::bench/$$/",
    ketama_points   => 150,
    connect_timeout => 5,
    io_timeout      => 5,
};

sub get_key {
    int( rand($max_keys) );
}

sub merge_hash {
    my ( $h1, $h2 ) = @_;

    while ( my ( $k, $v ) = each %$h2 ) {
        $h1->{$k} = $v;
    }
}

sub bench_finalize {
    my ( $title, $code, $finalize ) = @_;

    say "Benchmark: timing $count iterations of $title...";
    my $b1 = timeit( $count, $code );

    # We call nowait_push here.  Otherwise the time of gathering
    # the results would be added to the following commands.
    my $b2 = timeit( 1, $finalize );

    my $res = timesum( $b1, $b2 );
    say "$title: ", timestr( $res, 'auto' );

    return { $title => $res };
}

sub run {
    my ( $method, $value, $cas ) = @_;

    my $params = sub {
        my @params;
        push @params, $_[0] . '-' . get_key();
        push @params, 0      if $cas;
        push @params, $value if defined $value;
        return @params;
    };

    my $params_multi = sub {
        my @res;
        for ( my $i = 0; $i < key_count; ++$i ) {
            my @params;
            push @params, $_[0] . '-' . get_key();
            if ( $cas or defined $value ) {
                push @params, 0      if $cas;
                push @params, $value if defined $value;
                push @res,    \@params;
            }
            else {
                push @res, @params;
            }
        }
        return @res;
    };

    my @test = (
        "$method" => sub {
            my $res = $new->$method( &$params('p$') )
                foreach ( 1 .. key_count );
        },
    );

    push @test, (
        "old $method" => sub {
            my $res = $old->$method( &$params('o$') )
                foreach ( 1 .. key_count );
        },
    ) if defined $old and $method =~ /$old_method/o;

    my $bench = timethese( $count, {@test} );

    if ( defined $value and $noreply ) {

        # We call get('no-such-key') here.  Otherwise the time of
        # sending the requests might be added to the following