#!/usr/bin/perl

# This is mk-heartbeat, a script to measure replication delay.
#
# This program is copyright (c) 2006 Proven Scaling LLC and SixApart Ltd, and
# (c) 2007 Baron Schwartz.  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.

use strict;
use warnings FATAL => 'all';

# ###########################################################################
# OptionParser package 1178
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package OptionParser;

use Getopt::Long;
use List::Util qw(max);
use English qw(-no_match_vars);

sub new {
   my ( $class, @opts ) = @_;
   my %key_seen;
   my %long_seen;
   my %key_for;
   my %defaults;
   my @mutex;
   my @atleast1;
   my %long_for;
   my %disables;
   my %copyfrom;
   unshift @opts,
      { s => 'help',    d => 'Show this help message' },
      { s => 'version', d => 'Output version information and exit' };
   foreach my $opt ( @opts ) {
      if ( ref $opt ) {
         my ( $long, $short ) = $opt->{s} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
         $opt->{k} = $short || $long;
         $key_for{$long} = $opt->{k};
         $long_for{$opt->{k}} = $long;
         $long_for{$long} = $long;
         $opt->{l} = $long;
         die "Duplicate option $opt->{k}" if $key_seen{$opt->{k}}++;
         die "Duplicate long option $opt->{l}" if $long_seen{$opt->{l}}++;
         $opt->{t} = $short;
         $opt->{n} = $opt->{s} =~ m/!/;
         $opt->{g} ||= 'o';
         if ( (my ($y) = $opt->{s} =~ m/=([mdHhAaz])/) ) {
            $opt->{y} = $y;
            $opt->{s} =~ s/=./=s/;
         }
         $opt->{r} = $opt->{d} =~ m/required/;
         if ( (my ($def) = $opt->{d} =~ m/default(?: ([^)]+))?/) ) {
            $defaults{$opt->{k}} = defined $def ? $def : 1;
         }
         if ( (my ($dis) = $opt->{d} =~ m/(disables .*)/) ) {
            $disables{$opt->{k}} = [ $class->get_participants($dis) ];
         }
      }
      else { # It's an instruction.

         if ( $opt =~ m/at least one|mutually exclusive|one and only one/ ) {
            my @participants = map {
                  die "No such option '$_' in $opt" unless $long_for{$_};
                  $long_for{$_};
               } $class->get_participants($opt);
            if ( $opt =~ m/mutually exclusive|one and only one/ ) {
               push @mutex, \@participants;
            }
            if ( $opt =~ m/at least one|one and only one/ ) {
               push @atleast1, \@participants;
            }
         }
         elsif ( $opt =~ m/default to/ ) {
            my @participants = map {
                  die "No such option '$_' in $opt" unless $long_for{$_};
                  $key_for{$_};
               } $class->get_participants($opt);
            $copyfrom{$participants[0]} = $participants[1];
         }

      }
   }

   foreach my $dis ( keys %disables ) {
      $disables{$dis} = [ map {
            die "No such option '$_' while processing $dis" unless $long_for{$_};
            $long_for{$_};
         } @{$disables{$dis}} ];
   }

   return bless {
      specs => [ grep { ref $_ } @opts ],
      notes => [],
      instr => [ grep { !ref $_ } @opts ],
      mutex => \@mutex,
      defaults => \%defaults,
      long_for => \%long_for,
      atleast1 => \@atleast1,
      disables => \%disables,
      key_for  => \%key_for,
      copyfrom => \%copyfrom,
      strict   => 1,
      groups   => [ { k => 'o', d => 'Options' } ],
   }, $class;
}

sub get_participants {
   my ( $self, $str ) = @_;
   my @participants;
   foreach my $thing ( $str =~ m/(--?[\w-]+)/g ) {
      if ( (my ($long) = $thing =~ m/--(.+)/) ) {
         push @participants, $long;
      }
      else {
         foreach my $short ( $thing =~ m/([^-])/g ) {
            push @participants, $short;
         }
      }
   }
   return @participants;
}

