#!/usr/bin/perl

# This is mk-deadlock-logger, a program that extracts and saves a summary of
# the last deadlock recorded in MySQL.
#
# This program is copyright (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';

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

# ###########################################################################
# 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
# ###########################################################################

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

package Quoter;

sub new {
   my ( $class ) = @_;
   bless {}, $class;
}

sub quote {
   my ( $self, @vals ) = @_;
   foreach my $val ( @vals ) {
      $val =~ s/`/``/g;
   }
   return join('.', map { '`' . $_ . '`' } @vals);
}

1;

# ###########################################################################
# End Quoter 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
# ###########################################################################

use DBI;
use English qw(-no_match_vars);
use List::Util qw(max);
use Socket qw(inet_aton);
use sigtrap qw(handler finish untrapped normal-signals);

my $dp = new DSNParser(
   { key => 't', copy => 1, desc => 'Table in which to store deadlock information' },
);
$dp->prop('required', { h => 1 });
$dp->prop('autokey', 'h');

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

my @opt_spec = (
   { s => 'askpass',      d => 'Prompt for password for connections' },
   { s => 'collapse|c!',  d => 'Collapse whitespace in queries' },
   { s => 'columns|C=h',  d => 'Comma-separated list of columns to output' },
   { s => 'daemonize',    d => 'Fork to background and detach (POSIX only)' },
   { s => 'dest|d=d',     d => 'DSN for where to store deadlocks' },
   { s => 'interval|i=m', d => 'Sleep interval (suffix: s/m/h/d); default 0s' },
   { s => 'numip|n',      d => 'Express IP addresses as integers' },
   { s => 'print|p',      d => 'Print to STDOUT' },
   { s => 'source|s=d',   d => 'DSN to check for deadlocks; required' },
   { s => 'tab|t',        d => 'Output tab-separated' },
   { s => 'time|m=m',     d => 'Time to run before exiting (suffix: s/m/h/d)' },
   'Specify at least one of --print or --dest',
   'DSN values in --dest default to values from --source',
);

my $q          = new Quoter();
my $opt_parser = OptionParser->new(@opt_spec);
$opt_parser->{dsn} = $dp;
$opt_parser->{prompt} = '--source DSN <options>';
$opt_parser->{descr} = q{extracts and saves information about the most }
                     . q{recent deadlock in a MySQL server.  You need to }
                     . q{specify whether to print the output or save it in }
                     . q{a database.};
my %opts = $opt_parser->parse();

# Process options... TODO
$opts{c} = $opts{p} unless defined $opts{c};

# ############################################################################
# Parse arguments saying where to connect.  If the script doesn't have
# everything it needs, show help text.
# ############################################################################
my $source = $opts{s};
my $dest   = $opts{d};

$opt_parser->usage_or_errors(%opts);

# ############################################################################
# Configuration info.
# ############################################################################

# Some common patterns and variables
my $MAX_ULONG = 4294967296;                   # 2^32
my $d         = qr/(\d+)/;                    # Digit
my $t         = qr/(\d+ \d+)/;                # Transaction ID
my $i         = qr/((?:\d{1,3}\.){3}\d+)/;    # IP address
my $n         = qr/([^`\s]+)/;                # MySQL object name
my $w         = qr/(\w+)/;                    # Words
my $s         = qr/(\d{6} .\d:\d\d:\d\d)/;    # InnoDB timestamp

# A thread's proc_info can be at least 98 different things I've found in the
# source.  Fortunately, most of them begin with a gerunded verb.  These are
# the ones that don't.
my %is_proc_info = (
   'After create'                 => 1,
   'Execution of init_command'    => 1,
   'FULLTEXT initialization'      => 1,
   'Reopen tables'                => 1,
   'Repair done'                  => 1,
   'Repair with keycache'         => 1,
   'System lock'                  => 1,
   'Table lock'                   => 1,
   'Thread initialized'           => 1,
   'User lock'                    => 1,
   'copy to tmp table'            => 1,
   'discard_or_import_tablespace' => 1,
   'end'                          => 1,
   'got handler lock'             => 1,
   'got old table'                => 1,
   'init'                         => 1,
   'key cache'                    => 1,
   'locks'                        => 1,
   'malloc'                       => 1,
   'query end'                    => 1,
   'rename result table'          => 1,
   'rename'                       => 1,
   'setup'                        => 1,
   'statistics'                   => 1,
   'status'                       => 1,
   'table cache'                  => 1,
   'update'                       => 1,
);

