File Coverage

blib/lib/App/Memcached/Tool/CLI.pm
Criterion Covered Total %
statement 44 137 32.1
branch 12 38 31.5
condition 10 22 45.4
subroutine 12 19 63.1
pod 0 8 0.0
total 78 224 34.8


line stmt bran cond sub pod time code
1             package App::Memcached::Tool::CLI;
2              
3 2     2   15363 use strict;
  2         4  
  2         64  
4 2     2   9 use warnings;
  2         2  
  2         54  
5 2     2   36 use 5.008_001;
  2         5  
6              
7 2     2   1609 use Getopt::Long qw(:config posix_default no_ignore_case no_ignore_case_always);
  2         20308  
  2         11  
8 2     2   460 use List::Util qw(first);
  2         4  
  2         184  
9              
10 2     2   294 use App::Memcached::Tool;
  2         2  
  2         45  
11 2     2   339 use App::Memcached::Tool::DataSource;
  2         3  
  2         55  
12 2     2   8 use App::Memcached::Tool::Util ':all';
  2         3  
  2         219  
13              
14 2     2   10 use version; our $VERSION = 'v0.9.2';
  2         2  
  2         10  
15              
16             my @MODES = qw(display dump stats settings sizes help man);
17             my $DEFAULT_MODE = $MODES[0];
18              
19             sub new {
20 0     0 0 0 my $class = shift;
21 0         0 my %params = @_;
22             $params{ds}
23             = App::Memcached::Tool::DataSource->connect(
24             $params{addr}, timeout => $params{timeout}
25 0         0 );
26              
27 0         0 bless \%params, $class;
28             }
29              
30             sub parse_args {
31 15     15 0 18517 my $class = shift;
32              
33 15         25 my %params; # will be passed to new()
34 15 100 100     72 if (defined $ARGV[0] and looks_like_addr($ARGV[0])) {
35 5         31 $params{addr} = shift @ARGV;
36             }
37 15 100 100 66   235 if (defined $ARGV[0] and first { $_ eq $ARGV[0] } @MODES) {
  66         204  
38 8         46 $params{mode} = shift @ARGV;
39             }
40              
41             GetOptions(
42 15 50       143 \my %opts, 'addr|a=s', 'mode|m=s', 'timeout|t=i',
43             'debug|d', 'help|h', 'man',
44             ) or return +{};
45 15 50       7049 warn "Unevaluated args remain: @ARGV" if (@ARGV);
46              
47 15 100       91 if (defined $opts{man}) {
48 2         5 $params{mode} = 'man';
49             }
50 15 100       48 if (defined $opts{help}) {
51 3         7 $params{mode} = 'help';
52             }
53 15 50       35 if (defined $opts{debug}) {
54 0         0 $App::Memcached::Tool::DEBUG = 1;
55             }
56              
57             %params = (
58             addr => create_addr($params{addr} || $opts{addr}),
59             mode => $params{mode} || $opts{mode} || $DEFAULT_MODE,
60             timeout => $opts{timeout},
61             debug => $opts{debug},
62 15   66     91 );
      66        
63 15 50   63   307 unless (first { $_ eq $params{mode} } @MODES) {
  63         83  
64 0         0 warn "Invalid mode! $params{mode}";
65 0         0 delete $params{mode};
66             }
67              
68 15         83 return \%params;
69             }
70              
71             sub run {
72 0     0 0   my $self = shift;
73 0           debug "[start] $self->{mode} $self->{addr}";
74 0           my $method = $self->{mode};
75 0           my $ret = $self->$method;
76 0           $self->{ds}->disconnect;
77 0 0         unless ($ret) {
78 0           warn "Command '$self->{mode}' seems failed. Set '--debug' option if you want to see debug logs.";
79 0           exit 1;
80             }
81 0           debug "[end] $self->{mode} $self->{addr}";
82             }
83              
84             sub display {
85 0     0 0   my $self = shift;
86              
87 0           my %stats;
88 0           my $max = 1;
89              
90 0           my $resp_items = $self->{ds}->query('stats items');
91 0           for my $line (@$resp_items) {
92 0 0         if ($line =~ m/^STAT items:(\d+):(\w+) (\d+)/) {
93 0           $stats{$1}{$2} = $3;
94             }
95             }
96              
97 0           my $resp_slabs = $self->{ds}->query('stats slabs');
98 0           for my $line (@$resp_slabs) {
99 0 0         if ($line =~ m/^STAT (\d+):(\w+) (\d+)/) {
100 0           $stats{$1}{$2} = $3;
101 0           $max = $1;
102             }
103             }
104              
105 0           print " # Item_Size Max_age Pages Count Full? Evicted Evict_Time OOM\n";
106 0           for my $class (1..$max) {
107 0           my $slab = $stats{$class};
108 0 0         next unless $slab->{total_pages};
109              
110             my $size
111             = $slab->{chunk_size} < 1024 ? "$slab->{chunk_size}B"
112 0 0         : sprintf("%.1fK", $slab->{chunk_size} / 1024.0) ;
113              
114 0 0         my $full = ($slab->{free_chunks_end} == 0) ? 'yes' : 'no';
115             printf(
116             "%3d %8s %9ds %7d %7d %7s %8d %8d %4d\n",
117             $class, $size, $slab->{age} || 0, $slab->{total_pages},
118             $slab->{number} || 0, $full, $slab->{evicted} || 0,
119 0   0       $slab->{evicted_time} || 0, $slab->{outofmemory} || 0,
      0        
      0        
      0        
      0        
120             );
121             }
122              
123 0           return 1;
124             }
125              
126             sub stats {
127 0     0 0   my $self = shift;
128 0           my $response = $self->{ds}->query('stats');
129 0           my %stats;
130 0           for my $line (@$response) {
131 0 0         if ($line =~ m/^STAT\s+(\S*)\s+(.*)/) {
132 0           $stats{$1} = $2;
133             }
134             }
135 0           print "# stats - $self->{addr}\n";
136 0           printf "#%23s %16s\n", 'Field', 'Value';
137 0           for my $field (sort {$a cmp $b} (keys %stats)) {
  0            
138 0           printf ("%24s %16s\n", $field, $stats{$field});
139             }
140 0           return 1;
141             }
142              
143             sub settings {
144 0     0 0   my $self = shift;
145 0           my $response = $self->{ds}->query('stats settings');
146 0           my %stats;
147 0           for my $line (@$response) {
148 0 0         if ($line =~ m/^STAT\s+(\S*)\s+(.*)/) {
149 0           $stats{$1} = $2;
150             }
151             }
152 0           print "# stats settings - $self->{addr}\n";
153 0           printf "#%23s %16s\n", 'Field', 'Value';
154 0           for my $field (sort {$a cmp $b} (keys %stats)) {
  0            
155 0           printf ("%24s %16s\n", $field, $stats{$field});
156             }
157 0           return 1;
158             }
159              
160             sub dump {
161 0     0 0   my $self = shift;
162 0           my %items;
163             my $total;
164              
165 0           my $response = $self->{ds}->query('stats items');
166 0           for my $line (@$response) {
167 0 0         if ($line =~ m/^STAT items:(\d*):number (\d*)/) {
168 0           $items{$1} = $2;
169 0           $total += $2;
170             }
171             }
172              
173 0           print STDERR "Dumping memcache contents\n";
174 0           printf STDERR " Number of buckets: %d\n", scalar(keys(%items));
175 0           print STDERR " Number of items : $total\n";
176              
177 0           for my $bucket (sort(keys %items)) {
178 0           print STDERR "Dumping bucket $bucket - " . $items{$bucket} . " total items\n";
179 0           $response = $self->{ds}->query("stats cachedump $bucket $items{$bucket}");
180              
181 0           my %expires;
182 0           for my $line (@$response) {
183             # Ex) ITEM foo [6 b; 1176415152 s]
184 0 0         if ($line =~ m/^ITEM (\S+) \[.* (\d+) s\]/) {
185 0           $expires{$1} = $2;
186             }
187             }
188              
189 0           for my $key (keys %expires) {
190 0           my $data = $self->{ds}->get($key);
191 0           print "add $key $data->{flags} $expires{$key} $data->{length}\r\n$data->{value}\r\n";
192             }
193             }
194              
195 0           return 1;
196             }
197              
198             sub sizes {
199 0     0 0   my $self = shift;
200 0           my $response = $self->{ds}->query('stats sizes');
201 0           my %stats;
202 0           for my $line (@$response) {
203 0 0         if ($line =~ m/^STAT\s+(\S*)\s+(.*)/) {
204 0           $stats{$1} = $2;
205             }
206             }
207 0           print "# stats sizes - $self->{addr}\n";
208 0           printf "#%17s %12s\n", 'Size', 'Count';
209 0           for my $field (sort {$a cmp $b} (keys %stats)) {
  0            
210 0           printf ("%18s %12s\n", $field, $stats{$field});
211             }
212 0           return 1;
213             }
214              
215             1;
216             __END__