sub parse {
   my ( $self, %defaults ) = @_;
   my @specs = @{$self->{specs}};
   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);

   my %opt_seen;
   my %vals = %{$self->{defaults}};
   @vals{keys %defaults} = values %defaults;
   foreach my $spec ( @specs ) {
      $vals{$spec->{k}} = undef unless defined $vals{$spec->{k}};
      $opt_seen{$spec->{k}} = 1;
   }

   foreach my $key ( keys %defaults ) {
      die "Cannot set default for non-existent option '$key'\n"
         unless $opt_seen{$key};
   }

   Getopt::Long::Configure('no_ignore_case', 'bundling');
   GetOptions( map { $_->{s} => \$vals{$_->{k}} } @specs )
      or $self->error('Error parsing options');

   if ( $vals{version} ) {
      my $prog = $self->prog;
      printf("%s  Ver %s Distrib %s Changeset %s\n",
         $prog, $main::VERSION, $main::DISTRIB, $main::SVN_REV);
      exit(0);
   }

   if ( @ARGV && $self->{strict} ) {
      $self->error("Unrecognized command-line options @ARGV");
   }

   foreach my $dis ( grep { defined $vals{$_} } keys %{$self->{disables}} ) {
      my @disses = map { $self->{key_for}->{$_} } @{$self->{disables}->{$dis}};
      @vals{@disses} = map { undef } @disses;
   }

   foreach my $spec ( grep { $_->{r} } @specs ) {
      if ( !defined $vals{$spec->{k}} ) {
         $self->error("Required option --$spec->{l} must be specified");
      }
   }

   foreach my $mutex ( @{$self->{mutex}} ) {
      my @set = grep { defined $vals{$self->{key_for}->{$_}} } @$mutex;
      if ( @set > 1 ) {
         my $note = join(', ',
            map { "--$self->{long_for}->{$_}" }
                @{$mutex}[ 0 .. scalar(@$mutex) - 2] );
         $note .= " and --$self->{long_for}->{$mutex->[-1]}"
               . " are mutually exclusive.";
         $self->error($note);
      }
   }

   foreach my $required ( @{$self->{atleast1}} ) {
      my @set = grep { defined $vals{$self->{key_for}->{$_}} } @$required;
      if ( !@set ) {
         my $note = join(', ',
            map { "--$self->{long_for}->{$_}" }
                @{$required}[ 0 .. scalar(@$required) - 2] );
         $note .= " or --$self->{long_for}->{$required->[-1]}";
         $self->error("Specify at least one of $note");
      }
   }

   foreach my $spec ( grep { $_->{y} && defined $vals{$_->{k}} } @specs ) {
      my $val = $vals{$spec->{k}};
      if ( $spec->{y} eq 'm' ) {
         my ( $num, $suffix ) = $val =~ m/(\d+)([smhd])$/;
         if ( $suffix ) {
            $val = $suffix eq 's' ? $num            # Seconds
                 : $suffix eq 'm' ? $num * 60       # Minutes
                 : $suffix eq 'h' ? $num * 3600     # Hours
                 :                  $num * 86400;   # Days
            $vals{$spec->{k}} = $val;
         }
         else {
            $self->error("Invalid --$spec->{l} argument");
         }
      }
      elsif ( $spec->{y} eq 'd' ) {
         my $from_key = $self->{copyfrom}->{$spec->{k}};
         my $default = {};
         if ( $from_key ) {
            $default = $self->{dsn}->parse($self->{dsn}->as_string($vals{$from_key}));
         }
         $vals{$spec->{k}} = $self->{dsn}->parse($val, $default);
      }
      elsif ( $spec->{y} eq 'z' ) {
         my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
         if ( defined $num ) {
            if ( $factor ) {
               $num *= $factor_for{$factor};
            }
            $vals{$spec->{k}} = ($pre || '') . $num;
         }
         else {
            $self->error("Invalid --$spec->{l} argument");
         }
      }
   }

   foreach my $spec ( grep { $_->{y} } @specs ) {
      my $val = $vals{$spec->{k}};
      if ( $spec->{y} eq 'H' || (defined $val && $spec->{y} eq 'h') ) {
         $vals{$spec->{k}} = { map { $_ => 1 } split(',', ($val || '')) };
      }
      elsif ( $spec->{y} eq 'A' || (defined $val && $spec->{y} eq 'a') ) {
         $vals{$spec->{k}} = [ split(',', ($val || '')) ];
      }
   }

   return %vals;
}