# ############################################################################
# Start working.
# ############################################################################
my $dbh   = get_dbh($source, 1);
my $start = time();
my $end   = $start + ($opts{m} || 0); # When we should exit
my $now   = $start;
my $dbh2;
my $sth;
my $ins_sth;

# Since the user might not have specified a hostname for the connection, try to
# extract it from the $dbh
if ( !$source->{h} ) {
   ($source->{h}) = $dbh->{mysql_hostinfo} =~ m/(\w+) via/;
}

my @cols = qw( server ts thread txn_id txn_time user hostname ip db tbl idx
               lock_type lock_mode wait_hold victim query );
if ( $opts{C} ) {
   @cols = grep { $opts{C}->{$_} } @cols;
}

if ( $dest && $dest->{t} ) {
   my $db_tbl = 
      join('.',
      map  {  $q->quote($_) }
      grep { $_ }
      ( $dest->{D}, $dest->{t} ));

   $dbh2     = get_dbh($dest, 0);
   my $cols  = join(',', map { $q->quote($_) } @cols);
   my $parms = join(',', map { '?' } @cols);
   $ins_sth  = $dbh2->prepare("INSERT IGNORE INTO $db_tbl($cols) VALUES($parms)");
}

# 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";
}

my $oktorun = 1;
while (                       # Quit if:
   (!$opts{m} || $now < $end) # time is exceeded
   && $oktorun                # or instructed to quit
   )
{

   my $text = $dbh->selectrow_hashref("SHOW INNODB STATUS")->{Status};

   my %txns = %{parse_deadlocks($text)};

   if ( $ins_sth ) {
      foreach my $txn ( sort { $a->{thread} <=> $b->{thread} } values %txns ) {
         $ins_sth->execute(@{$txn}{@cols});
      }
      $dbh2->commit;
   }

   if ( $opts{p} ) {
      my $sep = $opts{t} ? "\t" : ' ';
      print join($sep, @cols), "\n";
      foreach my $txn ( sort { $a->{thread} <=> $b->{thread} } values %txns ) {
         # If $opts{c} is on, it's already been taken care of, but if it's unset,
         # by default strip whitespace.
         if ( !defined $opts{c} ) {
            $txn->{query} =~ s/\s+/ /g;
         }
         print join($sep, map { $txn->{$_} } @cols), "\n";
      }
   }

   # If there's an --interval argument, run forever or till specified.
   # Otherwise just run once.
   if ( $opts{i} ) {
      sleep($opts{i});
      $now = time();
   }
   else {
      $oktorun = 0;
   }
}

# ############################################################################
# Subroutines
# ############################################################################

