[LON-CAPA-cvs] cvs: loncom /debugging_tools memcached_dump.pl

[raeburn]

raeburn		Sun Feb 21 17:29:33 2016 EDT

  Added files:                 
    /loncom/debugging_tools	memcached_dump.pl 
  Log:
  - Dump memcached's currently stored keys and values.  
    See: http://mail.lon-capa.org/pipermail/lon-capa-admin/2015-February/003005.html
  
  

Index: loncom/debugging_tools/memcached_dump.pl
+++ loncom/debugging_tools/memcached_dump.pl
#!/usr/bin/perl -w
#
# The LearningOnline Network
#
# memcached_dump.pl - dump key => values from Memcached to standard output, 
#                                        unescaping keys if asked to do so.
#
# $Id: memcached_dump.pl,v 1.1 2016/02/21 17:29:33 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
#################################################
use strict;
use Cache::Memcached;
use Data::Dumper;
use Getopt::Long;
use lib '/home/httpd/lib/perl/';
use LONCAPA;

$SIG{'__WARN__'} = sub { warn $_[0] unless (caller eq "Cache::Memcached"); };

#
# Options
my ($unesc,$showsize,$help) = (0,0,0);
GetOptions("unescape" => \$unesc,
           "u"        => \$unesc,
           "size"     => \$showsize,
           "s"        => \$showsize,
           "help"     => \$help);
#
# Help them out if they ask for it
if ($help) {
    print <<END;
memcached_dump.pl - dump contents of memcache to stdout.
Specify --unescape to have all the keys unescaped.
Specify --size to show the size of the value stored for each key.
Specify names (or parts of names of keys) to look for on the command line.
Options:
   --help     Display this help.
   --unescape Unescape the keys before printing them out.
   -u         Same as --unescape
   --size     Display the size  of the value stored for each key.
   -s         Same as --size
Examples:
    memcached_dump.pl -u -s
    memcached_dump.pl -u dns
    memcached_dump.pl -u dns iphost
END
    exit;
}

my @keys;

#
# Loop through ARGV getting files.
while (my $keyname = shift) {
    unless(grep(/^\Q$keyname\E$/, at keys)) {
        push(@keys,$keyname);
    }
}

my $instance = "127.0.0.1:11211";
my $memd = new Cache::Memcached {
     'servers' => [ $instance],
     'debug' => 0,
};

my %containers;
my $stats = $memd->stats('items');
my $items = $stats->{hosts}->{$instance}->{items};
foreach my $line (split(/\r\n/,$items)) {
     my ($key) = (split(/:/,$line,3))[1];
     $containers{$key} = 1;
}

my $count = 0;
foreach my $container (sort(keys(%containers))) {
      my $result = $memd->stats("cachedump $container 0");
      my $contents = $result->{hosts}->{$instance}->{"cachedump $container 0"};

      foreach my $item (split(/\r\n/,$contents)) {
          my ($escname,$size) = ($item =~ /^ITEM\s+(\S+)\s+\[([^;]+)/);
          my $name = $escname;
          if ($unesc) {
              $name = &unescape($escname);
          }
          if (@keys) {
              my $match = 0;
              foreach my $key (@keys) {
                   if ($name =~ /\Q$key\E/) {
                       $match = 1;
                       last;
                   }
              } 
              next unless($match); 
          }
          my $val = $memd->get($escname);
          $count ++;
          if ($showsize) {
              print "$name $size ".Dumper($val)."\n";
          } else {
              print "$name ".Dumper($val)."\n";
          }
      }
}
$memd->disconnect_all;

if ((@keys) && ($count ==0)) {
    if (@keys == 1) {
        print "No matches found for $keys[0]\n";
    } else {
        print "No matches found for any of: ".join(' ', at keys)."\n";
    }
}