#!/usr/bin/env perl

# This program is copyright 2007-2009 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA  02111-1307  USA.

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

our $VERSION = '0.9.6';
our $DISTRIB = '3722';
our $SVN_REV = sprintf("%d", (q$Revision: 3710 $ =~ m/(\d+)/g, 0));

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

package DSNParser;

use DBI;
use Data::Dumper;
$Data::Dumper::Indent    = 0;
$Data::Dumper::Quotekeys = 0;
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, @opts ) = @_;
   my $self = {
      opts => {
         A => {
            desc => 'Default character set',
            dsn  => 'charset',
            copy => 1,
         },
         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 ) {
      MKDEBUG && _d('Adding extra property', $opt->{key});
      $self->{opts}->{$opt->{key}} = { desc => $opt->{desc}, copy => $opt->{copy} };
   }
   return bless $self, $class;
}

sub prop {
   my ( $self, $prop, $value ) = @_;
   if ( @_ > 2 ) {
      MKDEBUG && _d('Setting', $prop, 'property');
      $self->{$prop} = $value;
   }
   return $self->{$prop};
}

sub parse {
   my ( $self, $dsn, $prev, $defaults ) = @_;
   if ( !$dsn ) {
      MKDEBUG && _d('No DSN to parse');
      return;
   }
   MKDEBUG && _d('Parsing', $dsn);
   $prev     ||= {};
   $defaults ||= {};
   my %given_props;
   my %final_props;
   my %opts = %{$self->{opts}};
   my $prop_autokey = $self->prop('autokey');

   foreach my $dsn_part ( split(/,/, $dsn) ) {
      if ( my ($prop_key, $prop_val) = $dsn_part =~  m/^(.)=(.*)$/ ) {
         $given_props{$prop_key} = $prop_val;
      }
      elsif ( $prop_autokey ) {
         MKDEBUG && _d('Interpreting', $dsn_part, 'as',
            $prop_autokey, '=', $dsn_part);
         $given_props{$prop_autokey} = $dsn_part;
      }
      else {
         MKDEBUG && _d('Bad DSN part:', $dsn_part);
      }
   }

   foreach my $key ( keys %opts ) {
      MKDEBUG && _d('Finding value for', $key);
      $final_props{$key} = $given_props{$key};
      if (   !defined $final_props{$key}
           && defined $prev->{$key} && $opts{$key}->{copy} )
      {
         $final_props{$key} = $prev->{$key};
         MKDEBUG && _d('Copying value for', $key, 'from previous DSN');
      }
      if ( !defined $final_props{$key} ) {
         $final_props{$key} = $defaults->{$key};
         MKDEBUG && _d('Copying value for', $key, 'from defaults');
      }
   }

   foreach my $key ( keys %given_props ) {
      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 $final_props{$key};
      }
   }

   return \%final_props;
}

sub parse_options {
   my ( $self, $o ) = @_;
   die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
   my $dsn_string
      = join(',',
          map  { "$_=".$o->get($_); }
          grep { $o->has($_) && $o->get($_) }
          keys %{$self->{opts}}
        );
   MKDEBUG && _d('DSN string made from options:', $dsn_string);
   return $self->parse($dsn_string);
}

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

sub usage {
   my ( $self ) = @_;
   my $usage
      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n\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 A))
         . ';mysql_read_default_group=client';
   }
   MKDEBUG && _d($dsn);
   return ($dsn, $info->{u}, $info->{p});
}

sub fill_in_dsn {
   my ( $self, $dbh, $dsn ) = @_;
   my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
   my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
   $user =~ s/@.*//;
   $dsn->{h} ||= $vars->{hostname}->{Value};
   $dsn->{S} ||= $vars->{'socket'}->{Value};
   $dsn->{P} ||= $vars->{port}->{Value};
   $dsn->{u} ||= $user;
   $dsn->{D} ||= $db;
}

sub get_dbh {
   my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
   $opts ||= {};
   my $defaults = {
      AutoCommit        => 0,
      RaiseError        => 1,
      PrintError        => 0,
      mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/ ? 1 : 0),
   };
   @{$defaults}{ keys %$opts } = values %$opts;

   my $dbh;
   my $tries = 2;
   while ( !$dbh && $tries-- ) {
      MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, ' {',
         join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ), '}');

      eval {
         $dbh = DBI->connect($cxn_string, $user, $pass, $defaults);

         if ( $cxn_string =~ m/mysql/i ) {
            my $sql;

            $sql = q{SET @@SQL_QUOTE_SHOW_CREATE = 1}
                 . q{/*!40101, @@SQL_MODE='NO_AUTO_VALUE_ON_ZERO'*/};
            MKDEBUG && _d($dbh, ':', $sql);
            $dbh->do($sql);

            if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
               $sql = "/*!40101 SET NAMES $charset*/";
               MKDEBUG && _d($dbh, ':', $sql);
               $dbh->do($sql);
               MKDEBUG && _d('Enabling charset for STDOUT');
               if ( $charset eq 'utf8' ) {
                  binmode(STDOUT, ':utf8')
                     or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
               }
               else {
                  binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
               }
            }

            if ( $self->prop('setvars') ) {
               $sql = "SET " . $self->prop('setvars');
               MKDEBUG && _d($dbh, ':', $sql);
               $dbh->do($sql);
            }
         }
      };
      if ( !$dbh && $EVAL_ERROR ) {
         MKDEBUG && _d($EVAL_ERROR);
         if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
            MKDEBUG && _d('Going to try again without utf8 support');
            delete $defaults->{mysql_enable_utf8};
         }
         if ( !$tries ) {
            die $EVAL_ERROR;
         }
      }
   }

   MKDEBUG && _d('DBH info: ',
      $dbh,
      Dumper($dbh->selectrow_hashref(
         'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
      'Connection info:',      $dbh->{mysql_hostinfo},
      'Character set info:',   Dumper($dbh->selectall_arrayref(
                     'SHOW VARIABLES LIKE "character_set%"', { Slice => {}})),
      '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
      '$DBI::VERSION:',        $DBI::VERSION,
   );

   return $dbh;
}

sub get_hostname {
   my ( $self, $dbh ) = @_;
   if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
      return $host;
   }
   my ( $hostname, $one ) = $dbh->selectrow_array(
      'SELECT /*!50038 @@hostname, */ 1');
   return $hostname;
}

sub disconnect {
   my ( $self, $dbh ) = @_;
   MKDEBUG && $self->print_active_handles($dbh);
   $dbh->disconnect;
}

sub print_active_handles {
   my ( $self, $thing, $level ) = @_;
   $level ||= 0;
   printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
      $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
      or die "Cannot print: $OS_ERROR";
   foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
      $self->print_active_handles( $handle, $level + 1 );
   }
}

sub copy {
   my ( $self, $dsn_1, $dsn_2, %args ) = @_;
   die 'I need a dsn_1 argument' unless $dsn_1;
   die 'I need a dsn_2 argument' unless $dsn_2;
   my %new_dsn = map {
      my $key = $_;
      my $val;
      if ( $args{overwrite} ) {
         $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
      }
      else {
         $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
      }
      $key => $val;
   } keys %{$self->{opts}};
   return \%new_dsn;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

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

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

package Quoter;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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

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

sub quote_val {
   my ( $self, @vals ) = @_;
   return join(', ',
      map {
         if ( defined $_ ) {
            $_ =~ s/(['\\])/\\$1/g;
            $_ eq '' || $_ =~ m/^0|\D/ ? "'$_'" : $_;
         }
         else {
            'NULL';
         }
      } @vals
   );
}

sub split_unquote {
   my ( $self, $db_tbl, $default_db ) = @_;
   $db_tbl =~ s/`//g;
   my ( $db, $tbl ) = split(/[.]/, $db_tbl);
   if ( !$tbl ) {
      $tbl = $db;
      $db  = $default_db;
   }
   return ($db, $tbl);
}

1;

# ###########################################################################
# End Quoter package
# ###########################################################################

# ###########################################################################
# OptionParser package 3695
# ###########################################################################
package OptionParser;

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

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

use constant MKDEBUG => $ENV{MKDEBUG};

my $POD_link_re = '[LC]<"?([^">]+)"?>';

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(description) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
   $program_name ||= $PROGRAM_NAME;

   my $self = {
      description    => $args{description},
      prompt         => $args{prompt} || '<options>',
      strict         => (exists $args{strict} ? $args{strict} : 1),
      dp             => $args{dp}     || undef,
      program_name   => $program_name,
      opts           => {},
      got_opts       => 0,
      short_opts     => {},
      defaults       => {},
      groups         => {},
      allowed_groups => {},
      errors         => [],
      rules          => [],  # desc of rules for --help
      mutex          => [],  # rule: opts are mutually exclusive
      atleast1       => [],  # rule: at least one opt is required
      disables       => {},  # rule: opt disables other opts 
      defaults_to    => {},  # rule: opt defaults to value of other opt
      default_files  => [
         "/etc/maatkit/maatkit.conf",
         "/etc/maatkit/$program_name.conf",
         "$ENV{HOME}/.maatkit.conf",
         "$ENV{HOME}/.$program_name.conf",
      ],
   };
   return bless $self, $class;
}

sub get_specs {
   my ( $self, $file ) = @_;
   my @specs = $self->_pod_to_specs($file);
   $self->_parse_specs(@specs);
   return;
}

sub get_defaults_files {
   my ( $self ) = @_;
   return @{$self->{default_files}};
}

sub _pod_to_specs {
   my ( $self, $file ) = @_;
   $file ||= __FILE__;
   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";

   my %types = (
      string => 's', # standard Getopt type
      'int'  => 'i', # standard Getopt type
      float  => 'f', # standard Getopt type
      Hash   => 'H', # hash, formed from a comma-separated list
      hash   => 'h', # hash as above, but only if a value is given
      Array  => 'A', # array, similar to Hash
      array  => 'a', # array, similar to hash
      DSN    => 'd', # DSN, as provided by a DSNParser which is in $self->{dp}
      size   => 'z', # size with kMG suffix (powers of 2^10)
      'time' => 'm', # time, with an optional suffix of s/h/m/d
   );
   my @specs = ();
   my @rules = ();
   my $para;

   local $INPUT_RECORD_SEPARATOR = '';
   while ( $para = <$fh> ) {
      next unless $para =~ m/^=head1 OPTIONS/;
      last;
   }

   while ( $para = <$fh> ) {
      last if $para =~ m/^=over/;
      chomp $para;
      $para =~ s/\s+/ /g;
      $para =~ s/$POD_link_re/$1/go;
      MKDEBUG && _d('Option rule:', $para);
      push @rules, $para;
   }

   die 'POD has no OPTIONS section' unless $para;

   do {
      if ( my ($option) = $para =~ m/^=item --(.*)/ ) {
         chomp $para;
         MKDEBUG && _d($para);
         my %attribs;

         $para = <$fh>; # read next paragraph, possibly attributes

         if ( $para =~ m/: / ) { # attributes
            $para =~ s/\s+\Z//g;
            %attribs = map { split(/: /, $_) } split(/; /, $para);
            if ( $attribs{'short form'} ) {
               $attribs{'short form'} =~ s/-//;
            }
            $para = <$fh>; # read next paragraph, probably short help desc
         }
         else {
            MKDEBUG && _d('Option has no attributes');
         }

         $para =~ s/\s+\Z//g;
         $para =~ s/\s+/ /g;
         $para =~ s/$POD_link_re/$1/go;

         $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
         MKDEBUG && _d('Short help:', $para);

         die "No description after option spec $option" if $para =~ m/^=item/;

         if ( my ($base_option) =  $option =~ m/^\[no\](.*)/ ) {
            $option = $base_option;
            $attribs{'negatable'} = 1;
         }

         push @specs, {
            spec  => $option
               . ($attribs{'short form'} ? '|' . $attribs{'short form'} : '' )
               . ($attribs{'negatable'}  ? '!'                          : '' )
               . ($attribs{'cumulative'} ? '+'                          : '' )
               . ($attribs{'type'}       ? '=' . $types{$attribs{type}} : '' ),
            desc  => $para
               . ($attribs{default} ? " (default $attribs{default})" : ''),
            group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
         };
      }
      while ( $para = <$fh> ) {
         last unless $para;


         if ( $para =~ m/^=head1/ ) {
            $para = undef; # Can't 'last' out of a do {} block.
            last;
         }
         last if $para =~ m/^=item --/;
      }
   } while ( $para );

   die 'No valid specs in POD OPTIONS' unless @specs;

   close $fh;
   return @specs, @rules;
}

sub _parse_specs {
   my ( $self, @specs ) = @_;
   my %disables; # special rule that requires deferred checking

   foreach my $opt ( @specs ) {
      if ( ref $opt ) { # It's an option spec, not a rule.
         MKDEBUG && _d('Parsing opt spec:',
            map { ($_, '=>', $opt->{$_}) } keys %$opt);

         my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
         if ( !$long ) {
            die "Cannot parse long option from spec $opt->{spec}";
         }
         $opt->{long} = $long;

         die "Duplicate long option --$long" if exists $self->{opts}->{$long};
         $self->{opts}->{$long} = $opt;

         if ( length $long == 1 ) {
            MKDEBUG && _d('Long opt', $long, 'looks like short opt');
            $self->{short_opts}->{$long} = $long;
         }

         if ( $short ) {
            die "Duplicate short option -$short"
               if exists $self->{short_opts}->{$short};
            $self->{short_opts}->{$short} = $long;
            $opt->{short} = $short;
         }
         else {
            $opt->{short} = undef;
         }

         $opt->{is_negatable}  = $opt->{spec} =~ m/!/        ? 1 : 0;
         $opt->{is_cumulative} = $opt->{spec} =~ m/\+/       ? 1 : 0;
         $opt->{is_required}   = $opt->{desc} =~ m/required/ ? 1 : 0;

         $opt->{group} ||= 'default';
         $self->{groups}->{ $opt->{group} }->{$long} = 1;

         $opt->{value} = undef;
         $opt->{got}   = 0;

         my ( $type ) = $opt->{spec} =~ m/=(.)/;
         $opt->{type} = $type;
         MKDEBUG && _d($long, 'type:', $type);

         if ( $type && $type eq 'd' && !$self->{dp} ) {
            die "$opt->{long} is type DSN (d) but no dp argument "
               . "was given when this OptionParser object was created";
         }

         $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );

         if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
            if ( $opt->{is_negatable} ) {
               $def = $def eq 'yes' ? 1
                    : $def eq 'no'  ? 0
                    : $def;
            }
            $self->{defaults}->{$long} = defined $def ? $def : 1;
            MKDEBUG && _d($long, 'default:', $def);
         }

         if ( $long eq 'config' ) {
            $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
         }

         if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
            $disables{$long} = $dis;
            MKDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
         }

         $self->{opts}->{$long} = $opt;
      }
      else { # It's an option rule, not a spec.
         MKDEBUG && _d('Parsing rule:', $opt); 
         push @{$self->{rules}}, $opt;
         my @participants = $self->_get_participants($opt);
         my $rule_ok = 0;

         if ( $opt =~ m/mutually exclusive|one and only one/ ) {
            $rule_ok = 1;
            push @{$self->{mutex}}, \@participants;
            MKDEBUG && _d(@participants, 'are mutually exclusive');
         }
         if ( $opt =~ m/at least one|one and only one/ ) {
            $rule_ok = 1;
            push @{$self->{atleast1}}, \@participants;
            MKDEBUG && _d(@participants, 'require at least one');
         }
         if ( $opt =~ m/default to/ ) {
            $rule_ok = 1;
            $self->{defaults_to}->{$participants[0]} = $participants[1];
            MKDEBUG && _d($participants[0], 'defaults to', $participants[1]);
         }
         if ( $opt =~ m/restricted to option groups/ ) {
            $rule_ok = 1;
            my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
            my @groups = split(',', $groups);
            %{$self->{allowed_groups}->{$participants[0]}} = map {
               s/\s+//;
               $_ => 1;
            } @groups;
         }

         die "Unrecognized option rule: $opt" unless $rule_ok;
      }
   }

   foreach my $long ( keys %disables ) {
      my @participants = $self->_get_participants($disables{$long});
      $self->{disables}->{$long} = \@participants;
      MKDEBUG && _d('Option', $long, 'disables', @participants);
   }

   return; 
}

sub _get_participants {
   my ( $self, $str ) = @_;
   my @participants;
   foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
      die "Option --$long does not exist while processing rule $str"
         unless exists $self->{opts}->{$long};
      push @participants, $long;
   }
   MKDEBUG && _d('Participants for', $str, ':', @participants);
   return @participants;
}

sub opts {
   my ( $self ) = @_;
   my %opts = %{$self->{opts}};
   return %opts;
}

sub opt_values {
   my ( $self ) = @_;
   my %opts = map {
      my $opt = $self->{opts}->{$_}->{short} ? $self->{opts}->{$_}->{short}
              : $_;
      $opt => $self->{opts}->{$_}->{value}
   } keys %{$self->{opts}};
   return %opts;
}

sub short_opts {
   my ( $self ) = @_;
   my %short_opts = %{$self->{short_opts}};
   return %short_opts;
}

sub set_defaults {
   my ( $self, %defaults ) = @_;
   $self->{defaults} = {};
   foreach my $long ( keys %defaults ) {
      die "Cannot set default for nonexistent option $long"
         unless exists $self->{opts}->{$long};
      $self->{defaults}->{$long} = $defaults{$long};
      MKDEBUG && _d('Default val for', $long, ':', $defaults{$long});
   }
   return;
}

sub get_defaults {
   my ( $self ) = @_;
   return $self->{defaults};
}

sub get_groups {
   my ( $self ) = @_;
   return $self->{groups};
}

sub _set_option {
   my ( $self, $opt, $val ) = @_;
   my $long = exists $self->{opts}->{$opt}       ? $opt
            : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
            : die "Getopt::Long gave a nonexistent option: $opt";

   $opt = $self->{opts}->{$long};
   if ( $opt->{is_cumulative} ) {
      $opt->{value}++;
   }
   else {
      $opt->{value} = $val;
   }
   $opt->{got} = 1;
   MKDEBUG && _d('Got option', $long, '=', $val);
}

sub get_opts {
   my ( $self ) = @_; 

   foreach my $long ( keys %{$self->{opts}} ) {
      $self->{opts}->{$long}->{got} = 0;
      $self->{opts}->{$long}->{value}
         = exists $self->{defaults}->{$long}       ? $self->{defaults}->{$long}
         : $self->{opts}->{$long}->{is_cumulative} ? 0
         : undef;
   }
   $self->{got_opts} = 0;

   $self->{errors} = [];

   if ( @ARGV && $ARGV[0] eq "--config" ) {
      shift @ARGV;
      $self->_set_option('config', shift @ARGV);
   }
   if ( $self->has('config') ) {
      my @extra_args;
      foreach my $filename ( split(',', $self->get('config')) ) {
         eval {
            push @ARGV, $self->_read_config_file($filename);
         };
         if ( $EVAL_ERROR ) {
            if ( $self->got('config') ) {
               die $EVAL_ERROR;
            }
            elsif ( MKDEBUG ) {
               _d($EVAL_ERROR);
            }
         }
      }
      unshift @ARGV, @extra_args;
   }

   Getopt::Long::Configure('no_ignore_case', 'bundling');
   GetOptions(
      map    { $_->{spec} => sub { $self->_set_option(@_); } }
      grep   { $_->{long} ne 'config' } # --config is handled specially above.
      values %{$self->{opts}}
   ) or $self->save_error('Error parsing options');

   if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
      printf("%s  Ver %s Distrib %s Changeset %s\n",
         $self->{program_name}, $main::VERSION, $main::DISTRIB, $main::SVN_REV)
            or die "Cannot print: $OS_ERROR";
      exit 0;
   }

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

   foreach my $mutex ( @{$self->{mutex}} ) {
      my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
      if ( @set > 1 ) {
         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
                      @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
                 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
                 . ' are mutually exclusive.';
         $self->save_error($err);
      }
   }

   foreach my $required ( @{$self->{atleast1}} ) {
      my @set = grep { $self->{opts}->{$_}->{got} } @$required;
      if ( @set == 0 ) {
         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
                      @{$required}[ 0 .. scalar(@$required) - 2] )
                 .' or --'.$self->{opts}->{$required->[-1]}->{long};
         $self->save_error("Specify at least one of $err");
      }
   }

   foreach my $long ( keys %{$self->{opts}} ) {
      my $opt = $self->{opts}->{$long};
      if ( $opt->{got} ) {
         if ( exists $self->{disables}->{$long} ) {
            my @disable_opts = @{$self->{disables}->{$long}};
            map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
            MKDEBUG && _d('Unset options', @disable_opts,
               'because', $long,'disables them');
         }

         if ( exists $self->{allowed_groups}->{$long} ) {

            my @restricted_groups = grep {
               !exists $self->{allowed_groups}->{$long}->{$_}
            } keys %{$self->{groups}};

            my @restricted_opts;
            foreach my $restricted_group ( @restricted_groups ) {
               RESTRICTED_OPT:
               foreach my $restricted_opt (
                  keys %{$self->{groups}->{$restricted_group}} )
               {
                  next RESTRICTED_OPT if $restricted_opt eq $long;
                  push @restricted_opts, $restricted_opt
                     if $self->{opts}->{$restricted_opt}->{got};
               }
            }

            if ( @restricted_opts ) {
               my $err;
               if ( @restricted_opts == 1 ) {
                  $err = "--$restricted_opts[0]";
               }
               else {
                  $err = join(', ',
                            map { "--$self->{opts}->{$_}->{long}" }
                            grep { $_ } 
                            @restricted_opts[0..scalar(@restricted_opts) - 2]
                         )
                       . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
               }
               $self->save_error("--$long is not allowed with $err");
            }
         }

      }
      elsif ( $opt->{is_required} ) { 
         $self->save_error("Required option --$long must be specified");
      }

      $self->_validate_type($opt);
   }

   $self->{got_opts} = 1;
   return;
}

sub _validate_type {
   my ( $self, $opt ) = @_;
   return unless $opt && $opt->{type};
   my $val = $opt->{value};

   if ( $val && $opt->{type} eq 'm' ) {
      MKDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
      my ( $num, $suffix ) = $val =~ m/(\d+)([a-z])?$/;
      if ( !$suffix ) {
         my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
         $suffix = $s || 's';
         MKDEBUG && _d('No suffix given; using', $suffix, 'for',
            $opt->{long}, '(value:', $val, ')');
      }
      if ( $suffix =~ m/[smhd]/ ) {
         $val = $suffix eq 's' ? $num            # Seconds
              : $suffix eq 'm' ? $num * 60       # Minutes
              : $suffix eq 'h' ? $num * 3600     # Hours
              :                  $num * 86400;   # Days
         $opt->{value} = $val;
         MKDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
      }
      else {
         $self->save_error("Invalid time suffix for --$opt->{long}");
      }
   }
   elsif ( $val && $opt->{type} eq 'd' ) {
      MKDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
      my $from_key = $self->{defaults_to}->{ $opt->{long} };
      my $default = {};
      if ( $from_key ) {
         MKDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
         $default = $self->{dp}->parse(
            $self->{dp}->as_string($self->{opts}->{$from_key}->{value}) );
      }
      $opt->{value} = $self->{dp}->parse($val, $default);
   }
   elsif ( $val && $opt->{type} eq 'z' ) {
      MKDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
      my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
      my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
      if ( defined $num ) {
         if ( $factor ) {
            $num *= $factor_for{$factor};
            MKDEBUG && _d('Setting option', $opt->{y},
               'to num', $num, '* factor', $factor);
         }
         $opt->{value} = ($pre || '') . $num;
      }
      else {
         $self->save_error("Invalid size for --$opt->{long}");
      }
   }
   elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
      $opt->{value} = { map { $_ => 1 } split(',', ($val || '')) };
   }
   elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
      $opt->{value} = [ split(/(?<!\\),/, ($val || '')) ];
   }
   else {
      MKDEBUG && _d('Nothing to validate for option',
         $opt->{long}, 'type', $opt->{type}, 'value', $val);
   }

   return;
}

sub get {
   my ( $self, $opt ) = @_;
   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
   die "Option $opt does not exist"
      unless $long && exists $self->{opts}->{$long};
   return $self->{opts}->{$long}->{value};
}

sub got {
   my ( $self, $opt ) = @_;
   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
   die "Option $opt does not exist"
      unless $long && exists $self->{opts}->{$long};
   return $self->{opts}->{$long}->{got};
}

sub has {
   my ( $self, $opt ) = @_;
   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
   return defined $long ? exists $self->{opts}->{$long} : 0;
}

sub set {
   my ( $self, $opt, $val ) = @_;
   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
   die "Option $opt does not exist"
      unless $long && exists $self->{opts}->{$long};
   $self->{opts}->{$long}->{value} = $val;
   return;
}

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

sub errors {
   my ( $self ) = @_;
   return $self->{errors};
}

sub prompt {
   my ( $self ) = @_;
   return "Usage: $PROGRAM_NAME $self->{prompt}\n";
}

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

sub usage_or_errors {
   my ( $self ) = @_;
   if ( $self->{opts}->{help}->{got} ) {
      print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
      exit 0;
   }
   elsif ( scalar @{$self->{errors}} ) {
      print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
      exit 0;
   }
   return;
}

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

sub print_usage {
   my ( $self ) = @_;
   die "Run get_opts() before print_usage()" unless $self->{got_opts};
   my @opts = values %{$self->{opts}};

   my $maxl = max(
      map { length($_->{long}) + ($_->{is_negatable} ? 4 : 0) }
      @opts);

   my $maxs = max(0,
      map { length($_) + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) }
      values %{$self->{short_opts}});

   my $lcol = max($maxl, ($maxs + 3));
   my $rcol = 80 - $lcol - 6;
   my $rpad = ' ' x ( 80 - $rcol );

   $maxs = max($lcol - 3, $maxs);

   my $usage = $self->descr() . "\n" . $self->prompt();

   my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
   push @groups, 'default';

   foreach my $group ( reverse @groups ) {
      $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
      foreach my $opt (
         sort { $a->{long} cmp $b->{long} }
         grep { $_->{group} eq $group }
         @opts )
      {
         my $long  = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
         my $short = $opt->{short};
         my $desc  = $opt->{desc};
         if ( $opt->{type} && $opt->{type} eq 'm' ) {
            my ($s) = $desc =~ m/\(suffix (.)\)/;
            $s    ||= 's';
            $desc =~ s/\s+\(suffix .\)//;
            $desc .= ".  Optional suffix s=seconds, m=minutes, h=hours, "
                   . "d=days; if no suffix, $s is used.";
         }
         $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol})(?:\s+|$)/g);
         $desc =~ s/ +$//mg;
         if ( $short ) {
            $usage .= sprintf("  --%-${maxs}s -%s  %s\n", $long, $short, $desc);
         }
         else {
            $usage .= sprintf("  --%-${lcol}s  %s\n", $long, $desc);
         }
      }
   }

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

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

if ( MKDEBUG ) {
   print '# ', $^X, ' ', $], "\n";
   my $uname = `uname -a`;
   if ( $uname ) {
      $uname =~ s/\s+/ /g;
      print "# $uname\n";
   }
   printf("# %s  Ver %s Distrib %s Changeset %s line %d\n",
      $PROGRAM_NAME, ($main::VERSION || ''), ($main::DISTRIB || ''),
      ($main::SVN_REV || ''), __LINE__);
   print('# Arguments: ',
      join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n");
}

sub _read_config_file {
   my ( $self, $filename ) = @_;
   open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
   my @args;
   my $prefix = '--';
   my $parse  = 1;

   LINE:
   while ( my $line = <$fh> ) {
      chomp $line;
      next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
      $line =~ s/\s+#.*$//g;
      $line =~ s/^\s+|\s+$//g;
      if ( $line eq '--' ) {
         $prefix = '';
         $parse  = 0;
         next LINE;
      }
      if ( $parse
         && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
      ) {
         push @args, grep { defined $_ } ("$prefix$opt", $arg);
      }
      elsif ( $line =~ m/./ ) {
         push @args, $line;
      }
      else {
         die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
      }
   }
   close $fh;
   return @args;
}

sub read_para_after {
   my ( $self, $file, $regex ) = @_;
   open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
   local $INPUT_RECORD_SEPARATOR = '';
   my $para;
   while ( $para = <$fh> ) {
      next unless $para =~ m/^=pod$/m;
      last;
   }
   while ( $para = <$fh> ) {
      next unless $para =~ m/$regex/;
      last;
   }
   $para = <$fh>;
   chomp($para);
   close $fh or die "Can't close $file: $OS_ERROR";
   return $para;
}

sub clone {
   my ( $self ) = @_;

   my %clone = map {
      my $hashref  = $self->{$_};
      my $val_copy = {};
      foreach my $key ( keys %$hashref ) {
         my $ref = ref $hashref->{$key};
         $val_copy->{$key} = !$ref           ? $hashref->{$key}
                           : $ref eq 'HASH'  ? { %{$hashref->{$key}} }
                           : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
                           : $hashref->{$key};
      }
      $_ => $val_copy;
   } qw(opts short_opts defaults);

   foreach my $scalar ( qw(got_opts) ) {
      $clone{$scalar} = $self->{$scalar};
   }

   return bless \%clone;     
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

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

# ###########################################################################
# Transformers package 3407
# ###########################################################################

package Transformers;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Time::Local qw(timelocal);
use Digest::MD5 qw(md5_hex);

use constant MKDEBUG => $ENV{MKDEBUG};

require Exporter;
our @ISA         = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT      = ();
our @EXPORT_OK   = qw(
   micro_t
   percentage_of
   secs_to_time
   shorten
   ts
   parse_timestamp
   unix_timestamp
   make_checksum
);

sub micro_t {
   my ( $t, %args ) = @_;
   my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0;  # precision for ms vals
   my $p_s  = defined $args{p_s}  ? $args{p_s}  : 0;  # precision for s vals
   my $f;

   $t = 0 if $t < 0;

   $t = sprintf('%.17f', $t) if $t =~ /e/;

   $t =~ s/\.(\d{1,6})\d*/\.$1/;

   if ($t > 0 && $t <= 0.000999) {
      $f = ($t * 1000000) . 'us';
   }
   elsif ($t >= 0.001000 && $t <= 0.999999) {
      $f = sprintf("%.${p_ms}f", $t * 1000);
      $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
   }
   elsif ($t >= 1) {
      $f = sprintf("%.${p_s}f", $t);
      $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
   }
   else {
      $f = 0;  # $t should = 0 at this point
   }

   return $f;
}

sub percentage_of {
   my ( $is, $of, %args ) = @_;
   my $p   = $args{p} || 0; # float precision
   my $fmt = $p ? "%.${p}f" : "%d";
   return sprintf $fmt, ($is * 100) / ($of ||= 1);
}

sub secs_to_time {
   my ( $secs, $fmt ) = @_;
   $secs ||= 0;
   return '00:00' unless $secs;

   $fmt ||= $secs >= 86_400 ? 'd'
          : $secs >= 3_600  ? 'h'
          :                   'm';

   return
      $fmt eq 'd' ? sprintf(
         "%d+%02d:%02d:%02d",
         int($secs / 86_400),
         int(($secs % 86_400) / 3_600),
         int(($secs % 3_600) / 60),
         $secs % 60)
      : $fmt eq 'h' ? sprintf(
         "%02d:%02d:%02d",
         int(($secs % 86_400) / 3_600),
         int(($secs % 3_600) / 60),
         $secs % 60)
      : sprintf(
         "%02d:%02d",
         int(($secs % 3_600) / 60),
         $secs % 60);
}

sub shorten {
   my ( $num, %args ) = @_;
   my $p = defined $args{p} ? $args{p} : 2;     # float precision
   my $d = defined $args{d} ? $args{d} : 1_024; # divisor
   my $n = 0;
   my @units = ('', qw(k M G T P E Z Y));
   while ( $num >= $d && $n < @units - 1 ) {
      $num /= $d;
      ++$n;
   }
   return sprintf(
      $num =~ m/\./ || $n
         ? "%.${p}f%s"
         : '%d',
      $num, $units[$n]);
}

sub ts {
   my ( $time ) = @_;
   my ( $sec, $min, $hour, $mday, $mon, $year )
      = localtime($time);
   $mon  += 1;
   $year += 1900;
   return sprintf("%d-%02d-%02dT%02d:%02d:%02d",
      $year, $mon, $mday, $hour, $min, $sec);
}

sub parse_timestamp {
   my ( $val ) = @_;
   if ( my($y, $m, $d, $h, $i, $s, $f)
         = $val =~ m/^(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?$/ )
   {
      return sprintf "%d-%02d-%02d %02d:%02d:"
                     . (defined $f ? '%02.6f' : '%02d'),
                     $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
   }
   return $val;
}

sub unix_timestamp {
   my ( $val ) = @_;
   if ( my($y, $m, $d, $h, $i, $s)
         = $val =~ m/^(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)$/ )
   {
      return timelocal($s, $i, $h, $d, $m - 1, $y);
   }
   return $val;
}

sub make_checksum {
   my ( $val ) = @_;
   my $checksum = uc substr(md5_hex($val), -16);
   MKDEBUG && _d($checksum, 'checksum for', $val);
   return $checksum;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End Transformers package
# ###########################################################################

# ###########################################################################
# QueryRewriter package 3383
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package QueryRewriter;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

our $verbs   = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT
                  |UPDATE|DELETE|REPLACE|^SET|UNION|^START}xi;
my $quote_re = qr/"(?:(?!(?<!\\)").)*"|'(?:(?!(?<!\\)').)*'/; # Costly!
my $bal;
$bal         = qr/
                  \(
                  (?:
                     (?> [^()]+ )    # Non-parens without backtracking
                     |
                     (??{ $bal })    # Group with matching parens
                  )*
                  \)
                 /x;

my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/;  # One-line comments
my $mlc_re = qr#/\*[^!].*?\*/#sm;                  # But not /*!version */

sub new {
   my ( $class, %args ) = @_;
   my $self = { %args };
   return bless $self, $class;
}

sub strip_comments {
   my ( $self, $query ) = @_;
   $query =~ s/$olc_re//go;
   $query =~ s/$mlc_re//go;
   return $query;
}

sub shorten {
   my ( $self, $query, $length ) = @_;
   $query =~ s{
      \A(
         (?:INSERT|REPLACE)
         (?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)?
         (?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\)
      )
      \s*,\s*\(.*?(ON\s+DUPLICATE|\Z)}
      {$1 /*... omitted ...*/$2}xsi;

   return $query unless $query =~ m/IN\s*\(\s*(?!select)/i;

   if ( $length && length($query) > $length ) {
      my ($left, $mid, $right) = $query =~ m{
         (\A.*?\bIN\s*\()     # Everything up to the opening of IN list
         ([^\)]+)             # Contents of the list
         (\).*\Z)             # The rest of the query
      }xsi;
      if ( $left ) {
         my $targ = $length - length($left) - length($right);
         my @vals = split(/,/, $mid);
         my @left = shift @vals;
         my @right;
         my $len  = length($left[0]);
         while ( @vals && $len < $targ / 2 ) {
            $len += length($vals[0]) + 1;
            push @left, shift @vals;
         }
         while ( @vals && $len < $targ ) {
            $len += length($vals[-1]) + 1;
            unshift @right, pop @vals;
         }
         $query = $left . join(',', @left)
                . (@right ? ',' : '')
                . " /*... omitted " . scalar(@vals) . " items ...*/ "
                . join(',', @right) . $right;
      }
   }

   return $query;
}

sub fingerprint {
   my ( $self, $query ) = @_;

   $query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query
      && return 'mysqldump';
   $query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/#     # mk-table-checksum, etc query
      && return 'maatkit';
   $query =~ m/\A# administrator command: /
      && return $query;
   $query =~ m/\A\s*(call\s+\S+)\(/i
      && return lc($1); # Warning! $1 used, be careful.
   if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)? INTO .+? VALUES \(.*?\)),\(/i ) {
      $query = $beginning; # Shorten multi-value INSERT statements ASAP
   }

   $query =~ s/$olc_re//go;
   $query =~ s/$mlc_re//go;
   $query =~ s/\Ause \S+\Z/use ?/i       # Abstract the DB in USE
      && return $query;

   $query =~ s/\\["']//g;                # quoted strings
   $query =~ s/".*?"/?/sg;               # quoted strings
   $query =~ s/'.*?'/?/sg;               # quoted strings
   $query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g;# Anything vaguely resembling numbers
   $query =~ s/[xb.+-]\?/?/g;            # Clean up leftovers
   $query =~ s/\A\s+//;                  # Chop off leading whitespace
   chomp $query;                         # Kill trailing whitespace
   $query =~ tr[ \n\t\r\f][ ]s;          # Collapse whitespace
   $query = lc $query;
   $query =~ s/\bnull\b/?/g;             # Get rid of NULLs
   $query =~ s{                          # Collapse IN and VALUES lists
               \b(in|values?)(?:[\s,]*\([\s?,]*\))+
              }
              {$1(?+)}gx;
   $query =~ s{                          # Collapse UNION
               \b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+
              }
              {$1 /*repeat$2*/}xg;
   $query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT
   return $query;
}

sub distill {
   my ( $self, $query, %args ) = @_;
   my $qp = $args{qp} || $self->{QueryParser};
   die "I need a qp argument" unless $qp;

   $query =~ m/\A\s*call\s+(\S+)\(/i
      && return "CALL $1"; # Warning! $1 used, be careful.
   $query =~ m/\A# administrator/
      && return "ADMIN";
   $query =~ m/\A\s*use\s+/
      && return "USE";

   my @verbs = $query =~ m/\b($verbs)\b/gio;
   @verbs    = do {
      my $last = '';
      grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs;
   };
   my $verbs = join(q{ }, @verbs);
   $verbs =~ s/( UNION SELECT)+/ UNION/g;

   my @tables = map {
      $_ =~ s/`//g;
      $_ =~ s/(_?)[0-9]+/$1?/g;
      $_;
   } $qp->get_tables($query);

   @tables = do {
      my $last = '';
      grep { my $pass = $_ ne $last; $last = $_; $pass } @tables;
   };

   $query = join(q{ }, $verbs, @tables);
   return $query;
}

sub convert_to_select {
   my ( $self, $query ) = @_;
   return unless $query;
   $query =~ s{
                 \A.*?
                 update\s+(.*?)
                 \s+set\b(.*?)
                 (?:\s*where\b(.*?))?
                 (limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)?
                 \Z
              }
              {__update_to_select($1, $2, $3, $4)}exsi
      || $query =~ s{
                    \A.*?
                    (?:insert|replace)\s+
                    .*?\binto\b(.*?)\(([^\)]+)\)\s*
                    values?\s*(\(.*?\))\s*
                    (?:\blimit\b|on\s*duplicate\s*key.*)?\s*
                    \Z
                 }
                 {__insert_to_select($1, $2, $3)}exsi
      || $query =~ s{
                    \A.*?
                    delete\s+(.*?)
                    \bfrom\b(.*)
                    \Z
                 }
                 {__delete_to_select($1, $2)}exsi;
   $query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si;
   $query =~ s/\A.*?(?=\bSELECT\s*\b)//ism;
   return $query;
}

sub convert_select_list {
   my ( $self, $query ) = @_;
   $query =~ s{
               \A\s*select(.*?)\bfrom\b
              }
              {$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi;
   return $query;
}

sub __delete_to_select {
   my ( $delete, $join ) = @_;
   if ( $join =~ m/\bjoin\b/ ) {
      return "select 1 from $join";
   }
   return "select * from $join";
}

sub __insert_to_select {
   my ( $tbl, $cols, $vals ) = @_;
   MKDEBUG && _d('Args:', @_);
   my @cols = split(/,/, $cols);
   MKDEBUG && _d('Cols:', @cols);
   $vals =~ s/^\(|\)$//g; # Strip leading/trailing parens
   my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g;
   MKDEBUG && _d('Vals:', @vals);
   if ( @cols == @vals ) {
      return "select * from $tbl where "
         . join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols));
   }
   else {
      return "select * from $tbl limit 1";
   }
}