sub parse_deadlocks {
   my ( $text ) = @_;
   # Pull out the deadlock section
   my $dl_text;
   my @matches = $text =~ m#\n(---+)\n([A-Z /]+)\n\1\n(.*?)(?=\n(---+)\n[A-Z /]+\n\4\n|$)#gs;
   while ( my ( $start, $name, $text, $end ) = splice(@matches, 0, 4) ) {
      next unless $name eq 'LATEST DETECTED DEADLOCK';
      $dl_text = $text;
   }

   return {} unless $dl_text;

   my @sections
      = $dl_text
      =~ m{
         ^\*{3}\s([^\n]*)  # *** (1) WAITING FOR THIS...
         (.*?)             # Followed by anything, non-greedy
         (?=(?:^\*{3})|\z) # Followed by another three-stars or EOF
      }gmsx;

   # Loop through each section.  There are no assumptions about how many
   # there are, who holds and wants what locks, and who gets rolled back.
   my %txns;
   while ( my ($header, $body) = splice(@sections, 0, 2) ) {
      my ( $txn_id, $what ) = $header =~ m/^\($d\) (.*):$/m;
      next unless $txn_id;
      $txns{$txn_id} ||= { id => $txn_id };
      my $hash = $txns{$txn_id};

      if ( $what eq 'TRANSACTION' ) {
         @{$hash}{qw(txn_time)} = $body =~ m/ACTIVE $d sec/;

         # Parsing the line that begins 'MySQL thread id' is complicated.  The only
         # thing always in the line is the thread and query id.  See function
         # innobase_mysql_print_thd in InnoDB source file sql/ha_innodb.cc.
         my ( $thread_line ) = $body =~ m/^(MySQL thread id .*)$/m;
         my ( $mysql_thread_id, $query_id, $hostname, $ip, $user, $query_status );

         if ( $thread_line ) {
            # These parts can always be gotten.
            ( $mysql_thread_id, $query_id ) = $thread_line =~ m/^MySQL thread id $d, query id $d/m;

            # If it's a master/slave thread, "Has (read|sent) all" may be the thread's
            # proc_info.  In these cases, there won't be any host/ip/user info
            ( $query_status ) = $thread_line =~ m/(Has (?:read|sent) all .*$)/m;
            if ( defined($query_status) ) {
               $user = 'system user';
            }

            # It may be the case that the query id is the last thing in the line.
            elsif ( $thread_line =~ m/query id \d+ / ) {
               # The IP address is the only non-word thing left, so it's the most
               # useful marker for where I have to start guessing.
               ( $hostname, $ip ) = $thread_line =~ m/query id \d+(?: ([A-Za-z]\S+))? $i/m;
               if ( defined $ip ) {
                  ( $user, $query_status ) = $thread_line =~ m/$ip $w(?: (.*))?$/;
               }
               else { # OK, there wasn't an IP address.
                  # There might not be ANYTHING except the query status.
                  ( $query_status ) = $thread_line =~ m/query id \d+ (.*)$/;
                  if ( $query_status !~ m/^\w+ing/ && !exists($is_proc_info{$query_status}) ) {
                     # The remaining tokens are, in order: hostname, user, query_status.
                     # It's basically impossible to know which is which.
                     ( $hostname, $user, $query_status ) = $thread_line
                        =~ m/query id \d+(?: ([A-Za-z]\S+))?(?: $w(?: (.*))?)?$/m;
                  }
                  else {
                     $user = 'system user';
                  }
               }
            }
         }

         my ( $query_text ) = $body =~ m/\nMySQL thread id .*\n((?s).*)/;
         $query_text =~ s/\s+$//;
         $query_text =~ s/\s+/ /g if $opts{c};

         @{$hash}{qw(thread hostname ip user query)}
            = ($mysql_thread_id, $hostname, $ip, $user, $query_text);
         foreach my $key ( keys %$hash ) {
            if ( !defined $hash->{$key} ) {
               $hash->{$key} = '';
            }
         }

      }
      else {
         # Prefer information about locks waited-for over locks-held.
         if ( $what eq 'WAITING FOR THIS LOCK TO BE GRANTED' || !$hash->{lock_type} ) {
            $hash->{wait_hold} = $what eq 'WAITING FOR THIS LOCK TO BE GRANTED' ? 'w' : 'h';
            @{$hash}{ qw(lock_type idx db tbl txn_id lock_mode) }
               = $body
               =~ m{^(RECORD|TABLE) LOCKS? (?:space id \d+ page no \d+ n bits \d+ index `?$n`? of )?table `$n(?:/|`\.`)$n` trx id $t lock.mode (\S+)}m;
            if ( $hash->{txn_id} ) {
               my ( $high, $low ) = $hash->{txn_id} =~ m/^(\d+) (\d+)$/;
               $hash->{txn_id} = $high ? ( $low + $high * $MAX_ULONG ) : $low;
            }
         }
      }

      # Ensure all values are defined
      map { $hash->{$_} = 0 unless defined $hash->{$_} }
         qw(thread txn_id txn_time);
      map { $hash->{$_} = '' unless defined $hash->{$_} }
         qw(user hostname db tbl idx lock_type lock_mode query);
   }

   # Extract some miscellaneous data from the deadlock.
   my ( $ts ) = $dl_text =~ m/^$s$/m;
   my ( $year, $mon, $day, $hour, $min, $sec ) = $ts =~ m/^(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)$/;
   $ts = sprintf('%02d-%02d-%02dT%02d:%02d:%02d', $year + 2000, $mon, $day, $hour, $min, $sec);
   my ( $victim ) = $dl_text =~ m/^\*\*\* WE ROLL BACK TRANSACTION \((\d+)\)$/m;
   $victim ||= 0;

   # Stick the misc data into the transactions.
   foreach my $txn ( values %txns ) {
      $txn->{victim} = $txn->{id} == $victim ? 1 : 0;
      $txn->{ts}     = $ts;
      $txn->{server} = $source->{h} || '';
      $txn->{ip}     = inet_aton($txn->{ip}) if $opts{n};
   }

   return \%txns;
}

