#! /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
        # commands.
        my $res = bench_finalize(
            "$method noreply",
            sub {
                $new_noreply->$method( &$params('pr') )
                    foreach ( 1 .. key_count );
            },
            sub { $new_noreply->get('no-such-key') }
        );

        merge_hash( $bench, $res );

        if ( defined $old and $method =~ /$old_method/o ) {
            $res = bench_finalize(
                "old $method noreply",
                sub {
                    $old->$method( &$params('or') )
                        foreach ( 1 .. key_count );
                },
                sub { $old->get('no-such-key') }
            );

            merge_hash( $bench, $res );
        }
    }

    if ( defined $value and NOWAIT ) {

        # We call nowait_push here.  Otherwise the time of gathering
        # the results would be added to the following commands.
        my $res = bench_finalize(
            "$method nowait",
            sub {
                $new->$method( &$params('pw') ) foreach ( 1 .. key_count );
            },
            sub { $new->nowait_push }
        );
        merge_hash( $bench, $res );
    }

    my $method_multi = "${method}_multi";
    @test
        = ( "$method_multi"
            . ( defined $value ? ' (%h)' : '' ) =>
            sub { my $res = $new->$method_multi( &$params_multi('m%') ) }, );

    # We use the same 'm%' prefix here as for the new module because
    # old module doesn't have set_multi, and we want to retrieve
    # something.
    push @test,
        ( "old $method_multi" =>
            sub { my $res = $old->$method_multi( &$params_multi('m%') ) }, )
        if defined $old and $method =~ /$old_method_multi/o;

    push @test,
        ( "$method_multi (\@a)" =>
            sub { my @res = $new->$method_multi( &$params_multi('m@') ) }, )
        if defined $value;

    merge_hash( $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
        # commands.
        my $res = bench_finalize(
            "$method_multi noreply",
            sub {
                $new_noreply->$method_multi( &$params_multi('mr') );
            },
            sub { $new_noreply->get('no-such-key') }
        );

        merge_hash( $bench, $res );
    }

    if ( defined $value and NOWAIT ) {

        # We call nowait_push here.  Otherwise the time of gathering
        # the results would be added to the following commands.
        my $res = bench_finalize(
            "$method_multi nowait",
            sub {
                $new->$method_multi( &$params_multi('mw') );
            },
            sub { $new->nowait_push }
        );

        merge_hash( $bench, $res );
    }

    cmpthese($bench);
}

my @methods = (
    [ add     => \&run, $value ],
    [ set     => \&run, $value ],
    [ append  => \&run, $value ],
    [ prepend => \&run, $value ],
    [ replace => \&run, $value ],
    [ cas     => \&run, $value, 'CAS' ],
    [ get     => \&run ],
    [ gets    => \&run ],
    [ incr    => \&run, 1 ],
    [ decr    => \&run, 1 ],
    [ delete  => \&run, 0 ],
);

say "Servers: @{[ keys %$version ]}";
say "Iteration count: $count";
say 'Keys per iteration: ', key_count;
say 'Value size: ', length($value), ' bytes';

srand(1);
foreach my $args (@methods) {
    my $sub = splice( @$args, 1, 1 );
    &$sub(@$args);
}

# Benchmark latency issues.
if ($noreply) {
    cmpthese(
        timethese(
            $count,
            {   "set noreply followed by get" => sub {
                    foreach ( 1 .. key_count ) {
                        $new_noreply->set( 'snfbg', $value );
                        my $res = $new_noreply->get('snfbg');
                    }
                }
            }
        )
    );
}