sub error {
   my ( $self, $note ) = @_;
   $self->{__error__} = 1;
   push @{$self->{notes}}, $note;
}

sub prog {
   (my $prog) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
   return $prog || $PROGRAM_NAME;
}

sub prompt {
   my ( $self ) = @_;
   my $prog   = $self->prog;
   my $prompt = $self->{prompt} || '<options>';
   return "Usage: $prog $prompt\n";
}

sub descr {
   my ( $self ) = @_;
   my $prog = $self->prog;
   my $descr  = $prog . ' ' . ($self->{descr} || '')
          . "  For more details, please use the --help option, "
          . "or try 'perldoc $prog' for complete documentation.";
   $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g);
   $descr =~ s/ +$//mg;
   return $descr;
}

sub usage_or_errors {
   my ( $self, %opts ) = @_;
   if ( $opts{help} ) {
      print $self->usage(%opts);
      exit(0);
   }
   elsif ( $self->{__error__} ) {
      print $self->errors();
      exit(0);
   }
}

sub errors {
   my ( $self ) = @_;
   my $usage = $self->prompt() . "\n";
   if ( (my @notes = @{$self->{notes}}) ) {
      $usage .= join("\n  * ", 'Errors in command-line arguments:', @notes) . "\n";
   }
   return $usage . "\n" . $self->descr();
}

sub usage {
   my ( $self, %vals ) = @_;
   my @specs = @{$self->{specs}};

   my $maxl = max(map { length($_->{l}) + ($_->{n} ? 4 : 0)} @specs);

   my $maxs = max(0,
      map { length($_->{l}) + ($_->{n} ? 4 : 0)}
      grep { $_->{t} } @specs);

   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->prompt();
   foreach my $g ( @{$self->{groups}} ) {
      $usage .= "\n$g->{d}:\n";
      foreach my $spec ( sort { $a->{l} cmp $b->{l} } grep { $_->{g} eq $g->{k} } @specs ) {
         my $long  = $spec->{n} ? "[no]$spec->{l}" : $spec->{l};
         my $short = $spec->{t};
         my $desc  = $spec->{d};
         $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);
         }
      }
   }

   if ( (my @instr = @{$self->{instr}}) ) {
      $usage .= join("\n", map { "  $_" } @instr) . "\n";
   }
   if ( $self->{dsn} ) {
      $usage .= "\n" . $self->{dsn}->usage();
   }
   $usage .= "\nOptions and values after processing arguments:\n";
   foreach my $spec ( sort { $a->{l} cmp $b->{l} } @specs ) {
      my $val   = $vals{$spec->{k}};
      my $type  = $spec->{y} || '';
      my $bool  = $spec->{s} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
      $val      = $bool                     ? ( $val ? 'TRUE' : 'FALSE' )
                : !defined $val             ? '(No value)'
                : $type eq 'd'              ? $self->{dsn}->as_string($val)
                : $type =~ m/H|h/           ? join(',', sort keys %$val)
                : $type =~ m/A|a/           ? join(',', @$val)
                :                             $val;
      $usage .= sprintf("  --%-${lcol}s  %s\n", $spec->{l}, $val);
   }
   return $usage;
}

sub prompt_noecho {
   shift @_ if ref $_[0] eq __PACKAGE__;
   my ( $prompt ) = @_;
   local $OUTPUT_AUTOFLUSH = 1;
   print $prompt;
   my $response;
   eval {
      require Term::ReadKey;
      Term::ReadKey::ReadMode('noecho');
      chomp($response = <STDIN>);
      Term::ReadKey::ReadMode('normal');
      print "\n";
   };
   if ( $EVAL_ERROR ) {
      die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
   }
   return $response;
}