# Catches signals so the program can exit gracefully.
sub finish {
   my ($signal) = @_;
   print STDERR "Exiting on SIG$signal.\n";
   $oktorun = 0;
}

sub get_dbh {
   my ( $info, $ac ) = @_;
   my $db_options = {
      AutoCommit => $ac,
      RaiseError => 1,
      PrintError => 0,
   };

   if ( $opts{askpass} ) {
      $info->{p} = OptionParser::prompt_noecho("Enter password: ");
   }

   my $dbh = DBI->connect($dp->get_cxn_params($info), $db_options);
   $dbh->{InactiveDestroy} = 1; # Because of forking.
   return $dbh;
}

# ############################################################################
# Documentation
# ############################################################################
=pod

=head1 NAME

mk-deadlock-logger - Extract and log MySQL deadlock information.

=head1 SYNOPSIS

The following examples will print deadlocks, store deadlocks in a database
table, and daemonize and check once every 30 seconds for 4 hours,
respectively:

 mk-deadlock-logger --print
 mk-deadlock-logger --source u=user,p=pass,h=server --dest D=test,t=deadlocks
 mk-deadlock-logger --dest D=test,t=deadlocks --daemonize -m 4h -i 30s

=head1 DESCRIPTION

mk-deadlock-logger extracts deadlock data from a MySQL server (currently only
InnoDB deadlock information is available).  You can print it to standard output
or save it in a database table.  By default it does neither.

=head1 OPTIONS

Some options are negatable with --no.

=over

=item --askpass

Prompt for password for connections.

=item --collapse

Makes mk-deadlock-logger collapse all whitespace in queries to a single
space.  This might make it easier to inspect on the command line or in a query.
By default, whitespace is collapsed when printing with L<"--print">, but not
modified when storing to L<"--dest">.  (That is, the default is different for
each action).

=item --columns

Makes mk-deadlock-logger only output and/or save certain columns.  See
L<"OUTPUT"> for more details.

=item --daemonize

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

=item --dest

Specifies a server, database and table in which to store deadlock information,
in the same format as L<"--source">.  Missing values are filled in with the same
values as L<"--source">, so you can usually omit most parts of this argument if
you're storing deadlocks on the same server on which they happen.

By default, whitespace in the query column is left intact; use L<"--collapse">
if you want whitespace collapsed.

The following table is suggested if you want to store all the information
mk-deadlock-logger can extract about deadlocks:

 CREATE TABLE deadlocks (
   server char(20) NOT NULL,
   ts datetime NOT NULL,
   thread int unsigned NOT NULL,
   txn_id bigint unsigned NOT NULL,
   txn_time smallint unsigned NOT NULL,
   user char(16) NOT NULL,
   hostname char(20) NOT NULL,
   ip char(15) NOT NULL, -- alternatively, ip int unsigned NOT NULL
   db char(64) NOT NULL,
   tbl char(64) NOT NULL,
   idx char(64) NOT NULL,
   lock_type char(16) NOT NULL,
   lock_mode char(1) NOT NULL,
   wait_hold char(1) NOT NULL,
   victim tinyint unsigned NOT NULL,
   query text NOT NULL,
   PRIMARY KEY  (server,ts,thread)
 ) ENGINE=InnoDB

