Андрей (andy) wrote in changelog,
Андрей
andy
changelog

[livejournal] r17874: refactor LJ::MemCache

Committer: ailyin
refactor LJ::MemCache
U   trunk/cgi-bin/LJ/MemCache.pm
U   trunk/htdocs/admin/memcache.bml
Modified: trunk/cgi-bin/LJ/MemCache.pm
===================================================================
--- trunk/cgi-bin/LJ/MemCache.pm	2010-12-07 09:19:04 UTC (rev 17873)
+++ trunk/cgi-bin/LJ/MemCache.pm	2010-12-07 13:38:46 UTC (rev 17874)
@@ -1,361 +1,733 @@
-#
-# Wrapper around MemCachedClient
+=head1 NAME
 
+LJ::MemCache - LiveJournal-specific wrapper for various modules working
+with memcached servers
+
+=head1 NOTES AND CONVENTIONS
+
+The underlying modules are as follows:
+
+=over 2
+
+=item *
+
+Cache::Memcached
+
+=item *
+
+Cache::Memcached::Fast
+
+=back
+
+Please refer to the documentation of those for information how
+get/set/etc functions work.
+
+The methods here are not "class methods"; use LJ::MemCache::method,
+not LJ::MemCache->method.
+
+=head1 SUPPORTED METHODS
+
+=head2 READING DATA
+
+=over 2
+
+=item *
+
+get
+
+=item *
+
+gets
+
+=item *
+
+get_multi
+
+=item *
+
+gets_multi
+
+=back
+
+Note that gets and gets_multi may not be supported by the underlying module;
+call LJ::MemCached::can_gets to find out.
+
+=head2 WRITING DATA
+
+=over 2
+
+=item *
+
+add
+
+=item *
+
+set
+
+=item *
+
+replace
+
+=item *
+
+incr
+
+=item *
+
+decr
+
+=item *
+
+append
+
+=item *
+
+prepend
+
+=item *
+
+delete
+
+=item *
+
+cas
+
+=back
+
+=head1 LJ-SPECIFIC METHODS
+
+=head2 MAINTENANCE
+
+=over 2
+
+=item *
+
+init()
+
+=item *
+
+set_memcache($handler_class)
+
+=item *
+
+get_memcache()
+
+=item *
+
+reload_conf()
+
+=item *
+
+disconnect_all()
+
+=back
+
+=head2 UTILITY
+
+=over 2
+
+=item *
+
+get_or_set( $key, $coderef, $expire )
+
+=back
+
+=head2 SERIALIZATION AND DESERIALIZATION
+
+=over 2
+
+=item *
+
+array_to_hash($format, $array)
+
+=item *
+
+hash_to_array($format, $hash)
+
+=back
+
+The %LJ::MEMCACHE_ARRAYFMT variable in this modules is a table that defines
+formats; the first element of a format list is a numeric version value that
+is set when writing and checked when fetching data.
+
+=cut
+
 package LJ::MemCache;
 use strict;
-use lib "$ENV{LJHOME}/cgi-bin";
+use warnings;
 
-##
-my $use_fast = not $LJ::DISABLED{cache_memcached_fast};
+use String::CRC32 qw();
+use Carp qw();
 
-# HACK: Hardcode option for the 54 release
-$use_fast = 0; 
+### VARIABLES ###
 
-if ($use_fast){
-    require Cache::Memcached::Fast;
-} else {
-    require Cache::Memcached;
-}
+my @handlers = qw(
+    LJ::MemCache::Fast
+    LJ::MemCache::PP
+);
+my $used_handler;
 
-##
-my $keep_complex_keys = (not $use_fast # Cache::Memcache::Fast does not support composite keys.
-                            or (exists $LJ::DISABLED{complex_keys_simplification}
-                                and not $LJ::DISABLED{complex_keys_simplification})
-                                ) ? 1 : 0;
+# 'host:port' => handler
+my %connections;
 
-# HACK: Hardcode option for the 54 release
-$keep_complex_keys = 1;
-
-
-use vars qw($GET_DISABLED);
+use vars qw( $GET_DISABLED );
 $GET_DISABLED = 0;
 
 %LJ::MEMCACHE_ARRAYFMT = (
-                          'user' =>
-                          [qw[2 userid user caps clusterid dversion status statusvis statusvisdate
-                              name bdate themeid moodthemeid opt_forcemoodtheme allow_infoshow allow_contactshow
-                              allow_getljnews opt_showtalklinks opt_whocanreply opt_gettalkemail opt_htmlemail
-                              opt_mangleemail useoverrides defaultpicid has_bio txtmsg_status is_system
-                              journaltype lang oldenc packed_props]],
-                          'fgrp' => [qw[1 userid groupnum groupname sortorder is_public]],
-                          # version #101 because old userpic format in memcached was an arrayref of
-                          # [width, height, ...] and widths could have been 1 before, although unlikely
-                          'userpic' => [qw[101 width height userid fmt state picdate location flags]],
-                          'userpic2' => [qw[1 picid fmt width height state pictime md5base64 comment flags location url]],
-                          'talk2row' => [qw[1 nodetype nodeid parenttalkid posterid datepost state]],
-                          'usermsg' => [qw[1 journalid parent_msgid otherid timesent type]],
-                          'usermsgprop' => [qw[1 userpic preformated]],
-                          );
+    'user'          => [ qw( 2
+                             userid user caps clusterid dversion status
+                             statusvis statusvisdate name bdate themeid
+                             moodthemeid opt_forcemoodtheme allow_infoshow
+                             allow_contactshow allow_getljnews
+                             opt_showtalklinks opt_whocanreply
+                             opt_gettalkemail opt_htmlemail
+                             opt_mangleemail useoverrides defaultpicid
+                             has_bio txtmsg_status is_system journaltype
+                             lang oldenc packed_props ) ],
 