sub __update_to_select {
   my ( $from, $set, $where, $limit ) = @_;
   return "select $set from $from "
      . ( $where ? "where $where" : '' )
      . ( $limit ? " $limit "      : '' );
}

sub wrap_in_derived {
   my ( $self, $query ) = @_;
   return unless $query;
   return $query =~ m/\A\s*select/i
      ? "select 1 from ($query) as x limit 1"
      : $query;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End QueryRewriter package
# ###########################################################################

# ###########################################################################
# Processlist package 3571
# ###########################################################################
package Processlist;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};
use constant {
   ID      => 0,
   USER    => 1,
   HOST    => 2,
   DB      => 3,
   COMMAND => 4,
   TIME    => 5,
   STATE   => 6,
   INFO    => 7,
   START   => 8, # Calculated start time of statement
   ETIME   => 9, # Exec time of SHOW PROCESSLIST (margin of error in START)
   FSEEN   => 10, # First time ever seen
};

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

sub parse_event {
   my ( $self, $code, $misc, @callbacks ) = @_;
   my $num_events = 0;

   my @curr = sort { $a->[ID] <=> $b->[ID] } @{$code->()};
   my @prev = @{$misc->{prev} ||= []};
   my @new; # Will become next invocation's @prev
   my ($curr, $prev); # Rows from each source

   do {
      if ( !$curr && @curr ) {
         MKDEBUG && _d('Fetching row from curr');
         $curr = shift @curr;
      }
      if ( !$prev && @prev ) {
         MKDEBUG && _d('Fetching row from prev');
         $prev = shift @prev;
      }
      if ( $curr || $prev ) {
         if ( $curr && $prev && $curr->[ID] == $prev->[ID] ) {
            MKDEBUG && _d('$curr and $prev are the same cxn');
            my $fudge = $curr->[TIME] =~ m/\D/ ? 0.001 : 1; # Micro-precision?
            my $is_new = 0;
            if ( $prev->[INFO] ) {
               if (!$curr->[INFO] || $prev->[INFO] ne $curr->[INFO]) {
                  MKDEBUG && _d('$curr has a new query');
                  $is_new = 1;
               }
               elsif (defined $curr->[TIME] && $curr->[TIME] < $prev->[TIME]) {
                  MKDEBUG && _d('$curr time is less than $prev time');
                  $is_new = 1;
               }
               elsif ( $curr->[INFO] && defined $curr->[TIME]
                  && $misc->{time} - $curr->[TIME] - $prev->[START]
                     - $prev->[ETIME] - $misc->{etime} > $fudge
               ) {
                  MKDEBUG && _d('$curr has same query that restarted');
                  $is_new = 1;
               }
               if ( $is_new ) {
                  fire_event( $prev, $misc->{time}, @callbacks );
               }
            }
            if ( $curr->[INFO] ) {
               if ( $prev->[INFO] && !$is_new ) {
                  MKDEBUG && _d('Pushing old history item back onto $prev');
                  push @new, [ @$prev ];
               }
               else {
                  MKDEBUG && _d('Pushing new history item onto $prev');
                  push @new,
                     [ @$curr, int($misc->{time} - $curr->[TIME]),
                        $misc->{etime}, $misc->{time} ];
               }
            }
            $curr = $prev = undef; # Fetch another from each.
         }
         elsif ( !$curr
               || ( $curr && $prev && $curr->[ID] > $prev->[ID] )) {
            MKDEBUG && _d('$curr is not in $prev');
            fire_event( $prev, $misc->{time}, @callbacks );
            $prev = undef;
         }
         else { # This else must be entered, to prevent infinite loops.
            MKDEBUG && _d('$prev is not in $curr');
            if ( $curr->[INFO] && defined $curr->[TIME] ) {
               MKDEBUG && _d('Pushing new history item onto $prev');
               push @new,
                  [ @$curr, int($misc->{time} - $curr->[TIME]),
                     $misc->{etime}, $misc->{time} ];
            }
            $curr = undef; # No infinite loops.
         }
      }
   } while ( @curr || @prev || $curr || $prev );

   @{$misc->{prev}} = @new;

   return $num_events;
}

sub fire_event {
   my ( $row, $time, @callbacks ) = @_;
   my $Query_time = $row->[TIME];
   if ( $row->[TIME] < $time - $row->[FSEEN] ) {
      $Query_time = $time - $row->[FSEEN];
   }
   my $event = {
      id         => $row->[ID],
      db         => $row->[DB],
      user       => $row->[USER],
      host       => $row->[HOST],
      arg        => $row->[INFO],
      bytes      => length($row->[INFO]),
      ts         => $row->[START] + $row->[TIME], # Query END time
      Query_time => $Query_time,
      Lock_time  => 0,               # TODO
   };
   foreach my $callback ( @callbacks ) {
      last unless $event = $callback->($event);
   }
}

sub find {
   my ( $self, $proclist, %find_spec ) = @_;
   my @matches;
   QUERY:
   foreach my $query ( @$proclist ) {
      my $matched = 0;
      if ( $find_spec{busy_time} && ($query->{Command} || '') eq 'Query' ) {
         if ( $query->{Time} < $find_spec{busy_time} ) {
            MKDEBUG && _d("Query isn't running long enough");
            next QUERY;
         }
         $matched++;
      }
      PROPERTY:
      foreach my $property ( qw(Id User Host db State Command Info) ) {
         my $filter = "_find_match_$property";
         if ( defined $find_spec{ignore}->{$property}
            && $self->$filter($query, $find_spec{ignore}->{$property})
         ) {
            MKDEBUG && _d("Query matches 'ignore' filter on $property, skipping");
            next QUERY;
         }
         if ( defined $find_spec{match}->{$property} ) {
            if ( !$self->$filter($query, $find_spec{match}->{$property}) ) {
               MKDEBUG && _d("Query doesn't match 'match' filter on $property, skipping");
               next QUERY;
            }
            $matched++;
         }
      }
      if ( $matched ) {
         MKDEBUG && _d("Query passed all defined filters, adding");
         push @matches, $query;
      }
   }
   if ( @matches && $find_spec{only_oldest} ) {
      my ( $oldest ) = reverse sort { $a->{Time} <=> $b->{Time} } @matches;
      @matches = $oldest;
   }
   return @matches;
}

sub _find_match_Id {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{Id} && $query->{Id} == $property;
}

sub _find_match_User {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{User}
      && $query->{User} =~ m/$property/;
}

sub _find_match_Host {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{Host}
      && $query->{Host} =~ m/$property/;
}

sub _find_match_db {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{db}
      && $query->{db} =~ m/$property/;
}

sub _find_match_State {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{State}
      && $query->{State} =~ m/$property/;
}

sub _find_match_Command {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{Command}
      && $query->{Command} =~ m/$property/;
}

sub _find_match_Info {
   my ( $self, $query, $property ) = @_;
   return defined $property && defined $query->{Info}
      && $query->{Info} =~ m/$property/;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End Processlist package
# ###########################################################################

# ###########################################################################
# TcpdumpParser package 3633
# ###########################################################################
package TcpdumpParser;


use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;
$Data::Dumper::Indent   = 1;
$Data::Dumper::Sortkeys = 1;

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, %args ) = @_;
   my $self = {};
   return bless $self, $class;
}