If you use L<"--columns">, you can omit whichever columns you don't want to
store.

=item --help

Displays a help message.

=item --interval

How frequently mk-deadlock-logger should check for deadlocks.  The argument
must have a suffix of s, m, h, or d, indicating seconds, minutes, hours, or
days.

=item --numip

Makes mk-deadlock-logger express IP addresses as integers.

=item --print

Makes mk-deadlock-logger print results on standard output.  See L<"OUTPUT">
for more.  By default, enables L<"--collapse"> unless you explicitly disable it.

=item --source

Specifies a connection to a server to check for deadlocks.  This argument is
specially formatted as a key=value,key=value string.  Keys are a single letter:

   KEY MEANING
   === =======
   h   Connect to host
   P   Port number to use for connection
   S   Socket file to use for connection
   u   User for login if not current user
   p   Password to use when connecting
   F   Only read default options from the given file
   D   Database to connect to
   t   Table in which to store deadlock information

The 't' part only applies to L<"--dest">.  All parts are optional;
mk-deadlock-logger will try to read MySQL's option files to determine how
to connect.  If you specify a value without an '=' character,
mk-deadlock-logger will interpret this as a hostname.

=item --tab

Makes mk-deadlock-logger output tab-separated columns instead of
whitespace-aligning them.  See L<"OUTPUT"> for more.

=item --time

Causes mk-deadlock-logger to stop after the specified time has elapsed.
The argument must have a suffix of s, m, h, or d, indicating seconds, minutes,
hours, or days.

=item --version

Output version information and exit.

=back

=head1 INNODB CAVEATS AND DETAILS

InnoDB's output is hard to parse and sometimes there's no way to do it right.

Sometimes not all information (for example, username or IP address) is included
in the deadlock information.  In this case there's nothing for the script to put
in those columns.  It may also be the case that the deadlock output is so long
(because there were a lot of locks) that the whole thing is truncated.

Though there are usually two transactions involved in a deadlock, there are more
locks than that; at a minimum, one more lock than transactions is necessary to
create a cycle in the waits-for graph.  mk-deadlock-logger prints the
transactions (always two in the InnoDB output, even when there are more
transactions in the waits-for graph than that) and fills in locks.  It prefers
waited-for over held when choosing lock information to output, but you can
figure out the rest with a moment's thought.  If you see one wait-for and one
held lock, you're looking at the same lock, so of course you'd prefer to see
both wait-for locks and get more information.  If the two waited-for locks are
not on the same table, more than two transactions were involved in the deadlock.

=head1 OUTPUT

You can choose which columns are output and/or saved to L<"--dest"> with the
L<"--columns"> argument.  The default columns are as follows:

=over

=item server

The (source) server on which the deadlock occurred.  This might be useful if
you're tracking deadlocks on many servers.

=item ts

The date and time of the last detected deadlock.

=item thread

The MySQL thread number, which is the same as the connection ID in SHOW FULL
PROCESSLIST.

=item txn_id

The InnoDB transaction ID, which InnoDB expresses as two unsigned integers.  I
have multiplied them out to be one number.

=item txn_time

How long the transaction was active when the deadlock happened.

=item user

The connection's database username.

=item hostname

The connection's host.

=item ip

The connection's IP address.  If you specify L<"--numip">, this is converted to
an unsigned integer.

=item db

The database in which the deadlock occurred.

=item tbl

The table on which the deadlock occurred.

=item idx

The index on which the deadlock occurred.

=item lock_type

The lock type the transaction held on the lock that caused the deadlock.

=item lock_mode

The lock mode of the lock that caused the deadlock.

=item wait_hold

Whether the transaction was waiting for the lock or holding the lock.  Usually
you will see the two waited-for locks.

=item victim

Whether the transaction was selected as the deadlock victim and rolled back.

=item query

The query that caused the deadlock.

=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 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) 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

Baron Schwartz.

=head1 VERSION

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

=cut
