wki / redis_benchmark.pl

Created January 29, 2012


    
    View redis_benchmark.pl 
  
  
      redis_benchmark.pl
    
    
        Raw
      
    
    File suppressed. Click to show.
  
  
            1
            2
            3
            4
            5
            6
            7
            8
            9
            10
            11
            12
            13
            14
            15
            16
            17
            18
            19
            20
            21
            22
            23
            24
            25
            26
            27
            28
            29
            30
            31
            32
            33
            34
            35
            36
            37
            38
            39
            40
            41
            42
            43
            44
            45
            46
            47
            48
            49
            50
            51
            52
            53
            54
            55
            56
            57
            58
            59
            60
            61
            62
            63
            64
            65
            66
            67
            68
            69
            70
            71
            72
            73
            74
            75
            76
            77
            78
            79
            80
            81
            82
            83
            84
            85
            86
            87
            88
            89
            90
            91
            92
            93
            94
            95
            96
            97
          
          
            #!/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);