sub groups {
   my ( $self, @groups ) = @_;
   push @{$self->{groups}}, @groups;
}

1;

# ###########################################################################
# End OptionParser package
# ###########################################################################

# ###########################################################################
# DSNParser package 1149
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package DSNParser;

sub new {
   my ( $class, @opts ) = @_;
   my $self = {
      opts => {
         D => {
            desc => 'Database to use',
            dsn  => 'database',
            copy => 1,
         },
         F => {
            desc => 'Only read default options from the given file',
            dsn  => 'mysql_read_default_file',
            copy => 1,
         },
         h => {
            desc => 'Connect to host',
            dsn  => 'host',
            copy => 1,
         },
         p => {
            desc => 'Password to use when connecting',
            dsn  => 'password',
            copy => 1,
         },
         P => {
            desc => 'Port number to use for connection',
            dsn  => 'port',
            copy => 1,
         },
         S => {
            desc => 'Socket file to use for connection',
            dsn  => 'mysql_socket',
            copy => 1,
         },
         u => {
            desc => 'User for login if not current user',
            dsn  => 'user',
            copy => 1,
         },
      },
   };
   foreach my $opt ( @opts ) {
      $self->{opts}->{$opt->{key}} = { desc => $opt->{desc}, copy => $opt->{copy} };
   }
   return bless $self, $class;
}

sub prop {
   my ( $self, $prop, $value ) = @_;
   if ( @_ > 2 ) {
      $self->{$prop} = $value;
   }
   return $self->{$prop};
}

sub parse {
   my ( $self, $dsn, $prev, $defaults ) = @_;
   return unless $dsn;
   $prev     ||= {};
   $defaults ||= {};
   my %vals;
   my %opts = %{$self->{opts}};
   if ( $dsn !~ m/=/ && $self->prop('autokey') ) {
      $vals{ $self->prop('autokey') } = $dsn;
   }
   else {
      my %hash = map { m/^(.)=(.*)$/g } split(/,/, $dsn);
      foreach my $key ( keys %opts ) {
         $vals{$key} = $hash{$key};
         if ( !defined $vals{$key} && defined $prev->{$key} && $opts{$key}->{copy} ) {
            $vals{$key} = $prev->{$key};
         }
         if ( !defined $vals{$key} ) {
            $vals{$key} = $defaults->{$key};
         }
      }
      foreach my $key ( keys %hash ) {
         die "Unrecognized DSN part '$key' in '$dsn'\n"
            unless exists $opts{$key};
      }
   }
   if ( (my $required = $self->prop('required')) ) {
      foreach my $key ( keys %$required ) {
         die "Missing DSN part '$key' in '$dsn'\n" unless $vals{$key};
      }
   }
   return \%vals;
}

sub as_string {
   my ( $self, $dsn ) = @_;
   return $dsn unless ref $dsn;
   return join(',', map { "$_=$dsn->{$_}" } grep { defined $dsn->{$_} } sort keys %$dsn );
}

sub usage {
   my ( $self ) = @_;
   my $usage
      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n"
      . "  KEY  COPY  MEANING\n"
      . "  ===  ====  =============================================\n";
   my %opts = %{$self->{opts}};
   foreach my $key ( sort keys %opts ) {
      $usage .= "  $key    "
             .  ($opts{$key}->{copy} ? 'yes   ' : 'no    ')
             .  ($opts{$key}->{desc} || '[No description]')
             . "\n";
   }
   if ( (my $key = $self->prop('autokey')) ) {
      $usage .= "  If the DSN is a bareword, the word is treated as the '$key' key.\n";
   }
   return $usage;
}

sub get_cxn_params {
   my ( $self, $info ) = @_;
   my $dsn;
   my %opts = %{$self->{opts}};
   my $driver = $self->prop('dbidriver') || '';
   if ( $driver eq 'Pg' ) {
      $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
                     grep { defined $info->{$_} }
                     qw(h P));
   }
   else {
      $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
                     grep { defined $info->{$_} }
                     qw(F h P S))
         . ';mysql_read_default_group=mysql';
   }
   return ($dsn, $info->{u}, $info->{p});
}