+    'fgrp'          => [ qw( 1
+                             userid groupnum groupname sortorder
+                             is_public ) ],
 
-my $memc;  # memcache object
+    # version #101 because old userpic format in memcached was an arrayref
+    # of [width, height, ...] and widths could have been 1 before, although
+    # unlikely
+    'userpic'       => [ qw( 101
+                             width height userid fmt state picdate location
+                             flags ) ],
 
-sub init {
+    'userpic2'      => [ qw( 1
+                             picid fmt width height state pictime md5base64
+                             comment flags location url ) ],
 
-    my $opts = _configure_opts();
-    if ($use_fast){
-        ## Init Fast (written in C) interface to Memcached
-        $memc = Cache::Memcached::Fast->new($opts);
-    
-    } else {
-        ## Init pure perl Memcached interface
+    'talk2row'      => [ qw( 1
+                             nodetype nodeid parenttalkid posterid datepost
+                             state ) ],
 
-        ##
-        my $parser_class = LJ::conf_test($LJ::MEMCACHE_USE_GETPARSERXS) ? 'Cache::Memcached::GetParserXS'
-                                                                        : 'Cache::Memcached::GetParser';
-        eval "use $parser_class";
+    'usermsg'       => [ qw( 1
+                             journalid parent_msgid otherid timesent type ) ],
 
-        # Check to see if the 'new' function/method is defined in the proper namespace, othewise don't
-        # explicitly set a parser class. Cached::Memcached may have attempted to load the XS module, and
-        # failed. This is a reasonable check to make sure it all went OK.
-        if (eval 'defined &' . $parser_class . '::new') {
-            $opts->{'parser_class'} = $parser_class;
-        }
+    'usermsgprop'   => [ qw( 1
+                             userpic preformated ) ],
+);
 
-        ## connect
-        $memc = Cache::Memcached->new($opts);
+### PRIVATE FUNCTIONS ###
 
-        ##
-        if (LJ::_using_blockwatch()) {
-           eval { LJ::Blockwatch->setup_memcache_hooks($memc) };
+sub _hashfunc {
+    my ($what) = @_;
+    return ( String::CRC32::crc32($what) >> 16 ) & 0x7fff;
+}
 
-            warn "Unable to add Blockwatch hooks to Cache::Memcached client object: $@"
-                if $@;
-        }
+sub _connect {
+    my ($server) = @_;
 
-        ##
-        if ($LJ::DB_LOG_HOST) {
-            my $stat_callback = sub {
-                my ($stime, $etime, $host, $action) = @_;
-                LJ::blocking_report($host, 'memcache', $etime - $stime, "memcache: $action");
-            };
-            $memc->set_stat_callback($stat_callback);
-        }
+    unless ( exists $connections{$server} ) {
+        init()
+            unless defined $used_handler;
 
+        $connections{$server}
+            = $used_handler->new({ 'servers' => [ $server ] });
     }
 
-    return $memc;
+    return $connections{$server};
 }
 
-sub set_memcache {
-    $memc = shift;
-}
+sub _get_connection {
+    my ($key) = @_;
 
-sub get_memcache {
-    init() unless $memc;
-    return $memc
+    my $hashval     = ref $key eq 'ARRAY' ? int $key->[0]
+                                          : _hashfunc($key);
+
+    my $num_server  = $hashval % scalar(@LJ::MEMCACHE_SERVERS);
+    my $server      = $LJ::MEMCACHE_SERVERS[$num_server];
+
+    return _connect($server);
 }
 
-sub client_stats {
-    return $memc->{'stats'} || {};
+sub _set_compression {
+    my ( $conn, $key ) = @_;
+
+    # currently, we aren't compressing the value only if we get to work
+    # with a key as follows:
+    #
+    #   1. "talk2:$journalu->{'userid'}:L:$itemid"
+    if ( $key =~ /^talk2:/ ) {
+        $conn->enable_compress(0);
+        return;
+    }
+
+    $conn->enable_compress(1);
 }
 
+if ( !$LJ::DISABLED{'memcache_profile'} ) {
+    *_profile = sub {
+        my ( $funcname, $key, $result ) = @_;
 
-sub _configure_opts {
-    my @servers = $use_fast
-        ? map { { address => $_, weight => 1 } } @LJ::MEMCACHE_SERVERS
-        : @LJ::MEMCACHE_SERVERS;
-        
-    return {
-        servers => \@servers,
-        compress_threshold => $LJ::MEMCACHE_COMPRESS_THRESHOLD,
-        connect_timeout    => $LJ::MEMCACHE_CONNECT_TIMEOUT,
-        nowait => 1,
-        ($use_fast
-            ? () # Cache::Memcached::Fast specefic options
-            : (  
-                # Cache::Memcached specific options
-                debug           => $LJ::DEBUG{'memcached'},
-                pref_ip         => \%LJ::MEMCACHE_PREF_IP,
-                cb_connect_fail => $LJ::MEMCACHE_CB_CONNECT_FAIL,
-                readonly        => $ENV{LJ_MEMC_READONLY} ? 1 : 0,
-                )
-        ),
+        $key =~ s/\b\d+\b/?/g;
+
+        warn "[memcache-profile] $funcname($key) " .
+             ( defined $result ? '[hit]' : '[miss]' ) .
+             "\n";
     };
+} else {
+    *_profile = sub {};
 }
+
+### MAINTENANCE METHODS ###
+
+sub init {
+    undef $used_handler;
+
+    foreach my $handler (@handlers) {
+        next unless $handler->can_use;
+
+        $used_handler = $handler;
+        last;
+    }
+
+    Carp::croak "no memcache handler"
+        unless defined $used_handler;
+}
+
+sub get_memcache {
+    return $used_handler;
+}
+
+sub set_memcache {
+    my ($new_handler) = @_;
+    $used_handler = $new_handler;
+}
+
 sub reload_conf {
-    return init();
+    %connections = ();
+    init();
 }
 
-sub forget_dead_hosts { $memc->forget_dead_hosts(); }
-sub disconnect_all    { $memc->disconnect_all();    }
+sub disconnect_all {
+    foreach my $conn ( values %connections ) {
+        $conn->disconnect_all;
+    }
+}
 
-sub delete {
-    my $key = shift;
-    my $exp = shift;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
+sub list_servers {
+    my %ret = @_;
 
-    # use delete time if specified
-    return $memc->delete($key, $exp) if defined $exp;
+    foreach my $server ( @LJ::MEMCACHE_SERVERS ) {
+        $ret{$server} = _connect($server);
+    }
 
-    # else default to 4 seconds:
-    # version 1.1.7 vs. 1.1.6
-    $memc->delete($key, 1) || $memc->delete($key);
+    return \%ret;
 }
 
-sub add       { 
-    my ($key, $val, $exp) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    
-    $val = '' unless defined $val;
-    
-    $memc->enable_compress(_is_compressable($key));
-    return $memc->add($key, $val, $exp);
+### READING METHODS ###
+
+sub get {
+    my ( $key, @params ) = @_;
+
+    return if $GET_DISABLED;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    my $res = $conn->get( $key, @params );
+
+    _profile( 'get', $key, $res );
+
+    return $res;
 }
-sub replace   { 
-    my ($key, $val) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $val = '' unless defined $val;
 
-    $memc->enable_compress(_is_compressable($key));
-    return $memc->replace($key, $val);
+sub can_gets {
+    return $used_handler->can_gets;
 }
-sub set       { 
-    my ($key, $val, $exp) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $val = '' unless defined $val;
-    
-    # disable compression for some keys.
-    # we should keep it's values in raw string format to "append" some data later.
-    $memc->enable_compress(_is_compressable($key));
 
-    # perform action
-    my $res = $memc->set($key, $val, $exp);
+sub gets {
+    my ($key) = @_;
 
+    return if $GET_DISABLED;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    my $res = $conn->get($key);
+
+    _profile( 'gets', $key, $res );
+
     return $res;
 }
-sub incr      {
-    my ($key, @other) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-            if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $memc->incr($key, @other);
+
+sub get_multi {
+    return {} if $GET_DISABLED;
+
+    my @keys = @_;
+
+    my ( @connections, %keys_map, @keys_normal );
+
+    foreach my $key (@keys) {
+        my $conn = _get_connection($key);
+        my $cid  = int $conn;
+
+        unless ( exists $keys_map{$cid} ) {
+            $keys_map{$cid} = [];
+            push @connections, $conn;
+        }
+
+        my $key_normal = ref $key eq 'ARRAY' ? $key->[1]
+                                             : $key;
+
+        push @{ $keys_map{$cid} }, $key_normal;
+        push @keys_normal, $key_normal;
+    }
+
+    my %ret;
+
+    foreach my $conn (@connections) {
+        my $cid = int $conn;
+        my $conn_ret = $conn->get_multi( @{ $keys_map{$cid} } );
+
+        %ret = ( %ret, %$conn_ret );
+    }
+
+    _profile( 'get_multi', join(';', @keys_normal) );
+
+    return \%ret;
 }
-sub decr      {
-    my ($key, @other) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-            if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $memc->decr($key, @other);
+
+sub gets_multi {
+    return {} if $GET_DISABLED;
+
+    my @keys = @_;
+
+    my ( @connections, %keys_map, @keys_normal );
+
+    foreach my $key (@keys) {
+        my $conn = _get_connection($key);
+        my $cid  = int $conn;
+
+        unless ( exists $keys_map{$cid} ) {
+            $keys_map{$cid} = [];
+            push @connections, $conn;
+        }
+
+        my $key_normal = ref $key eq 'ARRAY' ? $key->[1]
+                                             : $key;
+
+        push @{ $keys_map{$cid} }, $key_normal;
+        push @keys_normal, $key_normal;
+    }
+
+    my %ret;
+
+    foreach my $conn (@connections) {
+        my $cid = int $conn;
+        my $conn_ret = $conn->gets_multi( @{ $keys_map{$cid} } );
+
+        %ret = ( %ret, %$conn_ret );
+    }
+
+    _profile( 'gets_multi', join(';', @keys_normal) );
+
+    return \%ret;
 }
 
-sub get       {
-    return undef if $GET_DISABLED;
-    my ($key, @others) = @_;
-    $key = $key->[1] 
-        if ref $key eq 'ARRAY'
-           and not $keep_complex_keys; # Cache::Memcached::Fast does not support combo [int, key] keys.
-    $memc->get($key, @others);
+### WRITING METHODS ###
+
+sub add {
+    my ( $key, $value, $expire ) = @_;
+
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'add', $key );
+
+    _set_compression( $conn, $key );
+    return $conn->add( $key, $value, $expire );
 }
 
-## gets supported only by ::Fast interface
-sub can_gets { return $use_fast }
+sub set {
+    my ( $key, $value, $expire ) = @_;
 
-## @@ret: reference to an array [$cas, $value], or nothing.
-## @@doc: Cache::Memcached::Fast only method
-sub gets {
-    return if $GET_DISABLED or not $use_fast;
-    
-    my $key = shift;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY'; # we have to simplify keys, because Cache::Memcached::Fast doesn't support complex keys.
-    return $memc->gets($key);
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'set', $key );
+
+    _set_compression( $conn, $key );
+    return $conn->set( $key, $value, $expire );
 }
-## @ret: reference to hash, where $href->{$key} holds a reference to an array [$cas, $value].
-## @@doc: Cache::Memcached::Fast only method
-sub gets_multi {
-    return if $GET_DISABLED or not $use_fast;
 
-    # Cache::Memcached::Fast does not support combo [int, key] keys.
-    my @keys = map { ref $_ eq 'ARRAY' ? $_->[1] : $_ } @_;
+sub replace {
+    my ( $key, $value, $expire ) = @_;
 
-    return $memc->gets_multi(@keys);
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'replace', $key );
+
+    _set_compression( $conn, $key );
+    return $conn->replace( $key, $value, $expire );
 }
 
-##
-sub get_multi {
-    return {} if $GET_DISABLED;
-    # Cache::Memcached::Fast does not support combo [int, key] keys.
-    my @keys = $keep_complex_keys
-        ? @_
-        : map { ref $_ eq 'ARRAY' ? $_->[1] : $_ } @_;
-    
-    return $memc->get_multi(@keys);
+sub incr {
+    my ( $key, $value ) = @_;
+
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'incr', $key );
+
+    return $conn->incr( $key, $value );
 }
 
+sub decr {
+    my ( $key, $value ) = @_;
+
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'decr', $key );
+
+    return $conn->decr( $key, $value );
+}
+
 sub append {
-    my ($key, $val) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $val = '' unless defined $val;
+    my ( $key, $value ) = @_;
 
-    ## Memcache v1.4.1 does not flush value if 'append' failed. But should!
-    ## Becouse value DO changed. Failed append means that cached key becomes invalid.
-    ## That's why we have to get result of command and delete key on if needed.
-    my $res = $use_fast
-        ? $memc->append($key, $val)
-        : _extended_set("append", $key, $val);
-    $memc->delete($key)
-        unless $res;
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'append', $key );
+
+    my $res = $conn->append( $key, $value );
+
+    unless ($res) {
+        # in case memcache failed to append to the value, it doesn't
+        # remove the value that is stored; we assume that the client
+        # updates memcache because it changed the original data, so
+        # let's actually clear the old value ourselves as a fallback
+        # mechanism
+        $conn->delete($key);
+    }
+
     return $res;
 }
 
 sub prepend {
-    my ($key, $val) = @_;
-    
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $val = '' unless defined $val;
+    my ( $key, $value ) = @_;
 
-    ## See 'append' method for description.
-    my $res = $use_fast
-        ? $memc->prepend($key, $val)
-        : _extended_set("prepend", $key, $val);
-    $memc->delete($key)
-        unless $res;
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'prepend', $key );
+
+    my $res = $conn->prepend( $key, $value );
+
+    unless ($res) {
+        # in case memcache failed to prepend to the value, it doesn't
+        # remove the value that is stored; we assume that the client
+        # updates memcache because it changed the original data, so
+        # let's actually clear the old value ourselves as a fallback
+        # mechanism
+        $conn->delete($key);
+    }
+
     return $res;
 }
 
-sub cas {
-    my ($key, $cas, $val) = @_;
-    $key = $key->[1]     # Cache::Memcached::Fast does not support combo [int, key] keys.
-        if ref $key eq 'ARRAY' and not $keep_complex_keys;
-    $val = '' unless defined $val;
-    return $use_fast 
-        ? $memc->cas($key, $cas, $val)
-        : _extended_set("cas", $key, $cas, $val);
+sub delete {
+    my ( $key, $expire ) = @_;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    _profile( 'delete', $key );
+
+    my $res = $conn->delete( $key, $expire );
+
+    return $res;
 }
 
-# Pureperl memcached interface Cache::Memcache v 1.26 does not support some memcached commands.
-# this method uses private methods of Cache::Memcache to provide new functionality
-sub _extended_set {
-    my ($cmd, @args) = @_;
-    my $append_func = ref($memc) . "::_set";
-    my $res = undef;
+sub cas {
+    my ( $key, $cas, $value ) = @_;
 
-    # Cache::Memcached::Fast has usefull flag 'nowt' - no wait for response
-    no strict 'refs';
-    if (defined wantarray()){ # scalar or list context
-        $res = &$append_func("append", $memc, @args);
-    } else {
-        &$append_func("append", $memc, @args); # void context
-    }
-    use strict 'refs';
+    $value = '' unless defined $value;
+
+    my $conn = _get_connection($key);
+
+    $key = $key->[1]
+        if ref $key eq 'ARRAY';
+
+    my $res = $conn->cas( $key, $cas, $value );
+
+    _profile( 'cas', $key, $res );
+
     return $res;
 }
 
+### UTILITY METHODS ###
 
+sub get_or_set {
+    my ( $key, $code, $expire ) = @_;
 
-sub _get_sock { $memc->get_sock(@_);   }
+    my $value = LJ::MemCache::get($key);
 
-sub run_command { $memc->run_command(@_); }
+    unless ($value) {
+        $value = $code->();
+        LJ::MemCache::set( $key, $value, $expire );
+    }
 
+    return $value;
+}
 
+### OBJECT SERIALIZATION METHODS ###
+
 sub array_to_hash {
-    my ($fmtname, $ar) = @_;
-    my $fmt = $LJ::MEMCACHE_ARRAYFMT{$fmtname};
-    return undef unless $fmt;
-    return undef unless $ar && ref $ar eq "ARRAY" && $ar->[0] == $fmt->[0];
-    my $hash = {};
-    my $ct = scalar(@$fmt);
-    for (my $i=1; $i<$ct; $i++) {
-        $hash->{$fmt->[$i]} = $ar->[$i];
+    my ( $format, $array ) = @_;
+
+    my $format_info = $LJ::MEMCACHE_ARRAYFMT{$format};
+    return unless $format_info;
+
+    my $format_version = $format_info->[0];
+    return unless $array
+              and ref $array eq "ARRAY"
+              and $array->[0] == $format_version;
+
+    my %ret;
+    foreach my $i ( 1 .. $#$format_info ) {
+        $ret{ $format_info->[$i] } = $array->[$i];
     }
-    return $hash;
+
+    return \%ret;
 }
 
 sub hash_to_array {
-    my ($fmtname, $hash) = @_;
-    my $fmt = $LJ::MEMCACHE_ARRAYFMT{$fmtname};
-    return undef unless $fmt;
-    return undef unless $hash && ref $hash;
-    my $ar = [$fmt->[0]];
-    my $ct = scalar(@$fmt);
-    for (my $i=1; $i<$ct; $i++) {
-        $ar->[$i] = $hash->{$fmt->[$i]};
+    my ( $format, $hash ) = @_;
+
+    my $format_info = $LJ::MEMCACHE_ARRAYFMT{$format};
+    return unless $format_info;
+
+    my $format_version = $format_info->[0];
+    return unless $hash
+              and ref $hash eq "HASH";
+
+    my @ret = ( $format_version );
+    foreach my $i ( 1 .. $#$format_info ) {
+        push @ret, $hash->{ $format_info->[$i] };
     }
-    return $ar;
-}
 
-sub get_or_set {
-    my ($memkey, $code, $expire) = @_;
-    my $val = LJ::MemCache::get($memkey);
-    return $val if $val;
-    $val = $code->();
-    LJ::MemCache::set($memkey, $val, $expire);
-    return $val;
+    return \@ret;
 }
 
-sub _is_compressable {
-    my $key = shift;
-    $key = $key->[1] if ref $key eq 'ARRAY'; # here we should handle real key
+package LJ::MemCache::Fast;
 
-    # now we have only one key whose value shouldn't be compressed:
-    #   1. "talk2:$journalu->{'userid'}:L:$itemid"
-    return 0 if $key =~ m/^talk2:/;
+BEGIN { our @ISA = qw( Cache::Memcached::Fast ); }
+
+sub can_use {
+    return unless LJ::is_enabled('cache_memcached_fast');
+
+    eval { require Cache::Memcached::Fast };
+    return if $@;
+
     return 1;
 }
 
+sub new {
+    my ( $class, $opts ) = @_;
+
+    return $class->SUPER::new({
+        %$opts,
+        'compress_threshold' => $LJ::MEMCACHE_COMPRESS_THRESHOLD,
+        'connect_timeout'    => $LJ::MEMCACHE_CONNECT_TIMEOUT,
+        'nowait'             => 1,
+    });
+}
+
+sub can_gets { 1 }
+
+package LJ::MemCache::PP;
+
+BEGIN { our @ISA = qw( Cache::Memcached ); }
+
+sub can_use {
+    eval { require Cache::Memcached };
+    1;
+}
+
+sub new {
+    my ( $class, $opts ) = @_;
+
+    my $conn = $class->SUPER::new({
+        %$opts,
+        'compress_threshold' => $LJ::MEMCACHE_COMPRESS_THRESHOLD,
+        'connect_timeout'    => $LJ::MEMCACHE_CONNECT_TIMEOUT,
+        'nowait'             => 1,
+
+        # Cache::Memcached specific options
+        'debug'              => $LJ::DEBUG{'memcached'},
+        'pref_ip'            => \%LJ::MEMCACHE_PREF_IP,
+        'cb_connect_fail'    => $LJ::MEMCACHE_CB_CONNECT_FAIL,
+        'readonly'           => $ENV{'LJ_MEMC_READONLY'} ? 1 : 0,
+    });
+
+    if ($LJ::DB_LOG_HOST) {
+        $conn->set_stat_callback(sub {
+            my ($stime, $etime, $host, $action) = @_;
+
+            LJ::blocking_report( $host, 'memcache', $etime - $stime,
+                                 "memcache: $action" );
+        });
+    }
+
+    return $conn;
+}
+
+sub can_gets { 0 }
+
+{
+    no strict 'refs';
+
+    # Cache::Memcached doesn't support some methods, so let's add them!
+    #
+    # this is a hacky way that uses a private method from Cache::Memcached,
+    # but oh well
+    foreach my $cmd (qw( append prepend delete )) {
+        *$cmd = sub {
+            return Cache::Memcached::_set( $cmd, @_ );
+        };
+    }
+}
+
 1;

Modified: trunk/htdocs/admin/memcache.bml
===================================================================
--- trunk/htdocs/admin/memcache.bml	2010-12-07 09:19:04 UTC (rev 17873)
+++ trunk/htdocs/admin/memcache.bml	2010-12-07 13:38:46 UTC (rev 17874)
@@ -1,174 +1,265 @@
 <?_code
 {
-#line 3
+#line 4
     use strict;
-    no strict 'refs';
     use vars qw(%GET);
     use Data::Dumper;
     use Time::HiRes ();
+    use LJ::MemCache;
 
     my $u = LJ::get_remote();
     return "You must be logged in to view this tool." unless $u;
-    return "You don't have 'siteadmin' priv." unless LJ::check_priv($u, "siteadmin", "memcacheview");
 
-    my $prev_hits = $u ? LJ::MemCache::get([$u->{'userid'},"mcrate:$u->{'userid'}"]) : undef;
+    return "You don't have the 'siteadmin:memcacheview' priv."
+        unless LJ::check_priv($u, "siteadmin", "memcacheview");
 
-    my $ret;
+    my %templates = (
+        'overview' => \qq{
+            <div class='topbar'>[<a href='memcache.bml'>Overview</a>]</div>
+            <h1>Memory Cache Overview</h1>
+            <table border='1' cellpadding='5'>
+                <tr>
+                    <th>Host</th>
+                    <th>Hit Rate</th>
+                    <th>Curr/Max Size</th>
+                    <th>Utilization %</th>
+                    <th>Uptime</th>
+                    <th>Version</th>
+                </tr>
+                <TMPL_LOOP hosts>
+                    <tr>
+                        <td>
+                            <a href="<TMPL_VAR details_link>">
+                                <TMPL_VAR host>
+                            </a>
+                        </td>
+                        <td><TMPL_VAR hit_rate></td>
+                        <td align="center"><TMPL_VAR size></td>
+                        <td><TMPL_VAR utilization></td>
+                        <td><TMPL_VAR uptime></td>
+                        <td><TMPL_VAR version></td>
+                    </tr>
+                </TMPL_LOOP>
+            </table>
+            <p>Global [<TMPL_VAR global>]</p>
+        },
 
-    my $mode = $GET{'mode'};
-    if ($GET{'host'}) {
-	$mode ||= "host";
-    }
-    $mode ||= "overview";
+        'host' => \qq{
+            <div class='topbar'>[<a href='memcache.bml'>Overview</a>]</div>
+            <h1>Details for <TMPL_VAR host></h1>
 
-    $ret .= "<div class='topbar'>[<a href='memcache.bml'>Overview</a>]\n";
+            <h2>Slab classes</h2>
+            <table border='1' cellpadding='2'>
+                <tr>
+                    <th>class</th>
+                    <th>size</th>
+                    <th>used</th>
+                    <th>total</th>
+                    <th colspan='2'>free</th>
+                    <th>pages</th>
+                    <th>max age</th>
+                </tr>
+                <TMPL_LOOP classes>
+                    <tr>
+                        <td><TMPL_VAR class></td>
+                        <td><TMPL_VAR chunk_size></td>
+                        <td><TMPL_VAR used_chunks></td>
+                        <td><TMPL_VAR total_chunks></td>
+                        <td><TMPL_VAR free_chunks></td>
+                        <td><TMPL_VAR free_chunks_end></td>
+                        <td><TMPL_VAR total_pages></td>
+                        <td><TMPL_VAR age></td>
+                    </tr>
+                </TMPL_LOOP>
+            </table>
+        },
+    );
 
-    if ($mode eq "overview") {
-	$ret .= <<"END_TOP";
-</div>
-<h1>Memory Cache Overview</h1>
-<table border='1' cellpadding='5'>
-<tr><th>Host</th><th>Hit Rate</th><th>Curr/Max Size</th><th><span title='Utilization'>Utlz %</span></th><th>Uptime</th><th>Version</th></tr>
-END_TOP
-    }
+    my $mode = $GET{'host'} ? 'host' : 'overview';
 
-    my %now_hits;
-    if ($prev_hits) { %now_hits = %$prev_hits; }
+    my $template = LJ::HTML::Template->new( scalarref => $templates{$mode} );
 
-    my ($tot_hits, $tot_misses) = ();
+    my $display_percents = sub {
+        my ($what) = @_;
+        return sprintf( '%0.02f%%', $what * 100 );
+    };
 
-    my %memc_servers = (); # ip => 1
-    foreach (@LJ::MEMCACHE_SERVERS) {
-        $memc_servers{$_}++;
-    }
+    my $display_size = sub {
+        my ($what) = @_;
 
-    foreach my $entry (sort keys %memc_servers) {
-	my $host = ref $entry ? $entry->[0] : $entry;
-	next if $mode eq "host" && $host ne $GET{'host'};
+        if ( $what > 1024 ** 3 ) {
+            return sprintf( '%0.02fG', $what / 1024 ** 3 );
+        } elsif ( $what > 1024 ** 2 ) {
+            return sprintf( '%0.02fM', $what / 1024 ** 2 );
+        } elsif ( $what > 1024 ) {
+            return sprintf( '%0.02fk', $what / 1024 );
+        } else {
+            return $what;
+        }
+    };
 
-	LJ::MemCache::forget_dead_hosts();
-	my $sock = Cache::Memcached::sock_to_host($host);
+    my $display_time = sub {
+        my ($what) = @_;
 
-        my $t1 = Time::HiRes::time();
+        if ( $what > 86400 ) {
+            return sprintf( '%0.02f days', $what / 86400 );
+        } elsif ( $what > 3600 ) {
+            return sprintf( '%0.02f hr', $what / 3600 );
+        } elsif ( $what > 60 ) {
+            return sprintf( '%0.02f min', $what / 60 );
+        } elsif ( $what > 1 ) {
+            return sprintf( '%0.02f sec', $what );
+        } else {
+            return sprintf( '%0.02f msec', $what * 1000 );
+        }
+    };
 
-	my $log;
-	my %stat;
-	my @cmds = ("", "malloc", "items", "slabs");
-	my $cmd;
-        if ($sock) {
-            while (defined($cmd = shift @cmds)) {
-                my $realcmd = "stats" . ($cmd ? " $cmd" : "");
-                $log .= "<b>$realcmd</b>\n";
-                foreach (LJ::MemCache::run_command($sock, "$realcmd\r\n")) {
-                    last if $_ eq "END\r\n";
-                    $log .= $_;
-                    next if $cmd eq "maps";
-                    if (/^STAT (\S+) (\S+)/) {
-                        $stat{$cmd}{$1} = $2;
-                    }
-                }
+    my $parse_stats = sub {
+        my ($raw) = @_;
+
+        my %ret;
+        while ( $raw =~ /^STAT (\S+) (\S+)/gm ) {
+            $ret{$1} = $2;
+        }
+        return \%ret;
+    };
+
+    my $get_stats = sub {
+        my ( $conn, $host, $statname ) = @_;
+
+        my $raw = $conn->stats($statname)->{'hosts'}->{$host}->{$statname};
+        return $parse_stats->($raw);
+    };
+
+    my $prev_hits = LJ::MemCache::get([ $u->userid, 'mcrate:' . $u->userid]);
+
+    my %now_hits  = $prev_hits ? %$prev_hits : ();
+
+    my $connections = LJ::MemCache::list_servers;
+
+    if ( $mode eq 'overview' ) {
+        my @hosts_display;
+
+        my ( $tot_hits, $tot_misses ) = qw(0 0);
+
+        foreach my $host ( sort keys %$connections ) {
+            my $conn        = $connections->{$host};
+
+            my $t1          = Time::HiRes::time();
+            my $stats       = $conn->stats->{'hosts'}->{$host}->{'misc'};
+            my $t2          = Time::HiRes::time();
+
+            my $hits        = $stats->{'get_hits'};
+            my $misses      = $stats->{'get_misses'};
+
+            my $cpu         = $stats->{'rusage_user'}
+                            + $stats->{'rusage_system'};
+
+            $now_hits{$host} = [ $hits, $misses, $cpu ];
+
+            my $requests    = $hits + $misses;
+            my $hit_rate    = $hits / ( $hits + $misses || 1 );
+
+            my $hit_rate_display = $display_percents->($hit_rate) . ' ';
+
+            if ( $prev_hits && $prev_hits->{$host} ) {
+                my ( $prev_hits, $prev_misses, $prev_cpu )
+                    = @{ $prev_hits->{$host} };
+
+                my $new_hits    = $hits     - $prev_hits;
+                my $new_misses  = $misses   - $prev_misses;
+                $tot_hits       += $new_hits;
+                $tot_misses     += $new_misses;
+
+                my $new_requests = $new_hits + $new_misses;
+                my $new_rate = $new_hits / ( $new_requests || 1 );
+
+                my $cpu = sprintf( "%0.6f", $cpu - $prev_cpu );
+
+                $hit_rate_display .= '[' .
+                                         $display_percents->($new_rate) . ' ' .
+                                         "{$new_requests} " .
+                                         $cpu .
+                                     '] ';
             }
+            $hit_rate_display .= $display_time->( $t2 - $t1 );
+
+            my $bytes_used      = $stats->{'bytes'};
+            my $bytes_avail     = $stats->{'limit_maxbytes'};
+
+            my $size_display    = $display_size->($bytes_used) . '/' .
+                                  $display_size->($bytes_avail);
+
+            my $used_ratio      = $bytes_used / ( $bytes_avail || 1 );
+            my $utilization     = $display_percents->($used_ratio);
+
+            my $uptime          = $display_time->( $stats->{'uptime'} );
+            my $version         = $stats->{'version'};
+
+            push @hosts_display, {
+                'host'          => $host,
+                'details_link'  => "$LJ::SITEROOT/admin/memcache.bml?" .
+                                   "host=$host",
+                'hit_rate'      => $hit_rate_display,
+                'size'          => $size_display,
+                'utilization'   => $utilization,
+                'uptime'        => $uptime,
+                'version'       => $version,
+            };
         }
 
-        my $t2 = Time::HiRes::time();
+        LJ::MemCache::set( [ $u->userid, 'mcrate:' . $u->userid], \%now_hits );
 
-	my $cpu = 0;
-	foreach my $key (qw(rusage_user rusage_system)) {
-	    my $sec = $stat{''}{$key};
-	    $sec =~ s/:/\./;
-	    $cpu += $sec;
-	    #$ret .= "Host $host was $stat{''}{$key} = $sec, cpu = $cpu<br />\n";
-	}
-	
-	$now_hits{$host} = [ $stat{''}{'get_hits'}, $stat{''}{'get_misses'}, $cpu ];
-	
-	my $hit_rate = sprintf("%0.02f%%", $stat{''}{'get_hits'}/($stat{''}{'get_hits'}+$stat{''}{'get_misses'}||1)*100);
+        my $tot_requests    = $tot_hits + $tot_misses;
+        my $tot_rate        = $tot_hits / ( $tot_requests || 1 );
+        my $global = $display_percents->($tot_rate) . ' ' .
+                     '{' . $tot_requests . '}';
 
-	if ($mode eq "overview") {
-	    $ret .= "<tr><td><a href='memcache.bml?host=$host'>$host</a></td>\n";
-	    $ret .= "<td>$hit_rate";
-	    if ($prev_hits && $prev_hits->{$host}) {
-		my $nh = $now_hits{$host};
-		my $ph = $prev_hits->{$host};
+        $template->param(
+            'hosts'     => \@hosts_display,
+            'global'    => $global,
+        );
+    } elsif ( $mode eq 'host' ) {
+        my $host = $GET{'host'};
+        my $conn = $connections->{$host};
 
-		my $new_hits = $now_hits{$host}[0] - $prev_hits->{$host}[0];
-		my $new_misses = $now_hits{$host}[1] - $prev_hits->{$host}[1];
-		$tot_hits += $new_hits;
-		$tot_misses += $new_misses;
-		my $new_whatev = $new_hits + $new_misses;
-		my $new_rate = $new_hits / ($new_whatev || 1);
+        die "invalid server $host"
+            unless $host and $conn;
 
-		my $cpu = sprintf("%0.6f", $nh->[2] - $ph->[2]);
-		$ret .= sprintf(" [%0.02f%% {$new_whatev} $cpu]", $new_rate * 100);
-	    }
-            $ret .= sprintf(" %0.02f", $t2-$t1);
-	    $ret .= "</td>";
-	    my $gb_used = $stat{''}{'bytes'} / (1024*1024*1024);
-	    my $gb_max = $stat{''}{'limit_maxbytes'} / (1024*1024*1024);
-	    if ($gb_used >= $gb_max) {
-		$ret .= sprintf("<td align='center'>%0.01fG</td>", $gb_max);
-	    } else {
-		$ret .= sprintf("<td>%0.02f/%0.01fG (%0.02f%%)</td>", $gb_used, $gb_max, $gb_used*100/($gb_max||1));
-	    }
+        my $stats_items = $get_stats->( $conn, $host, 'items' );
+        my $stats_slabs = $get_stats->( $conn, $host, 'slabs' );
 
-	    my $utiliz = $gb_used/($gb_max||1);
-    $ret .= sprintf("<td>%0.02f%%</td>", $utiliz*100);
-	    
-	    my $up = $stat{''}{'uptime'};
-	    my $upstring;
-	    foreach my $u ([86400,"d"],[3600,"h"],[60,"m"],[1,"s"]) {
-		if ($up / $u->[0] > 1) {
-		    my $v = int($up / $u->[0]);
-		    $upstring .= "${v}$u->[1] ";
-		    $up -= $v * $u->[0];
-		}
-	    }
-	    $ret .= "<td>$upstring</td>";
-	    $ret .= "<td>$stat{''}{'version'}</td>";
-	    $ret .= "</tr>";
-	}
+        my @classes_display;
 
-	if ($mode eq "host" && $host eq $GET{'host'}) {
-	    $ret .= "[<a href='memcache.bml?host=$host&amp;mode=raw'>Raw Data</a>]</div>";
-	    $ret .= "<h1>Details for $host</h1>";
+        foreach my $class (0..31) {
+            my $size = $stats_slabs->{"$class:chunk_size"};
+            next unless $size;
 
-	    $ret .= "<h2>Slab classes</h2>";
-	    $ret .= "<table border='1' cellpadding='2'>";
-	    $ret .= "<tr><th>class</th><th>size</th><th>used</th><th>total</th><th colspan='2'>free</th><th>pages</th><th>max age</th></tr>\n";
-	    foreach my $cls (0..31) {
-		my $size = $stat{'slabs'}{"$cls:chunk_size"};
-		next unless $size;
-		$ret .= "<tr><td>$cls</td>"
-		    . join('', map { "<td>" . $stat{'slabs'}{"$cls:$_"} . "</td>" }
-			   qw(chunk_size used_chunks total_chunks free_chunks free_chunks_end total_pages));
-		my $age = $stat{'items'}{"items:$cls:age"};
-		$ret .= "<td>$age</td>";
-		$ret .= "</tr>";
-	    }
-	    $ret .= "</table>\n";
+            my $age = $stats_items->{'items:' . $class . ':age'};
 
-	}
+            push @classes_display, {
+                'class'         => $class,
+                'chunk_size'    => $stats_slabs->{ $class . ':chunk_size' },
+                'used_chunks'   => $stats_slabs->{ $class . ':used_chunks' },
+                'total_chunks'  => $stats_slabs->{ $class . ':total_chunks' },
+                'free_chunks'   => $stats_slabs->{ $class . ':free_chunks' },
 
-	if ($mode eq "raw" && $host eq $GET{'host'}) {
-	    $ret .= "[<a href='memcache.bml?host=$host'>Host Stats</a>]</div>";
-	    $ret .= "<h1>Raw data for $host</h1>";
-	    $ret .= "<pre>$log</pre>";
-	}
-	
-    }
+                'free_chunks_end' =>
+                    $stats_slabs->{$class . ':free_chunks_end'},
 
-    LJ::MemCache::set([$u->{'userid'},"mcrate:$u->{'userid'}"], \%now_hits)
-	if $u;
+                'total_pages'   => $stats_slabs->{$class . ':total_pages'},
+                'age'           => $display_time->($age),
+            };
 
-    if ($mode eq "overview") {
-	$ret .= "</table>\n";
+        }
 
-	my $new_whatev = $tot_hits + $tot_misses;
-	my $new_rate = $tot_hits / ($new_whatev || 1);	
-	$ret .= sprintf("Global [%0.02f%% {$new_whatev}]", $new_rate * 100);
+        $template->param(
+            'classes'   => \@classes_display,
+            'host'      => $host,
+        );
     }
 
-    return $ret;
+    return $template->output;
 }
 _code?>
 

Tags: andy, bml, livejournal, pm
Subscribe
  • Post a new comment

    Error

    Anonymous comments are disabled in this journal

    default userpic

    Your reply will be screened

    Your IP address will be recorded 

  • 2 comments