sub parse_event {
   my ( $self, $fh, $misc, @callbacks ) = @_;

   my $num_packets = 0;

   local $INPUT_RECORD_SEPARATOR = "\n20";

   my $pos_in_log = tell($fh);
   while ( defined(my $raw_packet = <$fh>) ) {
      $raw_packet =~ s/\n20\Z//;
      $raw_packet = "20$raw_packet" unless $raw_packet =~ m/\A20/;

      MKDEBUG && _d('packet:', ++$num_packets, 'pos:', $pos_in_log);
      my $packet = $self->_parse_packet($raw_packet);
      $packet->{pos_in_log} = $pos_in_log;

      foreach my $callback ( @callbacks ) {
         last unless $packet = $callback->($packet);
      }

      $pos_in_log = tell($fh) - 1;
   }

   MKDEBUG && _d('Done parsing packets;', $num_packets, 'parsed');
   return $num_packets;
}

sub _parse_packet {
   my ( $self, $packet ) = @_;
   die "I need a packet" unless $packet;

   my ( $ts, $source, $dest )  = $packet =~ m/\A(\S+ \S+) IP (\S+) > (\S+):/;
   my ( $src_host, $src_port ) = $source =~ m/((?:\d+\.){3}\d+)\.(\w+)/;
   my ( $dst_host, $dst_port ) = $dest   =~ m/((?:\d+\.){3}\d+)\.(\w+)/;

   (my $data = join('', $packet =~ m/\t0x[0-9a-f]+:  (.*)/g)) =~ s/\s+//g; 

   my $ip_hlen = hex(substr($data, 1, 1)); # Num of 32-bit words in header.
   my $ip_plen = hex(substr($data, 4, 4)); # Num of BYTES in IPv4 datagram.
   my $complete = length($data) == 2 * $ip_plen ? 1 : 0;

   my $tcp_hlen = hex(substr($data, ($ip_hlen + 3) * 8, 1));
   $data = substr($data, ($ip_hlen + $tcp_hlen) * 8);

   my $pkt = {
      ts       => $ts,
      src_host => $src_host,
      src_port => $src_port,
      dst_host => $dst_host,
      dst_port => $dst_port,
      complete => $complete,
      ip_hlen  => $ip_hlen,
      tcp_hlen => $tcp_hlen,
      data     => $data ? substr($data, 0, 8).(length $data > 8 ? '...' : '')
                        : '',
   };
   MKDEBUG && _d('packet:', Dumper($pkt));
   $pkt->{data} = $data;
   return $pkt;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End TcpdumpParser package
# ###########################################################################

# ###########################################################################
# MySQLProtocolParser package 3640
# ###########################################################################
package MySQLProtocolParser;


use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;
$Data::Dumper::Indent = 1;

require Exporter;
our @ISA         = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT      = ();
our @EXPORT_OK   = qw(
   parse_error_packet
   parse_ok_packet
   parse_server_handshake_packet
   parse_client_handshake_packet
   parse_com_packet
);

use constant MKDEBUG => $ENV{MKDEBUG};
use constant {
   COM_SLEEP               => '00',
   COM_QUIT                => '01',
   COM_INIT_DB             => '02',
   COM_QUERY               => '03',
   COM_FIELD_LIST          => '04',
   COM_CREATE_DB           => '05',
   COM_DROP_DB             => '06',
   COM_REFRESH             => '07',
   COM_SHUTDOWN            => '08',
   COM_STATISTICS          => '09',
   COM_PROCESS_INFO        => '0a',
   COM_CONNECT             => '0b',
   COM_PROCESS_KILL        => '0c',
   COM_DEBUG               => '0d',
   COM_PING                => '0e',
   COM_TIME                => '0f',
   COM_DELAYED_INSERT      => '10',
   COM_CHANGE_USER         => '11',
   COM_BINLOG_DUMP         => '12',
   COM_TABLE_DUMP          => '13',
   COM_CONNECT_OUT         => '14',
   COM_REGISTER_SLAVE      => '15',
   COM_STMT_PREPARE        => '16',
   COM_STMT_EXECUTE        => '17',
   COM_STMT_SEND_LONG_DATA => '18',
   COM_STMT_CLOSE          => '19',
   COM_STMT_RESET          => '1a',
   COM_SET_OPTION          => '1b',
   COM_STMT_FETCH          => '1c',
   SERVER_QUERY_NO_GOOD_INDEX_USED => 16,
   SERVER_QUERY_NO_INDEX_USED      => 32,
};

my %com_for = (
   '00' => 'COM_SLEEP',
   '01' => 'COM_QUIT',
   '02' => 'COM_INIT_DB',
   '03' => 'COM_QUERY',
   '04' => 'COM_FIELD_LIST',
   '05' => 'COM_CREATE_DB',
   '06' => 'COM_DROP_DB',
   '07' => 'COM_REFRESH',
   '08' => 'COM_SHUTDOWN',
   '09' => 'COM_STATISTICS',
   '0a' => 'COM_PROCESS_INFO',
   '0b' => 'COM_CONNECT',
   '0c' => 'COM_PROCESS_KILL',
   '0d' => 'COM_DEBUG',
   '0e' => 'COM_PING',
   '0f' => 'COM_TIME',
   '10' => 'COM_DELAYED_INSERT',
   '11' => 'COM_CHANGE_USER',
   '12' => 'COM_BINLOG_DUMP',
   '13' => 'COM_TABLE_DUMP',
   '14' => 'COM_CONNECT_OUT',
   '15' => 'COM_REGISTER_SLAVE',
   '16' => 'COM_STMT_PREPARE',
   '17' => 'COM_STMT_EXECUTE',
   '18' => 'COM_STMT_SEND_LONG_DATA',
   '19' => 'COM_STMT_CLOSE',
   '1a' => 'COM_STMT_RESET',
   '1b' => 'COM_SET_OPTION',
   '1c' => 'COM_STMT_FETCH',
);

sub new {
   my ( $class, %args ) = @_;
   my $self = {
      server    => $args{server},
      version   => '41',
      sessions  => {},
   };
   return bless $self, $class;
}

sub parse_packet {
   my ( $self, $packet, $misc ) = @_;

   my $from   = "$packet->{src_host}:$packet->{src_port}";
   my $to     = "$packet->{dst_host}:$packet->{dst_port}";

   $self->{server} ||= $from =~ m/:(?:3306|mysql)$/ ? $from
                     : $to   =~ m/:(?:3306|mysql)$/ ? $to
                     :                                undef;

   my $client = $from eq $self->{server} ? $to : $from;
   MKDEBUG && _d('Client:', $client);

   if ( !exists $self->{sessions}->{$client} ) {
      MKDEBUG && _d('New session');
      $self->{sessions}->{$client} = {
         client => $client,
         ts     => $packet->{ts},
         state  => undef,
      };
   };
   my $session = $self->{sessions}->{$client};

   my $data = \$packet->{data};
   if ( !$$data  ) {
      MKDEBUG && _d('No data in TCP packet');
      if ( ($session->{state} || '') eq 'closing' ) {
         delete $self->{sessions}->{$session->{client}};
      }
      return;
   }

   my $mysql_hdr = substr($$data, 0, 8, '');
   my $data_len  = to_num(substr($mysql_hdr, 0, 6));
   my $pkt_num   = oct('0x'.substr($mysql_hdr, 6, 2));
   MKDEBUG && _d('MySQL packet: header data', $mysql_hdr,
      'data len (bytes)', $data_len, 'number', $pkt_num);

   $packet->{data_len} = $data_len;

   if ( !$$data ) {
      MKDEBUG && _d('No MySQL data');
      return;
   }

   my $event;
   if ( $from eq $self->{server} ) {
      $event = _packet_from_server($packet, $session, $misc);
   }
   elsif ( $from eq $client ) {
      $event = _packet_from_client($packet, $session, $misc);
   }
   else {
      MKDEBUG && _d('Packet origin unknown');
   }

   MKDEBUG && _d('Done parsing packet; client state:', $session->{state});
   return $event;
}

sub _packet_from_server {
   my ( $packet, $session, $misc ) = @_;
   die "I need a packet"  unless $packet;
   die "I need a session" unless $session;

   MKDEBUG && _d('Packet is from server; client state:', $session->{state});

   my $data = $packet->{data};
   my $ts   = $packet->{ts};


   my ( $first_byte ) = substr($data, 0, 2, '');
   MKDEBUG && _d("First byte of packet:", $first_byte);

   if ( $first_byte eq '00' ) { 
      if ( ($session->{state} || '') eq 'client_auth' ) {
         $session->{state} = 'ready';
         MKDEBUG && _d('Admin command: Connect');
         return _make_event(
            {  cmd => 'Admin',
               arg => 'administrator command: Connect',
               ts  => $ts, # Events are timestamped when they end
            },
            $packet, $session
         );
      }
      elsif ( $session->{cmd} ) {
         my $ok  = parse_ok_packet($data);
         my $com = $session->{cmd}->{cmd};
         my $arg;

         if ( $com eq COM_QUERY ) {
            $com = 'Query';
            $arg = $session->{cmd}->{arg};
         }
         else {
            $arg = 'administrator command: '
                 . ucfirst(lc(substr($com_for{$com}, 4)));
            $com = 'Admin';
         }

         $session->{state} = 'ready';
         return _make_event(
            {  cmd           => $com,
               arg           => $arg,
               ts            => $ts,
               Insert_id     => $ok->{insert_id},
               Warning_count => $ok->{warnings},
               Rows_affected => $ok->{affected_rows},
            },
            $packet, $session
         );
      } 
   }
   elsif ( $first_byte eq 'ff' ) {
      my $error = parse_error_packet($data);
      my $event;

      if ( $session->{state} eq 'client_auth' ) {
         MKDEBUG && _d('Connection failed');
         $event = {
            cmd       => 'Admin',
            arg       => 'administrator command: Connect',
            ts        => $ts,
            Error_no  => $error->{errno},
         };
         $session->{state} = 'closing';
      }
      elsif ( $session->{cmd} ) {
         my $com = $session->{cmd}->{cmd};
         my $arg;

         if ( $com eq COM_QUERY ) {
            $com = 'Query';
            $arg = $session->{cmd}->{arg};
         }
         else {
            $arg = 'administrator command: '
                 . ucfirst(lc(substr($com_for{$com}, 4)));
            $com = 'Admin';
         }
         $event = {
            cmd       => $com,
            arg       => $arg,
            ts        => $ts,
            Error_no  => $error->{errno},
         };
         $session->{state} = 'ready';
      }

      return _make_event($event, $packet, $session);
   }
   elsif ( $first_byte eq 'fe' && $packet->{data_len} < 9 ) {
      MKDEBUG && _d('Got an EOF packet');
      die "You should not have gotten here";
   }
   elsif ( !$session->{state}
           && $first_byte eq '0a'
           && length $data >= 33 )
   {
      my $handshake = parse_server_handshake_packet($data);
      $session->{state}     = 'server_handshake';
      $session->{thread_id} = $handshake->{thread_id};
   }
   else {
      MKDEBUG && _d('Got a row/field/result packet');
      if ( $session->{cmd} ) {
         my $com = $session->{cmd}->{cmd};
         MKDEBUG && _d('COM:', $com_for{$com});
         my $event = { ts  => $ts };
         if ( $com eq COM_QUERY ) {
            $event->{cmd} = 'Query';
            $event->{arg} = $session->{cmd}->{arg};
         }
         else {
            $event->{arg} = 'administrator command: '
                 . ucfirst(lc(substr($com_for{$com}, 4)));
            $event->{cmd} = 'Admin';
         }

         if ( $packet->{complete} ) {
            my ( $warning_count, $status_flags )
               = $data =~ m/fe(.{4})(.{4})\Z/;
            if ( $warning_count ) { 
               $event->{Warnings} = to_num($warning_count);
               my $flags = to_num($status_flags); # TODO set all flags?
               $event->{No_good_index_used}
                  = $flags & SERVER_QUERY_NO_GOOD_INDEX_USED ? 1 : 0;
               $event->{No_index_used}
                  = $flags & SERVER_QUERY_NO_INDEX_USED ? 1 : 0;
            }
         }

         $session->{state} = 'ready';
         return _make_event($event, $packet, $session);
      }
   }

   return;
}

sub _packet_from_client {
   my ( $packet, $session, $misc ) = @_;
   die "I need a packet"  unless $packet;
   die "I need a session" unless $session;

   MKDEBUG && _d('Packet is from client; state:', $session->{state});

   my $data = $packet->{data};
   my $ts   = $packet->{ts};
 
   if ( ($session->{state} || '') eq 'server_handshake' ) {
      MKDEBUG && _d('Expecting client authentication packet');
      my $handshake = parse_client_handshake_packet($data);
      $session->{state}      = 'client_auth';
      $session->{pos_in_log} = $packet->{pos_in_log};
      $session->{user}       = $handshake->{user};
      $session->{db}         = $handshake->{db};
   }
   else {
      my $com = parse_com_packet($data, $packet->{data_len});
      $session->{state}      = 'awaiting_reply';
      $session->{pos_in_log} = $packet->{pos_in_log};
      $session->{ts}         = $ts;
      $session->{cmd}        = {
         cmd => $com->{code},
         arg => $com->{data},
      };

      if ( $com->{code} eq COM_QUIT ) { # Fire right away; will cleanup later.
         MKDEBUG && _d('Got a COM_QUIT');
         $session->{state} = 'closing';
         return _make_event(
            {  cmd       => 'Admin',
               arg       => 'administrator command: Quit',
               ts        => $ts,
            },
            $packet, $session
         );
      }
   }

   return;
}

sub _make_event {
   my ( $event, $packet, $session ) = @_;
   MKDEBUG && _d('Making event');
   my ($host, $port) = $session->{client} =~ m/((?:\d+\.){3}\d+)\:(\w+)/;
   return $event = {
      cmd        => $event->{cmd},
      arg        => $event->{arg},
      bytes      => length( $event->{arg} ),
      ts         => tcp_timestamp( $event->{ts} ),
      host       => $host,
      ip         => $host,
      port       => $port,
      db         => $session->{db},
      user       => $session->{user},
      Thread_id  => $session->{thread_id},
      pos_in_log => $session->{pos_in_log},
      Query_time => timestamp_diff($session->{ts}, $packet->{ts}),
      Error_no   => ($event->{Error_no} || 0),
      Rows_affected      => ($event->{Rows_affected} || 0),
      Warning_count      => ($event->{Warning_count} || 0),
      No_good_index_used => ($event->{No_good_index_used} ? 'Yes' : 'No'),
      No_index_used      => ($event->{No_index_used}      ? 'Yes' : 'No'),
   };
}

sub tcp_timestamp {
   my ( $ts ) = @_;
   $ts =~ s/^\d\d(\d\d)-(\d\d)-(\d\d)/$1$2$3/;
   return $ts;
}

sub timestamp_diff {
   my ( $start, $end ) = @_;
   my $sd = substr($start, 0, 11, '');
   my $ed = substr($end,   0, 11, '');
   my ( $sh, $sm, $ss ) = split(/:/, $start);
   my ( $eh, $em, $es ) = split(/:/, $end);
   my $esecs = ($eh * 3600 + $em * 60 + $es);
   my $ssecs = ($sh * 3600 + $sm * 60 + $ss);
   if ( $sd eq $ed ) {
      return sprintf '%.6f', $esecs - $ssecs;
   }
   else { # Assume only one day boundary has been crossed, no DST, etc
      return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs;
   }
}

sub to_string {
   my ( $data ) = @_;
   $data = pack('H*', $data);
   return $data;
}

sub to_num {
   my ( $str ) = @_;
   my @bytes = $str =~ m/(..)/g;
   my $result = 0;
   foreach my $i ( 0 .. $#bytes ) {
      $result += hex($bytes[$i]) * (16 ** ($i * 2));
   }
   return $result;
}

sub get_lcb {
   my ( $string ) = @_;
   my $first_byte = hex(substr($$string, 0, 2, ''));
   if ( $first_byte < 251 ) {
      return $first_byte;
   }
   elsif ( $first_byte == 252 ) {
      return to_num(substr($$string, 0, 4, ''));
   }
   elsif ( $first_byte == 253 ) {
      return to_num(substr($$string, 0, 6, ''));
   }
   elsif ( $first_byte == 254 ) {
      return to_num(substr($$string, 0, 16, ''));
   }
}

sub parse_error_packet {
   my ( $data ) = @_;
   die "I need data" unless $data;
   MKDEBUG && _d('ERROR data:', $data);
   die "Error packet is too short: $data" if length $data < 16;
   my $errno    = to_num(substr($data, 0, 4));
   my $sqlstate = to_string(substr($data, 4, 12));
   my $message  = to_string(substr($data, 16));
   my $pkt = {
      errno    => $errno,
      sqlstate => $sqlstate,
      message  => $message,
   };
   MKDEBUG && _d('Error packet:', Dumper($pkt));
   return $pkt;
}

sub parse_ok_packet {
   my ( $data ) = @_;
   die "I need data" unless $data;
   MKDEBUG && _d('OK data:', $data);
   die "OK packet is too short: $data" if length $data < 12;
   my $affected_rows = get_lcb(\$data);
   my $insert_id     = get_lcb(\$data);
   my $status        = to_num(substr($data, 0, 4, ''));
   my $warnings      = to_num(substr($data, 0, 4, ''));
   my $message       = to_string($data);
   my $pkt = {
      affected_rows => $affected_rows,
      insert_id     => $insert_id,
      status        => $status,
      warnings      => $warnings,
      message       => $message,
   };
   MKDEBUG && _d('OK packet:', Dumper($pkt));
   return $pkt;
}

sub parse_server_handshake_packet {
   my ( $data ) = @_;
   die "I need data" unless $data;
   MKDEBUG && _d('Server handshake data:', $data);
   my $handshake_pattern = qr{
      ^                 # -----                ----
      (.+?)00           # n Null-Term String   server_version
      (.{8})            # 4                    thread_id
      .{16}             # 8                    scramble_buff
      .{2}              # 1                    filler: always 0x00
      .{4}              # 2                    server_capabilities
      .{2}              # 1                    server_language
      .{4}              # 2                    server_status
      .{26}             # 13                   filler: always 0x00
   }x;
   my ( $server_version, $thread_id ) = $data =~ m/$handshake_pattern/;
   my $pkt = {
      server_version => to_string($server_version),
      thread_id      => to_num($thread_id),
   };
   MKDEBUG && _d('Server handshake packet:', Dumper($pkt));
   return $pkt;
}

sub parse_client_handshake_packet {
   my ( $data ) = @_;
   die "I need data" unless $data;
   MKDEBUG && _d('Client handshake data:', $data);
   my ( $user, $buff_len ) = $data =~ m{
      ^.{18}         # Client flags, max packet size, charset
      (?:00){23}     # Filler
      ((?:..)+?)00   # Null-terminated user name
      (..)           # Length-coding byte for scramble buff
   }x;

   die "Did not match client handshake packet" unless $buff_len;

   my $code_len = hex($buff_len);
   my ( $db ) = $data =~ m!
      ^.{64}${user}00..   # Everything matched before
      (?:..){$code_len}   # The scramble buffer
      (.*)00\Z            # The database name
   !x;
   my $pkt = {
      user => to_string($user),
      db   => $db ? to_string($db) : '',
   };
   MKDEBUG && _d('Client handshake packet:', Dumper($pkt));
   return $pkt;
}

sub parse_com_packet {
   my ( $data, $len ) = @_;
   die "I need data"  unless $data;
   die "I need a len" unless $len;
   MKDEBUG && _d('COM data:', $data, 'len:', $len);
   my $code = substr($data, 0, 2);
   my $com  = $com_for{$code};
   die "Did not match COM packet" unless $com;
   $data    = to_string(substr($data, 2, ($len - 1) * 2));
   my $pkt = {
      code => $code,
      com  => $com,
      data => $data,
   };
   MKDEBUG && _d('COM packet:', Dumper($pkt));
   return $pkt;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End MySQLProtocolParser package
# ###########################################################################

# ###########################################################################
# SlowLogParser package 3192
# ###########################################################################
package SlowLogParser;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;

use constant MKDEBUG => $ENV{MKDEBUG};

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

my $slow_log_ts_line = qr/^# Time: ([0-9: ]{15})/;
my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]/;
my $slow_log_hd_line = qr{
      ^(?:
      T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix
      |
      [/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary)
      |
      Time\s+Id\s+Command
      ).*\n
   }xm;

sub parse_event {
   my ( $self, $fh, $misc, @callbacks ) = @_;
   my $num_events = 0;

   my @pending;
   local $INPUT_RECORD_SEPARATOR = ";\n#";
   my $trimlen    = length($INPUT_RECORD_SEPARATOR);
   my $pos_in_log = tell($fh);
   my $stmt;

   EVENT:
   while ( defined($stmt = shift @pending) or defined($stmt = <$fh>) ) {
      my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log);
      $pos_in_log = tell($fh);

      if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log
         my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt);
         if ( @chunks > 1 ) {
            MKDEBUG && _d("Found multiple chunks");
            $stmt = shift @chunks;
            unshift @pending, @chunks;
         }
      }

      $stmt = '#' . $stmt unless $stmt =~ m/\A#/;
      $stmt =~ s/;\n#?\Z//;


      my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed);
      my $pos = 0;
      my $len = length($stmt);
      my $found_arg = 0;
      LINE:
      while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match.
         $pos     = pos($stmt);  # Be careful not to mess this up!
         my $line = $1;          # Necessary for /g and pos() to work.
         MKDEBUG && _d($line);

         if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) {

            if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) {
               MKDEBUG && _d("Got ts", $time);
               push @properties, 'ts', $time;
               ++$got_ts;
               if ( !$got_uh
                  && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
               ) {
                  MKDEBUG && _d("Got user, host, ip", $user, $host, $ip);
                  push @properties, 'user', $user, 'host', $host, 'ip', $ip;
                  ++$got_uh;
               }
            }

            elsif ( !$got_uh
                  && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
            ) {
               MKDEBUG && _d("Got user, host, ip", $user, $host, $ip);
               push @properties, 'user', $user, 'host', $host, 'ip', $ip;
               ++$got_uh;
            }

            elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) {
               MKDEBUG && _d("Got admin command");
               push @properties, 'cmd', 'Admin', 'arg', $line;
               push @properties, 'bytes', length($properties[-1]);
               ++$found_arg;
               ++$got_ac;
            }

            elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap!
               MKDEBUG && _d("Got some line with properties");
               my @temp = $line =~ m/(\w+):\s+(\d+(?:\.\d+)?|\S+|\Z)/g;
               push @properties, @temp;
            }

            elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) {
               MKDEBUG && _d("Got a default database:", $db);
               push @properties, 'db', $db;
               ++$got_db;
            }

            elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) {
               MKDEBUG && _d("Got some setting:", $setting);
               push @properties, split(/,|\s*=\s*/, $setting);
               ++$got_set;
            }

            if ( !$found_arg && $pos == $len ) {
               MKDEBUG && _d("Did not find arg, looking for special cases");
               local $INPUT_RECORD_SEPARATOR = ";\n";
               if ( defined(my $l = <$fh>) ) {
                  chomp $l;
                  MKDEBUG && _d("Found admin statement", $l);
                  push @properties, 'cmd', 'Admin', 'arg', '#' . $l;
                  push @properties, 'bytes', length($properties[-1]);
                  $found_arg++;
               }
               else {
                  MKDEBUG && _d("I can't figure out what to do with this line");
                  next EVENT;
               }
            }
         }
         else {
            MKDEBUG && _d("Got the query/arg line");
            my $arg = substr($stmt, $pos - length($line));
            push @properties, 'arg', $arg, 'bytes', length($arg);
            if ( $misc && $misc->{embed}
               && ( my ($e) = $arg =~ m/($misc->{embed})/)
            ) {
               push @properties, $e =~ m/$misc->{capture}/g;
            }
            last LINE;
         }
      }

      MKDEBUG && _d('Properties of event:', Dumper(\@properties));
      my $event = { @properties };
      foreach my $callback ( @callbacks ) {
         last unless $event = $callback->($event);
      }
      ++$num_events;
      last EVENT unless @pending;
   }
   return $num_events;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End SlowLogParser package
