percona/percona-toolkit
1
0
Fork 0
mirror of https://github.com/percona/percona-toolkit.git synced 2025-09-04 11:37:16 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
8d70a272fee59cf199300b58968be1d9242ee969
percona-toolkit/bin/pt-diskstats

3647 lines
106 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/env perl
# This program is part of Percona Toolkit: http://www.percona.com/software/
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
# notices and disclaimers.
use strict;
use warnings FATAL => 'all';
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
# %INC magic to allow us to require/use these even within the big file.
BEGIN {
$INC{$_} = __FILE__ for map {
(my $t = $_ . ".pm") =~ s!::!/!g; $t
} qw( OptionParser Transformers ReadKeyMini Diskstats DiskstatsGroupByAll DiskstatsGroupByDisk DiskstatsGroupBySample DiskstatsMenu pt_diskstats );
}
# This program is copyright 2007-2011 Baron Schwartz, 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
);
my $self = {
head1 => 'OPTIONS', # These args are used internally
skip_rules => 0, # to instantiate another Option-
item => '--(.*)', # Parser obj that parses the
attributes => \%attributes, # DSN OPTIONS section. Tools
parse_attributes => \&_parse_attribs, # don't tinker with these args.
%args,
strict => 1, # disabled by a special rule
program_name => $program_name,
opts => {},
got_opts => 0,
short_opts => {},
defaults => {},
groups => {},
allowed_groups => {},
errors => [],
rules => [], # desc of rules for --help
mutex => [], # rule: opts are mutually exclusive
atleast1 => [], # rule: at least one opt is required
disables => {}, # rule: opt disables other opts
defaults_to => {}, # rule: opt defaults to value of other opt
DSNParser => undef,
default_files => [
"/etc/percona-toolkit/percona-toolkit.conf",
"/etc/percona-toolkit/$program_name.conf",
"$home/.percona-toolkit.conf",
"$home/.$program_name.conf",
],
types => {
string => 's', # standard Getopt type
int => 'i', # standard Getopt type
float => 'f', # standard Getopt type
Hash => 'H', # hash, formed from a comma-separated list
hash => 'h', # hash as above, but only if a value is given
Array => 'A', # array, similar to Hash
array => 'a', # array, similar to hash
DSN => 'd', # DSN
size => 'z', # size with kMG suffix (powers of 2^10)
time => 'm', # time, with an optional suffix of s/h/m/d
},
};
return bless $self, $class;
}
sub get_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
my @specs = $self->_pod_to_specs($file);
$self->_parse_specs(@specs);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
MKDEBUG && _d('Parsing DSN OPTIONS');
my $dsn_attribs = {
dsn => 1,
copy => 1,
};
my $parse_dsn_attribs = sub {
my ( $self, $option, $attribs ) = @_;
map {
my $val = $attribs->{$_};
if ( $val ) {
$val = $val eq 'yes' ? 1
: $val eq 'no' ? 0
: $val;
$attribs->{$_} = $val;
}
} keys %$attribs;
return {
key => $option,
%$attribs,
};
};
my $dsn_o = new OptionParser(
description => 'DSN OPTIONS',
head1 => 'DSN OPTIONS',
dsn => 0, # XXX don't infinitely recurse!
item => '\* (.)', # key opts are a single character
skip_rules => 1, # no rules before opts
attributes => $dsn_attribs,
parse_attributes => $parse_dsn_attribs,
);
my @dsn_opts = map {
my $opts = {
key => $_->{spec}->{key},
dsn => $_->{spec}->{dsn},
copy => $_->{spec}->{copy},
desc => $_->{desc},
};
$opts;
} $dsn_o->_pod_to_specs($file);
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
}
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
$self->{version} = $1;
MKDEBUG && _d($self->{version});
}
return;
}
sub DSNParser {
my ( $self ) = @_;
return $self->{DSNParser};
};
sub get_defaults_files {
my ( $self ) = @_;
return @{$self->{default_files}};
}
sub _pod_to_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my @specs = ();
my @rules = ();
my $para;
local $INPUT_RECORD_SEPARATOR = '';
while ( $para = <$fh> ) {
next unless $para =~ m/^=head1 $self->{head1}/;
last;
}
while ( $para = <$fh> ) {
last if $para =~ m/^=over/;
next if $self->{skip_rules};
chomp $para;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
MKDEBUG && _d('Option rule:', $para);
push @rules, $para;
}
die "POD has no $self->{head1} section" unless $para;
do {
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
chomp $para;
MKDEBUG && _d($para);
my %attribs;
$para = <$fh>; # read next paragraph, possibly attributes
if ( $para =~ m/: / ) { # attributes
$para =~ s/\s+\Z//g;
%attribs = map {
my ( $attrib, $val) = split(/: /, $_);
die "Unrecognized attribute for --$option: $attrib"
unless $self->{attributes}->{$attrib};
($attrib, $val);
} split(/; /, $para);
if ( $attribs{'short form'} ) {
$attribs{'short form'} =~ s/-//;
}
$para = <$fh>; # read next paragraph, probably short help desc
}
else {
MKDEBUG && _d('Option has no attributes');
}
$para =~ s/\s+\Z//g;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
MKDEBUG && _d('Short help:', $para);
die "No description after option spec $option" if $para =~ m/^=item/;
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
$option = $base_option;
$attribs{'negatable'} = 1;
}
push @specs, {
spec => $self->{parse_attributes}->($self, $option, \%attribs),
desc => $para
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
};
}
while ( $para = <$fh> ) {
last unless $para;
if ( $para =~ m/^=head1/ ) {
$para = undef; # Can't 'last' out of a do {} block.
last;
}
last if $para =~ m/^=item /;
}
} while ( $para );
die "No valid specs in $self->{head1}" unless @specs;
close $fh;
return @specs, @rules;
}
sub _parse_specs {
my ( $self, @specs ) = @_;
my %disables; # special rule that requires deferred checking
foreach my $opt ( @specs ) {
if ( ref $opt ) { # It's an option spec, not a rule.
MKDEBUG && _d('Parsing opt spec:',
map { ($_, '=>', $opt->{$_}) } keys %$opt);
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
if ( !$long ) {
die "Cannot parse long option from spec $opt->{spec}";
}
$opt->{long} = $long;
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
$self->{opts}->{$long} = $opt;
if ( length $long == 1 ) {
MKDEBUG && _d('Long opt', $long, 'looks like short opt');
$self->{short_opts}->{$long} = $long;
}
if ( $short ) {
die "Duplicate short option -$short"
if exists $self->{short_opts}->{$short};
$self->{short_opts}->{$short} = $long;
$opt->{short} = $short;
}
else {
$opt->{short} = undef;
}
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
MKDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
MKDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
MKDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
MKDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
MKDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
MKDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
MKDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
MKDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
MKDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
MKDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
MKDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
else {
$opt->{value} = $val;
}
$opt->{got} = 1;
MKDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] eq "--config" ) {
shift @ARGV;
$self->_set_option('config', shift @ARGV);
}
if ( $self->has('config') ) {
my @extra_args;
foreach my $filename ( split(',', $self->get('config')) ) {
eval {
push @extra_args, $self->_read_config_file($filename);
};
if ( $EVAL_ERROR ) {
if ( $self->got('config') ) {
die $EVAL_ERROR;
}
elsif ( MKDEBUG ) {
_d($EVAL_ERROR);
}
}
}
unshift @ARGV, @extra_args;
}
Getopt::Long::Configure('no_ignore_case', 'bundling');
GetOptions(
map { $_->{spec} => sub { $self->_set_option(@_); } }
grep { $_->{long} ne 'config' } # --config is handled specially above.
values %{$self->{opts}}
) or $self->save_error('Error parsing options');
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
if ( $self->{version} ) {
print $self->{version}, "\n";
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
}
exit 0;
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
MKDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
MKDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
MKDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
MKDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
MKDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
MKDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
}
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
}
else {
MKDEBUG && _d('Nothing to validate for option',
$opt->{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
MKDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
MKDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 0 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol})(?:\s+|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = <STDIN>);
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
MKDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
MKDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
MKDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
MKDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( MKDEBUG ) {
print '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print "# $uname\n";
}
print '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# This program is copyright 2008-2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# Transformers package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Transformers.pm
# t/lib/Transformers.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Transformers;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use Time::Local qw(timegm timelocal);
use Digest::MD5 qw(md5_hex);
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT = ();
our @EXPORT_OK = qw(
micro_t
percentage_of
secs_to_time
time_to_secs
shorten
ts
parse_timestamp
unix_timestamp
any_unix_timestamp
make_checksum
crc32
);
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
sub micro_t {
my ( $t, %args ) = @_;
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
my $f;
$t = 0 if $t < 0;
$t = sprintf('%.17f', $t) if $t =~ /e/;
$t =~ s/\.(\d{1,6})\d*/\.$1/;
if ($t > 0 && $t <= 0.000999) {
$f = ($t * 1000000) . 'us';
}
elsif ($t >= 0.001000 && $t <= 0.999999) {
$f = sprintf("%.${p_ms}f", $t * 1000);
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
}
elsif ($t >= 1) {
$f = sprintf("%.${p_s}f", $t);
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
}
else {
$f = 0; # $t should = 0 at this point
}
return $f;
}
sub percentage_of {
my ( $is, $of, %args ) = @_;
my $p = $args{p} || 0; # float precision
my $fmt = $p ? "%.${p}f" : "%d";
return sprintf $fmt, ($is * 100) / ($of ||= 1);
}
sub secs_to_time {
my ( $secs, $fmt ) = @_;
$secs ||= 0;
return '00:00' unless $secs;
$fmt ||= $secs >= 86_400 ? 'd'
: $secs >= 3_600 ? 'h'
: 'm';
return
$fmt eq 'd' ? sprintf(
"%d+%02d:%02d:%02d",
int($secs / 86_400),
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: $fmt eq 'h' ? sprintf(
"%02d:%02d:%02d",
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: sprintf(
"%02d:%02d",
int(($secs % 3_600) / 60),
$secs % 60);
}
sub time_to_secs {
my ( $val, $default_suffix ) = @_;
die "I need a val argument" unless defined $val;
my $t = 0;
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
$suffix = $suffix || $default_suffix || 's';
if ( $suffix =~ m/[smhd]/ ) {
$t = $suffix eq 's' ? $num * 1 # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$t *= -1 if $prefix && $prefix eq '-';
}
else {
die "Invalid suffix for $val: $suffix";
}
return $t;
}
sub shorten {
my ( $num, %args ) = @_;
my $p = defined $args{p} ? $args{p} : 2; # float precision
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
my $n = 0;
my @units = ('', qw(k M G T P E Z Y));
while ( $num >= $d && $n < @units - 1 ) {
$num /= $d;
++$n;
}
return sprintf(
$num =~ m/\./ || $n
? "%.${p}f%s"
: '%d',
$num, $units[$n]);
}
sub ts {
my ( $time, $gmt ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= $gmt ? gmtime($time) : localtime($time);
$mon += 1;
$year += 1900;
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
$us = sprintf("%.6f", $us);
$us =~ s/^0\././;
$val .= $us;
}
return $val;
}
sub parse_timestamp {
my ( $val ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $f)
= $val =~ m/^$mysql_ts$/ )
{
return sprintf "%d-%02d-%02d %02d:%02d:"
. (defined $f ? '%09.6f' : '%02d'),
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
}
return $val;
}
sub unix_timestamp {
my ( $val, $gmt ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
$val = $gmt
? timegm($s, $i, $h, $d, $m - 1, $y)
: timelocal($s, $i, $h, $d, $m - 1, $y);
if ( defined $us ) {
$us = sprintf('%.6f', $us);
$us =~ s/^0\././;
$val .= $us;
}
}
return $val;
}
sub any_unix_timestamp {
my ( $val, $callback ) = @_;
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
$n = $suffix eq 's' ? $n # Seconds
: $suffix eq 'm' ? $n * 60 # Minutes
: $suffix eq 'h' ? $n * 3600 # Hours
: $suffix eq 'd' ? $n * 86400 # Days
: $n; # default: Seconds
MKDEBUG && _d('ts is now - N[shmd]:', $n);
return time - $n;
}
elsif ( $val =~ m/^\d{9,}/ ) {
MKDEBUG && _d('ts is already a unix timestamp');
return $val;
}
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
MKDEBUG && _d('ts is MySQL slow log timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp(parse_timestamp($val));
}
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
MKDEBUG && _d('ts is properly formatted timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp($val);
}
else {
MKDEBUG && _d('ts is MySQL expression');
return $callback->($val) if $callback && ref $callback eq 'CODE';
}
MKDEBUG && _d('Unknown ts type:', $val);
return;
}
sub make_checksum {
my ( $val ) = @_;
my $checksum = uc substr(md5_hex($val), -16);
MKDEBUG && _d($checksum, 'checksum for', $val);
return $checksum;
}
sub crc32 {
my ( $string ) = @_;
return unless $string;
my $poly = 0xEDB88320;
my $crc = 0xFFFFFFFF;
foreach my $char ( split(//, $string) ) {
my $comp = ($crc ^ ord($char)) & 0xFF;
for ( 1 .. 8 ) {
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
}
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
}
return $crc ^ 0xFFFFFFFF;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Transformers package
# ###########################################################################
# This program is copyright 2010-2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# ReadKeyMini
# ###########################################################################
{
BEGIN {
package ReadKeyMini;
# Here be magic. We lie to %INC and say that someone already pulled us from
# the filesystem. Which might be true, if this is inside a .pm file, but
# might not be, if we are part of the big file. The spurious BEGINs are mostly
# unnecesary, but if we aren't inside a .pm and something uses us, import or
# EXPORT_OK might not yet be defined. Though that probably won't help.
# Costs us nothing though, so worth trying. Putting this on top of the file
# would solve the issue.
BEGIN { $INC{"ReadKeyMini.pm"} ||= 1 }
# Package: ReadKeyMini
# ReadKeyMini is a wrapper around Term::ReadKey. If that's available,
# we use ReadMode and GetTerminalSize from there. Otherwise, we use homebrewn
# definitions.
use warnings;
use strict;
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use POSIX qw( :termios_h );
use base qw( Exporter );
BEGIN {
our @EXPORT_OK = qw( ReadMode GetTerminalSize );
my $have_readkey = eval { require Term::ReadKey };
if ($have_readkey) {
Term::ReadKey->import(@EXPORT_OK);
}
else {
# If we don't have Term::ReadKey, fake it. We clobber our own glob,
# ReadKeyMini::Function, and the Term::ReadKey glob, so callers can
# both import it if requested, or even use the fully-qualified name
# without issues.
*ReadMode = *Term::ReadKey::ReadMode = \&_ReadMode;
*GetTerminalSize = *Term::ReadKey::GetTerminalSize = \&_GetTerminalSize;
}
}
my %modes = (
original => 0,
restore => 0,
normal => 1,
noecho => 2,
cbreak => 3,
raw => 4,
'ultra-raw' => 5,
);
# This primarily comes from the Perl Cookbook, recipe 15.8
{
my $fd_stdin = fileno(STDIN);
my $term = POSIX::Termios->new();
$term->getattr($fd_stdin);
my $oterm = $term->getlflag();
my $echo = ECHO | ECHOK | ICANON;
my $noecho = $oterm & ~$echo;
sub _ReadMode {
my $mode = $modes{ $_[0] };
if ( $mode == $modes{normal} ) {
cooked();
}
elsif ( $mode == $modes{cbreak} || $mode == $modes{noecho} ) {
cbreak( $mode == $modes{noecho} ? $noecho : $oterm );
}
else {
die("ReadMore('$_[0]') not supported");
}
}
sub cbreak {
my ($lflag) = $_[0] || $noecho;
$term->setlflag($lflag);
$term->setcc( VTIME, 1 );
$term->setattr( $fd_stdin, TCSANOW );
}
sub cooked {
$term->setlflag($oterm);
$term->setcc( VTIME, 0 );
$term->setattr( $fd_stdin, TCSANOW );
}
END { cooked() }
}
sub readkey {
my $key = '';
cbreak();
sysread(STDIN, $key, 1);
my $timeout = 0.1;
if ( $key eq "\033" ) {
# Ugly and broken hack, but good enough for the two minutes it took to write.
# Namely, Ctrl escapes, the F-NUM keys, and other stuff you can send from the keyboard
# take more than one "character" to represent, and would be wrong to break into pieces.
{
my $x = '';
STDIN->blocking(0);
sysread(STDIN, $x, 2);
STDIN->blocking(1);
$key .= $x;
redo if $key =~ /\[[0-2](?:[0-9];)?$/
}
}
cooked();
return $key;
}
# As per perlfaq8:
sub _GetTerminalSize {
if ( @_ ) {
die "My::Term::ReadKey doesn't implement GetTerminalSize with arguments";
}
eval { require 'sys/ioctl.ph' };
if ( !defined &TIOCGWINSZ ) {
*TIOCGWINSZ = sub () {
# Very few systems actually have ioctl.ph, thus it comes to this.
# These seem to be good enough, for now. See:
# http://stackoverflow.com/a/4286840/536499
$^O eq 'linux' ? 0x005413
: $^O eq 'solaris' ? 0x005468
: 0x40087468;
};
}
open( TTY, "+<", "/dev/tty" ) or die "No tty: $OS_ERROR";
my $winsize = '';
unless ( ioctl( TTY, &TIOCGWINSZ, $winsize ) ) {
die sprintf "$0: ioctl TIOCGWINSZ (%08x: $OS_ERROR)\n", &TIOCGWINSZ;
}
my ( $row, $col, $xpixel, $ypixel ) = unpack( 'S4', $winsize );
return ( $col, $row, $xpixel, $ypixel );
}
}
}
1;
# ###########################################################################
# End ReadKeyMini package
# ###########################################################################
# This program is copyright 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# Diskstats package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Diskstats.pm
# t/lib/Diskstats.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Diskstats;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use IO::Handle;
use List::Util qw( max first );
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($o) = @args{@required_args};
my $self = {
filename => '/proc/diskstats',
column_regex => qr/cnc|rt|busy|prg|time|io_s/,
device_regex => qr/(?=)/,
block_size => 512,
out_fh => \*STDOUT,
filter_zeroed_rows => $o->get('zero-rows') ? undef : 1,
sample_time => $o->get('sample-time') || 0,
interactive => 0,
_stats_for => {},
_ordered_devs => [],
_ts => {},
_first => 1,
_save_curr_as_prev => 1,
_print_header => 1,
};
if ( $o->get('memory-for-speed') ) {
PTDEBUG && _d('Diskstats', "Called with memory-for-speed");
eval {
require Memoize;
Memoize::memoize('_parse_diskstats_line');
};
if ($EVAL_ERROR) {
warn "Can't trade memory for speed: $EVAL_ERROR. Continuing as usual.";
}
}
my %pod_to_attribute = (
columns => 'column_regex',
devices => 'device_regex'
);
for my $key ( grep { defined $o->get($_) } keys %pod_to_attribute ) {
my $re = $o->get($key) || '(?=)';
$self->{ $pod_to_attribute{$key} } = qr/$re/i;
}
for my $attribute ( grep { !/^_/ && defined $args{$_} } keys %$self ) {
$self->{$attribute} = $args{$attribute};
}
return bless $self, $class;
}
sub curr_ts {
my ($self, $val) = @_;
if ($val) {
$self->{_ts}->{curr} = $val;
}
return $self->{_ts}->{curr} || 0;
}
sub prev_ts {
my ($self, $val) = @_;
if ($val) {
$self->{_ts}->{prev} = $val;
}
return $self->{_ts}->{prev} || 0;
}
sub first_ts {
my ($self, $val) = @_;
if ($val) {
$self->{_ts}->{first} = $val;
}
return $self->{_ts}->{first} || 0;
}
sub filter_zeroed_rows {
my ($self, $new_val) = @_;
if ( defined($new_val) ) {
$self->{filter_zeroed_rows} = $new_val;
}
return $self->{filter_zeroed_rows};
}
sub sample_time {
my ($self, $new_val) = @_;
if (defined($new_val)) {
$self->{sample_time} = $new_val;
}
return $self->{sample_time};
}
sub interactive {
my ($self, $new_val) = @_;
if (defined($new_val)) {
$self->{interactive} = $new_val;
}
return $self->{interactive};
}
sub out_fh {
my ( $self, $new_fh ) = @_;
if ( $new_fh && ref($new_fh) && $new_fh->opened ) {
$self->{out_fh} = $new_fh;
}
if ( !$self->{out_fh} || !$self->{out_fh}->opened ) {
$self->{out_fh} = \*STDOUT;
}
return $self->{out_fh};
}
sub column_regex {
my ( $self, $new_re ) = @_;
if ($new_re) {
return $self->{column_regex} = $new_re;
}
return $self->{column_regex};
}
sub device_regex {
my ( $self, $new_re ) = @_;
if ($new_re) {
return $self->{device_regex} = $new_re;
}
return $self->{device_regex};
}
sub filename {
my ( $self, $new_filename ) = @_;
if ( $new_filename ) {
return $self->{filename} = $new_filename;
}
return $self->{filename};
}
sub block_size {
my $self = shift;
return $self->{block_size};
}
sub ordered_devs {
my ( $self, $replacement_list ) = @_;
if ( $replacement_list ) {
$self->{_ordered_devs} = $replacement_list;
}
return @{ $self->{_ordered_devs} };
}
sub add_ordered_dev {
my ( $self, $new_dev ) = @_;
if ( !$self->{_seen_devs}->{$new_dev}++ ) {
push @{ $self->{_ordered_devs} }, $new_dev;
}
return;
}
sub clear_state {
my ($self) = @_;
$self->{_first} = 1;
$self->{_print_header} = 1;
$self->clear_curr_stats();
$self->clear_prev_stats();
$self->clear_first_stats();
$self->clear_ts();
$self->clear_ordered_devs();
}
sub clear_ts {
my ($self) = @_;
$self->{_ts} = {};
}
sub clear_ordered_devs {
my $self = shift;
$self->{_seen_devs} = {};
$self->ordered_devs( [] );
}
sub _clear_stats_common {
my ( $self, $key, @args ) = @_;
if (@args) {
for my $dev (@args) {
$self->{$key}->{$dev} = {};
}
}
else {
$self->{$key} = {};
}
}
sub clear_curr_stats {
my ( $self, @args ) = @_;
$self->_clear_stats_common( "_stats_for", @args );
}
sub clear_prev_stats {
my ( $self, @args ) = @_;
$self->_clear_stats_common( "_prev_stats_for", @args );
}
sub clear_first_stats {
my ( $self, @args ) = @_;
$self->_clear_stats_common( "_first_stats_for", @args );
}
sub stats_for {
my ( $self, $dev ) = @_;
$self->{_stats_for} ||= {};
if ($dev) {
return $self->{_stats_for}->{$dev};
}
return $self->{_stats_for};
}
sub prev_stats_for {
my ( $self, $dev ) = @_;
$self->{_prev_stats_for} ||= {};
if ($dev) {
return $self->{_prev_stats_for}->{$dev};
}
return $self->{_prev_stats_for};
}
sub first_stats_for {
my ( $self, $dev ) = @_;
$self->{_first_stats_for} ||= {};
if ($dev) {
return $self->{_first_stats_for}->{$dev};
}
return $self->{_first_stats_for};
}
sub has_stats {
my ($self) = @_;
my $stats = $self->stats_for;
for my $key ( keys %$stats ) {
return 1 if $stats->{$key} && %{ $stats->{$key} }
}
return;
}
sub _save_curr_as_prev {
my ( $self, $curr ) = @_;
if ( $self->{_save_curr_as_prev} ) {
$self->{_prev_stats_for} = $curr;
for my $dev (keys %$curr) {
$self->{_prev_stats_for}->{$dev}->{sum_ios_in_progress} +=
$curr->{$dev}->{ios_in_progress};
}
$self->prev_ts($self->curr_ts());
}
return;
}
sub _save_curr_as_first {
my ($self, $curr) = @_;
if ( $self->{_first} ) {
$self->{_first_stats_for} = {
map { $_ => {%{$curr->{$_}}} } keys %$curr
};
$self->first_ts($self->curr_ts());
$self->{_first} = undef;
}
}
sub _save_stats {
my ( $self, $stats ) = @_;
return $self->{_stats_for} = $stats;
}
sub trim {
my ($c) = @_;
$c =~ s/^\s+//;
$c =~ s/\s+$//;
return $c;
}
sub col_ok {
my ( $self, $column ) = @_;
my $regex = $self->column_regex();
return ($column =~ $regex) || (trim($column) =~ $regex);
}
sub dev_ok {
my ( $self, $device ) = @_;
my $regex = $self->device_regex();
return $device =~ $regex;
}
our @columns_in_order = (
[ " rd_s" => "%7.1f", "reads_sec", ],
[ "rd_avkb" => "%7.1f", "avg_read_sz", ],
[ "rd_mb_s" => "%7.1f", "mbytes_read_sec", ],
[ "rd_io_s" => "%7.1f", "ios_read_sec", ],
[ "rd_mrg" => "%5.0f%%", "read_merge_pct", ],
[ "rd_cnc" => "%6.1f", "read_conc", ],
[ " rd_rt" => "%7.1f", "read_rtime", ],
[ " wr_s" => "%7.1f", "writes_sec", ],
[ "wr_avkb" => "%7.1f", "avg_write_sz", ],
[ "wr_mb_s" => "%7.1f", "mbytes_written_sec", ],
[ "wr_io_s" => "%7.1f", "ios_written_sec", ],
[ "wr_mrg" => "%5.0f%%", "write_merge_pct", ],
[ "wr_cnc" => "%6.1f", "write_conc", ],
[ " wr_rt" => "%7.1f", "write_rtime", ],
[ "busy" => "%3.0f%%", "busy", ],
[ "in_prg" => "%6d", "in_progress", ],
[ " io_s" => "%7.1f", "s_spent_doing_io", ],
[ " qtime" => "%6.1f", "qtime", ],
[ " stime" => "%5.1f", "stime", ],
);
{
my %format_for = ( map { ( $_->[0] => $_->[1] ) } @columns_in_order, );
sub _format_for {
my ( $self, $col ) = @_;
return $format_for{$col};
}
}
{
my %column_to_key = ( map { ( $_->[0] => $_->[2] ) } @columns_in_order, );
sub _column_to_key {
my ( $self, $col ) = @_;
return $column_to_key{$col};
}
}
sub design_print_formats {
my ( $self, %args ) = @_;
my ( $dev_length, $columns ) = @args{qw( max_device_length columns )};
$dev_length ||= max 6, map length, $self->ordered_devs;
my ( $header, $format );
$header = $format = qq{%5s %-${dev_length}s };
if ( !$columns ) {
@$columns = grep { $self->col_ok($_) } map { $_->[0] } @columns_in_order;
}
elsif ( !ref($columns) || ref($columns) ne ref([]) ) {
die "The columns argument to design_print_formats should be an arrayref";
}
$header .= join " ", @$columns;
$format .= join " ", map $self->_format_for($_), @$columns;
return ( $header, $format, $columns );
}
{
my @diskstats_fields = qw(
reads reads_merged read_sectors ms_spent_reading
writes writes_merged written_sectors ms_spent_writing
ios_in_progress ms_spent_doing_io ms_weighted
);
sub parse_diskstats_line { shift; goto &_parse_diskstats_line }
sub _parse_diskstats_line {
my ( $line, $block_size ) = @_;
my $dev;
keys my %dev_stats = 30; # Pre-expand the amount of buckets for this hash.
if ( 14 == (( @dev_stats{qw( major minor )}, $dev, @dev_stats{@diskstats_fields} ) =
split " ", $line, 14 ) )
{
$dev_stats{read_kbs} =
( $dev_stats{read_bytes} = $dev_stats{read_sectors}
* $block_size ) / 1024;
$dev_stats{written_kbs} =
( $dev_stats{written_bytes} = $dev_stats{written_sectors}
* $block_size ) / 1024;
$dev_stats{ios_requested} = $dev_stats{reads}
+ $dev_stats{writes};
$dev_stats{ios_in_bytes} = $dev_stats{read_bytes}
+ $dev_stats{written_bytes};
return ( $dev, \%dev_stats );
}
elsif ((@dev_stats{qw( major minor )}, $dev,
@dev_stats{ qw( reads read_sectors writes written_sectors ) }) =
$line =~ /^
\s* (\d+) # major
\s+ (\d+) # minor
\s+ (.+?) # Device name
\s+ (\d+) # # of reads issued
\s+ (\d+) # # of sectors read
\s+ (\d+) # # of writes issued
\s+ (\d+) # # of sectors written
\s*$/x)
{
for my $key ( @diskstats_fields ) {
$dev_stats{$key} ||= 0;
}
$dev_stats{read_bytes} = $dev_stats{read_sectors} * $block_size;
$dev_stats{written_bytes} =
$dev_stats{written_sectors} * $block_size;
$dev_stats{read_kbs} = $dev_stats{read_bytes} / 1024;
$dev_stats{written_kbs} = $dev_stats{written_bytes} / 1024;
$dev_stats{ios_requested} = $dev_stats{reads} + $dev_stats{writes};
$dev_stats{ios_in_bytes} = $dev_stats{read_bytes}
+ $dev_stats{written_bytes};
return ( $dev, \%dev_stats );
}
else {
return;
}
}
}
sub parse_from {
my ( $self, %args ) = @_;
my $lines_read = $args{filehandle}
? $self->parse_from_filehandle( @args{qw( filehandle sample_callback )} )
: $args{data}
? $self->parse_from_data( @args{qw( data sample_callback )} )
: $self->parse_from_filename( @args{qw( filename sample_callback )} );
return $lines_read;
}
sub parse_from_filename {
my ( $self, $filename, $sample_callback ) = @_;
$filename ||= $self->filename();
open my $fh, "<", $filename
or die "Cannot parse $filename: $OS_ERROR";
my $lines_read = $self->parse_from_filehandle( $fh, $sample_callback );
close $fh or die "Cannot close: $OS_ERROR";
return $lines_read;
}
sub parse_from_filehandle {
my ( $self, $filehandle, $sample_callback ) = @_;
return $self->_load( $filehandle, $sample_callback );
}
sub parse_from_data {
my ( $self, $data, $sample_callback ) = @_;
open( my $fh, "<", ref($data) ? $data : \$data )
or die "Couldn't parse data: $OS_ERROR";
my $lines_read = $self->parse_from_filehandle( $fh, $sample_callback );
close $fh or die "";
return $lines_read;
}
sub _load {
my ( $self, $fh, $sample_callback ) = @_;
my $block_size = $self->block_size();
my $current_ts = 0;
my $new_cur = {};
while ( my $line = <$fh> ) {
if ( my ( $dev, $dev_stats ) = $self->parse_diskstats_line($line, $block_size) )
{
$new_cur->{$dev} = $dev_stats;
$self->add_ordered_dev($dev);
}
elsif ( my ($new_ts) = $line =~ /TS\s+([0-9]+(?:\.[0-9]+)?)/ ) {
if ( $current_ts && %$new_cur ) {
$self->_save_curr_as_prev( $self->stats_for() );
$self->_save_stats($new_cur);
$self->curr_ts($current_ts);
$self->_save_curr_as_first( $new_cur );
$new_cur = {};
}
if ($sample_callback) {
$self->$sample_callback($current_ts);
}
$current_ts = $new_ts;
}
else {
chomp($line);
warn "Line $INPUT_LINE_NUMBER: [$line] isn't in the diskstats format";
}
}
if ( $current_ts ) {
if ( %{$new_cur} ) {
$self->_save_curr_as_prev( $self->stats_for() );
$self->_save_stats($new_cur);
$self->curr_ts($current_ts);
$self->_save_curr_as_first( $new_cur );
$new_cur = {};
}
if ($sample_callback) {
$self->$sample_callback($current_ts);
}
}
return $INPUT_LINE_NUMBER;
}
sub _calc_read_stats {
my ( $self, %args ) = @_;
my @required_args = qw( delta_for elapsed devs_in_group );
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($delta_for, $elapsed, $devs_in_group) = @args{ @required_args };
my %read_stats = (
reads_sec => $delta_for->{reads} / $elapsed,
read_requests => $delta_for->{reads_merged} + $delta_for->{reads},
mbytes_read_sec => $delta_for->{read_kbs} / $elapsed / 1024,
ios_read_sec => $delta_for->{ms_spent_reading} / 1000,
read_conc => $delta_for->{ms_spent_reading} /
$elapsed / 1000 / $devs_in_group,
);
if ( $delta_for->{reads} > 0 ) {
$read_stats{read_rtime} =
$delta_for->{ms_spent_reading} / $delta_for->{reads};
$read_stats{avg_read_sz} =
$delta_for->{read_kbs} / $delta_for->{reads};
}
else {
$read_stats{read_rtime} = 0;
$read_stats{avg_read_sz} = 0;
}
$read_stats{read_merge_pct} =
$read_stats{read_requests} > 0
? 100 * $delta_for->{reads_merged} / $read_stats{read_requests}
: 0;
return %read_stats;
}
sub _calc_write_stats {
my ( $self, %args ) = @_;
my @required_args = qw( delta_for elapsed devs_in_group );
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($delta_for, $elapsed, $devs_in_group) = @args{ @required_args };
my %write_stats = (
writes_sec => $delta_for->{writes} / $elapsed,
write_requests => $delta_for->{writes_merged} + $delta_for->{writes},
mbytes_written_sec => $delta_for->{written_kbs} / $elapsed / 1024,
ios_written_sec => $delta_for->{ms_spent_writing} / 1000,
write_conc => $delta_for->{ms_spent_writing} /
$elapsed / 1000 /
$devs_in_group,
);
if ( $delta_for->{writes} > 0 ) {
$write_stats{write_rtime} =
$delta_for->{ms_spent_writing} / $delta_for->{writes};
$write_stats{avg_write_sz} =
$delta_for->{written_kbs} / $delta_for->{writes};
}
else {
$write_stats{write_rtime} = 0;
$write_stats{avg_write_sz} = 0;
}
$write_stats{write_merge_pct} =
$write_stats{write_requests} > 0
? 100 * $delta_for->{writes_merged} / $write_stats{write_requests}
: 0;
return %write_stats;
}
sub _calc_misc_stats {
my ( $self, %args ) = @_;
my @required_args = qw( delta_for elapsed devs_in_group stats );
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($delta_for, $elapsed, $devs_in_group, $stats) = @args{ @required_args };
my %extra_stats;
$extra_stats{busy} =
100 *
$delta_for->{ms_spent_doing_io} /
( 1000 * $elapsed * $devs_in_group );
my $number_of_ios = $stats->{ios_requested};
my $total_ms_spent_on_io = $delta_for->{ms_spent_reading}
+ $delta_for->{ms_spent_writing};
if ( $number_of_ios ) {
$extra_stats{qtime} = $total_ms_spent_on_io / $number_of_ios;
$extra_stats{stime} = $delta_for->{ms_spent_doing_io} / $number_of_ios;
}
else {
$extra_stats{qtime} = 0;
$extra_stats{stime} = 0;
}
$extra_stats{s_spent_doing_io} = $total_ms_spent_on_io / 1000;
$extra_stats{line_ts} = $self->compute_line_ts(
first_ts => $self->first_ts(),
curr_ts => $self->curr_ts(),
);
return %extra_stats;
}
sub _calc_delta_for {
my ( $self, $curr, $against ) = @_;
my %deltas = (
map { ( $_ => ($curr->{$_} || 0) - ($against->{$_} || 0) ) }
qw(
reads reads_merged read_sectors ms_spent_reading
writes writes_merged written_sectors ms_spent_writing
read_kbs written_kbs
ms_spent_doing_io ms_weighted
)
);
return \%deltas;
}
sub _calc_stats_for_deltas {
my ( $self, $elapsed ) = @_;
my @end_stats;
my @devices = $self->ordered_devs();
my $devs_in_group = $self->compute_devs_in_group();
foreach my $dev_and_curr (
map {
my $curr = $self->dev_ok($_) && $self->stats_for($_);
$curr ? [ $_, $curr ] : ()
}
@devices )
{
my $dev = $dev_and_curr->[0];
my $curr = $dev_and_curr->[1];
my $against = $self->delta_against($dev);
my $delta_for = $self->_calc_delta_for( $curr, $against );
my $in_progress = $curr->{"ios_in_progress"};
my $tot_in_progress = $against->{"sum_ios_in_progress"} || 0;
my %stats = (
$self->_calc_read_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
),
$self->_calc_write_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
),
in_progress =>
$self->compute_in_progress( $in_progress, $tot_in_progress ),
);
my %extras = $self->_calc_misc_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
stats => \%stats,
);
@stats{ keys %extras } = values %extras;
$stats{dev} = $dev;
push @end_stats, \%stats;
}
return @end_stats;
}
sub _calc_deltas {
my ( $self ) = @_;
my $elapsed = $self->curr_ts() - $self->delta_against_ts();
die "Time elapsed is [$elapsed]" unless $elapsed;
return $self->_calc_stats_for_deltas($elapsed);
}
sub print_header {
my ($self, $header, @args) = @_;
if ( $self->{_print_header} ) {
printf { $self->out_fh() } $header . "\n", @args;
}
}
sub print_rows {
my ($self, $format, $cols, $stat) = @_;
if ( $self->filter_zeroed_rows() ) {
return unless grep {
sprintf("%7.1f", $_) != 0
} @{$stat}{ @$cols };
}
printf { $self->out_fh() } $format . "\n",
@{$stat}{ qw( line_ts dev ), @$cols };
}
sub print_deltas {
my ( $self, %args ) = @_;
my ( $header, $format, $cols ) = $self->design_print_formats(
max_device_length => $args{max_device_length},
columns => $args{columns},
);
return unless $self->delta_against_ts();
@$cols = map { $self->_column_to_key($_) } @$cols;
my ( $header_callback, $rows_callback ) = @args{qw( header_callback rows_callback )};
if ( $header_callback ) {
$self->$header_callback( $header, "#ts", "device" );
}
else {
$self->print_header( $header, "#ts", "device" );
}
for my $stat ( $self->_calc_deltas() ) {
if ($rows_callback) {
$self->$rows_callback( $format, $cols, $stat );
}
else {
$self->print_rows( $format, $cols, $stat );
}
}
}
sub compute_line_ts {
my ( $self, %args ) = @_;
return sprintf( "%5.1f", $args{first_ts} > 0
? $args{curr_ts} - $args{first_ts}
: 0 );
}
sub compute_in_progress {
my ( $self, $in_progress, $tot_in_progress ) = @_;
return $in_progress;
}
sub compute_devs_in_group {
return 1;
}
sub delta_against {
die 'You must override delta_against() in a subclass';
}
sub delta_against_ts {
die 'You must override delta_against_ts() in a subclass';
}
sub group_by {
die 'You must override group_by() in a subclass';
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Diskstats package
# ###########################################################################
# This program is copyright 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# DiskstatsGroupByAll package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DiskstatsGroupByAll.pm
# t/lib/DiskstatsGroupByAll.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DiskstatsGroupByAll;
use warnings;
use strict;
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use base qw( Diskstats );
sub group_by_all {
my ($self, %args) = @_;
$self->clear_state();
if (!$self->interactive) {
$self->parse_from(
sample_callback => sub {
$self->print_deltas(
map { ( $_ => $args{$_} ) }
qw( header_callback rows_callback ),
);
},
map( { ($_ => $args{$_}) } qw(filehandle filename data) ),
);
}
else {
my $orig = tell $args{filehandle};
$self->parse_from(
sample_callback => sub {
$self->print_deltas(
header_callback => sub {
my $self = shift;
if ( $self->{_print_header} ) {
my $meth = $args{header_callback} || "print_header";
$self->$meth(@_);
}
$self->{_print_header} = undef;
},
rows_callback => $args{rows_callback},
);
},
map( { ($_ => $args{$_}) } qw(filehandle filename data) ),
);
if (!$self->prev_ts) {
seek $args{filehandle}, $orig, 0;
}
return;
}
$self->clear_state();
}
sub group_by {
my $self = shift;
$self->group_by_all(@_);
}
sub clear_state {
my $self = shift;
if (!$self->interactive()) {
$self->SUPER::clear_state(@_);
}
else {
my $orig_print_header = $self->{_print_header};
$self->SUPER::clear_state(@_);
$self->{_print_header} = $orig_print_header;
}
}
sub delta_against {
my ($self, $dev) = @_;
return $self->prev_stats_for($dev);
}
sub delta_against_ts {
my ($self) = @_;
return $self->prev_ts();
}
sub compute_line_ts {
my ($self, %args) = @_;
if ( $self->interactive() ) {
$args{first_ts} = $self->prev_ts();
}
return $self->SUPER::compute_line_ts(%args);
}
1;
}
# ###########################################################################
# End DiskstatsGroupByAll package
# ###########################################################################
# This program is copyright 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# DiskstatsGroupByDisk package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DiskstatsGroupByDisk.pm
# t/lib/DiskstatsGroupByDisk.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DiskstatsGroupByDisk;
use warnings;
use strict;
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use base qw( Diskstats );
sub new {
my ($class, %args) = @_;
my $self = $class->SUPER::new(%args);
$self->{_iterations} = 0;
$self->{_print_header} = 1;
return $self;
}
sub group_by {
my ($self, @args) = @_;
$self->group_by_disk(@args);
}
sub group_by_disk {
my ($self, %args) = @_;
my ($header_callback, $rows_callback) = $args{ qw( header_callback rows_callback ) };
$self->clear_state() unless $self->interactive();
my $original_offset = $args{filehandle} ? tell($args{filehandle}) : undef;
my $lines_read = $self->parse_from(
sample_callback => sub {
my ($self, $ts) = @_;
if ( $self->has_stats() ) {
$self->{_iterations}++;
if ($self->interactive() && $self->{_iterations} >= 2) {
my $elapsed = ( $self->curr_ts() || 0 )
- ( $self->first_ts() || 0 );
if ( $ts > 0 && $elapsed >= $self->sample_time() ) {
$self->print_deltas(
header_callback => sub {
my ($self, @args) = @_;
if ( $self->{_print_header} ) {
my $method = $args{header_callback}
|| "print_header";
$self->$method(@args);
}
$self->{_print_header} = undef;
},
rows_callback => $args{rows_callback},
);
$self->{_iterations} = -1;
return;
}
}
}
},
filehandle => $args{filehandle},
filename => $args{filename},
data => $args{data},
);
if ($self->interactive) {
if ($self->{_iterations} == -1 && defined($original_offset)
&& eof($args{filehandle})) {
$self->clear_state;
seek $args{filehandle}, $original_offset, 0;
}
return $lines_read;
}
if ( $self->{_iterations} < 2 ) {
return;
}
$self->print_deltas(
header_callback => $args{header_callback},
rows_callback => $args{rows_callback},
);
$self->clear_state();
return $lines_read;
}
sub clear_state {
my ($self, @args) = @_;
my $orig_print_h = $self->{_print_header};
$self->{_iterations} = 0;
$self->SUPER::clear_state(@args);
$self->{_print_header} = $orig_print_h;
}
sub compute_line_ts {
my ($self, %args) = @_;
return "{" . ($self->{_iterations} - 1) . "}";
}
sub delta_against {
my ($self, $dev) = @_;
return $self->first_stats_for($dev);
}
sub delta_against_ts {
my ($self) = @_;
return $self->first_ts();
}
sub compute_in_progress {
my ($self, $in_progress, $tot_in_progress) = @_;
return $tot_in_progress / ($self->{_iterations} - 1);
}
1;
}
# ###########################################################################
# End DiskstatsGroupByDisk package
# ###########################################################################
# This program is copyright 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# DiskstatsGroupBySample package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DiskstatsGroupBySample.pm
# t/lib/DiskstatsGroupBySample.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DiskstatsGroupBySample;
use warnings;
use strict;
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use base qw( Diskstats );
sub new {
my ( $class, %args ) = @_;
my $self = $class->SUPER::new(%args);
$self->{_iterations} = 0;
$self->{_save_curr_as_prev} = 0;
$self->{_print_header} = 1;
return $self;
}
sub group_by {
my $self = shift;
$self->group_by_sample(@_);
}
sub group_by_sample {
my ( $self, %args ) = @_;
my ( $header_callback, $rows_callback ) = $args{qw( header_callback rows_callback )};
$self->clear_state() unless $self->interactive();
$self->parse_from(
sample_callback => $self->can("_sample_callback"),
filehandle => $args{filehandle},
filename => $args{filename},
data => $args{data},
);
$self->clear_state() unless $self->interactive();
return;
}
sub _sample_callback {
my ( $self, $ts, %args ) = @_;
my $printed_a_line = 0;
if ( $self->has_stats() ) {
$self->{_iterations}++;
}
my $elapsed = ($self->curr_ts() || 0)
- ($self->prev_ts() || 0);
if ( $ts > 0 && $elapsed >= $self->sample_time() ) {
$self->print_deltas(
max_device_length => 6,
header_callback => sub {
my ( $self, $header, @args ) = @_;
if ( $self->{_print_header} ) {
my $method = $args{header_callback} || "print_header";
$self->$method( $header, @args );
$self->{_print_header} = undef;
}
},
rows_callback => sub {
my ( $self, $format, $cols, $stat ) = @_;
my $method = $args{rows_callback} || "print_rows";
$self->$method( $format, $cols, $stat );
$printed_a_line = 1;
}
);
}
if ( $self->{_iterations} == 1 || $printed_a_line == 1 ) {
$self->{_save_curr_as_prev} = 1;
$self->_save_curr_as_prev( $self->stats_for() );
$self->{_save_curr_as_prev} = 0;
}
return;
}
sub delta_against {
my ( $self, $dev ) = @_;
return $self->prev_stats_for($dev);
}
sub delta_against_ts {
my ( $self ) = @_;
return $self->prev_ts();
}
sub clear_state {
my ( $self, @args ) = @_;
$self->{_iterations} = 0;
$self->{_save_curr_as_prev} = 0;
$self->{_print_header} = 1;
$self->SUPER::clear_state(@args);
}
sub compute_devs_in_group {
my ($self) = @_;
my $stats = $self->stats_for();
my $re = $self->device_regex();
return scalar grep {
$stats->{$_} && $_ =~ $re
} $self->ordered_devs;
}
sub compute_dev {
my ( $self, $devs ) = @_;
$devs ||= $self->compute_devs_in_group();
return $devs > 1
? "{" . $devs . "}"
: ( $self->ordered_devs )[0];
}
sub _calc_stats_for_deltas {
my ( $self, $elapsed ) = @_;
my $delta_for;
foreach my $dev ( grep { $self->dev_ok($_) } $self->ordered_devs ) {
my $curr = $self->stats_for($dev);
my $against = $self->delta_against($dev);
my $delta = $self->_calc_delta_for( $curr, $against );
$delta->{ios_in_progress} = $curr->{ios_in_progress};
while ( my ( $k, $v ) = each %$delta ) {
$delta_for->{$k} += $v;
}
}
my $in_progress = $delta_for->{ios_in_progress};
my $tot_in_progress = 0;
my $devs_in_group = $self->compute_devs_in_group() || 1;
my %stats = (
$self->_calc_read_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
),
$self->_calc_write_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
),
in_progress =>
$self->compute_in_progress( $in_progress, $tot_in_progress ),
);
my %extras = $self->_calc_misc_stats(
delta_for => $delta_for,
elapsed => $elapsed,
devs_in_group => $devs_in_group,
stats => \%stats,
);
@stats{ keys %extras } = values %extras;
$stats{dev} = $self->compute_dev( $devs_in_group );
return \%stats;
}
1;
}
# ###########################################################################
# End DiskstatsGroupBySample package
# ###########################################################################
# This program is copyright 2011 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# ###########################################################################
# DiskstatsMenu
# ###########################################################################
{
package DiskstatsMenu;
# DiskstatsMenu
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use IO::Handle;
use IO::Select;
use Scalar::Util qw( looks_like_number blessed );
use ReadKeyMini qw( ReadMode );
use Transformers qw( ts );
require DiskstatsGroupByAll;
require DiskstatsGroupByDisk;
require DiskstatsGroupBySample;
my %actions = (
'A' => \&group_by,
'D' => \&group_by,
'S' => \&group_by,
'i' => \&hide_inactive_disks,
'd' => get_new_value_for( "redisplay_interval",
"Enter a new redisplay interval in seconds: " ),
'z' => get_new_value_for( "sample_time",
"Enter a new interval between samples in seconds: " ),
'c' => get_new_regex_for( "column_regex",
"Enter a column pattern: " ),
'/' => get_new_regex_for( "device_regex",
"Enter a disk/device pattern: " ),
# Magical return value.
'q' => sub { return 'last' },
'p' => sub {
print "Paused - press any key to continue\n";
pause(@_);
return;
},
'?' => \&help,
);
my %input_to_object = (
D => "DiskstatsGroupByDisk",
A => "DiskstatsGroupByAll",
S => "DiskstatsGroupBySample",
);
sub new {
bless {}, shift;
}
sub run_interactive {
my ($self, %args) = @_;
my @required_args = qw(OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($o) = @args{@required_args};
my %opts = (
interactive => 1,
OptionParser => $o,
);
my ($tmp_fh, $filename, $child_pid, $child_fh);
# Here's a big crux of the program. If we have a filename, we don't
# need to fork and create a child, just read from it.
if ( $filename = $args{filename} ) {
open $tmp_fh, "<", $filename or die "Cannot open $filename: $OS_ERROR";
}
else {
($tmp_fh, $filename) = file_to_use( $o->get('save-samples') );
# fork(), but future-proofing it in case we ever need to speak to
# the child
$child_pid = open $child_fh, "|-";
die "Cannot fork: $OS_ERROR" unless defined $child_pid;
if ( !$child_pid ) {
# Child
# Bit of helpful magic: Changes how the program's name is displayed,
# so it's easier to track in things like ps.
local $PROGRAM_NAME = "$PROGRAM_NAME (data-gathering daemon)";
close $tmp_fh;
gather_samples(
gather_while => sub { getppid() },
samples_to_gather => $o->get('iterations'),
sampling_interval => $o->get('interval'),
filename => $filename,
);
unlink $filename unless $o->get('save-samples');
exit(0);
}
}
PTDEBUG && _d("Using filename", $filename);
# I don't think either of these are needed actually, since piped opens
# are supposed to deal with children on their own, but it doesn't hurt.
local $SIG{CHLD} = 'IGNORE';
local $SIG{PIPE} = 'IGNORE';
STDOUT->autoflush;
STDIN->blocking(0);
my $sel = IO::Select->new(\*STDIN);
my $group_by = $o->get('group-by') || 'disk';
my $class = $group_by =~ m/disk/i ? 'DiskstatsGroupByDisk'
: $group_by =~ m/sample/i ? 'DiskstatsGroupBySample'
: $group_by =~ m/all/i ? 'DiskstatsGroupByAll'
: die "Invalid --group-by: $group_by";
$opts{current_group_by_obj} = $class->new( %opts );
if ( $args{filename} ) {
group_by(
header_callback => sub { shift->print_header(@_) },
select_obj => $sel,
options => \%opts,
filehandle => $tmp_fh,
input => substr(ucfirst($group_by), 0, 1),
);
}
ReadKeyMini::cbreak();
MAIN_LOOP:
while (1) {
if ( my $input = read_command_timeout($sel, $o->get('redisplay-interval') ) ) {
if ($actions{$input}) {
my $ret = $actions{$input}->(
select_obj => $sel,
options => \%opts,
input => $input,
filehandle => $tmp_fh,
) || '';
last MAIN_LOOP if $ret eq 'last';
}
}
# As a possible source of confusion, note that this calls the group_by
# _method_ in DiskstatsGroupBySomething, not the group_by _function_
# defined below.
$opts{current_group_by_obj}->group_by( filehandle => $tmp_fh ) || 0;
if ( eof $tmp_fh ) {
# This one comes from IO::Handle. I clears the eof flag
# from a filehandle, so we can try reading from it again.
$tmp_fh->clearerr;
}
# If we are gathering samples (don't have a filename), and
# we have a sample limit (set by --iterations), the child
# process just calls it quits once it gathers enough samples.
# When that happens, we are also done.
if ( !$args{filename} && $o->get('iterations')
&& !kill(0, $child_pid) ) {
waitpid $child_pid, 0;
last MAIN_LOOP;
}
}
ReadKeyMini::cooked();
if ( !$args{filename} && kill 0, $child_pid ) {
$child_fh->printflush("End\n");
waitpid $child_pid, 0;
}
close $tmp_fh or die "Cannot close: $OS_ERROR";
return 0; # Exit status
}
sub read_command_timeout {
my ($sel, $timeout) = @_;
if ( $sel->can_read( $timeout ) ) {
return scalar <STDIN>;
}
return;
}
sub gather_samples {
my (%opts) = @_;
my $samples = 0;
STDIN->blocking(0);
my $sel = IO::Select->new(\*STDIN);
my $filename = $opts{filename};
GATHER_DATA:
while ( $opts{gather_while}->() ) {
if ( read_command_timeout( $sel, $opts{sampling_interval} ) ) {
last GATHER_DATA;
}
open my $fh, ">>", $filename or die $OS_ERROR;
open my $diskstats_fh, "<", "/proc/diskstats"
or die $OS_ERROR;
my @to_print = timestamp();
push @to_print, <$diskstats_fh>;
# Lovely little method from IO::Handle: turns on autoflush,
# prints, and then restores the original autoflush state.
$fh->printflush(@to_print);
close $diskstats_fh or die $OS_ERROR;
close $fh or die $OS_ERROR;
$samples++;
if ( defined($opts{samples_to_gather})
&& $samples >= $opts{samples_to_gather} ) {
last GATHER_DATA;
}
}
return;
}
sub group_by {
my (%args) = @_;
my @required_args = qw( options input );
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($options, $input) = @args{@required_args};
if ( ref( $args{options}->{current_group_by_obj} ) ne $input_to_object{$input} ) {
# Particularly important! Otherwise we would depend on the
# object's ->new being smart about discarding unrecognized
# values.
delete $args{options}->{current_group_by_obj};
# This would fail on a stricter constructor, so it probably
# needs fixing.
$args{options}->{current_group_by_obj} = $input_to_object{$input}->new(
%{$args{options}}
);
}
seek $args{filehandle}, 0, 0;
# Just aliasing this for a bit.
for my $obj ( $args{options}->{current_group_by_obj} ) {
if ( $obj->isa("DiskstatsGroupBySample") ) {
$obj->interactive(1);
}
else {
$obj->interactive(0);
}
$obj->group_by(
filehandle => $args{filehandle},
# Only print the header once, as if in interactive.
header_callback => $args{header_callback} || sub {
my $print_header;
return sub {
unless ($print_header++) {
shift->print_header(@_)
}
};
}->(),
);
$obj->interactive(1);
$obj->{_print_header} = 0;
}
}
sub help {
my (%args) = @_;
my $obj = $args{options}->{current_group_by_obj};
my $mode = substr ref($obj), 16, 1;
my $column_re = $args{options}->{OptionParser}->get('columns');
my $device_re = $args{options}->{OptionParser}->get('devices');
my $interval = $obj->sample_time() || '(none)';
my $disp_int = $args{options}->{OptionParser}->get('redisplay-interval');
my $inact_disk = $obj->filter_zeroed_rows() ? 'yes' : 'no';
for my $re ( $column_re, $device_re ) {
$re ||= '(none)';
}
print <<"HELP";
You can control this program by key presses:
------------------- Key ------------------- ---- Current Setting ----
A, D, S) Set the group-by mode $mode
c) Enter a Perl regex to match column names $column_re
/) Enter a Perl regex to match disk names $device_re
z) Set the sample size in seconds $interval
i) Hide inactive disks $inact_disk
d) Set the redisplay interval in seconds $disp_int
p) Pause the program
q) Quit the program
------------------- Press any key to continue -----------------------
HELP
pause(@_);
return;
}
sub file_to_use {
my ( $filename ) = @_;
if ( !$filename ) {
PTDEBUG && _d('No explicit filename passed in, trying to get one from mktemp');
chomp($filename = `mktemp -t pt-diskstats.$PID.XXXXXXXX`);
}
if ( $filename ) {
open my $fh, "+>", $filename
or die "Cannot open $filename: $OS_ERROR";
return $fh, $filename;
}
else {
PTDEBUG && _d("mktemp didn't return a filename, trying to use File::Temp");
local $EVAL_ERROR;
if ( !eval { require File::Temp } ) {
die "Can't call mktemp nor load File::Temp.",
" Install either of those, or pass in an explicit",
" filename through --save-samples.";
}
my $dir = File::Temp::tempdir( CLEANUP => 1 );
return File::Temp::tempfile(
"pt-diskstats.$PID.XXXXXXXX",
DIR => $dir,
UNLINK => 1,
OPEN => 1,
);
}
}
sub get_blocking_input {
my ($message) = @_;
STDIN->blocking(1);
ReadKeyMini::cooked();
print $message;
chomp(my $new_opt = <STDIN>);
ReadKeyMini::cbreak();
STDIN->blocking(0);
return $new_opt;
}
sub hide_inactive_disks {
my (%args) = @_;
my $new_val = get_blocking_input("Filter inactive rows? (Leave blank for 'No') ");
# Eeep. In OptionParser, "true" means show; in Diskstats, "true" means hide.
# Thus !$new_val for OptionParser
$args{options}->{OptionParser}->set('zero-rows', !$new_val);
$args{options}->{current_group_by_obj}->filter_zeroed_rows($new_val);
return;
}
sub get_new_value_for {
my ($looking_for, $message) = @_;
(my $looking_for_o = $looking_for) =~ tr/_/-/;
return sub {
my (%args) = @_;
my $new_interval = get_blocking_input($message) || 0;
die "Invalid timeout: $new_interval"
unless looks_like_number($new_interval);
if ( $args{options}->{current_group_by_obj}->can($looking_for) ) {
$args{options}->{current_group_by_obj}->$looking_for($new_interval);
}
$args{options}->{OptionParser}->set($looking_for_o, $new_interval);
return $new_interval;
};
}
sub get_new_regex_for {
my ($looking_for, $message) = @_;
(my $looking_for_o = $looking_for) =~ s/_.*$/s/;
return sub {
my (%args) = @_;
my $new_regex = get_blocking_input($message);
local $EVAL_ERROR;
if ( $new_regex && (my $re = eval { qr/$new_regex/i }) ) {
$args{options}->{current_group_by_obj}->$looking_for( $re );
$args{options}->{OptionParser}->set($looking_for_o, $new_regex);
}
elsif ( !$EVAL_ERROR && !$new_regex ) {
# This might seem weird, but an empty pattern is
# somewhat magical, and basically just asking for trouble.
# Instead we give them what awk would, a pattern that always
# matches.
$args{options}->{current_group_by_obj}->$looking_for( qr/(?=)/ );
$args{options}->{OptionParser}->set($looking_for_o, '');
}
else {
die "invalid regex specification: $EVAL_ERROR";
}
return;
};
}
sub pause {
my (%args) = @_;
STDIN->blocking(1);
$args{select_obj}->can_read();
STDIN->blocking(0);
scalar <STDIN>;
return;
}
my $got_highres = eval { require Time::HiRes };
sub timestamp {
if ( $got_highres ) {
# Can do everything in Perl
# TS timestamp.nanoseconds ISO8601-timestamp
PTDEBUG && _d('Timestamp', "Using the pure Perl version");
my ( $seconds, $microseconds ) = Time::HiRes::gettimeofday();
return sprintf( "TS %d.%d %s\n", $seconds,
$microseconds*1000, Transformers::ts($seconds) );
}
else {
PTDEBUG && _d('Timestamp', "Using the system's date command");
`date +'TS %s.%N %F %T'`;
}
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DiskstatsMenu package
# ###########################################################################
{
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_diskstats;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use DiskstatsMenu;
use OptionParser;
# This gives us a nice little backtrace should an exception happen while
# debugging is enabled.
local $SIG{__DIE__} = sub {
require Carp;
Carp::confess(@_) unless $^S; # This is $EXCEPTIONS_BEING_CAUGHT
} if MKDEBUG;
sub main {
@ARGV = @_; # set global ARGV for this package
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser file => __FILE__;
$o->get_specs();
$o->get_opts();
$o->usage_or_errors();
my $diskstats = new DiskstatsMenu;
# Interactive mode. Delegate to DiskstatsMenu::run_interactive
return $diskstats->run_interactive( OptionParser => $o, filename => $ARGV[0] );
}
# Somewhat important if STDOUT is tied to a terminal.
END { close STDOUT or die "Couldn't close stdout: $OS_ERROR" }
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1;
}
# #############################################################################
# Documentation.
# #############################################################################
=pod
=head1 NAME
pt-diskstats - Aggregate and summarize F</proc/diskstats>.
=head1 SYNOPSIS
Usage: pt-diskstats [OPTION...] [FILES]
pt-diskstats reads F</proc/diskstats> periodically, or files with the
contents of F</proc/diskstats>, aggregates the data, and prints it nicely.
=head1 RISKS
The following section is included to inform users about the potential risks,
whether known or unknown, of using this tool. The two main categories of risks
are those created by the nature of the tool (e.g. read-only tools vs. read-write
tools) and those created by bugs.
pt-diskstats is a read-only tool. It should be very low-risk.
At the time of this release, we know of no bugs that could cause serious harm
to users.
The authoritative source for updated information is always the online issue
tracking system. Issues that affect this tool will be marked as such. You can
see a list of such issues at the following URL:
L<http://www.percona.com/bugs/pt-diskstats>.
See also L<"BUGS"> for more information on filing bugs and getting help.
=head1 DESCRIPTION
pt-diskstats tool is similar to iostat, but has some advantages. It separates
reads and writes, for example, and computes some things that iostat does in
either incorrect or confusing ways. It is also menu-driven and interactive
with several different ways to aggregate the data, and integrates well with
the L<pt-collect> tool. These properties make it very convenient for quickly
drilling down into I/O performance at the desired level of granularity.
This program works in two main modes. One way is to process a file with saved
disk statistics, which you specify on the command line. The other way is to
start a background process gathering samples at intervals and saving them into
a file, and process this file in the foreground. In both cases, the tool is
interactively controlled by keystrokes, so you can redisplay and slice the
data flexibly and easily. If the tool is not attached to a terminal, it
doesn't run interactively; it just processes and prints its output, then exits.
Otherwise it loops until you exit with the 'q' key.
If you press the '?' key, you will bring up the interactive help menu that
shows which keys control the program.
Files should have this format:
TS <timestamp> <-- must start with a TS line.
<contents of /proc/diskstats>
TS <timestamp>
<contents of /proc/diskstats>
... et cetera
Note that previously the format was backwards -- It would put the timestamp
at the bottom of each sample, not the top. This was doubly troublesome:
It was inconsistent with how the rest of the Toolkit deals with timestamps,
and allowed malformed data to sit in the bottom of the file and give incorrect
results.
See L<http://aspersa.googlecode.com/svn/html/diskstats.html> for a detailed
example of using the tool.
=head1 OUTPUT
The columns are as follows:
=over
=item #ts
The number of seconds of samples in the line. If there is only one, then
the timestamp itself is shown, without the {curly braces}.
=item device
The device name. If there is more than one device, then instead the number
of devices aggregated into the line is shown, in {curly braces}.
=item rd_io_s
The number of IO reads per second, average, during the sampled interval.
=item rd_cnc
The average concurrency of the read operations, as computed by Little's Law
(a.k.a. queueing theory).
=item rd_rt
The average response time of the read operations, in milliseconds.
=item wr_mb_s
IO writes per second, average.
=item wr_cnc
Write concurrency, similar to read concurrency.
=item wr_rt
Write response time, similar to read response time.
=item busy
The fraction of time that the device had at least one request in progress;
this is what iostat calls %util (which is a misleading name).
=item in_prg
The number of requests that were in progress. Unlike the read and write
concurrencies, which are averages that are generated from reliable numbers,
this number is an instantaneous sample, and you can see that it might
represent a spike of requests, rather than the true long-term average.
=back
In addition to the above columns, there are a few columns that are hidden by
default. If you press the 'c' key, and then press Enter, you will blank out
the regular expression pattern that selects columns to display, and you will
then see the extra columns:
=over
=item rd_s
The number of reads per second.
=item rd_avkb
The average size of the reads, in kilobytes.
=item rd_mrg
The percentage of read requests that were merged together in the disk
scheduler before reaching the device.
=item rd_mb_s
The number of megabytes read per second, average, during the sampled interval.
=item wr_s, wr_avgkb, and wr_mrg, wr_mb_s
These are analogous to their C<rd_*> cousins.
=back
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --columns
type: string; default: cnc|rt|busy|prg|time|io_s
Perl regex of which columns to include.
=item --devices
type: string; default: .+
Perl regex of which devices to include.
=item --group-by
type: string; default: disk
Group-by mode (default disk); specify one of the following:
disk - Each line of output shows one disk device.
sample - Each line of output shows one sample of statistics.
all - Each line of output shows one sample and one disk device.
=item --sample-time
type: int; default: 1
In --group-by sample mode, include INTERVAL seconds of samples per group.
=item --save-samples
type: string
File to save diskstats samples in; these can be used for later analysis.
=item --iterations
type: int
When in interactive mode, stop after N samples.
=item --redisplay-interval
type: int; default: 1
When in interactive mode, wait N seconds before printing to the screen.
=item --interval
type: int; default: 1
Sample /proc/diskstats every N seconds.
=item --zero-rows
Show rows with all zero values.
=item --memory-for-speed
EXPERIMENTAL! Trades memory for speed, by storing more things in memory.
What it stores, and how, may all be subject to change.
=item --help
Show help and exit.
=item --version
Show version and exit.
=back
=head1 ENVIRONMENT
This tool does not use any environment variables.
=head1 SYSTEM REQUIREMENTS
This tool requires Perl v5.8.0 or newer and the F</proc> filesystem, unless
reading from files.
=head1 BUGS
For a list of known bugs, see L<http://www.percona.com/bugs/pt-diskstats>.
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C<PTDEBUG>;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
latest release of Percona Toolkit. Or, get the latest release from the
command line:
wget percona.com/get/percona-toolkit.tar.gz
wget percona.com/get/percona-toolkit.rpm
wget percona.com/get/percona-toolkit.deb
You can also get individual tools from the latest release:
wget percona.com/get/TOOL
Replace C<TOOL> with the name of any tool.
=head1 AUTHORS
Baron Schwartz, Brian Fraser, and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools developed by Percona for MySQL support and consulting. Percona Toolkit
was forked from two projects in June, 2011: Maatkit and Aspersa. Those
projects were created by Baron Schwartz and developed primarily by him and
Daniel Nichter, both of whom are employed by Percona. Visit
L<http://www.percona.com/software/> for more software developed by Percona.
=head1 COPYRIGHT, LICENSE, AND WARRANTY
This program is copyright 2010-2011 Baron Schwartz, 2011 Percona Inc.
Feedback and improvements are welcome.
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
This program 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, version 2; OR the Perl Artistic License. On UNIX and similar
systems, you can issue `man perlgpl' or `man perlartistic' to read these
licenses.
You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place, Suite 330, Boston, MA 02111-1307 USA.
=head1 VERSION
pt-diskstats 2.0.0_WIP
=cut
__END__
Reference in New Issue View Git Blame Copy Permalink