632 lines
17 KiB
Perl
Executable File
632 lines
17 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
##############################################################################
|
|
|
|
=head1 NAME
|
|
|
|
dbreportd - Report database latencies at regular intervals.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
$ dbreportd OPTIONS
|
|
|
|
=head1 OPTIONS
|
|
|
|
=over 4
|
|
|
|
=item -c, --clearscreen
|
|
|
|
Clear the screen and home the cursor before printing each report, like top. May
|
|
not work on all terminals.
|
|
|
|
=item -d, --debug
|
|
|
|
Turn on debugging information. May be specified more than once for (potentially)
|
|
increased levels of debugging.
|
|
|
|
=item -h, --help
|
|
|
|
Output a help message and exit.
|
|
|
|
=item -i, --interval=SECONDS
|
|
|
|
Set the number of seconds between reports to SECONDS. Defaults to 3 second
|
|
intervals.
|
|
|
|
=item -p, --port=PORT
|
|
|
|
Set the port to listen on for reports. This is set in ljconfig.pl, but can be
|
|
overridden here.
|
|
|
|
=item -V, --version
|
|
|
|
Output version information and exit.
|
|
|
|
=back
|
|
|
|
=head1 REQUIRES
|
|
|
|
I<Token requires line>
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
None yet.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Michael Granger <ged@FaerieMUD.org>
|
|
|
|
Copyright (c) 2004 Danga Interactive. All rights reserved.
|
|
|
|
This program is Open Source software. You may use, modify, and/or redistribute
|
|
this software under the terms of the Perl Artistic License. (See
|
|
http://language.perl.com/misc/Artistic.html)
|
|
|
|
THIS SOFTWARE 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.
|
|
|
|
=cut
|
|
|
|
# :TODO: Change param order in received msgs
|
|
|
|
##############################################################################
|
|
package dbreportd;
|
|
use strict;
|
|
use warnings qw{all};
|
|
|
|
|
|
###############################################################################
|
|
### I N I T I A L I Z A T I O N
|
|
###############################################################################
|
|
BEGIN {
|
|
|
|
# Turn STDOUT buffering off
|
|
$| = 1;
|
|
|
|
# Versioning stuff and custom includes
|
|
use vars qw{$VERSION $RCSID};
|
|
$VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
|
|
$RCSID = q$Id: ljblockwatcher.pl,v 1.3 2004/03/09 22:25:05 deveiant Exp $;
|
|
|
|
# Define some constants
|
|
use constant TRUE => 1;
|
|
use constant FALSE => 0;
|
|
|
|
# How many time samples to keep around to determine average latency
|
|
use constant SAMPLE_DEPTH => 10;
|
|
|
|
# How many samples to show in the "top <n> slow queries"
|
|
use constant TOP_QUERY_SIZE => 5;
|
|
|
|
# ANSI vt100 escape codes for various things
|
|
use constant VT100_CLEARSCREEN => "\e[2J";
|
|
use constant VT100_HOME => "\e[0;0H";
|
|
|
|
# Modules
|
|
use Getopt::Long qw{GetOptions};
|
|
use Pod::Usage qw{pod2usage};
|
|
|
|
use IO::Socket::INET qw{};
|
|
use IO::Select qw{};
|
|
use Time::HiRes qw{usleep};
|
|
use Data::Dumper qw{};
|
|
|
|
# Turn on option bundling (-vid)
|
|
Getopt::Long::Configure( "bundling" );
|
|
}
|
|
|
|
our $Debug = FALSE;
|
|
|
|
### Main body
|
|
MAIN: {
|
|
my (
|
|
$helpFlag, # User requested help?
|
|
$versionFlag, # User requested version info?
|
|
|
|
$interval, # Interval between generated reports
|
|
$port, # Port number to listen on
|
|
|
|
$msg, # The message buffer for reports
|
|
$sock, # UDP socket
|
|
$selector, # IO::Select object
|
|
$lastReport, # time() of last report output
|
|
$host, # Message host
|
|
$time, # Message time
|
|
$notes, # Message notes
|
|
$type, # Operation type (currently unused)
|
|
%buffers, # SampleBuffers keyed by host
|
|
$clearscreenFlag, # Clear the screen before every report?
|
|
);
|
|
|
|
# Print the program header and read in command line options
|
|
GetOptions(
|
|
'd|debug+' => \$Debug,
|
|
'h|help' => \$helpFlag,
|
|
'i|interval=i' => \$interval,
|
|
'V|version' => \$versionFlag,
|
|
'p|port=i' => \$port,
|
|
'c|clearscreen' => \$clearscreenFlag,
|
|
) or abortWithUsage();
|
|
|
|
# If the -h flag or -V flag was given, just show the help or version,
|
|
# respectively, and exit.
|
|
helpMode() and exit if $helpFlag;
|
|
versionMode() and exit if $versionFlag;
|
|
|
|
# Either get the port from the command line or a default
|
|
$port ||= 4774;
|
|
|
|
# Set the interval to a default if it wasn't specified
|
|
$interval = 3 if !defined $interval;
|
|
|
|
# Open a receiving UDP socket
|
|
print VT100_CLEARSCREEN, VT100_HOME if $clearscreenFlag;
|
|
print "Setting up listener on port $port\n";
|
|
$sock = new IO::Socket::INET (
|
|
Proto => 'udp',
|
|
LocalPort => $port
|
|
) or die "Failed to open receiving socket: $!";
|
|
|
|
$selector = new IO::Select;
|
|
$selector->add( $sock );
|
|
$lastReport = time();
|
|
|
|
%buffers = ();
|
|
|
|
# Print reports every couple of seconds
|
|
while ( 1 ) {
|
|
if ( $selector->can_read($interval) ) {
|
|
|
|
# Get the message and split it back into four parts
|
|
my $addr = $sock->recv( $msg, 1024, 0 );
|
|
print ">>> Message: $msg\n" if $Debug;
|
|
( $host, $type, $time, $notes ) = split( /\x3/, $msg, 4 );
|
|
|
|
# Add the time and notes to the table of hosts
|
|
$buffers{ $host } ||= new SampleBuffer ( $host, depth => SAMPLE_DEPTH );
|
|
$buffers{ $host }->add( $type, $time, $notes );
|
|
} else {
|
|
sleep 0.5;
|
|
}
|
|
|
|
} continue {
|
|
if ( (time() - $lastReport) > $interval ) {
|
|
print VT100_CLEARSCREEN, VT100_HOME if $clearscreenFlag;
|
|
print_report( values %buffers );
|
|
$lastReport = time();
|
|
}
|
|
};
|
|
|
|
}
|
|
|
|
|
|
### FUNCTION: print_report( @buffers )
|
|
### Given a list of SampleBuffer objects, print a table with the ones with the
|
|
### highest average times.
|
|
sub print_report {
|
|
my @buffers = @_;
|
|
|
|
my (
|
|
$row, # Row count for display
|
|
@top, # Top 5 slowest average buffers
|
|
%top, # ^-- Hash of same
|
|
@sbuffers, # Buffer objects sorted by hostname
|
|
@wbuffers, # Buffer objects sorted by worst op
|
|
$fmt, # printf format for report rows
|
|
$prefix, # Line prefixes
|
|
);
|
|
|
|
if ( @buffers ) {
|
|
# Pick the 5 slowest operations
|
|
@top =
|
|
map { $_->[0] }
|
|
sort { $b->[1] <=> $a->[1] }
|
|
map { [$_->host, $_->average_time] }
|
|
@buffers;
|
|
$row = 0;
|
|
%top = ();
|
|
foreach my $host ( @top[0 ... TOP_QUERY_SIZE] ) {
|
|
last unless defined $host;
|
|
$top{$host} = ++$row unless exists $top{$host};
|
|
}
|
|
#print Data::Dumper->Dumpxs( [\%top], ['top'] ), "\n";
|
|
|
|
# Make an array of sorted buffer objects by worst average time
|
|
@sbuffers =
|
|
map { $_->[0] }
|
|
sort { $b->[1] <=> $a->[1] }
|
|
map { [$_, $_->average_time] }
|
|
@buffers;
|
|
|
|
# Make an array of sorted buffer objects by worst time
|
|
@wbuffers =
|
|
map { $_->[0] }
|
|
sort { $b->[1] <=> $a->[1] }
|
|
map { [$_, $_->worst_time] }
|
|
@buffers;
|
|
|
|
# Output all hosts with the average worst operation times
|
|
$fmt = "%-2s%25s %0.5fs";
|
|
$row = 0;
|
|
header( "Average longest blocking operations, by host" );
|
|
foreach my $buf (@sbuffers) {
|
|
$row++;
|
|
|
|
if ( exists $top{$buf->host} && $top{$buf->host} <= 3 ) {
|
|
$prefix = '+';
|
|
} else {
|
|
$prefix = ' ';
|
|
}
|
|
|
|
printf "$fmt\n", $prefix, $buf->host, $buf->average_time;
|
|
}
|
|
print "\n";
|
|
|
|
# Output the worst operations with their notes
|
|
$row = 0;
|
|
$fmt = "%0.5fs: '%s' [%s/%s]\n";
|
|
header( "%d worst blockers", TOP_QUERY_SIZE );
|
|
foreach my $buf (@wbuffers[0 ... TOP_QUERY_SIZE]) {
|
|
last unless defined $buf;
|
|
$row++;
|
|
|
|
my $sample = $buf->worst_sample;
|
|
printf( $fmt,
|
|
$sample->time,
|
|
$sample->notes || "(none)",
|
|
$sample->type,
|
|
$buf->host );
|
|
}
|
|
print "\n";
|
|
|
|
# Print the raw buffer objects if debugging
|
|
if ( $Debug ) {
|
|
header( "Raw buffers" );
|
|
foreach my $buf ( @buffers ) {
|
|
local $Data::Dumper::Indent = 0;
|
|
local $Data::Dumper::Terse = TRUE;
|
|
print Data::Dumper->Dumpxs( [$buf], ['buf'] ), "\n";
|
|
}
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
else {
|
|
print "No hosts reporting.\n";
|
|
}
|
|
}
|
|
|
|
|
|
### FUNCTION: header( $fmt, @args )
|
|
### Printf the given message as a header.
|
|
sub header {
|
|
my ( $fmt, @args ) = @_;
|
|
my $msg = sprintf( $fmt, @args );
|
|
chomp( $msg );
|
|
|
|
print "$msg\n", '-' x 75, "\n";
|
|
}
|
|
|
|
|
|
### FUNCTION: helpMode()
|
|
### Exit normally after printing the usage message
|
|
sub helpMode {
|
|
pod2usage( -verbose => 1, -exitval => 0 );
|
|
}
|
|
|
|
|
|
### FUNCTION: versionMode()
|
|
### Exit normally after printing version information
|
|
sub versionMode {
|
|
print STDERR "dbreportd $VERSION\n";
|
|
exit;
|
|
}
|
|
|
|
|
|
### FUNCTION: abortWithUsage()
|
|
### Abort the program showing usage message.
|
|
sub abortWithUsage {
|
|
if ( @_ ) {
|
|
pod2usage( -verbose => 1, -exitval => 1, -msg => join('', @_) );
|
|
} else {
|
|
pod2usage( -verbose => 1, -exitval => 1 );
|
|
}
|
|
}
|
|
|
|
|
|
### FUNCTION: abort( @messages )
|
|
### Print the specified messages to the terminal and exit with a non-zero status.
|
|
sub abort {
|
|
my $msg = @_ ? join '', @_ : "unknown error";
|
|
print STDERR $msg, "\n";
|
|
exit 1;
|
|
}
|
|
|
|
|
|
|
|
#####################################################################
|
|
### T I M E S A M P L E C L A S S
|
|
#####################################################################
|
|
package Sample;
|
|
use strict;
|
|
|
|
BEGIN {
|
|
use vars qw{$AUTOLOAD};
|
|
use Carp qw{croak confess};
|
|
use Data::Dumper ();
|
|
$Data::Dumper::Terse = 1;
|
|
$Data::Dumper::Indent = 1;
|
|
}
|
|
|
|
### METHOD: new( $host )
|
|
### Create a new sample buffer for the given host
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref $proto || $proto;
|
|
|
|
my $self = bless {
|
|
type => 'db',
|
|
time => 0.0,
|
|
notes => '',
|
|
}, $class;
|
|
|
|
if ( @_ && (@_ % 2 == 0) ) {
|
|
my %args = @_;
|
|
foreach my $meth ( keys %args ) {
|
|
$self->$meth( $args{$meth} );
|
|
}
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
|
|
|
|
### FUNCTION: blessed( $var )
|
|
### Returns a true value if the given value is a blessed reference.
|
|
sub blessed {
|
|
my $arg = shift;
|
|
return ref $arg && UNIVERSAL::isa( $arg, 'UNIVERSAL' );
|
|
}
|
|
|
|
|
|
### (PROXY) METHOD: AUTOLOAD( @args )
|
|
### Proxy method to build (non-translucent) object accessors.
|
|
sub AUTOLOAD {
|
|
my $self = shift;
|
|
confess "Cannot be called as a function" unless $self && blessed $self;
|
|
|
|
( my $name = $AUTOLOAD ) =~ s{.*::}{};
|
|
|
|
### Build an accessor for extant attributes
|
|
if ( exists $self->{$name} ) {
|
|
|
|
### Define an accessor for this attribute
|
|
my $method = sub {
|
|
my $closureSelf = shift or confess "Cannot be called as a function";
|
|
$closureSelf->{$name} = shift if @_;
|
|
return $closureSelf->{$name};
|
|
};
|
|
|
|
### Install the new method in the symbol table
|
|
NO_STRICT_REFS: {
|
|
no strict 'refs';
|
|
*{$AUTOLOAD} = $method;
|
|
}
|
|
|
|
### Now jump to the new method after sticking the self-ref back onto the
|
|
### stack
|
|
unshift @_, $self;
|
|
goto &$AUTOLOAD;
|
|
}
|
|
|
|
### Try to delegate to our parent's version of the method
|
|
my $parentMethod = "SUPER::$name";
|
|
return $self->$parentMethod( @_ );
|
|
}
|
|
|
|
sub DESTROY {}
|
|
sub END {}
|
|
|
|
|
|
|
|
#####################################################################
|
|
### S A M P L E B U F F E R C L A S S
|
|
#####################################################################
|
|
|
|
### Class for tracking latencies for a given host
|
|
package SampleBuffer;
|
|
use strict;
|
|
|
|
BEGIN {
|
|
use Carp qw{croak confess};
|
|
use vars qw{$AUTOLOAD};
|
|
}
|
|
|
|
|
|
### METHOD: new( $host )
|
|
### Create a new sample buffer for the given host
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref $proto || $proto;
|
|
my $host = shift or die "No hostname given";
|
|
|
|
my $self = bless {
|
|
host => $host,
|
|
samples => {},
|
|
depth => 10,
|
|
}, $class;
|
|
|
|
if ( @_ && (@_ % 2 == 0) ) {
|
|
my %args = @_;
|
|
foreach my $meth ( keys %args ) {
|
|
$self->$meth( $args{$meth} );
|
|
}
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
|
|
### METHOD: add( $type, $time, $notes )
|
|
### Add the specified I<time> to the sample buffer for the given I<type> with
|
|
### the given I<notes>.
|
|
sub add {
|
|
my $self = shift or confess "Cannot be called as a function";
|
|
my ( $type, $time, $notes ) = @_;
|
|
|
|
$self->{samples}{ $type } ||= [];
|
|
my $slist = $self->{samples}{ $type };
|
|
|
|
my $sample = new Sample ( type => $type, time => $time, notes => $notes );
|
|
unshift @$slist, $sample;
|
|
pop @$slist if @$slist > $self->{depth};
|
|
|
|
return scalar @$slist;
|
|
}
|
|
|
|
|
|
### METHOD: samples( [$type] )
|
|
### Fetch a list of the samples of the given I<type> in the buffer, or a list of
|
|
### all samples if I<type> is not specified.
|
|
sub samples {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my $type = shift;
|
|
|
|
my @samples = ();
|
|
|
|
# Gather the samples that are going to be used to make the average, either
|
|
# the specific kind requested, or all of 'em.
|
|
if ( $type ) {
|
|
# Regexp filter
|
|
if ( ref $type eq 'Regexp' ) {
|
|
foreach my $key ( keys %{$self->{samples}} ) {
|
|
push @samples, @{$self->{samples}{ $key }}
|
|
if $type =~ $key;
|
|
}
|
|
}
|
|
|
|
# Any other filter just gets string-equalled.
|
|
else {
|
|
@samples = @{$self->{samples}{ $type }};
|
|
}
|
|
} else {
|
|
foreach my $type ( keys %{$self->{samples}} ) {
|
|
push @samples, @{$self->{samples}{ $type }};
|
|
}
|
|
}
|
|
|
|
return @samples;
|
|
}
|
|
|
|
|
|
### METHOD: average_time( [$type] )
|
|
### Return the average of all the times currently in the buffer for the given
|
|
### I<type>. If I<type> isn't given, returns the overall average.
|
|
sub average_time {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my $type = shift;
|
|
|
|
my ( $time, $count ) = ( 0, 0 );
|
|
|
|
# Now add and count all the time from each target sample
|
|
foreach my $sample ( $self->samples($type) ) {
|
|
$time += $sample->time;
|
|
$count++;
|
|
}
|
|
|
|
return $time / $count;
|
|
}
|
|
|
|
|
|
### METHOD: worst_sample( [$type] )
|
|
### Return the worst sample in the buffer for the given I<type>. If no type is
|
|
### given, return the worst overall sample.
|
|
sub worst_sample {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my $type = shift;
|
|
return () unless %{$self->{samples}};
|
|
|
|
my @samples =
|
|
map { $_->[0] }
|
|
sort { $a->[1] <=> $b->[1] }
|
|
map { [$_, $_->time] } $self->samples( $type );
|
|
|
|
return $samples[-1];
|
|
}
|
|
|
|
|
|
### METHOD: worst_time( [$type] )
|
|
### Return the worst time in the buffer for the given I<type>. If no I<type> is
|
|
### given, returns the worst overall time.
|
|
sub worst_time {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my $type = shift;
|
|
|
|
my $samp = $self->worst_sample( $type ) or return ();
|
|
return $samp->time;
|
|
}
|
|
|
|
|
|
### METHOD: worst_notes( [$type] )
|
|
### Return the notes from the worst sample in the buffer for the given
|
|
### I<type>. If I<type> is not specified, returns the notes for the worst
|
|
### overall sample.
|
|
sub worst_notes {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my $type = shift;
|
|
|
|
my $samp = $self->worst_sample( $type ) or return ();
|
|
return $samp->notes;
|
|
}
|
|
|
|
|
|
### FUNCTION: blessed( $var )
|
|
### Returns a true value if the given value is a blessed reference.
|
|
sub blessed {
|
|
my $arg = shift;
|
|
return ref $arg && UNIVERSAL::isa( $arg, 'UNIVERSAL' );
|
|
}
|
|
|
|
|
|
### (PROXY) METHOD: AUTOLOAD( @args )
|
|
### Proxy method to build (non-translucent) object accessors.
|
|
sub AUTOLOAD {
|
|
my $self = shift;
|
|
confess "Cannot be called as a function" unless $self && blessed $self;
|
|
|
|
( my $name = $AUTOLOAD ) =~ s{.*::}{};
|
|
|
|
### Build an accessor for extant attributes
|
|
if ( exists $self->{$name} ) {
|
|
|
|
### Define an accessor for this attribute
|
|
my $method = sub {
|
|
my $closureSelf = shift or confess "Cannot be called as a function";
|
|
$closureSelf->{$name} = shift if @_;
|
|
return $closureSelf->{$name};
|
|
};
|
|
|
|
### Install the new method in the symbol table
|
|
NO_STRICT_REFS: {
|
|
no strict 'refs';
|
|
*{$AUTOLOAD} = $method;
|
|
}
|
|
|
|
### Now jump to the new method after sticking the self-ref back onto the
|
|
### stack
|
|
unshift @_, $self;
|
|
goto &$AUTOLOAD;
|
|
}
|
|
|
|
### Try to delegate to our parent's version of the method
|
|
my $parentMethod = "SUPER::$name";
|
|
return $self->$parentMethod( @_ );
|
|
}
|
|
|
|
sub DESTROY {}
|
|
sub END {}
|
|
|
|
|