1;

# ###########################################################################
# End DSNParser package
# ###########################################################################

# ###########################################################################
# And now for the "program".
# ###########################################################################

package main;

use DBI;
use English qw(-no_match_vars);
use List::Util qw(min max sum);
use Time::HiRes qw(ualarm gettimeofday);

our $VERSION = '1.0.2';
our $DISTRIB = '1316';
our $SVN_REV = sprintf("%d", q$Revision: 1308 $ =~ m/(\d+)/g || 0);

# ############################################################################
# Get configuration information.
# ############################################################################

my @opt_spec = (
   { s => 'askpass',           d => 'Prompt for password for connections' },
   { s => 'check',             d => 'Check slave delay once and exit' },
   { s => 'daemonize',         d => 'Fork to background and detach (POSIX only)' },
   { s => 'database|D=s',      d => 'Database to use' },
   { s => 'dbidriver=s',       d => 'Specify DBI driver; supports Pg (default mysql)' },
   { s => 'defaults-file|F=s', d => 'Only read mysql options from the given file' },
   { s => 'file=s',            d => 'Print latest --monitor output to this file' },
   { s => 'frames=s',          d => 'Timeframes for averages (default 1m,5m,15m)' },
   { s => 'host|h=s',          d => 'Connect to host' },
   { s => 'monitor',           d => 'Monitor slave delay continuously' },
   { s => 'password|p=s',      d => 'Password to use when connecting' },
   { s => 'port|P=i',          d => 'Port number to use for connection' },
   { s => 'socket|S=s',        d => 'Socket file to use for connection' },
   { s => 'table|t=s',         d => 'Table to use for heartbeat (default heartbeat)' },
   { s => 'update',            d => "Update a master's heartbeat" },
   { s => 'user|u=s',          d => 'User for login if not current user' },
   'Specify one and only one of --update, --monitor, or --check',
);

my $opt_parser = OptionParser->new(@opt_spec);
$opt_parser->{prompt} = '<options> {--update|--monitor|--check}';
$opt_parser->{descr}  = q{measures replication lag on a MySQL or PostgreSQL }
                      . q{server.  You can use it to update a master or }
                      . q{monitor a slave.  If possible, MySQL connection }
                      . q{options are read from your .my.cnf file.};
my %opts = $opt_parser->parse();

if ( !$opts{help} ) {
   my @frames = $opts{frames} =~ m/(\d+[smhd])/g;
   if ( @frames ) {
      $opts{frames} = [];
      foreach my $frame ( @frames ) {
         my ($num, $suf ) = $frame =~ m/(\d+)([smhd])$/;
         if ( !$num ) {
            $opt_parser->error("Invalid --frames argument");
         }
         else {
            push @{$opts{frames}}, 
                 $suf eq 's' ? $num            # Seconds
               : $suf eq 'm' ? $num * 60       # Minutes
               : $suf eq 'h' ? $num * 3600     # Hours
               :               $num * 86400;   # Days
         }
      }
   }
   else {
      $opt_parser->error("Invalid --frames argument");
   }
}

$opt_parser->usage_or_errors(%opts);

# ############################################################################
# Work.
# ############################################################################

# Get the password before daemonizing.
if ( !$opts{p} && $opts{askpass} ) {
   $opts{p} = OptionParser::prompt_noecho("Enter password: ");
}

my $update_sql = "UPDATE $opts{t} SET ts = NOW() WHERE id = 1";
my $select_sql = "SELECT "
               . ( $opts{dbidriver} eq 'Pg'
                  ? "ROUND(DATE_PART('epoch', NOW() - ts)) "
                  : "UNIX_TIMESTAMP() - UNIX_TIMESTAMP(ts) " )
               . "AS delay FROM $opts{t} WHERE id = 1";

