public

wki / redis_benchmark.pl

Created 2012-01-29

#!/usr/bin/env perl
use strict;
use warnings;
use feature ':5.10';
use Redis;
use YAML::XS ();
use YAML ();
use JSON::XS ();
use IO::Socket::INET;
use Data::Dumper;
use Benchmark ':all';
 
my $redis = Redis->new;
 
my %structure = (
    foo => 'bar',
    bar => 42,
    baz => [ 1,2,3,4 ],
    another => { foo => 42, string => "\x{2022} utf8 string"}
);
 
my $json = JSON::XS::encode_json \%structure;
 
my $socket = IO::Socket::INET->new( PeerAddr => '127.0.0.1:6379', Proto => 'tcp' );
 
sub set_string { $redis->set('user:wki' => 'foo bar') }
sub get_string { $redis->get('user:wki') }
sub set_yaml_xs { $redis->set('session:12345_yaml', YAML::XS::Dump \%structure) }
sub get_yaml_xs { YAML::XS::Load $redis->get('session:12345_yaml') }
sub set_json_xs { $redis->set('session:12345_json', JSON::XS::encode_json \%structure) }
sub get_json_xs { JSON::XS::decode_json $redis->get('session:12345_json') }
 
sub pure_native { native_redis_command(setex => 'session:12345_native', 3600, $json) }
sub set_native_json_xs { native_redis_command(setex => 'session:12345_native', 3600, JSON::XS::encode_json \%structure) }
sub get_native_json_xs { JSON::XS::decode_json native_redis_command(get => 'session:12345_native') }
 
sub native_redis_command {
    # theoretically needed but slows down a bit. At least on Unix-Systems the default \n is OK
    # local $/ = "\r\n";
    
    syswrite $socket,
             join("\r\n",
                  # first line is:
                  #   * <nr_of_lines>
                  '*' . scalar(@_),
                  
                  # every content-line is split into 2:
                  #   $ <nr_of_bytes_in_following_line>
                  #   payload
                  (map { ('$' . length, $_) } @_),
                  
                  # needed to have a trailing CR-LF
                  ''
                  );
 
    my $line = <$socket>;
    if (substr($line,0,1) eq '$') {
        # one result -- a known nr of bytes
        my $buffer;
        read $socket, $buffer, substr($line,1)+2;
        return $buffer;
    } elsif (substr($line,0,1) eq '-') {
        # error
        die 'Redis Error: ' . substr($line,1,-2);
    } elsif (substr($line,0,1) eq '+') {
        # status
        return substr($line,1,-2);
    } elsif (substr($line,0,1) eq ':') {
        # integer
        return substr($line,1,-2);
    } elsif (substr($line,0,1) eq '*') {
        # bulk reply
        die 'bulk reply not yet done';
    } else {
        die 'unknown reply: ' . substr($line,0,-2)
    }
}
 
# ensure we have data saved to allow get...() to occur before set...() during benchmark
set_string;
set_yaml_xs;
set_json_xs;
set_native_json_xs;
 
my $results = timethese(10_000, {
    set_string  => \&set_string,
    get_string  => \&get_string,
    set_yaml_xs => \&set_yaml_xs,
    get_yaml_xs => \&get_yaml_xs,
    set_json_xs => \&set_json_xs,
    get_json_xs => \&get_json_xs,
    pure_native => \&pure_native,
    set_native => \&set_native_json_xs,
    get_native => \&get_native_json_xs,
});
 
cmpthese($results);