mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-10-19 08:56:34 +00:00
Work in progress v3: Working interactive mode, initial documentation.
With this most of the interactive mode should be working. pt_diskstats.pm has the documentation and can be used for testing, which should be in the next commit. This commit also includes the revamped command line options.
This commit is contained in:
Brian Fraser
@@ -22,8 +22,8 @@ package DiskstatsMenu;
|
||||
|
||||
# DiskstatsMenu
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
|
||||
|
||||
@@ -31,14 +31,13 @@ use re qw( regexp_pattern );
|
||||
|
||||
use IO::Handle;
|
||||
use IO::Select;
|
||||
use Scalar::Util qw( looks_like_number );
|
||||
use File::Temp qw( tempfile tempdir );
|
||||
use Scalar::Util qw( looks_like_number blessed );
|
||||
|
||||
use ReadKeyMini qw( ReadMode );
|
||||
use ReadKeyMini qw( ReadMode );
|
||||
|
||||
use DiskstatsGroupByAll;
|
||||
use DiskstatsGroupByDisk;
|
||||
use DiskstatsGroupBySample;
|
||||
require DiskstatsGroupByAll;
|
||||
require DiskstatsGroupByDisk;
|
||||
require DiskstatsGroupBySample;
|
||||
|
||||
our $VERSION = '0.01';
|
||||
|
||||
@@ -46,125 +45,270 @@ my %actions = (
|
||||
'A' => \&group_by,
|
||||
'D' => \&group_by,
|
||||
'S' => \&group_by,
|
||||
's' => \&get_new_interval,
|
||||
'c' => get_new_x_regex("column_re", "Enter a column pattern: "),
|
||||
'd' => get_new_x_regex("disk_re", "Enter a disk/device pattern: "),
|
||||
'i' => \&hide_inactive_disks,
|
||||
'd' => get_new_value_for( "redisplay_interval", "Enter a new redisplay interval in seconds: " ),
|
||||
'z' => get_new_value_for( "interval", "Enter a new interval between samples in seconds: " ),
|
||||
'c' => get_new_x_regex( "column_regex", "Enter a column pattern: " ),
|
||||
'/' => get_new_x_regex( "device_regex", "Enter a disk/device pattern: " ),
|
||||
'q' => sub { return 'last' },
|
||||
'p' => \&pause,
|
||||
'?' => \&help,
|
||||
);
|
||||
|
||||
sub run {
|
||||
my ($self, %args) = @_;
|
||||
|
||||
my %opts = (
|
||||
keep_file => undef,
|
||||
samples_to_gather => undef,
|
||||
sample_interval => 3,
|
||||
interval => 0.5,
|
||||
device_regex => qr/sda/,
|
||||
interactive => 1,
|
||||
my %option_to_object = (
|
||||
D => "DiskstatsGroupByDisk",
|
||||
A => "DiskstatsGroupByAll",
|
||||
S => "DiskstatsGroupBySample",
|
||||
);
|
||||
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
my ($tmp_fh, $filename) = tempfile(
|
||||
"diskstats-samples.XXXXXXXX",
|
||||
DIR => $dir,
|
||||
UNLINK => 1,
|
||||
OPEN => 1,
|
||||
);
|
||||
my $pid = open my $child_fh, "|-";
|
||||
my %object_to_option = reverse %option_to_object;
|
||||
|
||||
if (not defined $pid) {
|
||||
die "Couldn't fork: $OS_ERROR";
|
||||
sub run_interactive {
|
||||
my ($self, %args) = @_;
|
||||
|
||||
die "I need an [o] argument" unless $args{o} && blessed($args{o})
|
||||
&& (
|
||||
$args{o}->isa("OptionParser")
|
||||
|| $args{o}->can("get")
|
||||
);
|
||||
my $o = $args{o};
|
||||
|
||||
my %opts = (
|
||||
save_samples => $o->get('save-samples') || undef,
|
||||
samples_to_gather => $o->get('iterations') || undef,
|
||||
sampling_interval => $o->get('interval') || 1,
|
||||
display_interval => 1,
|
||||
sample_time => $o->get('sample-time') || 1,
|
||||
column_regex => $o->get('columns') || undef,
|
||||
device_regex => $o->get('devices') || undef,
|
||||
interactive => 1,
|
||||
filter_zeroed_rows => 0,
|
||||
);
|
||||
|
||||
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 ( $args{filename} ) {
|
||||
$filename = $args{filename};
|
||||
open $tmp_fh, "<", $filename or die "Couldn't open [$filename]: $OS_ERROR";
|
||||
}
|
||||
else {
|
||||
($tmp_fh, $filename) = file_to_use( $opts{save_samples} );
|
||||
|
||||
if ( !$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);
|
||||
|
||||
open my $fh, ">>", $filename or die $!;
|
||||
|
||||
while ( getppid() ) {
|
||||
sleep($opts{sample_interval});
|
||||
open my $diskstats_fh, "<", "/proc/diskstats"
|
||||
or die $!;
|
||||
|
||||
my @to_print = <$diskstats_fh>;
|
||||
push @to_print, `date +'TS %s.%N %F %T'`;
|
||||
|
||||
# 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 $!;
|
||||
# fork(), but future-proofing it in case we ever need to speak to
|
||||
# the child
|
||||
$child_pid = open $child_fh, "|-";
|
||||
|
||||
if (not defined $child_pid) {
|
||||
die "Couldn't fork: $OS_ERROR";
|
||||
}
|
||||
|
||||
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);
|
||||
|
||||
open my $fh, ">>", $filename or die $!;
|
||||
|
||||
gather_samples(
|
||||
gather_while => sub { getppid() },
|
||||
samples_to_gather => $opts{samples_to_gather},
|
||||
sampling_interval => $opts{sampling_interval},
|
||||
filehandle => $fh,
|
||||
);
|
||||
|
||||
close $fh or die $!;
|
||||
unlink $filename unless $opts{save_samples};
|
||||
exit(0);
|
||||
}
|
||||
close $fh or die $!;
|
||||
unlink $filename unless $opts{keep_file};
|
||||
exit(0);
|
||||
}
|
||||
|
||||
local $SIG{CHLD} = 'IGNORE';
|
||||
|
||||
STDOUT->autoflush;
|
||||
STDIN->blocking(0);
|
||||
|
||||
my $sel = IO::Select->new(\*STDIN);
|
||||
my $sel = IO::Select->new(\*STDIN);
|
||||
my $class = $option_to_object{ substr uc($o->get('group-by') || 'Disk'), 0, 1 };
|
||||
$opts{obj} = $class->new( %opts );
|
||||
|
||||
my $lines_read = 0;
|
||||
|
||||
$opts{obj} = DiskstatsGroupByDisk->new(%opts);
|
||||
if ( $args{filename} ) {
|
||||
group_by(
|
||||
select_obj => $sel,
|
||||
options => \%opts,
|
||||
filehandle => $tmp_fh,
|
||||
got => substr(uc($o->get('group-by') || 'Disk'), 0, 1),
|
||||
);
|
||||
}
|
||||
|
||||
ReadKeyMini::cbreak();
|
||||
warn $filename;
|
||||
MAIN_LOOP:
|
||||
while (1) {
|
||||
if ( $sel->can_read( $opts{interval} ) ) {
|
||||
while (my $got = <STDIN>) { # Should probably be sysread
|
||||
if ( $sel->can_read( $opts{display_interval} ) ) {
|
||||
while ( my $got = <STDIN> ) {
|
||||
if ($actions{$got}) {
|
||||
my $ret = $actions{$got}->(
|
||||
select_obj => $sel,
|
||||
options => \%opts,
|
||||
got => $got,
|
||||
filehandle => $tmp_fh,
|
||||
select_obj => $sel,
|
||||
options => \%opts,
|
||||
got => $got,
|
||||
filehandle => $tmp_fh,
|
||||
) || '';
|
||||
last MAIN_LOOP if $ret eq 'last';
|
||||
}
|
||||
}
|
||||
}
|
||||
$lines_read += $opts{obj}->group_by( filehandle => $tmp_fh ) || 0;
|
||||
$tmp_fh->clearerr if eof $tmp_fh;
|
||||
# As a possible source of confusion, note that this calls the group_by
|
||||
# _method_ in DiskstatsGroupBySomething, not the group_by _function_
|
||||
# defined below.
|
||||
$opts{obj}->group_by( filehandle => $tmp_fh, clear_state => 0 ) || 0;
|
||||
|
||||
if ( eof $tmp_fh ) {
|
||||
# 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} && $opts{samples_to_gather} && kill 0, $child_pid ) {
|
||||
last MAIN_LOOP;
|
||||
}
|
||||
|
||||
# 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;
|
||||
}
|
||||
}
|
||||
ReadKeyMini::cooked();
|
||||
kill 9, $pid;
|
||||
close($tmp_fh);
|
||||
|
||||
if ( !$args{filename} ) {
|
||||
close( $child_fh ) or die "Child error: $?";
|
||||
kill 9, $child_pid;
|
||||
}
|
||||
close($tmp_fh) or die "Couldn't close: $OS_ERROR";
|
||||
return;
|
||||
}
|
||||
|
||||
{
|
||||
my %objects = (
|
||||
D => "DiskstatsGroupByDisk",
|
||||
A => "DiskstatsGroupByAll",
|
||||
S => "DiskstatsGroupBySample",
|
||||
);
|
||||
sub gather_samples {
|
||||
my (%opts) = @_;
|
||||
my $samples = 0;
|
||||
|
||||
sub group_by {
|
||||
my (%args) = @_;
|
||||
GATHER_DATA:
|
||||
while ( $opts{gather_while}->() ) {
|
||||
sleep($opts{sampling_interval});
|
||||
open my $diskstats_fh, "<", "/proc/diskstats"
|
||||
or die $!;
|
||||
|
||||
my $got = $args{got};
|
||||
my @to_print = <$diskstats_fh>;
|
||||
push @to_print, `date +'TS %s.%N %F %T'`;
|
||||
|
||||
if ( ref( $args{options}->{obj} ) ne $objects{$got} ) {
|
||||
delete $args{options}->{obj};
|
||||
# This would fail on a stricter constructor, so it probably
|
||||
# needs fixing.
|
||||
$args{options}->{obj} = $objects{$got}->new( %{$args{options}} );
|
||||
# Lovely little method from IO::Handle: turns on autoflush,
|
||||
# prints, and then restores the original autoflush state.
|
||||
$opts{filehandle}->printflush(@to_print);
|
||||
close $diskstats_fh or die $!;
|
||||
|
||||
$samples++;
|
||||
if ( defined($opts{samples_to_gather}) && $samples >= $opts{samples_to_gather} ) {
|
||||
last GATHER_DATA;
|
||||
}
|
||||
seek $args{filehandle}, 0, 0;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub group_by {
|
||||
my (%args) = @_;
|
||||
|
||||
my $got = $args{got};
|
||||
|
||||
if ( ref( $args{options}->{obj} ) ne $option_to_object{$got} ) {
|
||||
# Particularly important! Otherwise we would depend on the
|
||||
# object's ->new being smart about discarding unrecognized
|
||||
# values.
|
||||
delete $args{options}->{obj};
|
||||
# This would fail on a stricter constructor, so it probably
|
||||
# needs fixing.
|
||||
$args{options}->{obj} = $option_to_object{$got}->new( %{$args{options}});
|
||||
}
|
||||
seek $args{filehandle}, 0, 0;
|
||||
|
||||
# Just aliasing this for a bit.
|
||||
for my $obj ( $args{options}->{obj} ) {
|
||||
if ( $option_to_object{$got} eq "DiskstatsGroupBySample" ) {
|
||||
$obj->interactive(1);
|
||||
}
|
||||
else {
|
||||
$obj->interactive(0);
|
||||
}
|
||||
$obj->group_by(
|
||||
filehandle => $args{filehandle},
|
||||
# Only print the header once, as if in interactive.
|
||||
header_cb => 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}->{obj};
|
||||
my $mode = $object_to_option{ref($obj)};
|
||||
my ($column_re) = regexp_pattern( $obj->column_regex() );
|
||||
my ($device_re) = regexp_pattern( $obj->device_regex() );
|
||||
my $interval = $obj->interval() || '(none)';
|
||||
my $disp_int = $args{options}->{display_interval} || '(none)';
|
||||
my $inact_disk = $obj->filter_zeroed_rows() || '';
|
||||
|
||||
for my $re ( $column_re, $device_re ) {
|
||||
$re =~ s/^\Q(?=)\E$//;
|
||||
$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/show 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(@_);
|
||||
}
|
||||
|
||||
sub file_to_use {
|
||||
my ( $filename ) = @_;
|
||||
#$filename ||= `mktemp -d /tmp/pt-diskstats.$PID.XXXXXXXX`;
|
||||
if ( $filename ) {
|
||||
open my $fh, "<", $filename
|
||||
or die "Couldn't open $filename: $OS_ERROR";
|
||||
return $fh, $filename;
|
||||
}
|
||||
else {
|
||||
local $EVAL_ERROR;
|
||||
if ( !eval { require File::Temp } ) {
|
||||
die "Can't call mktemp nor load File::Temp. Please install either of those or pass in an explicit filename.";
|
||||
}
|
||||
my $dir = File::Temp::tempdir( CLEANUP => 1 );
|
||||
return File::Temp::tempfile(
|
||||
"pt-diskstats.$PID.XXXXXXXX",
|
||||
DIR => $dir,
|
||||
UNLINK => 1,
|
||||
OPEN => 1,
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub get_input {
|
||||
@@ -181,18 +325,33 @@ sub get_input {
|
||||
return $new_opt;
|
||||
}
|
||||
|
||||
sub get_new_interval {
|
||||
sub hide_inactive_disks {
|
||||
my (%args) = @_;
|
||||
my $new_interval = get_input("Enter a redisplay interval: ");
|
||||
my $new_val = get_input("Filter inactive rows? (Leave blank for 'No') ");
|
||||
|
||||
$new_interval ||= 0;
|
||||
$args{options}->{filter_zeroed_rows} = $new_val;
|
||||
$args{options}->{obj}->filter_zeroed_rows($new_val);
|
||||
return;
|
||||
}
|
||||
|
||||
if ( looks_like_number($new_interval) ) {
|
||||
return $args{options}->{interval} = $new_interval;
|
||||
}
|
||||
else {
|
||||
die("invalid timeout specification");
|
||||
}
|
||||
sub get_new_value_for {
|
||||
my ($looking_for, $message) = @_;
|
||||
return sub {
|
||||
my (%args) = @_;
|
||||
my $new_interval = get_input($message);
|
||||
|
||||
$new_interval ||= 0;
|
||||
|
||||
if ( looks_like_number($new_interval) ) {
|
||||
if ( $args{options}->{obj}->can($looking_for) ) {
|
||||
$args{options}->{obj}->$looking_for($new_interval);
|
||||
}
|
||||
return $args{options}->{$looking_for} = $new_interval;
|
||||
}
|
||||
else {
|
||||
die("invalid timeout specification");
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub get_new_x_regex {
|
||||
@@ -201,10 +360,11 @@ sub get_new_x_regex {
|
||||
my (%args) = @_;
|
||||
my $new_regex = get_input($message);
|
||||
|
||||
local $EVAL_ERROR;
|
||||
if ( $new_regex && (my $re = eval { qr/$new_regex/i }) ) {
|
||||
$args{options}->{$looking_for} = $re;
|
||||
}
|
||||
elsif (!$EVAL_ERROR && !$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
|
||||
@@ -214,26 +374,10 @@ sub get_new_x_regex {
|
||||
else {
|
||||
die("invalid regex specification: $EVAL_ERROR");
|
||||
}
|
||||
$args{options}->{obj}->$looking_for( $args{options}->{$looking_for} );
|
||||
};
|
||||
}
|
||||
|
||||
sub help {
|
||||
# XXX: TODO
|
||||
print <<'HELP';
|
||||
You can control this program by key presses:
|
||||
------------------- Key ------------------- ---- Current Setting ----
|
||||
A, D, S) Set the group-by mode \$opt{OPT_g}
|
||||
c) Enter an awk regex to match column names \$opt{OPT_c}
|
||||
d) Enter an awk regex to match disk names \$opt{OPT_d}
|
||||
i) Set the sample size in seconds \$opt{OPT_i}
|
||||
s) Set the redisplay interval in seconds \$opt{OPT_s}
|
||||
p) Pause the program
|
||||
q) Quit the program
|
||||
------------------- Press any key to continue -----------------------
|
||||
HELP
|
||||
pause(@_);
|
||||
}
|
||||
|
||||
sub pause {
|
||||
my (%args) = @_;
|
||||
STDIN->blocking(1);
|
||||
@@ -244,8 +388,8 @@ sub pause {
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__PACKAGE__->run(@ARGV) unless caller;
|
||||
#XXX TODO
|
||||
#__PACKAGE__->run_interactive(@ARGV, o => bless {}, "OptionParser") unless caller;
|
||||
|
||||
}
|
||||
# ###########################################################################
|
||||
|
||||
Reference in New Issue
Block a user