my $dbopt = { AutoCommit => 1, RaiseError => 1, PrintError => 0 };
my $dsn   = new DSNParser;
$dsn->prop('dbidriver', $opts{dbidriver});
my $dbh   = DBI->connect($dsn->get_cxn_params(\%opts), $dbopt);
my $sth   = $dbh->prepare($opts{update} ? $update_sql : $select_sql);

$dbh->{InactiveDestroy}  = 1; # Don't disconnect on fork

# Do a little check just to make sure the table is there, so there's one last
# chance to catch errors before daemonizing.
$sth->execute();
$sth->finish();

# Daemonize only after (potentially) asking for passwords for --askpass.
if ( $opts{daemonize} ) {
   require POSIX;
   chdir '/'                 or die "Can't chdir to /: $OS_ERROR";
   open STDIN, '/dev/null'   or die "Can't read /dev/null: $OS_ERROR";
   open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $OS_ERROR";
   defined( my $pid = fork ) or die "Can't fork: $OS_ERROR";
   exit if $pid;
   POSIX::setsid()           or die "Can't start a new session: $OS_ERROR";
   open STDERR, '>&STDOUT'   or die "Can't dup STDOUT: $OS_ERROR";
}

# Setup for moving averages.
my @samples;
my $limit  = max(@{$opts{frames}});
my $format = "%4ds [ " . join(", ", map { "%5.2fs" } @{$opts{frames}}) . " ]\n";

# This handler will do nothing but wake us up from sleep();
$SIG{ALRM} = sub {};

# Set up an alarm.  --update alarms happen on the second boundary, and
# --monitor alarms happen halfway between seconds.
ualarm(( ($opts{update} ? 1_000_000 : 1_500_000) - (gettimeofday)[1] ), 1_000_000);

while ( 1 ) {

      eval {
      # Normally it is not safe to use sleep and alarm together, but since we're
      # sleeping an infinite time and waiting for the alarm to wake us up,
      # there's no harm in it.  In other words, infinite sleep isn't implemented
      # with alarm.
      sleep;

      # Connect or reconnect if necessary.
      if ( !$dbh->ping ) {
         $dbh = DBI->connect($dsn->get_cxn_params(\%opts), $dbopt);
         $sth = undef;
      }

      if ( $opts{monitor} || $opts{check} ) {

         # Get the data
         $sth ||= $dbh->prepare($select_sql);
         $sth->execute;
         my ( $delay ) = $sth->fetchrow_array;
         unshift @samples, $delay;
         pop @samples if @samples > $limit;

         # Calculate and print results
         if ( $opts{check} ) {
            print "$delay\n";
            exit(0);
         }
         else {
            my @vals = map {
               my $bound = min($_, scalar(@samples));
               sum(@samples[0 .. $bound-1]) / $_;
            } @{$opts{frames}};
            my $output = sprintf($format, $delay, @vals);
            if ( $opts{file} ) {
               open my $file, ">", $opts{file}
                  or die "Can't open $opts{file}: $OS_ERROR";
               print $file $output
                  or die "Can't print to  $opts{file}: $OS_ERROR";
               close $file or die "Can't close $opts{file}: $OS_ERROR";
            }
            else {
               print $output;
            }
         }
      }

      else { # --update mode
         $sth ||= $dbh->prepare($update_sql);
         $sth->execute;
      }
   };
   if ( $EVAL_ERROR ) {
      my ( $err ) = $EVAL_ERROR =~ m/^(?:DBI|DBD).*failed: (.*?)\s*at \S+ line .*/;
      if ( $err ) {
         print STDERR $err, "\n";
      }
      else {
         die $EVAL_ERROR;
      }
   }
}

# ############################################################################
# Documentation.
# ############################################################################

=pod

=head1 NAME

mk-heartbeat - Monitor MySQL replication delay.

=head1 SYNOPSIS

 mk-heartbeat -D test --update -h master-server
 mk-heartbeat -D test --monitor -h slave-server
 mk-heartbeat -D test --monitor -h slave-server --dbidriver Pg

=head1 DESCRIPTION