# ###########################################################################

# ###########################################################################
# SlowLogWriter package 3405
# ###########################################################################
package SlowLogWriter;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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

sub write {
   my ( $self, $fh, $event ) = @_;
   if ( $event->{ts} ) {
      print $fh "# Time: $event->{ts}\n";
   }
   if ( $event->{user} ) {
      printf $fh "# User\@Host: %s[%s] \@ %s []\n",
         $event->{user}, $event->{user}, $event->{host};
   }
   printf $fh
      "# Query_time: %d  Lock_time: %d  Rows_sent: %d  Rows_examined: %d\n",
      map { $_ || 0 }
         @{$event}{qw(Query_time Lock_time Rows_sent Rows_examined)};
   if ( $event->{db} ) {
      printf $fh "use %s;\n", $event->{db};
   }
   if ( $event->{arg} =~ m/^administrator command/ ) {
      print $fh '# ';
   }
   print $fh $event->{arg}, ";\n";
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End SlowLogWriter package
# ###########################################################################

# ###########################################################################
# EventAggregator package 3543
# ###########################################################################
package EventAggregator;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);

use constant MKDEBUG      => $ENV{MKDEBUG};
use constant BUCK_SIZE    => 1.05;
use constant BASE_LOG     => log(BUCK_SIZE);
use constant BASE_OFFSET  => abs(1 - log(0.000001) / BASE_LOG); # 284.1617969
use constant NUM_BUCK     => 1000;
use constant MIN_BUCK     => .000001;

our @buckets  = map { 0 } (0..NUM_BUCK-1);

my @buck_vals = map { bucket_value($_); } (0..NUM_BUCK-1);

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(groupby worst attributes) ) {
      die "I need a $arg argument" unless $args{$arg};
   }

   return bless {
      groupby      => $args{groupby},
      attributes   => {
         map  { $_ => $args{attributes}->{$_} }
         grep { $_ ne $args{groupby} }
         keys %{$args{attributes}}
      },
      worst        => $args{worst},
      unroll_limit => $args{unroll_limit} || 50,
      attrib_limit => $args{attrib_limit},
      result_classes => {},
      result_globals => {},
      result_samples => {},
   }, $class;
}

sub reset_aggregated_data {
   my ( $self ) = @_;
   foreach my $class ( values %{$self->{result_classes}} ) {
      foreach my $attrib ( values %$class ) {
         delete @{$attrib}{keys %$attrib};
      }
   }
   foreach my $class ( values %{$self->{result_globals}} ) {
      delete @{$class}{keys %$class};
   }
   delete @{$self->{result_samples}}{keys %{$self->{result_samples}}};
}

sub aggregate {
   my ( $self, $event ) = @_;

   my $group_by = $event->{$self->{groupby}};
   return unless defined $group_by;

   if ( exists $self->{unrolled_loops} ) {
      return $self->{unrolled_loops}->($self, $event, $group_by);
   }

   my @attrs = sort keys %{$self->{attributes}};
   ATTRIB:
   foreach my $attrib ( @attrs ) {
      GROUPBY:
      foreach my $val ( ref $group_by ? @$group_by : ($group_by) ) {
         my $class_attrib  = $self->{result_classes}->{$val}->{$attrib} ||= {};
         my $global_attrib = $self->{result_globals}->{$attrib} ||= {};
         my $samples       = $self->{result_samples};
         my $handler = $self->{handlers}->{ $attrib };
         if ( !$handler ) {
            $handler = $self->make_handler(
               $attrib,
               $event,
               wor => $self->{worst} eq $attrib,
               alt => $self->{attributes}->{$attrib},
            );
            $self->{handlers}->{$attrib} = $handler;
         }
         next GROUPBY unless $handler;
         $samples->{$val} ||= $event; # Initialize to the first event.
         $handler->($event, $class_attrib, $global_attrib, $samples, $group_by);
      }
   }

   if ( $self->{n_queries}++ > 50 # Give up waiting after 50 events.
      || !grep {ref $self->{handlers}->{$_} ne 'CODE'} @attrs
   ) {
      my @attrs = grep { $self->{handlers}->{$_} } @attrs;
      my $globs = $self->{result_globals}; # Global stats for each
      my $samples = $self->{result_samples};

      my @lines = (
         'my ( $self, $event, $group_by ) = @_;',
         'my ($val, $class, $global, $idx);',
         (ref $group_by ? ('foreach my $group_by ( @$group_by ) {') : ()),
         'my $temp = $self->{result_classes}->{ $group_by }
            ||= { map { $_ => { } } @attrs };',
         '$samples->{$group_by} ||= $event;', # Always start with the first.
      );
      foreach my $i ( 0 .. $#attrs ) {
         push @lines, (
            '$class  = $temp->{"'  . $attrs[$i] . '"};',
            '$global = $globs->{"' . $attrs[$i] . '"};',
            $self->{unrolled_for}->{$attrs[$i]},
         );
      }
      if ( ref $group_by ) {
         push @lines, '}'; # Close the loop opened above
      }
      @lines = map { s/^/   /gm; $_ } @lines; # Indent for debugging
      unshift @lines, 'sub {';
      push @lines, '}';

      my $code = join("\n", @lines);
      MKDEBUG && _d('Unrolled subroutine:', @lines);
      my $sub = eval $code;
      die if $EVAL_ERROR;
      $self->{unrolled_loops} = $sub;
   }
}

sub results {
   my ( $self ) = @_;
   return {
      classes => $self->{result_classes},
      globals => $self->{result_globals},
      samples => $self->{result_samples},
   };
}

sub attributes {
   my ( $self ) = @_;
   return $self->{type_for};
}

sub type_for {
   my ( $self, $attrib ) = @_;
   return $self->{type_for}->{$attrib};
}

sub make_handler {
   my ( $self, $attrib, $event, %args ) = @_;
   die "I need an attrib" unless defined $attrib;
   my ($val) = grep { defined $_ } map { $event->{$_} } @{ $args{alt} };
   my $is_array = 0;
   if (ref $val eq 'ARRAY') {
      $is_array = 1;
      $val      = $val->[0];
   }
   return unless defined $val; # Can't decide type if it's undef.

   my $float_re = qr{[+-]?(?:(?=\d|[.])\d+(?:[.])\d{0,})(?:E[+-]?\d+)?}i;
   my $type = $val  =~ m/^(?:\d+|$float_re)$/o ? 'num'
            : $val  =~ m/^(?:Yes|No)$/         ? 'bool'
            :                                    'string';
   MKDEBUG && _d('Type for', $attrib, 'is', $type,
      '(sample:', $val, '), is array:', $is_array);
   $self->{type_for}->{$attrib} = $type;

   %args = ( # Set up defaults
      min => 1,
      max => 1,
      sum => $type =~ m/num|bool/    ? 1 : 0,
      cnt => 1,
      unq => $type =~ m/bool|string/ ? 1 : 0,
      all => $type eq 'num'          ? 1 : 0,
      glo => 1,
      trf => ($type eq 'bool') ? q{($val || '' eq 'Yes') ? 1 : 0} : undef,
      wor => 0,
      alt => [],
      %args,
   );

   my @lines = ("# type: $type"); # Lines of code for the subroutine
   if ( $args{trf} ) {
      push @lines, q{$val = } . $args{trf} . ';';
   }

   foreach my $place ( qw($class $global) ) {
      my @tmp;
      if ( $args{min} ) {
         my $op   = $type eq 'num' ? '<' : 'lt';
         push @tmp, (
            'PLACE->{min} = $val if !defined PLACE->{min} || $val '
               . $op . ' PLACE->{min};',
         );
      }
      if ( $args{max} ) {
         my $op = ($type eq 'num') ? '>' : 'gt';
         push @tmp, (
            'PLACE->{max} = $val if !defined PLACE->{max} || $val '
               . $op . ' PLACE->{max};',
         );
      }
      if ( $args{sum} ) {
         push @tmp, 'PLACE->{sum} += $val;';
      }
      if ( $args{cnt} ) {
         push @tmp, '++PLACE->{cnt};';
      }
      if ( $args{all} ) {
         push @tmp, (
            'exists PLACE->{all} or PLACE->{all} = [ @buckets ];',
            '++PLACE->{all}->[ EventAggregator::bucket_idx($val) ];',
         );
      }
      push @lines, map { s/PLACE/$place/g; $_ } @tmp;
   }

   if ( $args{unq} ) {
      push @lines, '++$class->{unq}->{$val};';
   }
   if ( $args{wor} ) {
      my $op = $type eq 'num' ? '>=' : 'ge';
      push @lines, (
         'if ( $val ' . $op . ' ($class->{max} || 0) ) {',
         '   $samples->{$group_by} = $event;',
         '}',
      );
   }

   my @limit;
   if ( $args{all} && $type eq 'num' && $self->{attrib_limit} ) {
      push @limit, (
         "if ( \$val > $self->{attrib_limit} ) {",
         '   $val = $class->{last} ||= 0;',
         '}',
         '$class->{last} = $val;',
      );
   }

   my @unrolled = (
      "\$val = \$event->{'$attrib'};",
      ($is_array ? ('foreach my $val ( @$val ) {') : ()),
      (map { "\$val = \$event->{'$_'} unless defined \$val;" }
         grep { $_ ne $attrib } @{$args{alt}}),
      'defined $val && do {',
      ( map { s/^/   /gm; $_ } (@limit, @lines) ), # Indent for debugging
      '};',
      ($is_array ? ('}') : ()),
   );
   $self->{unrolled_for}->{$attrib} = join("\n", @unrolled);

   unshift @lines, (
      'sub {',
      'my ( $event, $class, $global, $samples, $group_by ) = @_;',
      'my ($val, $idx);', # NOTE: define all variables here
      "\$val = \$event->{'$attrib'};",
      (map { "\$val = \$event->{'$_'} unless defined \$val;" }
         grep { $_ ne $attrib } @{$args{alt}}),
      'return unless defined $val;',
      ($is_array ? ('foreach my $val ( @$val ) {') : ()),
      @limit,
      ($is_array ? ('}') : ()),
   );
   push @lines, '}';
   my $code = join("\n", @lines);
   $self->{code_for}->{$attrib} = $code;

   MKDEBUG && _d('Metric handler for', $attrib, ':', @lines);
   my $sub = eval join("\n", @lines);
   die if $EVAL_ERROR;
   return $sub;
}

sub bucket_idx {
   my ( $val ) = @_;
   return 0 if $val < MIN_BUCK;
   my $idx = int(BASE_OFFSET + log($val)/BASE_LOG);
   return $idx > (NUM_BUCK-1) ? (NUM_BUCK-1) : $idx;
}

sub bucket_value {
   my ( $bucket ) = @_;
   return 0 if $bucket == 0;
   die "Invalid bucket: $bucket" if $bucket < 0 || $bucket > (NUM_BUCK-1);
   return (BUCK_SIZE**($bucket-1)) * MIN_BUCK;
}