mk-heartbeat is a two-part MySQL and PostgreSQL replication delay monitoring
system that doesn't require the slave to be working (in other words, it doesn't
rely on C<SHOW SLAVE STATUS> on MySQL).  The first part updates a timestamp
every second on the master.  You must create a table on the master as follows:

 CREATE TABLE heartbeat (
   id int NOT NULL PRIMARY KEY,
   ts datetime NOT NULL
 );
 INSERT INTO heartbeat(id) VALUES(1);

Now you connect mk-heartbeat to the master and run it in L<"--update"> mode
to generate the heartbeat.  This completes the first part.

The second part is to monitor the slave's delay with L<"--monitor"> or
L<"--check">.  This works even on daisy-chained slaves to any depth.

mk-heartbeat has a one-second resolution.  It depends on the clocks on the
master and slave servers being closely synchronized via NTP.  L<"--update">
checks happen on the edge of the second, and L<"--monitor"> checks happen
halfway between seconds.  As long as the servers' clocks aren't skewed much
and the replication events are propagating in less than half a second,
mk-heartbeat will report zero seconds of delay.

mk-heartbeat will try to reconnect if the connection has an error, but will
not retry if it can't get a connection when it first starts.

The L<"--dbidriver"> option lets you use mk-heartbeat to monitor PostgreSQL
as well.  It is reported to work well with Slony-1 replication.

=head1 OPTIONS

=over

=item --askpass

Prompts the user for a password when connecting to MySQL.

=item --check

Reports slave delay and exits.

=item --daemonize

Fork to the background and detach from the shell.  This probably doesn't work
on Microsoft Windows.

=item --database

The database to use for the connection.

=item --defaults-file

Only read default options from the given file.  You must give an absolute
pathname.

=item --dbidriver

Specify a DBI driver for the connection.  At the moment C<mysql> and C<Pg> are
supported.  The default is C<mysql>.

=item --file

When L<"--monitor"> is given, prints output to the specified file instead of to
STDOUT.  The file is opened, truncated, and closed every second, so it will only
contain the most recent statistics.  Useful when L<"--daemonize"> is given.

=item --frames

Specifies the timeframes over which to calculate moving averages when
L<"--monitor"> is given.  The default value is one, five and fifteen minutes.
Specify as a comma-separated list of numbers with suffixes.  The suffix can be s
for seconds, m for minutes, h for hours, or d for days.  The size of the largest
frame determines the maximum memory usage, as up the specified number of
per-second samples are kept in memory to calculate the averages.  You can
specify as many timeframes as you like.

=item --help

Displays a help message.

=item --host

Connect to host.

=item --monitor

Specifies that mk-heartbeat should check the slave's delay every second and
report to STDOUT (or if L<"--file"> is given, to the file instead).  The output
is the current delay followed by moving averages over the timeframe given in
L<"--frames">.  For example,

 5s [  0.25s,  0.05s,  0.02s ]

=item --password

Password to use when connecting.

=item --port

Port number to use for connection.

=item --socket

Socket file to use for connection.

=item --table

The table to use for the heartbeat.  The default is 'heartbeat'.  Don't
specify database.table; use L<"--database"> to specify the database.

=item --update

Assumes the server is a master and updates the heartbeat every second.

=item --user

User for login if not current user.

=item --version

Output version information and exit.

=back

=head1 SYSTEM REQUIREMENTS

You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.

=head1 SEE ALSO

See also L<mk-slave-delay> and L<mk-slave-restart>.

=head1 BUGS

Please use the Sourceforge bug tracker, forums, and mailing lists to request
support or report bugs: L<http://sourceforge.net/projects/maatkit/>.

=head1 COPYRIGHT, LICENSE AND WARRANTY

This program is copyright (c) 2006 Proven Scaling LLC and SixApart Ltd, and
(c) 2007 Baron Schwartz.  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.

=head1 AUTHOR

Proven Scaling LLC, SixApart Ltd, and Baron Schwartz.

=head1 VERSION

This manual page documents Ver 1.0.2 Distrib 1316 $Revision: 1308 $.

=cut