{
   my @buck_tens;
   sub buckets_of {
      return @buck_tens if @buck_tens;

      my $start_bucket  = 0;
      my @base10_starts = (0);
      map { push @base10_starts, (10**$_)*MIN_BUCK } (1..7);

      for my $base10_bucket ( 0..($#base10_starts-1) ) {
         my $next_bucket = bucket_idx( $base10_starts[$base10_bucket+1] );
         MKDEBUG && _d('Base 10 bucket $base10_bucket maps to',
            'base 1.05 buckets', $start_bucket, '..', $next_bucket-1);
         for my $base1_05_bucket ($start_bucket..($next_bucket-1)) {
            $buck_tens[$base1_05_bucket] = $base10_bucket;
         }
         $start_bucket = $next_bucket;
      }

      map { $buck_tens[$_] = 7 } ($start_bucket..(NUM_BUCK-1));

      return @buck_tens;
   }
}

sub calculate_statistical_metrics {
   my ( $self, $vals, $args ) = @_;
   my $statistical_metrics = {
      pct_95    => 0,
      stddev    => 0,
      median    => 0,
      cutoff    => undef,
   };

   return $statistical_metrics
      unless defined $vals && @$vals && $args->{cnt};

   my $n_vals = $args->{cnt};
   if ( $n_vals == 1 || $args->{max} == $args->{min} ) {
      my $v      = $args->{max} || 0;
      my $bucket = int(6 + ( log($v > 0 ? $v : MIN_BUCK) / log(10)));
      $bucket    = $bucket > 7 ? 7 : $bucket < 0 ? 0 : $bucket;
      return {
         pct_95 => $v,
         stddev => 0,
         median => $v,
         cutoff => $n_vals,
      };
   }
   elsif ( $n_vals == 2 ) {
      foreach my $v ( $args->{min}, $args->{max} ) {
         my $bucket = int(6 + ( log($v && $v > 0 ? $v : MIN_BUCK) / log(10)));
         $bucket = $bucket > 7 ? 7 : $bucket < 0 ? 0 : $bucket;
      }
      my $v      = $args->{max} || 0;
      my $mean = (($args->{min} || 0) + $v) / 2;
      return {
         pct_95 => $v,
         stddev => sqrt((($v - $mean) ** 2) *2),
         median => $mean,
         cutoff => $n_vals,
      };
   }

   my $cutoff = $n_vals >= 10 ? int ( $n_vals * 0.95 ) : $n_vals;
   $statistical_metrics->{cutoff} = $cutoff;

   my $total_left = $n_vals;
   my $top_vals   = $n_vals - $cutoff; # vals > 95th
   my $sum_excl   = 0;
   my $sum        = 0;
   my $sumsq      = 0;
   my $mid        = int($n_vals / 2);
   my $median     = 0;
   my $prev       = NUM_BUCK-1; # Used for getting median when $cutoff is odd
   my $bucket_95  = 0; # top bucket in 95th

   MKDEBUG && _d('total vals:', $total_left, 'top vals:', $top_vals, 'mid:', $mid);

   BUCKET:
   for my $bucket ( reverse 0..(NUM_BUCK-1) ) {
      my $val = $vals->[$bucket];
      next BUCKET unless $val; 

      $total_left -= $val;
      $sum_excl   += $val;
      $bucket_95   = $bucket if !$bucket_95 && $sum_excl > $top_vals;

      if ( !$median && $total_left <= $mid ) {
         $median = (($cutoff % 2) || ($val > 1)) ? $buck_vals[$bucket]
                 : ($buck_vals[$bucket] + $buck_vals[$prev]) / 2;
      }

      $sum    += $val * $buck_vals[$bucket];
      $sumsq  += $val * ($buck_vals[$bucket]**2);
      $prev   =  $bucket;
   }

   my $var      = $sumsq/$n_vals - ( ($sum/$n_vals) ** 2 );
   my $stddev   = $var > 0 ? sqrt($var) : 0;
   my $maxstdev = (($args->{max} || 0) - ($args->{min} || 0)) / 2;
   $stddev      = $stddev > $maxstdev ? $maxstdev : $stddev;

   MKDEBUG && _d('sum:', $sum, 'sumsq:', $sumsq, 'stddev:', $stddev,
      'median:', $median, 'prev bucket:', $prev,
      'total left:', $total_left, 'sum excl', $sum_excl,
      'bucket 95:', $bucket_95, $buck_vals[$bucket_95]);

   $statistical_metrics->{stddev} = $stddev;
   $statistical_metrics->{pct_95} = $buck_vals[$bucket_95];
   $statistical_metrics->{median} = $median;

   return $statistical_metrics;
}

sub metrics {
   my ( $self, %args ) = @_;
   foreach my $arg ( qw(attrib where) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my $stats = $self->results;
   my $store = $stats->{classes}->{$args{where}}->{$args{attrib}};

   my $global_cnt = $stats->{globals}->{$args{attrib}}->{cnt};
   my $metrics    = $self->calculate_statistical_metrics($store->{all}, $store);

   return {
      cnt    => $store->{cnt},
      pct    => $global_cnt && $store->{cnt} ? $store->{cnt} / $global_cnt : 0,
      sum    => $store->{sum},
      min    => $store->{min},
      max    => $store->{max},
      avg    => $store->{sum} && $store->{cnt} ? $store->{sum} / $store->{cnt} : 0,
      median => $metrics->{median},
      pct_95 => $metrics->{pct_95},
      stddev => $metrics->{stddev},
   };
}

sub top_events {
   my ( $self, %args ) = @_;
   my $classes = $self->{result_classes};
   my @sorted = reverse sort { # Sorted list of $groupby values
      $classes->{$a}->{$args{attrib}}->{$args{orderby}}
         <=> $classes->{$b}->{$args{attrib}}->{$args{orderby}}
      } grep {
         defined $classes->{$_}->{$args{attrib}}->{$args{orderby}}
      } keys %$classes;
   my @chosen;
   my ($total, $count) = (0, 0);
   foreach my $groupby ( @sorted ) {
      if ( 
         (!$args{total} || $total < $args{total} )
         && ( !$args{count} || $count < $args{count} )
      ) {
         push @chosen, [$groupby, 'top'];
      }

      elsif ( $args{ol_attrib} && (!$args{ol_freq}
         || $classes->{$groupby}->{$args{ol_attrib}}->{cnt} >= $args{ol_freq})
      ) {
         MKDEBUG && _d('Calculating statistical_metrics');
         my $stats = $self->calculate_statistical_metrics(
            $classes->{$groupby}->{$args{ol_attrib}}->{all},
            $classes->{$groupby}->{$args{ol_attrib}}
         );
         if ( $stats->{pct_95} >= $args{ol_limit} ) {
            push @chosen, [$groupby, 'outlier'];
         }
      }

      $total += $classes->{$groupby}->{$args{attrib}}->{$args{orderby}};
      $count++;
   }
   return @chosen;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End EventAggregator package
# ###########################################################################

# ###########################################################################
# QueryReportFormatter package 3408
# ###########################################################################


package QueryReportFormatter;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
Transformers->import(
   qw(shorten micro_t parse_timestamp unix_timestamp
      make_checksum percentage_of));

use constant MKDEBUG     => $ENV{MKDEBUG};
use constant LINE_LENGTH => 74;

my %formatting_function = (
   db => sub {
      my ( $stats ) = @_;
      my $cnt_for = $stats->{unq};
      if ( 1 == keys %$cnt_for ) {
         return 1, keys %$cnt_for;
      }
      my $line = '';
      my @top = sort { $cnt_for->{$b} <=> $cnt_for->{$a} || $a cmp $b }
                     keys %$cnt_for;
      my $i = 0;
      foreach my $db ( @top ) {
         last if length($line) > LINE_LENGTH - 27;
         $line .= "$db ($cnt_for->{$db}), ";
         $i++;
      }
      $line =~ s/, $//;
      if ( $i < $#top ) {
         $line .= "... " . ($#top - $i) . " more";
      }
      return (scalar keys %$cnt_for, $line);
   },
   ts => sub {
      my ( $stats ) = @_;
      my $min = parse_timestamp($stats->{min} || '');
      my $max = parse_timestamp($stats->{max} || '');
      return $min && $max ? "$min to $max" : '';
   },
   user => sub {
      my ( $stats ) = @_;
      my $cnt_for = $stats->{unq};
      if ( 1 == keys %$cnt_for ) {
         return 1, keys %$cnt_for;
      }
      my $line = '';
      my @top = sort { $cnt_for->{$b} <=> $cnt_for->{$a} || $a cmp $b }
                     keys %$cnt_for;
      my $i = 0;
      foreach my $user ( @top ) {
         last if length($line) > LINE_LENGTH - 27;
         $line .= "$user ($cnt_for->{$user}), ";
         $i++;
      }
      $line =~ s/, $//;
      if ( $i < $#top ) {
         $line .= "... " . ($#top - $i) . " more";
      }
      return (scalar keys %$cnt_for, $line);
   },
);

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

sub header {
   my ($self) = @_;

   my ( $rss, $vsz, $user, $system ) = ( 0, 0, 0, 0 );
   eval {
      my $mem = `ps -o rss,vsz $PID`;
      ( $rss, $vsz ) = $mem =~ m/(\d+)/g;
   };
   ( $user, $system ) = times();

   sprintf "# %s user time, %s system time, %s rss, %s vsz\n",
      micro_t( $user,   p_s => 1, p_ms => 1 ),
      micro_t( $system, p_s => 1, p_ms => 1 ),
      shorten( $rss * 1_024 ),
      shorten( $vsz * 1_024 );
}

sub global_report {
   my ( $self, $ea, %opts ) = @_;
   my $stats = $ea->results;
   my @result;

   my $global_cnt = $stats->{globals}->{$opts{worst}}->{cnt};

   my ($qps, $conc) = (0, 0);
   if ( $global_cnt && $stats->{globals}->{ts}
      && ($stats->{globals}->{ts}->{max} || '')
         gt ($stats->{globals}->{ts}->{min} || '')
   ) {
      eval {
         my $min  = parse_timestamp($stats->{globals}->{ts}->{min});
         my $max  = parse_timestamp($stats->{globals}->{ts}->{max});
         my $diff = unix_timestamp($max) - unix_timestamp($min);
         $qps     = $global_cnt / $diff;
         $conc    = $stats->{globals}->{$opts{worst}}->{sum} / $diff;
      };
   }

   my $line = sprintf(
      '# Overall: %s total, %s unique, %s QPS, %sx concurrency ',
      shorten($global_cnt),
      shorten(scalar keys %{$stats->{classes}}),
      shorten($qps),
      shorten($conc));
   $line .= ('_' x (LINE_LENGTH - length($line)));
   push @result, $line;

   my ($format, @headers) = make_header('global');
   push @result, sprintf($format, '', @headers);

   foreach my $attrib ( @{$opts{select}} ) {
      next unless $ea->type_for($attrib);
      if ( $formatting_function{$attrib} ) { # Handle special cases
         push @result, sprintf $format, make_label($attrib),
            $formatting_function{$attrib}->($stats->{globals}->{$attrib}),
            (map { '' } 0..9);# just for good measure
      }
      else {
         my $store = $stats->{globals}->{$attrib};
         my @values;
         if ( $ea->type_for($attrib) eq 'num' ) {
            my $func = $attrib =~ m/time$/ ? \&micro_t : \&shorten;
            MKDEBUG && _d('Calculating global statistical_metrics for', $attrib);
            my $metrics = $ea->calculate_statistical_metrics($store->{all}, $store);
            @values = (
               @{$store}{qw(sum min max)},
               $store->{sum} / $store->{cnt},
               @{$metrics}{qw(pct_95 stddev median)},
            );
            @values = map { defined $_ ? $func->($_) : '' } @values;
         }
         else {
            @values = ('', $store->{min}, $store->{max}, '', '', '', '');
         }
         push @result, sprintf $format, make_label($attrib), @values;
      }
   }

   return join("\n", map { s/\s+$//; $_ } @result) . "\n";
}

sub event_report {
   my ( $self, $ea, %opts ) = @_;
   my $stats = $ea->results;
   my @result;

   my $store = $stats->{classes}->{$opts{where}};
   return "# No such event $opts{where}\n" unless $store;
   my $sample = $stats->{samples}->{$opts{where}};

   my $global_cnt = $stats->{globals}->{$opts{worst}}->{cnt};
   my $class_cnt  = $store->{$opts{worst}}->{cnt};

   my ($qps, $conc) = (0, 0);
   if ( $global_cnt && $store->{ts}
      && ($store->{ts}->{max} || '')
         gt ($store->{ts}->{min} || '')
   ) {
      eval {
         my $min  = parse_timestamp($store->{ts}->{min});
         my $max  = parse_timestamp($store->{ts}->{max});
         my $diff = unix_timestamp($max) - unix_timestamp($min);
         $qps     = $class_cnt / $diff;
         $conc    = $store->{$opts{worst}}->{sum} / $diff;
      };
   }

   my $line = sprintf(
      '# %s %d: %s QPS, %sx concurrency, ID 0x%s at byte %d ',
      ($ea->{groupby} eq 'fingerprint' ? 'Query' : 'Item'),
      $opts{rank} || 0,
      shorten($qps),
      shorten($conc),
      make_checksum($opts{where}),
      $sample->{pos_in_log} || 0);
   $line .= ('_' x (LINE_LENGTH - length($line)));
   push @result, $line;

   if ( $opts{reason} ) {
      push @result, "# This item is included in the report because it matches "
         . ($opts{reason} eq 'top' ? '--limit.' : '--outliers.');
   }

   my ($format, @headers) = make_header();
   push @result, sprintf($format, '', @headers);

   push @result, sprintf
      $format, 'Count', percentage_of($class_cnt, $global_cnt), $class_cnt,
         map { '' } (1 ..9);

   foreach my $attrib ( @{$opts{select}} ) {
      next unless $ea->type_for($attrib);
      my $vals = $store->{$attrib};
      if ( $formatting_function{$attrib} ) { # Handle special cases
         push @result, sprintf $format, make_label($attrib),
            $formatting_function{$attrib}->($vals),
            (map { '' } 0..9);# just for good measure
      }
      else {
         my @values;
         my $pct;
         if ( $ea->type_for($attrib) eq 'num' ) {
            my $func = $attrib =~ m/time$/ ? \&micro_t : \&shorten;
            my $metrics = $ea->calculate_statistical_metrics($vals->{all}, $vals);
            @values = (
               @{$vals}{qw(sum min max)},
               $vals->{sum} / $vals->{cnt},
               @{$metrics}{qw(pct_95 stddev median)},
            );
            @values = map { defined $_ ? $func->($_) : '' } @values;
            $pct = percentage_of($vals->{sum},
               $stats->{globals}->{$attrib}->{sum});
         }
         else {
            @values = ('', $vals->{min}, $vals->{max}, '', '', '', '');
            $pct = 0;
         }
         push @result, sprintf $format, make_label($attrib), $pct, @values;
      }
   }

   return join("\n", map { s/\s+$//; $_ } @result) . "\n";
}

sub chart_distro {
   my ( $self, $ea, %opts ) = @_;
   my $stats = $ea->results;
   my $store = $stats->{classes}->{$opts{where}}->{$opts{attribute}};
   my $vals  = $store->{all};
   return "" unless defined $vals && scalar @$vals;
   my @buck_tens = $ea->buckets_of(10);
   my @distro = map { 0 } (0 .. 7);
   map { $distro[$buck_tens[$_]] += $vals->[$_] } (1 .. @$vals - 1);

   my $max_val = 0;
   my $vals_per_mark; # number of vals represented by 1 #-mark
   my $max_disp_width = 64;
   my $bar_fmt = "# %5s%s";
   my @distro_labels = qw(1us 10us 100us 1ms 10ms 100ms 1s 10s+);
   my @results = "# $opts{attribute} distribution";

   foreach my $n_vals ( @distro ) {
      $max_val = $n_vals if $n_vals > $max_val;
   }
   $vals_per_mark = $max_val / $max_disp_width;

   foreach my $i ( 0 .. $#distro ) {
      my $n_vals = $distro[$i];
      my $n_marks = $n_vals / ($vals_per_mark || 1);
      $n_marks = 1 if $n_marks < 1 && $n_vals > 0;
      my $bar = ($n_marks ? '  ' : '') . '#' x $n_marks;
      push @results, sprintf $bar_fmt, $distro_labels[$i], $bar;
   }

   return join("\n", @results) . "\n";
}

sub make_header {
   my ( $global ) = @_;
   my $format = "# %-9s %6s %7s %7s %7s %7s %7s %7s %7s";
   my @headers = qw(pct total min max avg 95% stddev median);
   if ( $global ) {
      $format =~ s/%(\d+)s/' ' x $1/e;
      shift @headers;
   }
   return $format, @headers;
}

sub make_label {
   my ( $val ) = @_;
   return $val eq 'ts'          ? 'Time range'
         : $val eq 'user'       ? 'Users'
         : $val eq 'db'         ? 'Databases'
         : $val eq 'Query_time' ? 'Exec time'
         : do { $val =~ s/_/ /g; $val = substr($val, 0, 9); $val };
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End QueryReportFormatter package
# ###########################################################################

# ###########################################################################
# EventTimeline package 3539
# ###########################################################################


package EventTimeline;


use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
Transformers->import(qw(parse_timestamp secs_to_time unix_timestamp));

use constant MKDEBUG => $ENV{MKDEBUG};
use constant KEY     => 0;
use constant CNT     => 1;
use constant ATT     => 2;

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(groupby attributes) ) {
      die "I need a $arg argument" unless $args{$arg};
   }

   my %is_groupby = map { $_ => 1 } @{$args{groupby}};

   return bless {
      groupby    => $args{groupby},
      attributes => [ grep { !$is_groupby{$_} } @{$args{attributes}} ],
      results    => [],
   }, $class;
}

sub reset_aggregated_data {
   my ( $self ) = @_;
   $self->{results} = [];
}

sub aggregate {
   my ( $self, $event ) = @_;
   my $handler = $self->{handler};
   if ( !$handler ) {
      $handler = $self->make_handler($event);
      $self->{handler} = $handler;
   }
   return unless $handler;
   $handler->($event);
}

sub results {
   my ( $self ) = @_;
   return $self->{results};
}

sub make_handler {
   my ( $self, $event ) = @_;

   my $float_re = qr{[+-]?(?:(?=\d|[.])\d*(?:[.])\d{0,})?(?:[E](?:[+-]?\d+)|)}i;
   my @lines; # lines of code for the subroutine

   foreach my $attrib ( @{$self->{attributes}} ) {
      my ($val) = $event->{$attrib};
      next unless defined $val; # Can't decide type if it's undef.

      my $type = $val  =~ m/^(?:\d+|$float_re)$/o ? 'num'
               : $val  =~ m/^(?:Yes|No)$/         ? 'bool'
               :                                    'string';
      MKDEBUG && _d('Type for', $attrib, 'is', $type, '(sample:', $val, ')');
      $self->{type_for}->{$attrib} = $type;

      push @lines, (
         "\$val = \$event->{$attrib};",
         'defined $val && do {',
         "# type: $type",
         "\$store = \$last->[ATT]->{$attrib} ||= {};",
      );

      if ( $type eq 'bool' ) {
         push @lines, q{$val = $val eq 'Yes' ? 1 : 0;};
         $type = 'num';
      }
      my $op   = $type eq 'num' ? '<' : 'lt';
      push @lines, (
         '$store->{min} = $val if !defined $store->{min} || $val '
            . $op . ' $store->{min};',
      );
      $op = ($type eq 'num') ? '>' : 'gt';
      push @lines, (
         '$store->{max} = $val if !defined $store->{max} || $val '
            . $op . ' $store->{max};',
      );
      if ( $type eq 'num' ) {
         push @lines, '$store->{sum} += $val;';
      }
      push @lines, '};';
   }

   unshift @lines, (
      'sub {',
      'my ( $event ) = @_;',
      'my ($val, $last, $store);', # NOTE: define all variables here
      '$last = $results->[-1];',
      'if ( !$last || '
         . join(' || ',
            map { "\$last->[KEY]->[$_] ne (\$event->{$self->{groupby}->[$_]} || 0)" }
                (0 .. @{$self->{groupby}} -1))
         . ' ) {',
      '  $last = [['
         . join(', ',
            map { "(\$event->{$self->{groupby}->[$_]} || 0)" }
                (0 .. @{$self->{groupby}} -1))
         . '], 0, {} ];',
      '  push @$results, $last;',
      '}',
      '++$last->[CNT];',
   );
   push @lines, '}';
   my $results = $self->{results}; # Referred to by the eval
   my $code = join("\n", @lines);
   $self->{code} = $code;

   MKDEBUG && _d('Timeline handler:', $code);
   my $sub = eval $code;
   die if $EVAL_ERROR;
   return $sub;
}

sub report {
   my ( $self, $results, $callback ) = @_;
   $callback->("# " . ('#' x 72) . "\n");
   $callback->("# " . join(',', @{$self->{groupby}}) . " report\n");
   $callback->("# " . ('#' x 72) . "\n");
   foreach my $res ( @$results ) {
      my $t;
      my @vals;
      if ( ($t = $res->[ATT]->{ts}) && $t->{min} ) {
         my $min = parse_timestamp($t->{min});
         push @vals, $min;
         if ( $t->{max} && $t->{max} gt $t->{min} ) {
            my $max  = parse_timestamp($t->{max});
            my $diff = secs_to_time(unix_timestamp($max) - unix_timestamp($min));
            push @vals, $diff;
         }
         else {
            push @vals, '0:00';
         }
      }
      else {
         push @vals, ('', '');
      }
      $callback->(sprintf("# %19s %7s %3d %s\n", @vals, $res->[CNT], $res->[KEY]->[0]));
   }
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End EventTimeline package
# ###########################################################################

# ###########################################################################
# QueryParser package 3637
# ###########################################################################
package QueryParser;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};
our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/;
our $tbl_regex = qr{
         \b(?:FROM|JOIN|(?<!KEY\s)UPDATE|INTO) # Words that precede table names
         \b\s*
         ($tbl_ident
            (?: (?:\s+ (?:AS\s+)? \w+)?, \s*$tbl_ident )*
         )
      }xio;
our $has_derived = qr{
      \b(?:FROM|JOIN|,)
      \s*\(\s*SELECT
   }xi;

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

sub get_tables {
   my ( $self, $query ) = @_;
   return unless $query;
   MKDEBUG && _d('Getting tables for', $query);

   $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;

   $query =~ s/\\["']//g;                # quoted strings
   $query =~ s/".*?"/?/sg;               # quoted strings
   $query =~ s/'.*?'/?/sg;               # quoted strings

   my @tables;
   foreach my $tbls ( $query =~ m/$tbl_regex/gio ) {
      MKDEBUG && _d('Match tables:', $tbls);
      foreach my $tbl ( split(',', $tbls) ) {
         $tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio;
         push @tables, $tbl;
      }
   }
   return @tables;
}

sub has_derived_table {
   my ( $self, $query ) = @_;
   my $match = $query =~ m/$has_derived/;
   MKDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table');
   return $match;
}

sub get_aliases {
   my ( $self, $query ) = @_;
   return unless $query;
   my $aliases;

   $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;

   $query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig;

   my ($tbl_refs, $from) = $query =~ m{
      (
         (FROM|INTO|UPDATE)\b\s*   # Keyword before table refs
         .+?                       # Table refs
      )
      (?:\s+|\z)                   # If the query does not end with the table
      (?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs
   }ix;

   die "Failed to parse table references from $query"
      unless $tbl_refs && $from;

   MKDEBUG && _d('tbl refs:', $tbl_refs);

   my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i;

   my $after_tbl  = qr/(?:,|JOIN|ON|USING|\z)/i;

   $tbl_refs =~ s/ = /=/g;

   while (
      $tbl_refs =~ m{
         $before_tbl\b\s*
            ( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? )
         \s*$after_tbl
      }xgio )
   {
      my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3);
      MKDEBUG && _d('Match table:', $tbl_ref);

      if ( $tbl_ref =~ m/^AS\s+\w+/i ) {
         MKDEBUG && _d('Subquery', $tbl_ref);
         $aliases->{$alias} = undef;
         next;
      }

      my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/;
      $aliases->{$alias || $tbl} = $tbl;
      $aliases->{DATABASE}->{$tbl} = $db if $db;
   }
   return $aliases;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End QueryParser package
# ###########################################################################

# ###########################################################################
# MySQLDump package 3312
# ###########################################################################
package MySQLDump;

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

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

( our $before = <<'EOF') =~ s/^   //gm;
   /*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;
   /*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */;
   /*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */;
   /*!40101 SET NAMES utf8 */;
   /*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */;
   /*!40103 SET TIME_ZONE='+00:00' */;
   /*!40014 SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0 */;
   /*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;
   /*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */;
   /*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;
EOF

( our $after = <<'EOF') =~ s/^   //gm;
   /*!40103 SET TIME_ZONE=@OLD_TIME_ZONE */;
   /*!40101 SET SQL_MODE=@OLD_SQL_MODE */;
   /*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */;
   /*!40014 SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS */;
   /*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;
   /*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */;
   /*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */;
   /*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */;
EOF

sub new {
   my ( $class, %args ) = @_;
   $args{cache} = 1 unless defined $args{cache};
   my $self = bless \%args, $class;
   return $self;
}

sub dump {
   my ( $self, $dbh, $quoter, $db, $tbl, $what ) = @_;

   if ( $what eq 'table' ) {
      my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
      if ( $ddl->[0] eq 'table' ) {
         return $before
            . 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
            . $ddl->[1] . ";\n";
      }
      else {
         return 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
            . '/*!50001 DROP VIEW IF EXISTS '
            . $quoter->quote($tbl) . "*/;\n/*!50001 "
            . $self->get_tmp_table($dbh, $quoter, $db, $tbl) . "*/;\n";
      }
   }
   elsif ( $what eq 'triggers' ) {
      my $trgs = $self->get_triggers($dbh, $quoter, $db, $tbl);
      if ( $trgs && @$trgs ) {
         my $result = $before . "\nDELIMITER ;;\n";
         foreach my $trg ( @$trgs ) {
            if ( $trg->{sql_mode} ) {
               $result .= qq{/*!50003 SET SESSION SQL_MODE='$trg->{sql_mode}' */;;\n};
            }
            $result .= "/*!50003 CREATE */ ";
            if ( $trg->{definer} ) {
               my ( $user, $host )
                  = map { s/'/''/g; "'$_'"; }
                    split('@', $trg->{definer}, 2);
               $result .= "/*!50017 DEFINER=$user\@$host */ ";
            }
            $result .= sprintf("/*!50003 TRIGGER %s %s %s ON %s\nFOR EACH ROW %s */;;\n\n",
               $quoter->quote($trg->{trigger}),
               @{$trg}{qw(timing event)},
               $quoter->quote($trg->{table}),
               $trg->{statement});
         }
         $result .= "DELIMITER ;\n\n/*!50003 SET SESSION SQL_MODE=\@OLD_SQL_MODE */;\n\n";
         return $result;
      }
      else {
         return undef;
      }
   }
   elsif ( $what eq 'view' ) {
      my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
      return '/*!50001 DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
         . '/*!50001 DROP VIEW IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
         . '/*!50001 ' . $ddl->[1] . "*/;\n";
   }
   else {
      die "You didn't say what to dump.";
   }
}

sub _use_db {
   my ( $self, $dbh, $quoter, $new ) = @_;
   if ( !$new ) {
      MKDEBUG && _d('No new DB to use');
      return;
   }
   my $sql = 'SELECT DATABASE()';
   MKDEBUG && _d($sql);
   my $curr = $dbh->selectrow_array($sql);
   if ( $curr && $new && $curr eq $new ) {
      MKDEBUG && _d('Current and new DB are the same');
      return $curr;
   }
   $sql = 'USE ' . $quoter->quote($new);
   MKDEBUG && _d($sql);
   $dbh->do($sql);
   return $curr;
}

sub get_create_table {
   my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
   if ( !$self->{cache} || !$self->{tables}->{$db}->{$tbl} ) {
      my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
         . q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
         . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
         . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
      MKDEBUG && _d($sql);
      eval { $dbh->do($sql); };
      MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
      my $curr_db = $self->_use_db($dbh, $quoter, $db);
      $sql = "SHOW CREATE TABLE " . $quoter->quote($db, $tbl);
      MKDEBUG && _d($sql);
      my $href = $dbh->selectrow_hashref($sql);
      $self->_use_db($dbh, $quoter, $curr_db);
      $sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
         . '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
      MKDEBUG && _d($sql);
      $dbh->do($sql);
      my ($key) = grep { m/create table/i } keys %$href;
      if ( $key ) {
         MKDEBUG && _d('This table is a base table');
         $self->{tables}->{$db}->{$tbl} = [ 'table', $href->{$key} ];
      }
      else {
         MKDEBUG && _d('This table is a view');
         ($key) = grep { m/create view/i } keys %$href;
         $self->{tables}->{$db}->{$tbl} = [ 'view', $href->{$key} ];
      }
   }
   return $self->{tables}->{$db}->{$tbl};
}

sub get_columns {
   my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
   MKDEBUG && _d('Get columns for', $db, $tbl);
   if ( !$self->{cache} || !$self->{columns}->{$db}->{$tbl} ) {
      my $curr_db = $self->_use_db($dbh, $quoter, $db);
      my $sql = "SHOW COLUMNS FROM " . $quoter->quote($db, $tbl);
      MKDEBUG && _d($sql);
      my $cols = $dbh->selectall_arrayref($sql, { Slice => {} });
      $self->_use_db($dbh, $quoter, $curr_db);
      $self->{columns}->{$db}->{$tbl} = [
         map {
            my %row;
            @row{ map { lc $_ } keys %$_ } = values %$_;
            \%row;
         } @$cols
      ];
   }
   return $self->{columns}->{$db}->{$tbl};
}

sub get_tmp_table {
   my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
   my $result = 'CREATE TABLE ' . $quoter->quote($tbl) . " (\n";
   $result .= join(",\n",
      map { '  ' . $quoter->quote($_->{field}) . ' ' . $_->{type} }
      @{$self->get_columns($dbh, $quoter, $db, $tbl)});
   $result .= "\n)";
   MKDEBUG && _d($result);
   return $result;
}

sub get_triggers {
   my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
   if ( !$self->{cache} || !$self->{triggers}->{$db} ) {
      $self->{triggers}->{$db} = {};
      my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
         . q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
         . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
         . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
      MKDEBUG && _d($sql);
      eval { $dbh->do($sql); };
      MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
      $sql = "SHOW TRIGGERS FROM " . $quoter->quote($db);
      MKDEBUG && _d($sql);
      my $sth = $dbh->prepare($sql);
      $sth->execute();
      if ( $sth->rows ) {
         my $trgs = $sth->fetchall_arrayref({});
         foreach my $trg (@$trgs) {
            my %trg;
            @trg{ map { lc $_ } keys %$trg } = values %$trg;
            push @{ $self->{triggers}->{$db}->{ $trg{table} } }, \%trg;
         }
      }
      $sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
         . '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
      MKDEBUG && _d($sql);
      $dbh->do($sql);
   }
   if ( $tbl ) {
      return $self->{triggers}->{$db}->{$tbl};
   }
   return values %{$self->{triggers}->{$db}};
}

sub get_databases {
   my ( $self, $dbh, $quoter, $like ) = @_;
   if ( !$self->{cache} || !$self->{databases} || $like ) {
      my $sql = 'SHOW DATABASES';
      my @params;
      if ( $like ) {
         $sql .= ' LIKE ?';
         push @params, $like;
      }
      my $sth = $dbh->prepare($sql);
      MKDEBUG && _d($sql, @params);
      $sth->execute( @params );
      my @dbs = map { $_->[0] } @{$sth->fetchall_arrayref()};
      $self->{databases} = \@dbs unless $like;
      return @dbs;
   }
   return @{$self->{databases}};
}

sub get_table_status {
   my ( $self, $dbh, $quoter, $db, $like ) = @_;
   if ( !$self->{cache} || !$self->{table_status}->{$db} || $like ) {
      my $sql = "SHOW TABLE STATUS FROM " . $quoter->quote($db);
      my @params;
      if ( $like ) {
         $sql .= ' LIKE ?';
         push @params, $like;
      }
      MKDEBUG && _d($sql, @params);
      my $sth = $dbh->prepare($sql);
      $sth->execute(@params);
      my @tables = @{$sth->fetchall_arrayref({})};
      @tables = map {
         my %tbl; # Make a copy with lowercased keys
         @tbl{ map { lc $_ } keys %$_ } = values %$_;
         $tbl{engine} ||= $tbl{type} || $tbl{comment};
         delete $tbl{type};
         \%tbl;
      } @tables;
      $self->{table_status}->{$db} = \@tables unless $like;
      return @tables;
   }
   return @{$self->{table_status}->{$db}};
}

sub get_table_list {
   my ( $self, $dbh, $quoter, $db, $like ) = @_;
   if ( !$self->{cache} || !$self->{table_list}->{$db} || $like ) {
      my $sql = "SHOW /*!50002 FULL*/ TABLES FROM " . $quoter->quote($db);
      my @params;
      if ( $like ) {
         $sql .= ' LIKE ?';
         push @params, $like;
      }
      MKDEBUG && _d($sql, @params);
      my $sth = $dbh->prepare($sql);
      $sth->execute(@params);
      my @tables = @{$sth->fetchall_arrayref()};
      @tables = map {
         my %tbl = (
            name   => $_->[0],
            engine => ($_->[1] || '') eq 'VIEW' ? 'VIEW' : '',
         );
         \%tbl;
      } @tables;
      $self->{table_list}->{$db} = \@tables unless $like;
      return @tables;
   }
   return @{$self->{table_list}->{$db}};
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End MySQLDump package
# ###########################################################################

# ###########################################################################
# TableParser package 3475
# ###########################################################################
package TableParser;

use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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


sub parse {
   my ( $self, $ddl, $opts ) = @_;

   if ( ref $ddl eq 'ARRAY' ) {
      if ( lc $ddl->[0] eq 'table' ) {
         $ddl = $ddl->[1];
      }
      else {
         return {
            engine => 'VIEW',
         };
      }
   }

   if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
      die "Cannot parse table definition; is ANSI quoting "
         . "enabled or SQL_QUOTE_SHOW_CREATE disabled?";
   }

   $ddl =~ s/(`[^`]+`)/\L$1/g;

   my $engine = $self->get_engine($ddl);

   my @defs   = $ddl =~ m/^(\s+`.*?),?$/gm;
   my @cols   = map { $_ =~ m/`([^`]+)`/ } @defs;
   MKDEBUG && _d('Columns:', join(', ', @cols));

   my %def_for;
   @def_for{@cols} = @defs;

   my (@nums, @null);
   my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
   foreach my $col ( @cols ) {
      my $def = $def_for{$col};
      my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
      die "Can't determine column type for $def" unless $type;
      $type_for{$col} = $type;
      if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
         push @nums, $col;
         $is_numeric{$col} = 1;
      }
      if ( $def !~ m/NOT NULL/ ) {
         push @null, $col;
         $is_nullable{$col} = 1;
      }
      $is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
   }

   my $keys = $self->get_keys($ddl, $opts, \%is_nullable);

   return {
      cols           => \@cols,
      col_posn       => { map { $cols[$_] => $_ } 0..$#cols },
      is_col         => { map { $_ => 1 } @cols },
      null_cols      => \@null,
      is_nullable    => \%is_nullable,
      is_autoinc     => \%is_autoinc,
      keys           => $keys,
      defs           => \%def_for,
      numeric_cols   => \@nums,
      is_numeric     => \%is_numeric,
      engine         => $engine,
      type_for       => \%type_for,
   };
}

sub sort_indexes {
   my ( $self, $tbl ) = @_;

   my @indexes
      = sort {
         (($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
         || ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
         || ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
         || ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
      }
      grep {
         $tbl->{keys}->{$_}->{type} eq 'BTREE'
      }
      sort keys %{$tbl->{keys}};

   MKDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
   return @indexes;
}

sub find_best_index {
   my ( $self, $tbl, $index ) = @_;
   my $best;
   if ( $index ) {
      ($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
   }
   if ( !$best ) {
      if ( $index ) {
         die "Index '$index' does not exist in table";
      }
      else {
         ($best) = $self->sort_indexes($tbl);
      }
   }
   MKDEBUG && _d('Best index found is', $best);
   return $best;
}

sub find_possible_keys {
   my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
   return () unless $where;
   my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
      . ' WHERE ' . $where;
   MKDEBUG && _d($sql);
   my $expl = $dbh->selectrow_hashref($sql);
   $expl = { map { lc($_) => $expl->{$_} } keys %$expl };
   if ( $expl->{possible_keys} ) {
      MKDEBUG && _d('possible_keys =', $expl->{possible_keys});
      my @candidates = split(',', $expl->{possible_keys});
      my %possible   = map { $_ => 1 } @candidates;
      if ( $expl->{key} ) {
         MKDEBUG && _d('MySQL chose', $expl->{key});
         unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
         MKDEBUG && _d('Before deduping:', join(', ', @candidates));
         my %seen;
         @candidates = grep { !$seen{$_}++ } @candidates;
      }
      MKDEBUG && _d('Final list:', join(', ', @candidates));
      return @candidates;
   }
   else {
      MKDEBUG && _d('No keys in possible_keys');
      return ();
   }
}

sub table_exists {
   my ( $self, $dbh, $db, $tbl, $q, $can_insert ) = @_;
   my $result = 0;
   my $db_tbl = $q->quote($db, $tbl);
   my $sql    = "SHOW FULL COLUMNS FROM $db_tbl";
   MKDEBUG && _d($sql);
   eval {
      my $sth = $dbh->prepare($sql);
      $sth->execute();
      my @columns = @{$sth->fetchall_arrayref({})};
      if ( $can_insert ) {
         $result = grep { ($_->{Privileges} || '') =~ m/insert/ } @columns;
      }
      else {
         $result = 1;
      }
   };
   if ( MKDEBUG && $EVAL_ERROR ) {
      _d($EVAL_ERROR);
   }
   return $result;
}

sub get_engine {
   my ( $self, $ddl, $opts ) = @_;
   my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
   MKDEBUG && _d('Storage engine:', $engine);
   return $engine || undef;
}

sub get_keys {
   my ( $self, $ddl, $opts, $is_nullable ) = @_;
   my $engine = $self->get_engine($ddl);
   my $keys   = {};

   KEY:
   foreach my $key ( $ddl =~ m/^  ((?:[A-Z]+ )?KEY .*)$/gm ) {

      next KEY if $key =~ m/FOREIGN/;

      MKDEBUG && _d('Parsed key:', $key);

      if ( $engine !~ m/MEMORY|HEAP/ ) {
         $key =~ s/USING HASH/USING BTREE/;
      }

      my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
      my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
      $type = $type || $special || 'BTREE';
      if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000'
         && $engine =~ m/HEAP|MEMORY/i )
      {
         $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP
      }

      my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
      my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
      my @cols;
      my @col_prefixes;
      foreach my $col_def ( split(',', $cols) ) {
         my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
         push @cols, $name;
         push @col_prefixes, $prefix;
      }
      $name =~ s/`//g;

      MKDEBUG && _d('Key', $name, 'cols:', join(', ', @cols));

      $keys->{$name} = {
         name         => $name,
         type         => $type,
         colnames     => $cols,
         cols         => \@cols,
         col_prefixes => \@col_prefixes,
         is_unique    => $unique,
         is_nullable  => scalar(grep { $is_nullable->{$_} } @cols),
         is_col       => { map { $_ => 1 } @cols },
      };
   }

   return $keys;
}

sub get_fks {
   my ( $self, $ddl, $opts ) = @_;
   my $fks = {};

   foreach my $fk (
      $ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
   {
      my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
      my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
      my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;

      if ( $parent !~ m/\./ && $opts->{database} ) {
         $parent = "`$opts->{database}`.$parent";
      }

      $fks->{$name} = {
         name           => $name,
         colnames       => $cols,
         cols           => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
         parent_tbl     => $parent,
         parent_colnames=> $parent_cols,
         parent_cols    => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
      };
   }

   return $fks;
}

sub remove_auto_increment {
   my ( $self, $ddl ) = @_;
   $ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
   return $ddl;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End TableParser package
# ###########################################################################

# ###########################################################################
# QueryReview package 3277
# ###########################################################################

package QueryReview;


use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
Transformers->import(qw(make_checksum parse_timestamp));

use Data::Dumper;

use constant MKDEBUG => $ENV{MKDEBUG};

my %basic_cols = map { $_ => 1 }
   qw(checksum fingerprint sample first_seen last_seen reviewed_by
      reviewed_on comments);
my %skip_cols  = map { $_ => 1 } qw(fingerprint sample checksum);

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(dbh db_tbl tbl_struct quoter) ) {
      die "I need a $arg argument" unless $args{$arg};
   }

   foreach my $col ( keys %basic_cols ) {
      die "Query review table $args{db_tbl} does not have a $col column"
         unless $args{tbl_struct}->{is_col}->{$col};
   }

   my $now = defined $args{ts_default} ? $args{ts_default} : 'NOW()';

   my $sql = <<"      SQL";
      INSERT INTO $args{db_tbl}
      (checksum, fingerprint, sample, first_seen, last_seen)
      VALUES(CONV(?, 16, 10), ?, ?, COALESCE(?, $now), COALESCE(?, $now))
      ON DUPLICATE KEY UPDATE
         first_seen = IF(
            first_seen IS NULL,
            COALESCE(?, $now),
            LEAST(first_seen, COALESCE(?, $now))),
         last_seen = IF(
            last_seen IS NULL,
            COALESCE(?, $now),
            GREATEST(last_seen, COALESCE(?, $now)))
      SQL
   MKDEBUG && _d('SQL to insert into review table:', $sql);
   my $insert_sth = $args{dbh}->prepare($sql);

   my @review_cols = grep { !$skip_cols{$_} } @{$args{tbl_struct}->{cols}};
   $sql = "SELECT "
        . join(', ', map { $args{quoter}->quote($_) } @review_cols)
        . ", CONV(checksum, 10, 16) AS checksum_conv FROM $args{db_tbl}"
        . " WHERE checksum=CONV(?, 16, 10)";
   MKDEBUG && _d('SQL to select from review table:', $sql);
   my $select_sth = $args{dbh}->prepare($sql);

   my $self = {
      dbh         => $args{dbh},
      db_tbl      => $args{db_tbl},
      insert_sth  => $insert_sth,
      select_sth  => $select_sth,
      tbl_struct  => $args{tbl_struct},
      quoter      => $args{quoter},
      ts_default  => $now,
   };
   return bless $self, $class;
}

sub set_history_options {
   my ( $self, %args ) = @_;
   foreach my $arg ( qw(table dbh tbl_struct col_pat) ) {
      die "I need a $arg argument" unless $args{$arg};
   }

   my @cols;
   my @metrics;
   foreach my $col ( @{$args{tbl_struct}->{cols}} ) {
      my ( $attr, $metric ) = $col =~ m/$args{col_pat}/;
      next unless $attr && $metric;
      $attr = ucfirst $attr if $attr =~ m/_/; # TableParser lowercases
      push @cols, $col;
      push @metrics, [$attr, $metric];
   }

   my $sql = "REPLACE INTO $args{table}("
      . join(', ',
         map { $self->{quoter}->quote($_) } ('checksum', 'sample', @cols))
      . ') VALUES (CONV(?, 16, 10), ?, '
      . join(', ', map {
         $_ eq 'ts_min' || $_ eq 'ts_max'
            ? "COALESCE(?, $self->{ts_default})"
            : '?'
        } @cols) . ')';
   MKDEBUG && _d($sql);

   $self->{history_sth}     = $args{dbh}->prepare($sql);
   $self->{history_cols}    = \@cols;
   $self->{history_metrics} = \@metrics;
}

sub set_review_history {
   my ( $self, $id, $sample, %data ) = @_;
   foreach my $thing ( qw(min max) ) {
      next unless defined $data{ts} && defined $data{ts}->{$thing};
      $data{ts}->{$thing} = parse_timestamp($data{ts}->{$thing});
   }
   $self->{history_sth}->execute(
      make_checksum($id),
      $sample,
      map { $data{$_->[0]}->{$_->[1]} } @{$self->{history_metrics}});
}

sub get_review_info {
   my ( $self, $id ) = @_;
   $self->{select_sth}->execute(make_checksum($id));
   my $review_vals = $self->{select_sth}->fetchall_arrayref({});
   if ( $review_vals && @$review_vals == 1 ) {
      return $review_vals->[0];
   }
   return undef;
}

sub set_review_info {
   my ( $self, %args ) = @_;
   $self->{insert_sth}->execute(
      make_checksum($args{fingerprint}),
      @args{qw(fingerprint sample)},
      map { $args{$_} ? parse_timestamp($args{$_}) : undef }
         qw(first_seen last_seen first_seen first_seen last_seen last_seen));
}

sub review_cols {
   my ( $self ) = @_;
   return grep { !$skip_cols{$_} } @{$self->{tbl_struct}->{cols}};
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;
# ###########################################################################
# End QueryReview package
# ###########################################################################

# ###########################################################################
# Daemon package 3647
# ###########################################################################

package Daemon;

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

use POSIX qw(setsid);
use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(o) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my $o = $args{o};
   my $self = {
      o        => $o,
      log_file => $o->has('log') ? $o->get('log') : undef,
      PID_file => $o->has('pid') ? $o->get('pid') : undef,
   };

   if ( $self->{PID_file} && -f $self->{PID_file} ) {
      die "The PID file $self->{PID_file} already exists"
   }

   MKDEBUG && _d('Daemonized child will log to', $self->{log_file});
   return bless $self, $class;
}

sub daemonize {
   my ( $self ) = @_;

   MKDEBUG && _d('About to fork and daemonize');
   defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
   if ( $pid ) {
      MKDEBUG && _d('I am the parent and now I die');
      exit;
   }

   $self->{child} = 1;

   POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
   chdir '/'       or die "Cannot chdir to /: $OS_ERROR";

   $self->_make_PID_file();

   if ( -t STDIN ) {
      open STDIN, '/dev/null'
         or die "Cannot reopen STDIN to /dev/null";
   }

   if ( $self->{log_file} ) {
      open STDOUT, '>>', $self->{log_file}
         or die "Cannot open log file $self->{log_file}: $OS_ERROR";
      open STDERR, ">&STDOUT"
         or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
   }

   MKDEBUG && _d('I am the child and now I live daemonized');
   return;
}

sub make_PID_file {
   my ( $self ) = @_;
   if ( exists $self->{child} ) {
      die "Do not call Daemon::make_PID_file() for daemonized scripts";
   }
   $self->_make_PID_file();
   $self->{rm_PID_file} = 1;
   return;
}

sub _make_PID_file {
   my ( $self ) = @_;

   my $PID_file = $self->{PID_file};
   if ( !$PID_file ) {
      MKDEBUG && _d('No PID file to create');
      return;
   }

   if ( -f $self->{PID_file} ) {
      die "The PID file $self->{PID_file} already exists"
   }

   open my $PID_FH, '>', $PID_file
      or die "Cannot open PID file $PID_file: $OS_ERROR";
   print $PID_FH $PID
      or die "Cannot print to PID file $PID_file: $OS_ERROR";
   close $PID_FH
      or die "Cannot close PID file $PID_file: $OS_ERROR";

   MKDEBUG && _d('Created PID file:', $self->{PID_file});
   return;
}

sub _remove_PID_file {
   my ( $self ) = @_;
   if ( $self->{PID_file} && -f $self->{PID_file} ) {
      unlink $self->{PID_file}
         or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
      MKDEBUG && _d('Removed PID file');
   }
   else {
      MKDEBUG && _d('No PID to remove');
   }
   return;
}

sub DESTROY {
   my ( $self ) = @_;
   $self->_remove_PID_file() if $self->{child} || $self->{rm_PID_file};
   return;
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

1;

# ###########################################################################
# End Daemon package
# ###########################################################################

# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package mk_query_digest;

# TODO: sort by ninetyfive, stddev and med.
# TODO: reverse sorting.
# TODO: sort by expressions like Rows_sent/Rows_examined

use English qw(-no_match_vars);
use Time::Local qw(timelocal);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$OUTPUT_AUTOFLUSH     = 1;

Transformers->import(qw(shorten micro_t percentage_of ts make_checksum));

use constant MKDEBUG => $ENV{MKDEBUG};

# TODO: use sigtrap
$SIG{INT} = \&sig_int;

# Global variables.  Only really essential variables should be here.
my $oktorun = 1;
my $dp = new DSNParser (
   { key => 'D', copy => 1, desc => 'Database that contains the query review table' },
   { key => 't', desc => 'Table to use as the query review table' } );
$dp->prop('autokey', 'h');
my $q  = new Quoter();
my $qp = new QueryParser();
my $qr = new QueryRewriter(QueryParser=>$qp);
my $qv;      # QueryReview
my $qv_dbh;  # For QueryReview
my $qv_dbh2; # For QueryReview and --review-history
my $ex_dbh;  # For --execute
my $ep_dbh;  # For --explain
my $ps_dbh;  # For Processlist
my %ea;      # EventAggregators

sub main {
   @ARGV = @_;  # set global ARGV for this package

   # ##########################################################################
   # Get configuration information.
   # ##########################################################################
   my $o = new OptionParser(
      strict      => 0,
      dp          => $dp,
      prompt      => '[OPTION...] [FILE]',
      description => q{parses and analyzes MySQL log files.  With no }
                   . q{FILE, or when FILE is -, read standard input.},
   );
   $o->get_specs();
   $o->get_opts();

   # Frequently used options.
   my $review_dsn = $o->get('review'); 
   my $report     = $o->get('report');
   my $timeline   = $o->get('timeline');
   my $groupby    = $o->get('group-by');
   my $orderby    = $o->get('order-by');

   if ( !$o->get('help') ) {
      if ( $review_dsn
           && (!defined $review_dsn->{D} || !defined $review_dsn->{t}) ) {
         $o->save_error('The --review DSN requires a D (database) and t"
            . " (table) part specifying the query review table');
      }
      if ( $o->get('mirror')
           && (!$o->get('execute') || !$o->get('processlist')) ) {
         $o->save_error('--mirror requires --execute and --processlist');
      }
      if ( $o->get('outliers')
         && grep { $_ !~ m/^\w+:[0-9.]+(?::[0-9.]+)?$/ } @{$o->get('outliers')}
      ) {
         $o->save_error('--outliers requires two or three colon-separated fields');
      }
   }

   # --report and --timeline cascade to --group-by which cascades to --order-by.
   foreach my $r ( @$report, @{$timeline} ) {
      if ( !grep { $_ eq $r } @$groupby ) {
         push @$groupby, $r;
      }
   }
   foreach my $i ( 1 .. @$groupby - 1 ) {
      $orderby->[$i] ||= $orderby->[0];
   }

   $o->usage_or_errors();

   # ########################################################################
   # Set up for --explain
   # ########################################################################
   if ( $o->get('explain') ) {
      $ep_dbh = $dp->get_dbh(
         $dp->get_cxn_params($o->get('explain')), {AutoCommit => 1});
   }

   # ########################################################################
   # Set up for --review and --review-history.
   # ########################################################################
   if ( $review_dsn ) {
      my $tp  = new TableParser();
      my $du  = new MySQLDump();
      $qv_dbh = $dp->get_dbh(
         $dp->get_cxn_params($review_dsn), {AutoCommit => 1});
      my @db_tbl = @{$review_dsn}{qw(D t)};
      my $db_tbl = $q->quote(@db_tbl);

      # Create the review table if desired
      if ( $o->get('create-review-table') ) {
         my $sql = $o->read_para_after(
            __FILE__, qr/MAGIC_create_review/);
         $sql =~ s/query_review/IF NOT EXISTS $db_tbl/;
         MKDEBUG && _d($sql);
         $qv_dbh->do($sql);
      }

      # Check for existence and the permissions to insert into the
      # table.
      if ( !$tp->table_exists($qv_dbh, @db_tbl, $q, 1) ) {
         die "The query review table $db_tbl "
            . "does not exist or you do not have INSERT privileges";
      }

      # Set up the new QueryReview object.
      my $struct = $tp->parse($du->get_create_table($qv_dbh, $q, @db_tbl));
      $qv = new QueryReview(
         dbh         => $qv_dbh,
         db_tbl      => $db_tbl,
         tbl_struct  => $struct,
         quoter      => $q,
      );

      # Set up the review-history table
      if ( $o->get('review-history') ) {
         $qv_dbh2 = $dp->get_dbh(
            $dp->get_cxn_params($o->get('review-history')), {AutoCommit => 1});
         my @hdb_tbl = @{$o->get('review-history')}{qw(D t)};
         my $hdb_tbl = $q->quote(@hdb_tbl);

         # Create the review-history table if desired
         if ( $o->get('create-review-history-table') ) {
            my $sql = $o->read_para_after(
               __FILE__, qr/MAGIC_create_review_history/);
            $sql =~ s/query_review_history/IF NOT EXISTS $hdb_tbl/;
            MKDEBUG && _d($sql);
            $qv_dbh2->do($sql);
         }

         # Check for existence and the permissions to insert into the
         # table.
         if ( !$tp->table_exists($qv_dbh2, @hdb_tbl, $q, 1) ) {
            die "The query review history table $hdb_tbl "
               . "does not exist or you do not have INSERT privileges";
         }

         # Inspect for MAGIC_history_cols.  Add them to the --select list.
         my $tbl = $tp->parse($du->get_create_table($qv_dbh2, $q, @hdb_tbl));
         my $pat = $o->read_para_after(__FILE__, qr/MAGIC_history_cols/);
         $pat    =~ s/\s+//g;
         $pat    = qr/^(.*?)_($pat)$/;
         my %select = map { $_ => 1 } @{$o->get('select')};
         foreach my $col ( @{$tbl->{cols}} ) {
            my ( $attr, $metric ) = $col =~ m/$pat/;
            next unless $attr && $metric;
            # TODO: should we add info to TableParser to retrieve the original
            # lettercase of column names when it matters?  If so, fix
            # QueryReview also.
            $attr = ucfirst $attr if $attr =~ m/_/; # TableParser lowercases
            $select{$attr}++;
         }
         $o->set('select', [keys %select]);
         MKDEBUG && _d("--select value after parsing --review-history table:", 
            @{$o->get('select')});

         # And tell the QueryReview that it has more work to do.
         $qv->set_history_options(
            table      => $hdb_tbl,
            dbh        => $qv_dbh2,
            tbl_struct => $tbl,
            col_pat    => $pat,
         );
      }
   }
   
   # ########################################################################
   # Set up an array of callbacks to filter and transform events.  The first
   # one should add the fingerprint to the event (except if we're parsing
   # tcpdump output; see below).  After that, callbacks can do anything, as
   # long as they return the event (failing to return the event terminates
   # the chain).
   # ########################################################################
   my @callbacks;

   my $mysql_proto;
   if ( $o->get('type') eq 'tcpdump' ) {
      # If we're parsing tcpdump output, we'll create a TcpdumpParser
      # obj later, but first we need a callback for MySQLProtocolParser
      # which will make events out of the tcpdump data.  This callback
      # must be first because it creates the events for subsequent callbacks.
      $mysql_proto = new MySQLProtocolParser(
         server => $o->get('watch-server'),
      );
      push @callbacks, sub {
         # Returns an event only when one is ready (it takes a few
         # packets to make an event).
         return $mysql_proto->parse_packet(@_);
      };
   }

   if ( grep { $_ eq 'fingerprint' } @$groupby ) {
      push @callbacks, sub {
         my ( $event ) = @_;
         # Skip events which do not have the group_by attribute.
         my $group_by_val = $event->{arg};
         return 0 unless defined $group_by_val;
         $event->{fingerprint} = $qr->fingerprint($group_by_val);
         return $event;
      };
   }

   if ( $o->get('print') ) {
      my $w = new SlowLogWriter();
      push @callbacks, sub {
         my ( $event ) = @_;
         $w->write(*STDOUT, $event);
         return $event;
      };
   }

   if ( grep { $_ eq 'tables' } @$groupby ) {
      push @callbacks, sub {
         my ( $event ) = @_;
         my $group_by_val = $event->{arg};
         return 0 unless defined $group_by_val;
         $event->{tables} = [
            map {
               # Canonicalize and add the db name in front
               $_ =~ s/`//g;
               if ($_ !~ m/\./ && (my $db = $event->{db} || $event->{Schema})) {
                  $_ = "$db.$_";
               }
               $_;
            }
            $qp->get_tables($group_by_val)
         ];
         return $event;
      };
   }

   if ( grep { $_ eq 'distill' } @$groupby ) {
      push @callbacks, sub {
         my ( $event ) = @_;
         my $group_by_val = $event->{arg};
         return 0 unless defined $group_by_val;
         $event->{distill} = $qr->distill($group_by_val);
         MKDEBUG && !$event->{distill} && _d('Cannot distill', $event->{arg});
         return $event;
      };
   }

   if ( $o->get('filter') ) {
      my $filter = $o->get('filter');
      my $code   = "sub{ my(\$event) = shift; $filter && return \$event; };";
      MKDEBUG && _d('--filter code:', $code);
      my $sub = eval $code or die;
      push @callbacks, $sub;
   }

   if ( $o->get('execute') ) {
      require Time::HiRes;
      my $cur_server = 'execute';
      ($cur_server, $ex_dbh) = find_role($o, $ex_dbh, $cur_server,
            1, 'for --execute');
      my $cur_time = Time::HiRes::time();
      my $curdb;
      push @callbacks, sub {
         my ( $event ) = @_;
         my $db = $event->{db};
         eval {
            if ( $db && (!$curdb || $db ne $curdb) ) {
               $ex_dbh->do("USE $db");
               $curdb = $db;
            }
            my $start = Time::HiRes::time();
            $ex_dbh->do($event->{arg}); # TODO: only if it's a cmd=Query event
            my $end = Time::HiRes::time();
            if ( $o->get('mirror') && $end - $cur_time > $o->get('mirror') ) {
               ($cur_server, $ex_dbh) = find_role($o, $ex_dbh, $cur_server,
                     1, 'for --execute');
               $cur_time = $end;
            }
            $event->{Query_time} = $end - $start;
         };
         # Don't try to re-execute the statement.  Just skip it.
         if ( $EVAL_ERROR && $EVAL_ERROR =~ m/server has gone away/ ) {
            print STDERR $EVAL_ERROR;
            eval {
               ($cur_server, $ex_dbh) = find_role($o, $ex_dbh, $cur_server,
                     1, 'for --execute');
               $cur_time = Time::HiRes::time();
            };
            if ( $EVAL_ERROR ) {
               print STDERR $EVAL_ERROR;
               sleep 1;
            }
            return 0;
         }
         return $event;
      };
   }

   if ( $o->get('zero-admin') ) {
      push @callbacks, sub {
         my ( $event ) = @_;
         if ( $event->{arg} && $event->{arg} =~ m/^# administrator/ ) {
            $event->{Rows_sent}     = 0;
            $event->{Rows_read}     = 0;
            $event->{Rows_examined} = 0;
         }
         return $event;
      };
   }

   my $i = 0;
   foreach my $i ( 0 .. @$groupby - 1 ) {
      my $groupby = $groupby->[$i];
      die "You need to specify an --order-by for each --group-by"
         unless $orderby->[$i];
      my ( $attrib, $orderby ) = split(/:/, $orderby->[$i]);
      my %attributes = map {
         my ($name, @alt) = split(/:/, $_);
         $name => [$name, @alt];
      } grep { $_ !~ m/^$groupby\b/ } @{$o->get('select')};
      my $e;
      if ( @$report ) {
         $e = new EventAggregator(
            groupby      => $groupby,
            attributes   => { %attributes },
            worst        => $attrib,
            attrib_limit => $o->get('attribute-limit'),
         );
      }
      elsif ( @{$timeline} ) {
         $e = new EventTimeline(
            groupby    => [$groupby],
            attributes => [ keys %attributes ],
         );
      }
      $ea{$groupby} = $e;
      push @callbacks, sub {
         my ( $event ) = @_;
         $e->aggregate($event);
         return $event;
      };
   }

   # ########################################################################
   # Daemonize now that everything is setup and ready to work.
   # ########################################################################
   my $daemon;
   if ( $o->get('daemonize') ) {
      $daemon = new Daemon(o=>$o);
      $daemon->daemonize();
      MKDEBUG && _d('I am a daemon now');
   }

   # ##########################################################################
   # Parse the input.
   # ##########################################################################
   my $run_func;
   if ( $o->get('processlist') ) {    # Sniff SHOW FULL PROCESSLIST
      require Time::HiRes;
      my $pl = new Processlist();
      my ( $sth, $cxn );
      my $cur_server = 'processlist';
      my $cur_time   = 0;
      my $misc       = { prev => [], time => 0, etime => 0 };
      my $get_processlist_sub = sub {
         my $time = $misc->{time} = Time::HiRes::time();
         my $err;
         do {
            eval { $sth->execute; };
            $err = $EVAL_ERROR;
            if ( $err ) { # Try to reconnect when there's an error.
               $misc = { prev => [], time => 0, etime => 0 };
               eval {
                  ($cur_server, $ps_dbh) = find_role(
                     $o, $ps_dbh, $cur_server, 0, 'for --processlist');
                  $cur_time = Time::HiRes::time();
                  $sth      = $ps_dbh->prepare('SHOW FULL PROCESSLIST');
                  $cxn      = $ps_dbh->{mysql_thread_id};
                  $sth->execute();
               };
               $err = $EVAL_ERROR;
               if ( $err ) {
                  print STDERR $err;
                  sleep 1;
               }
            }
         } until ( $sth && !$err );
         if ( $o->get('mirror')
              && Time::HiRes::time() - $cur_time > $o->get('mirror')) {
            ($cur_server, $ps_dbh) = find_role($o, $ps_dbh, $cur_server,
               0, 'for --processlist');
            $cur_time = Time::HiRes::time();
         }
         $misc->{etime} = Time::HiRes::time() - $time;
         [ grep { $_->[0] != $cxn } @{ $sth->fetchall_arrayref(); } ];
      };
      $run_func = sub {
         my $events;
         eval {
            $events = $pl->parse_event(
               $get_processlist_sub,
               $misc,
               @callbacks,
            );
            Time::HiRes::usleep($o->get('interval') * 1_000_000);
         };
         MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
         return $events;
      };
   }
   else { # Parse log files
      if ( @ARGV == 0 ) {
         push @ARGV, '-'; # Magical STDIN filename.
      }

      # Set up the parser and miscellaneous options to it.
      my $misc   = {};
      my $parser = $o->get('type') eq 'slowlog' ? new SlowLogParser()
                 : $o->get('type') eq 'tcpdump' ? new TcpdumpParser()
                 : die("Unknown type " . $o->get('type'));
      if ( my $patterns = $o->get('embedded-attributes') ) {
         $misc->{embed}   = qr/$patterns->[0]/o;
         $misc->{capture} = qr/$patterns->[1]/o;
         MKDEBUG && _d('Patterns for embedded attributes:', $misc->{embed},
            $misc->{capture});
      }

      # TODO: carry the last db and ts values forward if they're undefined
      # now.  Do that by unshifting a new callback onto the front of @callbacks.
      my ($fh);
      $run_func = sub {
         if ( !$fh ) {
            my $file = shift @ARGV or return;
            if ( $file eq '-' ) {
               $fh = *STDIN;
            }
            else {
               open $fh, "<", $file or die "Cannot open $file: $OS_ERROR\n";
            }
         }
         # TODO: non-blocking I/O so we can respond to CTRL-C.  See
         # http://www.perlmonks.org/?node_id=55241
         # http://tinyurl.com/c6lqzz
         # Or look at the Perl Cookbook, ch07.

         my $events;
         eval {
            $events = $parser->parse_event($fh, $misc, @callbacks);
            if ( !$events ) {
               close $fh;
               $fh = undef;
            }
         };
         if ( $EVAL_ERROR ) {
            _d($EVAL_ERROR);
         }
         return $events;
      };
   }

   my $start = time();
   my $end   = $start + ($o->get('run-time') || 0); # When we should exit
   my $now   = $start;

   my $iters = 0;
   ITERATION:
   while (  # Quit if instructed to, or if iterations are exceeded.
      $oktorun
      && (!$o->get('iterations') || $iters++ < $o->get('iterations') )
   ) {

      EVENT:
      while (                                 # Quit if:
         $oktorun                             # instructed to quit
         && ($start == $end || $now < $end) ) # or time is exceeded
      {
         my $result = $run_func->();
         $now = time();
         last EVENT unless defined $result;
         # TODO: progress report (issue 169)
      }

      # ######################################################################
      # Finish up.
      # ######################################################################
      my $query_report = $o->get('report-format')->{query_report};
      if ( @$report ) {
         # Pick the first one and run the global report.
         my @select = map {my ($name) = split(/:/,$_); $name} @{$o->get('select')};
         my $qrf = new QueryReportFormatter();
         if ( $o->get('report-format')->{header} ) {
            my $ea = $ea{$report->[0]};
            print $qrf->header() if $o->get('report-format')->{rusage};
            if ( !$ea->results->{globals}->{$select[0]}->{cnt} ) {
               print "# No events processed.\n";
            }
            else {
               print $qrf->global_report(
                  $ea,
                  select => [ grep { $_ !~ m/^(?:user|db)$/ } @select ],
                  worst  => $select[0],
               );
            }
         }

         foreach my $i ( 0 .. @$report - 1 ) {
            my $groupby = $report->[$i];

            # Prepare to do query review for the items, if needed. TODO: this is
            # ugly, we can still access the global $qv.
            my $local_qv;
            if ( $groupby eq 'fingerprint' && $review_dsn ) {
               $local_qv = $qv;
            }

            if ( $query_report && (@$report > 1 || $groupby ne 'fingerprint') ) {
               print "\n# ", ( '#' x 72 ), "\n";
               print "# Report grouped by $groupby\n";
               print '# ', ( '#' x 72 ), "\n";
            }

            my $ea      = $ea{$groupby};

            # $attrib is the attribute by which the report is ordered.
            my ( $attrib, $orderby ) = split(/:/, $orderby->[$i]);
            if ( !$ea->type_for($attrib) && $attrib ne 'Query_time' ) {
               # This fixes issue 244: missing --order-by
               # TODO: get the default from the $o, here and in the "if"
               print "--order-by attribute $attrib doesn't exist, using Query_time\n"
                  if $query_report;
               $attrib = 'Query_time'; # Fall back to the default.
            }
            my $limit = $o->get('limit')->[$i] || '95%:20';
            my ($total, $count);
            if ( $limit =~ m/^\d+$/ ) {
               $count = $limit;
            }
            else {
               # It's a percentage, so grab as many as needed to get to
               # that % of the file.
               ($total, $count) = $limit =~ m/(\d+)/g;
               $total *= ($ea->results->{globals}->{$attrib}->{sum} || 0) / 100;
            }

            my %top_spec = (
               attrib  => $attrib,
               orderby => $orderby || 'cnt',
               total   => $total,
               count   => $count,
            );
            if ( $o->get('outliers')->[$i] ) {
               @top_spec{qw(ol_attrib ol_limit ol_freq)}
                  = split(/:/, $o->get('outliers')->[$i]);
            }

            # Find the items to include in the report
            my @worst          = $ea->top_events(%top_spec);
            my $expected_range = $o->get('expected-range');
            my $explain_why
               = $expected_range
               && (@worst < $expected_range->[0] || @worst > $expected_range->[1]);

            # Create a profile (issue 381).
            my @profiles;
            my $total_r = 0;

            # Print a report for each item.
            ITEM:
            foreach my $rank ( 1 .. @worst ) {
               my $item   = $worst[$rank - 1]->[0];
               my $stats  = $ea->results->{classes}->{$item};
               my $sample = $ea->results->{samples}->{$item};
               my %profile = (
                  rank => $rank,
                  r    => $stats->{Query_time}->{sum},
                  cnt  => $stats->{Query_time}->{cnt},
                  id   => '',
               );
               $total_r += $profile{r};

               my %history; # Prepare for saving review history
               if ( $o->get('review-history') ) {
                  foreach my $attrib(@select) {
                     $history{$attrib} = $ea->metrics(
                        attrib => $attrib,
                        where  => $item,
                     );
                  }
               }

               my $review_vals;
               if ( $local_qv ) {
                  $review_vals = $local_qv->get_review_info($item);
                  if ( $review_vals->{reviewed_by} && !$o->get('report-all') ) {
                     # This item has already been reviewed, skip it.  But before
                     # doing so, save the history if necessary.
                     if ( $o->get('review-history') ) {
                        $local_qv->set_review_history(
                           $item, $sample->{arg} || '', %history);
                     }
                     next ITEM;
                  }
               }

               print "\n" if $query_report;
               print $qrf->event_report(
                  $ea,
                  select => \@select,
                  where  => $item,
                  rank   => $rank,
                  worst  => $attrib,
                  reason => $explain_why ? $worst[$rank - 1]->[1] : '',
               ) if $query_report;
               print $qrf->chart_distro(
                  $ea,
                  attribute  => $attrib,
                  where      => $item,
               ) if $query_report;

               if ( $local_qv ) {
                  # Print the review information that is already in the table,
                  # before putting anything new into the table.
                  print "# Review information\n" if $query_report;
                  foreach my $col ($local_qv->review_cols) {
                     my $val = $review_vals->{$col};
                     if ( !$val || $val ne '0000-00-00 00:00:00' ) { # See issue 202
                        printf "# %13s: %-s\n", $col, ( defined $val ? $val : '' )
                           if $query_report;
                     }
                  }
                  # Update the query review information and history.
                  $local_qv->set_review_info(
                     fingerprint => $item,
                     sample      => $sample->{arg} || '',
                     first_seen  => $stats->{ts}->{min},
                     last_seen   => $stats->{ts}->{max});
                  if ( $o->get('review-history') ) {
                     $local_qv->set_review_history(
                        $item, $sample->{arg} || '', %history);
                  }
               }

               # Print the query fingerprint.
               if ( $groupby eq 'fingerprint' && $o->get('fingerprints') ) {
                  print "# Fingerprint\n#    $item\n" if $query_report;
               }

               if ( $groupby eq 'fingerprint' ) {
                  my $samp_query = $sample->{arg} || '';
                  $profile{sample} = $qr->distill($samp_query);
                  $profile{id}     = make_checksum($item);

                  # Shorten it if necessary (issue 216 and 292).
                  if ( $o->get('shorten') ) {
                     $samp_query = $qr->shorten($samp_query, $o->get('shorten'));
                  }

                  # Print out tables for the query, and if it's a SELECT
                  # statement, print out its EXPLAIN...
                  my ($db_for_show) = $sample->{db} ? $sample->{db}
                                    : keys %{$stats->{db}->{unq}};
                  if ( $o->get('for-explain') ) {
                     print_tables(extract_tables($samp_query, $db_for_show))
                        if $query_report;
                  }
                  if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {
                     if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN
                        print $samp_query, "\\G\n"
                           if $query_report;
                     }
                     else {
                        print "# EXPLAIN\n$samp_query\\G\n"
                           if $query_report;
                        print_explain($ep_dbh, $samp_query, $db_for_show)
                           if $query_report;
                     }
                  }
                  else {
                     print "$samp_query\\G\n"
                        if $query_report;
                     my $converted = $qr->convert_to_select($samp_query);
                     if ( $o->get('for-explain')
                          && $converted
                          && $converted =~ m/^[\(\s]*select/i ) {
                        # It converted OK to a SELECT
                        print "# Converted for EXPLAIN\n# EXPLAIN\n"
                           if $query_report;
                        print "$converted\\G\n"
                           if $query_report;
                     }
                  }
               }
               else {
                  if ( $groupby eq 'tables' ) {
                     my ( $db, $tbl ) = $q->split_unquote($item);
                     print_tables([$db, $tbl])
                        if $query_report;
                  }
                  print $item, "\n"
                     if $query_report;
                  $profile{sample} = $item;
               }
               push @profiles, \%profile;
            }

            # Print profile (issue 381).
            if ( $o->get('report-format')->{profile} ) {
               print "# Rank Query ID           Response time    Calls   R/Call",
                     "     Item\n",
                     "# ==== ================== ================ ======= ======",
                     "==== ====\n";
               foreach my $item ( reverse sort { $a->{r} <=> $b->{r} } @profiles) {
                  printf "# %4d 0x%16s %10.4f %4.1f%% %7d %10.6f %s\n",
                     $item->{rank}, $item->{id}, $item->{r},
                     $item->{r} / $total_r * 100,
                     $item->{cnt}, $item->{r} / $item->{cnt}, $item->{sample};
               }
            }
         }
      }

      elsif ( $timeline ) {
         foreach my $i ( 0 .. @{$timeline} - 1 ) {
            my $t = $ea{$timeline->[$i]};
            $t->report($t->results, sub { print @_ });
         }
      }

      # Reset the start/end/now times so the next iteration will run for the
      # same amount of time.
      $start = time();
      $end   = $start + ($o->get('run-time') || 0); # When we should exit
      $now   = $start;

      foreach my $ea ( values %ea ) {
         $ea->reset_aggregated_data();
      }
   }

   # Disconnect all open $dbh's
   map { $dp->disconnect($_) } grep { $_ }
      ($qv_dbh, $qv_dbh2, $ex_dbh, $ps_dbh, $ep_dbh);

   exit;
} # End global scope.

# ############################################################################
# Subroutines.
# ############################################################################
sub extract_tables {
   my ( $query, $default_db ) = @_;
   my @tables;
   my %seen;
   foreach my $db_tbl ( $qp->get_tables($query) ) {
      next if $seen{$db_tbl}++; # Unique-ify for issue 337.
      my ( $db, $tbl ) = $q->split_unquote($db_tbl);
      push @tables, [ $db || $default_db, $tbl ];
   }
   return @tables;
}

# Gets a default database and a list of arrayrefs of [db, tbl] to print out
sub print_tables {
   my ( @tables ) = @_;
   return unless @tables;
   print "# Tables\n";
   foreach my $db_tbl ( @tables ) {
      my ( $db, $tbl ) = @$db_tbl;
      print '#    SHOW TABLE STATUS',
         ($db ? " FROM `$db`" : ''), " LIKE '$tbl'\\G\n";
      print "#    SHOW CREATE TABLE ",
         $q->quote(grep { $_ } @$db_tbl), "\\G\n";
   }
}

sub print_explain {
   my ( $dbh, $query, $db ) = @_;
   return unless $dbh && $query;
   eval {
      if ( !$qp->has_derived_table($query) ) {
         if ( $db ) {
            $dbh->do("USE " . $q->quote($db));
         }
         my $sth = $dbh->prepare("EXPLAIN $query");
         $sth->execute();
         my $i = 1;
         while ( my @row = $sth->fetchrow_array() ) {
            print "# *************************** ", $i++,
               ". row ***************************\n";
            foreach my $j ( 0 .. $#row ) {
               printf "# %13s: %s\n", $sth->{NAME}->[$j],
                  defined $row[$j] ? $row[$j] : 'NULL';
            }
         }
      }
   };
   if ( MKDEBUG && $EVAL_ERROR ) {
      _d("Problem explaining", $query, $EVAL_ERROR);
   }
}

# Pass in the currently open $dbh (if any), where $current points to ('execute'
# or 'processlist') and whether you want to be connected to the read_only
# server.  Get back which server you're looking at, and the $dbh.  Assumes that
# one of the servers is ALWAYS read only and the other is ALWAYS not!  If
# there's some transition period where this isn't true, maybe both will end up
# pointing to the same place, but that should resolve shortly.
# The magic switching functionality only works if --mirror is given!  Otherwise
# it just returns the correct $dbh.  $comment is some descriptive text for
# debuggin, like 'for --execute'.
sub find_role {
   my ( $o, $dbh, $current, $read_only, $comment ) = @_;
   if ( !$dbh || !$dbh->ping ) {
      MKDEBUG && _d('Getting a dbh from', $current, $comment);
      $dbh = $dp->get_dbh(
         $dp->get_cxn_params($o->get($current)), {AutoCommit => 1});
   }
   if ( $o->get('mirror') ) {
      my ( $is_read_only ) = $dbh->selectrow_array('SELECT @@global.read_only');
      MKDEBUG && _d("read_only on", $current, $comment, ':',
                    $is_read_only, '(want', $read_only, ')');
      if ( $is_read_only != $read_only ) {
         $current = $current eq 'execute' ? 'processlist' : 'execute';
         MKDEBUG && _d("read_only wrong", $comment, "getting a dbh from", $current);
         $dbh = $dp->get_dbh(
            $dp->get_cxn_params($o->get($current)), {AutoCommit => 1});
      }
   }
   return ($current, $dbh);
}

# Catches signals so we can exit gracefully.
# TODO: test this
# TODO: break wait for <$fh> with SIGINT.  Possibly by closing all $fh?
sub sig_int {
   my ( $signal ) = @_;
   if ( $oktorun ) {
      print STDERR "# Caught SIG$signal.\n";
      $oktorun = 0;
   }
   else {
      print STDERR "# Exiting on SIG$signal.\n";
      exit(1);
   }
}

sub _d {
   my ($package, undef, $line) = caller 0;
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
        map { defined $_ ? $_ : 'undef' }
        @_;
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}

# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }

1; # Because this is a module as well as a script.

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

=pod

=head1 NAME

mk-query-digest - Parses logs and more.  Analyze, transform, filter, review and
report on queries.

=head1 SYNOPSIS

Analyze and report on a slow log:

 mk-query-digest /path/to/slow.log

Review a slow log, saving results to the test.query_review table in a MySQL
server running on host1.  See L<"--review"> for more on reviewing queries:

 mk-query-digest --review h=host1,D=test,t=query_review /path/to/slow.log

Watch a server's SHOW FULL PROCESSLIST and analyze the queries as if they were
from a slow query log:

 mk-query-digest --processlist h=host1

Watch a server's SHOW FULL PROCESSLIST, filter out everything but SELECT
queries, and replay the queries against another server, then use the timings
from replaying them to analyze their performance:

 mk-query-digest --processlist h=host1 --execute h=another_server \
   --filter '$event->{fingerprint} =~ m/^select/'

=head1 DESCRIPTION

This tool was formerly known as mk-log-parser.

C<mk-query-digest> is a framework for doing things with events from a query
source such as the slow query log or PROCESSLIST.  By default it acts as a very
sophisticated log analysis tool.  You can group and sort queries in many
different ways simultaneously and find the most expensive queries, or create a
timeline of queries in the log, for example.  It can also do a "query review,"
which means to save a sample of each type of query into a MySQL table so you can
easily see whether you've reviewed and analyzed a query before.  The benefit of
this is that you can keep track of changes to your server's queries and avoid
repeated work.  You can also save other information with the queries, such as
comments, issue numbers in your ticketing system, and so on.

Note that this is a work in *very* active progress and you should expect
incompatible changes in the future.

=head1 ATTRIBUTES

mk-query-digest works on events, which are a collection of key/value pairs
called attributes.  You'll recognize most of the attributes right away:
Query_time, Lock_time, and so on.  You can just look at a slow log and see them.
However, there are some that don't exist in the slow log, and slow logs
may actually include different kinds of attributes (for example, you may have a
server with the Percona patches).  A full list is at
L<http://code.google.com/p/maatkit/wiki/QueryEvents>.  These attributes show up
in lots of different places.

=head1 OUTPUT

The default output is a query analysis report.  There is one paragraph for each
class of query analyzed.  A "class" of queries all have the same fingerprint,
which is an abstracted version of the query text with literals removed,
whitespace collapsed, and so forth.  The report is formatted so it's easy to
paste into emails without wrapping, and all non-query lines begin with a
comment, so you can save it to a .sql file and open it in your favorite
syntax-highlighting text editor.  There is a response-time profile at the very
end.

The report begins with one paragraph about the entire analysis run.  The
information is very similar to what you'll see for each class of queries in the
log, but it doesn't have some information that would be too expensive to keep
globally for the analysis.  It also has some statistics about the code's
excution itself, such as the CPU and memory usage.

Following this, each query then appears in a paragraph.  Here's a sample,
slightly reformatted so 'perldoc' will not wrap lines in a terminal.  The
following will all be one paragraph, but we'll break it up for commentary.

 # Query 2: 0.01 QPS, 0.02x conc, ID 0xFDEA8D2993C9CAF3 at byte 160665

This line identifies the sequential number of the query in the sort order
specified by L<"--order-by">.  Then there's the queries per second, and the
approximate concurrency for this query (calculated as a function of the timespan
and total Query_time).  Next there's a query ID.  This ID is a hex version of
the query's checksum in the database, if you're using L<"--review">.  You can
select the reviewed query's details from the database with a query like C<SELECT
.... WHERE checksum=0xFDEA8D2993C9CAF3>.

Finally, in case you want to find a sample of the query in the log file, there's
the byte offset where you can look.  (This is not always accurate, due to some
silly anomalies in the slow-log format, but it's usually right.)  The position
refers to the worst sample, which we'll see more about below.

Next is the table of metrics about this class of queries.

 #           pct   total    min    max     avg     95%  stddev  median
 # Count       0       2
 # Exec time  13   1105s   552s   554s    553s    554s      2s    553s
 # Lock time   0   216us   99us  117us   108us   117us    12us   108us
 # Rows sent  20   6.26M  3.13M  3.13M   3.13M   3.13M   12.73   3.13M
 # Rows exam   0   6.26M  3.13M  3.13M   3.13M   3.13M   12.73   3.13M

The first line is column headers for the table.  The percentage is the percent
of the total for the whole analysis run, and the total is the actual value of
the specified metric.  For example, in this case we can see that the query
executed 2 times, which is 13% of the total number of queries in the file.  The
min, max and avg columns are self-explanatory.  The 95% column shows the 95th
percentile; 95% of the values are less than or equal to this value.  The
standard deviation shows you how tightly grouped the values are.  The standard
deviation and median are both calculated from the 95th percentile, discarding
the extremely large values.

The stddev, median and 95th percentile statistics are approximate.  Exact
statistics require keeping every value seen, sorting, and doing some
calculations on them.  This uses a lot of memory.  To avoid this, we keep 1000
buckets, each of them 5% bigger than the one before, ranging from .000001 up to
a very big number.  When we see a value we increment the bucket into which it
falls.  Thus we have fixed memory per class of queries.  The drawback is the
imprecision, which typically falls in the 5 percent range.

Next we have statistics on the users, databases and time range for the query.

 # Users       1   user1
 # Databases   2     db1(1), db2(1)
 # Time range 2008-11-26 04:55:18 to 2008-11-27 00:15:15

The users and databases are shown as a count of distinct values, followed by the
values.  If there's only one, it's shown alone; if there are many, we show each
of the most frequent ones, followed by the number of times it appears.

 # Query_time distribution
 #   1us
 #  10us
 # 100us
 #   1ms
 #  10ms
 # 100ms
 #    1s
 #  10s+  #############################################################

The execution times show a logarithmic chart of time clustering.  Each query
goes into one of the "buckets" and is counted up.  The buckets are powers of
ten.  The first bucket is all values in the "single microsecond range" -- that
is, less than 10us.  The second is "tens of microseconds," which is from 10us
up to (but not including) 100us; and so on.

 # Tables
 #    SHOW TABLE STATUS LIKE 'table1'\G
 #    SHOW CREATE TABLE `table1`\G
 # EXPLAIN
 SELECT * FROM table1\G

This section is a convenience: if you're trying to optimize the queries you see
in the slow log, you probably want to examine the table structure and size.
These are copy-and-paste-ready commands to do that.

Finally, we see a sample of the queries in this class of query.  This is not a
random sample.  It is the query that performed the worst, according to the sort
order given by L<"--order-by">.  You will normally see a commented C<# EXPLAIN>
line just before it, so you can copy-paste the query to examine its EXPLAIN
plan. But for non-SELECT queries that isn't possible to do, so the tool tries to
transform the query into a roughly equivalent SELECT query, and adds that below.

If you want to find this sample event in the log, use the offset mentioned
above, and something like the following:

  tail -c +<offset> /path/to/file | head

The final bit of output is the response-time profile over the events.  This is a
summarized view of what we've already seen.  Here is a sample:

  # Rank Query ID           Response time    Calls   R/Call     Item
  # ==== ================== ================ ======= ========== ====
  #    1 0x31DA25F95494CA95     0.1494 99.9%       1   0.149435 SHOW
  #    2 0x3AEAAD0E15D725B5     0.0001  0.1%       2   0.000041 SET
  #    3 0x813031B8BBC3B329     0.0000  0.0%       1   0.000015 COMMIT

The columns should be fairly self-explanatory: rank, query ID, response time sum
and percentage of total; number of calls and response time per call; and the
distilled query (see L<"distill"> for more detail on this).

=head1 QUERY REVIEWS

A "query review" is the process of storing all the query fingerprints analyzed.
This has several benefits:

=over

=item *

You can add meta-data to classes of queries, such as marking them for follow-up,
adding notes to queries, or marking them with an issue ID for your issue
tracking system.

=item *

You can refer to the stored values on subsequent runs so you'll know whether
you've seen a query before.  This can help you cut down on duplicated work.

=item *

You can store historical data such as the row count, query times, and generally
anything you can see in the report.

=back

To use this feature, you run mk-query-digest with the L<"--review"> option.  It
will store the fingerprints and other information into the table you specify.
Next time you run it with the same option, it will do the following:

=over

=item *

It won't show you queries you've already reviewed.  A query is considered to be
already reviewed if you've set a value for the C<reviewed_by> column.  (If you
want to see queries you've already reviewed, use the L<"--report-all"> option.)

=item *

Queries that you've reviewed, and don't appear in the output, will cause gaps in
the query number sequence in the first line of each paragraph.  And the value
you've specified for L<"--limit"> will still be honored.  So if you've reviewed all
queries in the top 10 and you ask for the top 10, you won't see anything in the
output.

=item *

If you want to see the queries you've already reviewed, you can specify
L<"--report-all">.  Then you'll see the normal analysis output, but you'll also see
the information from the review table, just below the execution time graph.  For
example,

  # Review information
  #      comments: really bad IN() subquery, fix soon!
  #    first_seen: 2008-12-01 11:48:57
  #   jira_ticket: 1933
  #     last_seen: 2008-12-18 11:49:07
  #      priority: high
  #   reviewed_by: xaprb
  #   reviewed_on: 2008-12-18 15:03:11

You can see how useful this meta-data is -- as you analyze your queries, you get
your comments integrated right into the report.

If you add the L<"--review-history"> option, it will also store information into
a separate database table, so you can keep historical trending information on
classes of queries.

=back

=head1 FINGERPRINTS

A query fingerprint is the abstracted form of a query, which makes it possible
to group similar queries together.  Abstracting a query removes literal values,
normalizes whitespace, and so on.  For example, these two queries:

  SELECT name, password FROM user WHERE id='12823';
  select name,   password from user
     where id=5;

Both of those queries will fingerprint to

  select name, password from user where id=?

Once the query's fingerprint is known, we can then talk about a query as though
it represents all similar queries.

What C<mk-query-digest> does is analogous to a GROUP BY statement in SQL.  If your
command-line looks like this,

  mk-query-digest /path/to/slow.log --select Rows_read,Rows_sent \
      --group-by fingerprint --order-by Query_time:sum --limit 10

The corresponding pseudo-SQL looks like this:

  SELECT WORST(query BY Query_time), SUM(Query_time), ...
  FROM /path/to/slow.log
  GROUP BY FINGERPRINT(query)
  ORDER BY SUM(Query_time) DESC
  LIMIT 10

You can also use the value C<distill>, which is a kind of super-fingerprint.
See L<"--group-by"> for more.

=head1 OPTIONS

DSN values in L<"--review-history"> default to values in L<"--review"> if COPY
is yes.

=over

=item --attribute-limit

type: int; default: 4294967296

A sanity limit for attribute values.

This option deals with bugs in slow-logging functionality that causes large
values for attributes.  If the attribute's value is bigger than this, the
last-seen value for that class of query is used instead.

=item --config

type: Array

Read this comma-separated list of config files; if specified, this must be the
first option on the command line.

=item --create-review-history-table

Create the L<"--review-history"> table if it does not exist.

This option causes the table specified by L<"--review-history"> to be created
with the default structure shown in the documentation for that option.

=item --create-review-table

Create the L<"--review"> table if it does not exist.

This option causes the table specified by L<"--review"> to be created with the
default structure shown in the documentation for that option.

=item --daemonize

Fork to the background and detach from the shell.  POSIX
operating systems only.

=item --embedded-attributes

type: array

Two Perl regex patterns to capture pseudo-attributes embedded in queries.

Embedded attributes might be special attribute-value pairs that you've hidden
in comments.  The first regex should match the entire set of attributes (in
case there are multiple).  The second regex should match and capture
attribute-value pairs from the first regex.

For example, suppose your query looks like the following:

  SELECT * from users -- file: /login.php, line: 493;

You might run mk-query-digest with the following option:

  mk-query-digest --embedded-attributes ' -- .*','(\w+): ([^\,]+)'

The first regular expression captures the whole comment:

  " -- file: /login.php, line: 493;"

The second one splits it into attribute-value pairs and adds them to the event:

   ATTRIBUTE  VALUE
   =========  ==========
   file       /login.php
   line       493

B<NOTE>: All commas in the regex patterns must be escaped with \ otherwise
the pattern will break.

=item --execute

type: DSN

Execute queries on this DSN.

Adds a callback into the chain, after filters but before L<"--report">.  Events
are executed on this DSN.  If they are successful, the time they take to execute
overwrites the event's Query_time attribute.  If unsuccessful, the callback
returns false and terminates the chain.

If the connection fails, mk-query-digest tries to reconnect once per second.
See also L<"--mirror">.

=item --expected-range

type: array; default: 5,10

Explain items when there are more or fewer than expected.

Defines the number of items expected to be seen in the report given by
L<"--report">, as controlled by L<"--limit"> and L<"--outliers">.  If there are
more or fewer items in the report, each one will explain why it was included.

=item --explain

type: DSN

Run EXPLAIN for the sample query with this DSN and print results.

This works only when L<"--report"> includes fingerprint.  It causes
mk-query-digest to run EXPLAIN and include the output into the report.  For
safety, queries that appear to have a subquery that EXPLAIN will execute won't
be EXPLAINed.  Those are typically "derived table" queries of the form

  select ... from ( select .... ) der;

=item --filter

type: string

Discard events for which this Perl code doesn't return true.

This option is a string of Perl code that gets compiled into a subroutine with
one argument: $event.  This is a hashref.  If the code returns true, the chain
of callbacks continues; otherwise it ends.  The code is the last statement in
the subroutine other than C<return $event>.

An example filter that discards everything but SELECT statements:

  --filter '$event->{arg} =~ m/^select/i'

This is compiled into a subroutine like the following:

  sub { $event = shift; $event->{arg} =~ m/^select/i && return $event; }

It is permissible for the code to have side effects (to alter $event).

=item --fingerprints

Add query fingerprints to the L<"--report">.  This is mostly useful
for debugging purposes.

=item --[no]for-explain

default: yes

Print extra information to make analysis easy.

This option adds code snippets to make it easy to run SHOW CREATE TABLE and SHOW
TABLE STATUS for the query's tables.  It also rewrites non-SELECT queries into a
SELECT that might be helpful for determining the non-SELECT statement's index
usage.

=item --group-by

type: Array

Which attribute of the events to group by.

This option is a comma-separated list of items that defaults to the same items
as L<"--report"> but may contain extras.

In general, you can group queries into classes based on any attribute of the
query, such as C<user> or C<db>, which will by default show you which users
and which databases get the most C<Query_time>.

Every value must have a corresponding value in the same position in
L<"--order-by">.  However, adding values to L<"--group-by"> will automatically
add values to L<"--order-by">, for your convenience.  And, since L<"--report">
automatically adds values to L<"--group-by">, these cascade through to
L<"--order-by">.  So you generally don't need to think about anything except
L<"--report">.

There are several magical values that cause some extra data mining to happen
before the grouping takes place:

=over

=item fingerprint

This causes events to be fingerprinted to abstract queries into
a canonical form, which is then used to group events together into a class.  See
L<"FINGERPRINTS"> for more about fingerprinting.

=item tables

This causes events to be inspected for what appear to be tables, and
then aggregated by that.  Note that a query that contains two or more tables
will be counted as many times as there are tables; so a join against two tables
will count the Query_time against both tables.

=item distill

This is a sort of super-fingerprint that collapses queries down
into a suggestion of what they do, such as C<INSERT SELECT table1 table2>.

=back

=item --help

Show help and exit.

=item --interval

type: float; default: .1

How frequently to poll the processlist, in seconds.

=item --iterations

type: int; default: 1

How many times to iterate through the collect-and-report cycle.  If 0, iterate
to infinity.  See also L<--run-time>.

=item --limit

type: Array; default: 95%:20

Limit output to the given percentage or count.

If the argument is an integer, report only the top N worst queries.  If the
argument is an integer followed by the C<%> sign, report that percentage of the
worst queries.  If the percentage is followed by a colon and another integer,
report the top percentage or the number specified by that integer, whichever
comes first.

The value is actually a comma-separated array of values, one for each item in
L<"--report">.  If you don't specify a value for any of those items, the default
is the top 95%.

See also L<"--outliers">.

=item --log

type: string

Print all output to this file when daemonized.

=item --mirror

type: float

How often to check whether connections should be moved, depending on
C<read_only>.  Requires L<"--processlist"> and L<"--execute">.

This option causes mk-query-digest to check every N seconds whether it is reading
from a read-write server and executing against a read-only server, which is a
sensible way to set up two servers if you're doing something like master-master
replication.  The L<http://code.google.com/p/mysql-master-master/> master-master
toolkit does this. The aim is to keep the passive server ready for failover,
which is impossible without putting it under a realistic workload.

=item --order-by

type: Array; default: Query_time:sum

Sort events by this attribute and aggregate function.

This is a comma-separated list of order-by expressions, one for each attribute
you wish to report by (see L<"--report">).  The syntax is attribute:aggregate.
Valid aggregates are sum, min, max, cnt.  See the default value for an example.

This option is automatically altered by L<"--group-by">.  If you specify an
attribute that doesn't exist in the events that are parsed and aggregated,
mk-query-digest falls back to the default with a notice just at the beginning
of the per-item report.

=item --outliers

type: array; default: Query_time:1:10

Report outliers by attribute:percentile:count.

The syntax of this option is a comma-separated list of colon-delimited strings.
The first field is the attribute by which an outlier is defined.  The second is
a number that is compared to the attribute's 95th percentile.  The third is
optional, and is compared to the attribute's cnt aggregate.  Queries that pass
this specification are added to the report, regardless of any limits you
specified in L<"--limit">.

For example, to report queries whose 95th percentile Query_time is at least 60
seconds and which are seen at least 5 times, use the following argument:

  --outliers Query_time:60:5

You can specify an --outliers option for each value in L<"--report">.

=item --pid

type: string

Create the given PID file when daemonized.  The file contains the process
ID of the daemonized instance.  The PID file is removed when the
daemonized instance exits.  The program checks for the existence of the
PID file when starting; if it exists and the process with the matching PID
exists, the program exits.

=item --print

Print log events to STDOUT in standard slow-query-log format.

=item --processlist

type: DSN

Poll this DSN's processlist for queries, with L<"--interval"> sleep between.

If the connection fails, mk-query-digest tries to reopen it once per second. See
also L<"--mirror">.

=item --report

type: Array; default: fingerprint

Print out reports on the aggregate results from L<"--group-by">.

This is the standard slow-log analysis functionality.  See L<"OUTPUT"> for the
description of what this does and what the results look like.

Any value you specify here automatically adds a corresponding value to
L<"--group-by">.

=item --report-all

Include all queries, even if they have already been reviewed.

=item --report-format

type: Hash; default: rusage,header,query_report,profile

Print these elements in the query analysis report.  Valid element names are
rusage, header, query_report, and profile.  The rusage is information about CPU
times and memory usage.  The header is information about the entire analysis
run.  The query_report is detailed information on each query in the report.  The
profile is a compact table of queries for an at-a-glance view of the report.
Order does not matter; you cannot use this parameter to influence the order of
items in the report, only the presence or absence of items.

See L<"OUTPUT"> for more information on the various parts of the query report.

=item --review

type: DSN

Store a sample of each class of query in this DSN.

The argument specifies a table to store all unique query fingerprints in.  The
table must have at least the following columns, but you can add any more columns
you wish.  The following CREATE TABLE definition is also used for
L<"--create-review-table">.  MAGIC_create_review:

  CREATE TABLE query_review (
     checksum     BIGINT UNSIGNED NOT NULL PRIMARY KEY,
     fingerprint  TEXT NOT NULL,
     sample       TEXT NOT NULL,
     first_seen   DATETIME,
     last_seen    DATETIME,
     reviewed_by  VARCHAR(20),
     reviewed_on  DATETIME,
     comments     TEXT
  )

The columns are as follows:

  COLUMN       MEANING
  ===========  ===============
  checksum     A 64-bit checksum of the query fingerprint
  fingerprint  The abstracted version of the query; its primary key
  sample       The query text of a sample of the class of queries
  first_seen   The smallest timestamp of this class of queries
  last_seen    The largest timestamp of this class of queries
  reviewed_by  Initially NULL; if set, query is skipped thereafter
  reviewed_on  Initially NULL; not assigned any special meaning
  comments     Initially NULL; not assigned any special meaning

Note that the C<fingerprint> column is the true primary key for a class of
queries.  The C<checksum> is just a cryptographic hash of this value, which
provides a shorter value that is very likely to also be unique.

After the tool generates the fingerprint report for L<"--report">, it uses the
aggregated values from the report to fill the review table.  When you're done,
your table should contain a row for each fingerprint.  This option depends on
C<--report fingerprint>.  It will not work otherwise.

=item --review-history

type: DSN

The table in which to store historical values for review trend analysis.

Each time you review queries with L<"--review">, mk-query-digest will save
information into this table so you can see how classes of queries have changed
over time.

This DSN inherits unspecified values from --review.  It should mention a
table in which to store statistics about each class of queries.  mk-query-digest
verifies the existence of the table, and your privileges to insert, delete and
update on that table.

mk-query-digest then inspects the columns in the table.  The table must have at
least the following columns:

  CREATE TABLE query_review_history (
    checksum     BIGINT UNSIGNED NOT NULL,
    sample       TEXT NOT NULL
  );

Any columns not mentioned above are inspected to see if they follow a certain
naming convention.  The column is special if the name ends with an underscore
followed by any of these MAGIC_history_cols values:

  pct|avt|cnt|sum|min|max|pct_95|stddev|median|rank

If the column ends with one of those values, then the prefix is interpreted as
the event attribute to store in that column, and the suffix is interpreted as
the metric to be stored.  For example, a column named Query_time_min will be
used to store the minimum Query_time for the class of events.  The presence of
this column will also add Query_time to the L<"--select"> list.

The table should also have a primary key, but that is up to you, depending on
how you want to store the historical data.  We suggest adding ts_min and ts_max
columns and making them part of the primary key along with the checksum.  But
you could also just add a ts_min column and make it a DATE type, so you'd get
one row per class of queries per day.

The default table structure follows.  The following MAGIC_create_review_history
table definition is used for L<"--create-review-history-table">:

 CREATE TABLE query_review_history (
   checksum             BIGINT UNSIGNED NOT NULL,
   sample               TEXT NOT NULL,
   ts_min               DATETIME,
   ts_max               DATETIME,
   ts_cnt               FLOAT,
   Query_time_sum       FLOAT,
   Query_time_min       FLOAT,
   Query_time_max       FLOAT,
   Query_time_pct_95    FLOAT,
   Query_time_stddev    FLOAT,
   Query_time_median    FLOAT,
   Lock_time_sum        FLOAT,
   Lock_time_min        FLOAT,
   Lock_time_max        FLOAT,
   Lock_time_pct_95     FLOAT,
   Lock_time_stddev     FLOAT,
   Lock_time_median     FLOAT,
   Rows_sent_sum        FLOAT,
   Rows_sent_min        FLOAT,
   Rows_sent_max        FLOAT,
   Rows_sent_pct_95     FLOAT,
   Rows_sent_stddev     FLOAT,
   Rows_sent_median     FLOAT,
   Rows_examined_sum    FLOAT,
   Rows_examined_min    FLOAT,
   Rows_examined_max    FLOAT,
   Rows_examined_pct_95 FLOAT,
   Rows_examined_stddev FLOAT,
   Rows_examined_median FLOAT,
   PRIMARY KEY(checksum, ts_min, ts_max)
 );

Note that we store the count (cnt) for the ts attribute only; it will be
redundant to store this for other attributes.

=item --run-time

type: time

How long to run before exiting.  The default is to run forever (you can
interrupt with CTRL-C).  See also L<--iterations>.

=item --select

type: Array; default: Query_time,Lock_time,Rows_sent,Rows_examined,user,db:Schema,ts

Compute aggregate statistics for these attributes.

The value is a comma-separated list of items you can see in the slow query log,
or otherwise know are attributes in the query events.  You can specify an
alternative attribute with a colon.  For example, C<db:Schema> uses db if it's
available, and Schema if it's not.

=item --shorten

type: int; default: 1024

Shorten long statements in reports.

Shortens long statements, replacing the omitted portion with a C</*... omitted
...*/> comment.  This applies only to the output in reports, not to information
stored for L<"--review"> or other places.  It prevents a large statement from
causing difficulty in a report.  The argument is the preferred length of the
shortened statement.  Not all statements can be shortened, but very large INSERT
and similar statements often can; and so can IN() lists, although only the first
such list in the statement will be shortened.

If it shortens something beyond recognition, you can find the original statement
in the log, at the offset shown in the report header (see L<"OUTPUT">).

=item --timeline

type: Array

Show a timeline of events (disables L<"--report">).

This option makes mk-query-digest aggregate events into a timeline by the
specified attribute.  Each event is compared to the previous one, and if the
specified attribute is the same, they are aggregated together.  At the end, the
report prints out the timestamp, interval, count and value of each aggregated
group of events.

The setting cascades to L<"--order-by"> and L<"--group-by"> just like
L<"--report"> does.  At this time, L<"--timeline"> and L<"--report"> are
mutually exclusive, and since L<"--report"> has a default value, setting
L<"--timeline"> will merely unset L<"--report">.

Example:

  mk-query-digest /path/to/log --timeline distill

=item --type

type: string

The type of input to parse (default slowlog).  The permitted types are

=over

=item slowlog

Parse a log file in any varation of MySQL slow-log format.

=item tcpdump

mk-query-digest does not actually watch the network (i.e. it does NOT "sniff
packets").  Instead, it's just parsing the output of tcpdump.  You are
responsible for generating this output; mk-query-digest does not do it for you.
Then you send this to mk-query-digest as you would any log file: as files on the
command line or to STDIN.

The parser expects the input to be formatted with the following options: C<-x -n
-q -tttt>.  For example, if you want to capture output from your local machine,
you can do something like

  tcpdump -i eth0 port 3306 -s 65535 -c 1000 -x -n -q -tttt \
    | mk-query-digest --type tcpdump

The other tcpdump parameters, such as -s, -c, and -i, are up to you.  Just make
sure the output looks like this:

  2009-04-12 09:50:16.804849 IP 127.0.0.1.42167 > 127.0.0.1.3306: tcp 37
      0x0000:  4508 0059 6eb2 4000 4006 cde2 7f00 0001
      0x0010:  ....

Remember tcpdump has a handy -c option to stop after it captures some number of
packets!  That's very useful for testing your tcpdump command.

If you're analyzing traffic to a non-standard port, see L<"--watch-server">.

=back

=item --version

Show version and exit.

=item --watch-server

type: string

Which IP address and port is the server when parsing tcpdump output. This option
tells mk-query-digest whether a given TCP packet is from client to server, or
server to client.  If you don't specify it, mk-query-digest tries to guess the
host and port of the server by looking for port 3306 or port "mysql".  If you're
watching a server with a non-standard port, this won't work, and you'll need to
specify the IP address and port to watch.  If mk-query-digest doesn't know what
to watch, nothing works right.

=item --[no]zero-admin

default: yes

Zero out the Rows_XXX properties for administrator command events.

=back

=head1 DOWNLOADING

You can download Maatkit from Google Code at
L<http://code.google.com/p/maatkit/>, or you can get any of the tools
easily with a command like the following:

   wget http://www.maatkit.org/get/toolname
   or
   wget http://www.maatkit.org/trunk/toolname

Where C<toolname> can be replaced with the name (or fragment of a name) of any
of the Maatkit tools.  Once downloaded, they're ready to run; no installation is
needed.  The first URL gets the latest released version of the tool, and the
second gets the latest trunk code from Subversion.

=head1 SYSTEM REQUIREMENTS

You need Perl and some core packages that ought to be installed in any
reasonably new version of Perl.

=head1 ENVIRONMENT

The environment variable C<MKDEBUG> enables verbose debugging output in all of
the Maatkit tools:

   MKDEBUG=1 mk-....

=head1 BUGS

Please use Google Code Issues and Groups to report bugs or request support:
L<http://code.google.com/p/maatkit/>.  You can also join #maatkit on Freenode to
discuss Maatkit.

Please include the complete command-line used to reproduce the problem you are
seeing, the version of all MySQL servers involved, the complete output of the
tool when run with L<"--version">, and if possible, debugging output produced by
running with the C<MKDEBUG=1> environment variable.

=head1 COPYRIGHT, LICENSE AND WARRANTY

This program is copyright 2007-2009 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, Daniel Nichter

=head1 VERSION

This manual page documents Ver 0.9.6 Distrib 3722 $Revision: 3710 $.

=cut
