#!/usr/bin/env perl

# This is mk-audit, a program to inspect, analyze, and report on a MySQL server.
#
# This program is copyright 2008-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.8';
our $DISTRIB = '4047';
our $SVN_REV = sprintf("%d", (q$Revision: 3965 $ =~ m/(\d+)/g, 0));

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

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

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

# ###########################################################################
# DSNParser package 3963
# ###########################################################################
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}};

   foreach my $dsn_part ( split(/,/, $dsn) ) {
      if ( my ($prop_key, $prop_val) = $dsn_part =~  m/^(.)=(.*)$/ ) {
         $given_props{$prop_key} = $prop_val;
      }
      else {
         MKDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
         $given_props{h} = $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";
   }
   $usage .= "\n  If the DSN is a bareword, the word is treated as the 'h' 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
# ###########################################################################

# ###########################################################################
# VersionParser package 3186
# ###########################################################################
package VersionParser;

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

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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

sub parse {
   my ( $self, $str ) = @_;
   my $result = sprintf('%03d%03d%03d', $str =~ m/(\d+)/g);
   MKDEBUG && _d($str, 'parses to', $result);
   return $result;
}

sub version_ge {
   my ( $self, $dbh, $target ) = @_;
   if ( !$self->{$dbh} ) {
      $self->{$dbh} = $self->parse(
         $dbh->selectrow_array('SELECT VERSION()'));
   }
   my $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0;
   MKDEBUG && _d($self->{$dbh}, 'ge', $target, ':', $result);
   return $result;
}

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

# ###########################################################################
# ServerSpecs package 3186
# ###########################################################################

package ServerSpecs;

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

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

sub server_specs {
   my %server;

   @{ $server{problems} } = ();

   $server{os}->{name} = $OSNAME;
   $server{os}->{regsize} = `file /bin/ls` =~ m/64-bit/ ? '64' : '32';

   $server{os}->{version} = _os_version();

   if ( -f '/lib/libc.so.6' ) {
      my $stuff = `/lib/libc.so.6`;
      ($server{sw}->{libc}->{ver}) = $stuff =~ m/GNU C.*release version (.+), /;
      $server{sw}->{libc}->{threading}
         = $stuff =~ m/Native POSIX/    ? 'NPTL'
         : $stuff =~ m/linuxthreads-\d/ ? 'Linuxthreads'
         :                                'Unknown';
      ($server{sw}->{libc}->{compiled_by}) = $stuff =~ m/Compiled by (.*)/;
      $server{sw}->{libc}->{GNU_LIBPTHREAD_VERSION} = do {
         my $ver = `getconf GNU_LIBPTHREAD_VERSION`;
         chomp $ver;
         $ver;
      };
   }

   if ( -f '/proc/cpuinfo' ) {
      my $info = `cat /proc/cpuinfo`;
      my $cores = scalar( map { $_ } $info =~ m/(^processor)/gm );
      $server{cpu}->{cores} = $cores;
      $server{cpu}->{count}
         = `grep 'physical id' /proc/cpuinfo | sort | uniq | wc -l`;
      ($server{cpu}->{speed})
         = join(' ', 'MHz:', $info =~ m/cpu MHz.*: (\d+)/g);
      ($server{cpu}->{cache}) = $info =~ m/cache size.*: (.+)/;
      ($server{cpu}->{model}) = $info =~ m/model name.*: (.+)/;
      $server{cpu}->{regsize} = $info =~ m/flags.*\blm\b/ ? '64' : '32';
   }
   else {
      $server{cpu}->{count} = $ENV{NUMBER_OF_PROCESSORS};
   }

   @{$server{memory}->{slots}} = _memory_slots();

   if ( chomp(my $mem = `free -b`) ) {
      my @words = $mem =~ m/(\w+)/g;
      my @keys;
      while ( my $key = shift @words ) {
         last if $key eq 'Mem';
         push @keys, $key;
      }
      foreach my $key ( @keys ) {
         $server{memory}->{$key} = shorten(shift @words);
      }
   }

   if ( chomp(my $df = `df -hT` ) ) {
      $df = "\n\t" . join("\n\t",
         grep { $_ !~ m/^(varrun|varlock|udev|devshm|lrm)/ }
         split(/\n/, $df));
      $server{storage}->{df} = $df;
   }

   chomp(my $vgs_cmd = `which vgs`);
   if ( -f $vgs_cmd ) {
      chomp(my $vgs_output = `$vgs_cmd`);
      $vgs_output =~ s/^\s*/\t/g;
      $server{storage}->{vgs} = $vgs_output;
   }
   else {
      $server{storage}->{vgs} = 'No LVM2';
   }

   get_raid_info(\%server);

   chomp($server{os}->{swappiness} = `cat /proc/sys/vm/swappiness`);
   push @{ $server{problems} },
      "*** Server swappiness != 60; is currently: $server{os}->{swappiness}"
      if $server{os}->{swappiness} != 60;

   check_proc_sys_net_ipv4_values(\%server);

   return \%server;
}

sub get_raid_info
{
   my ( $server ) = @_;

   $server->{storage}->{raid} = {};
   if ( chomp(my $dmesg = `dmesg | grep '^scsi[0-9]'`) ) {
      if (my ($raid) = $dmesg =~ m/: (.*MegaRaid)/mi) {
         $server->{storage}->{raid}{$raid} = _get_raid_info_megarc();
      }
      if (my ($raid) = $dmesg =~ m/: (aacraid)/m) {
         $server->{storage}->{raid}{$raid} = _get_raid_info_arcconf();
      }
      if (my ($raid) = $dmesg =~ m/: (3ware [0-9]+ Storage Controller)/m) {
         $server->{storage}->{raid}{$raid} = _get_raid_info_tw_cli();
      }
   }
}

sub _get_raid_info_megarc
{
   my $result = '';
   my $megarc = `which megarc && megarc -AllAdpInfo -aALL`;
   if ( $megarc ) {
      if ( $megarc =~ /No MegaRAID Found/i ) {
         if ( -f '/opt/MegaRAID/MegaCli/MegaCli' ) {
            $megarc  = `/opt/MegaRAID/MegaCli/MegaCli -AdpAllInfo -aALL`;
            $megarc .= `/opt/MegaRAID/MegaCli/MegaCli -AdpBbuCmd -GetBbuStatus -aALL`;
         }
         elsif ( -f '/opt/MegaRAID/MegaCli/MegaCli64' ) {
            $megarc  = `/opt/MegaRAID/MegaCli/MegaCli64 -AdpAllInfo -aALL`;
            $megarc .= `/opt/MegaRAID/MegaCli/MegaCli64 -AdpBbuCmd -GetBbuStatus -aALL`;
         }
         else {
            $megarc = '';
         }
      }
      else {
         $megarc .= `megarc -AdpBbuCmd -GetBbuStatus -aALL`;
      }
   }

   if ( $megarc ) {
      $result .= ($megarc =~ /^(Product Name.*\n)/m ? $1 : '');
      $result .= ($megarc =~ /^(BBU.*\n)/m ? $1 : '');
      $result .= ($megarc =~ /^(Battery Warning.*\n)/m ? $1 : '');
      $result .= ($megarc =~ /^(Alarm.*\n)/m ? $1 : '');
      $result .= ($megarc =~ /(Device Present.*?\n)\s+Supported/ms ? $1 : '');
      $result .= ($megarc =~ /(Battery state.*?\n)isSOHGood/ms ? $1 : '');
      $result =~ s/^/   /mg;
   }
   else {
      $result .= "\n*** MegaRAID present but unable to check its status";
   }

   return $result;
}

sub _get_raid_info_arcconf
{
   my $result = '';
   my $arcconf;
   if (-x '/usr/StorMan/arcconf') {
      $arcconf = `/usr/StorMan/arcconf GETCONFIG 1`;
   }
   else {
      $arcconf = `which arcconf && arcconf GETCONFIG 1`;
   }
   if ( $arcconf ) {
      $result .= ($arcconf =~ /^(\s*Controller Model.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Controller Status.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Installed memory.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Temperature.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Defunct disk drive count.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Logical devices\/Failed \(error\)\/Degraded.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Write-cache mode.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Write-cache setting.*\n)/m ? $1 : '');
      $result .= ($arcconf =~ /^(\s*Controller Battery Information.*?\n\n)/ms ? $1 : '');
   }
   else {
      $result .= "\n*** aacraid present but unable to check its status";
   }

   return $result;
}

sub _get_raid_info_tw_cli
{
   my $result = '';
   my $tw_cli = `which tw_cli && tw_cli /c0 show all`;
   if ( $tw_cli ) {
      $result .= ($tw_cli =~ /^\/c0\s*(Model.*\n)/m ? $1 : '');
      $result .= ($tw_cli =~ /^\/c0\s*(Memory Installed.*\n)/m ? $1 : '');
      $result .= ($tw_cli =~ /\n(\n.*)/ms ? $1 : '');
      $result =~ s/^/   /mg;
   }
   else {
      $result .= "\n*** 3ware Storage Controller present but unable to check its status";
   }

   return $result;
}

sub check_proc_sys_net_ipv4_values
{
   my ( $server, $sysctl_conf ) = @_;

   my %ipv4_defaults = qw(
      ip_forward                        0
      ip_default_ttl                    64
      ip_no_pmtu_disc                   0
      min_pmtu                          562
      ipfrag_secret_interval            600
      ipfrag_max_dist                   64
      somaxconn                         128
      tcp_abc                           0
      tcp_abort_on_overflow             0
      tcp_adv_win_scale                 2
      tcp_allowed_congestion_control    reno
      tcp_app_win                       31
      tcp_fin_timeout                   60
      tcp_frto_response                 0
      tcp_keepalive_time                7200
      tcp_keepalive_probes              9 
      tcp_keepalive_intvl               75
      tcp_low_latency                   0
      tcp_max_syn_backlog               1024
      tcp_moderate_rcvbuf               1
      tcp_reordering                    3
      tcp_retries1                      3
      tcp_retries2                      15
      tcp_rfc1337                       0
      tcp_rmem                          8192_87380_174760
      tcp_slow_start_after_idle         1
      tcp_stdurg                        0
      tcp_synack_retries                5
      tcp_syncookies                    0
      tcp_syn_retries                   5
      tcp_tso_win_divisor               3
      tcp_tw_recycle                    0
      tcp_tw_reuse                      0
      tcp_wmem                          4096_16384_131072
      tcp_workaround_signed_windows     0
      tcp_dma_copybreak                 4096
      ip_nonlocal_bind                  0
      ip_dynaddr                        0
      icmp_echo_ignore_all              0
      icmp_echo_ignore_broadcasts       1
      icmp_ratelimit                    100
      icmp_ratemask                     6168
      icmp_errors_use_inbound_ifaddr    0
      igmp_max_memberships              20
      icmp_ignore_bogus_error_responses 0
   );

   $sysctl_conf ||= '/etc/sysctl.conf';
   load_ipv4_defaults(\%ipv4_defaults, $sysctl_conf);

   $server->{os}->{non_default_ipv4_vals} = '';
   if ( chomp(my $ipv4_files = `ls -1p /proc/sys/net/ipv4/`) ) {
      foreach my $ipv4_file ( split "\n", $ipv4_files ) {
         next if !exists $ipv4_defaults{$ipv4_file};
         chomp(my $val = `cat /proc/sys/net/ipv4/$ipv4_file`);
         $val =~ s/\s+/_/g;
         if ( $ipv4_defaults{$ipv4_file} ne $val ) {
            push @{ $server->{problems} },
               "Not default value /proc/sys/net/ipv4/$ipv4_file\:\n" .
               "\t\tset=$val\n\t\tdefault=$ipv4_defaults{$ipv4_file}";
         }
      }
   }

   return;
}

sub load_ipv4_defaults {
   my ( $ipv4_defaults, $sysctl_conf ) = @_;
 
   my %conf_ipv4_defaults = parse_sysctl_conf($sysctl_conf);

   foreach my $var ( keys %conf_ipv4_defaults ) {
      if ( MKDEBUG && exists $ipv4_defaults->{$var} ) {
         _d('sysctl override', $var, ': conf=', $conf_ipv4_defaults{$var},
            'overrides default', $ipv4_defaults->{$var});
      }
      $ipv4_defaults->{$var} = $conf_ipv4_defaults{$var};
   }

   return;
}

sub parse_sysctl_conf {
   my ( $sysctl_conf ) = @_;
   my %sysctl;

   if ( !-f $sysctl_conf ) {
      MKDEBUG && _d('sysctl file', $sysctl_conf, 'does not exist');
      return;
   }

   if ( open my $SYSCTL, '<', $sysctl_conf ) {
      MKDEBUG && _d('Parsing', $sysctl_conf);
      while ( my $line = <$SYSCTL> ) {
         next if $line  =~ /^#/; # skip comments
         next unless $line =~ /\s*net.ipv4.(\w+)\s*=\s*(\w+)/;
         my ( $var, $val ) = ( $1, $2 );
         MKDEBUG && _d('sysctl:', $var, '=', $val);
         if ( exists $sysctl{$var} && MKDEBUG ) {
            _d('Duplicate sysctl var:', $var,
               '; was', $sysctl{$var}, ', is now', $val);
         }
         $sysctl{$var} = $val;
      }
   }
   else {
      warn "Cannot read $sysctl_conf: $OS_ERROR";
   }

   return %sysctl;
}

sub _can_run {
   my ( $cmd ) = @_;
   my $retval = system("$cmd 2>/dev/null > /dev/null");
   $retval = $retval >> 8;
   MKDEBUG && _d('Running', $cmd, 'returned', $retval);
   return !$retval ? 1 : 0;
}

sub _os_version {
   my $version = 'unknown version';

   if ( _can_run('cat /etc/*release') ) {
      chomp(my $rel = `cat /etc/*release`);
      if ( my ($desc) = $rel =~ m/DISTRIB_DESCRIPTION="(.*)"/ ) {
         $version = $desc;
      }
      else {
         $version = $rel;
      }
   }
   elsif ( -r '/etc/debian_version' ) {
      chomp(my $rel = `cat /etc/debian_version`);
      $version = "Debian (or Debian-based) $rel";
   }
   elsif ( MKDEBUG ) {
      _d('No OS version info because no /etc/*release exists');
   }

   return $version;
}

sub _memory_slots {
   my @memory_slots = ();

   if ( _can_run('dmidecode') ) {
      my $dmi = `dmidecode`;
      chomp $dmi;
      my @mem_info = $dmi =~ m/^(Memory Device\n.*?)\n\n/gsm;
      my @attribs  = ( 'Size', 'Form Factor', 'Type', 'Type Detail', 'Speed' );
      foreach my $mem ( @mem_info ) {
         my %fields = map { split /: / } $mem =~ m/^\s+(\S.*:.*)$/gm;
         push(@memory_slots, join(' ', grep { $_ } @fields{@attribs}));
      }
   }
   elsif ( MKDEBUG ) {
      _d('No memory slots info because dmidecode cannot be ran');
   }

   return @memory_slots;
}

sub shorten
{
   my ( $number, $kb, $d ) = @_;
   my $n = 0;
   my $short;

   $kb ||= 1;
   $d  ||= 2;

   if ( $kb ) {
      while ( $number > 1_023 ) { $number /= 1_024; $n++; }
   }
   else {
      while ($number > 999) { $number /= 1000; $n++; }
   }
   $short = sprintf "%.${d}f%s", $number, ('','k','M','G','T')[$n];
   return $1 if $short =~ /^(.+)\.(00)$/o; # 12.00 -> 12 but not 12.00k -> 12k
   return $short;
}

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

# ###########################################################################
# MySQLInstance package 3459
# ###########################################################################
package MySQLInstance;

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

use English qw(-no_match_vars);
use File::Temp ();
use Data::Dumper;
$Data::Dumper::Indent = 1;

use constant MKDEBUG => $ENV{MKDEBUG};

my $option_pattern = '([^\s=]+)(?:=(\S+))?';

my %alias_for = (
   ON   => 'TRUE',
   OFF  => 'FALSE',
   YES  => '1',
   NO   => '0',
);

my %undef_for = (
   'log'                         => 'OFF',
   log_bin                       => 'OFF',
   log_slow_queries              => 'OFF',
   log_slave_updates             => 'ON',
   log_queries_not_using_indexes => 'ON',
   log_update                    => 'OFF',
   skip_bdb                      => 0,
   skip_external_locking         => 'ON',
   skip_name_resolve             => 'ON',
);

my %ignore_sys_var = (
   date_format     => 1,
   datetime_format => 1,
   time_format     => 1,
);

my %eq_for = (
   ft_stopword_file          => sub { return _veq(@_, '(built-in)', ''); },
   query_cache_type          => sub { return _veq(@_, 'ON', '1');        },
   ssl                       => sub { return _veq(@_, '1', 'TRUE');      },
   sql_mode                  => sub { return _veq(@_, '', 'OFF');        },

   basedir                   => sub { return _patheq(@_);                },
   language                  => sub { return _patheq(@_);                },

   log_bin                   => sub { return _eqifon(@_);                },
   log_slow_queries          => sub { return _eqifon(@_);                },

   general_log_file          => sub { return _eqifconfundef(@_);         },
   innodb_data_file_path     => sub { return _eqifconfundef(@_);         },
   innodb_log_group_home_dir => sub { return _eqifconfundef(@_);         },
   log_error                 => sub { return _eqifconfundef(@_);         },
   open_files_limit          => sub { return _eqifconfundef(@_);         },
   slow_query_log_file       => sub { return _eqifconfundef(@_);         },
   tmpdir                    => sub { return _eqifconfundef(@_);         },

   long_query_time           => sub { return _numericeq(@_);             },
);

my %can_be_duplicate = (
   replicate_wild_do_table     => 1,
   replicate_wild_ignore_table => 1,
   replicate_rewrite_db        => 1,
   replicate_ignore_table      => 1,
   replicate_ignore_db         => 1,
   replicate_do_table          => 1,
   replicate_do_db             => 1,
);

sub mysqld_processes
{
   my ( $ps_output ) = @_;
   my @mysqld_processes;
   my $cmd = 'ps -o euser,%cpu,rss,vsz,cmd -e | grep -v grep | grep mysql';
   my $ps  = defined $ps_output ? $ps_output : `$cmd`;
   if ( $ps ) {
      MKDEBUG && _d('ps full output:', $ps);
      foreach my $line ( split("\n", $ps) ) {
         MKDEBUG && _d('ps line:', $line);
         my ($user, $pcpu, $rss, $vsz, $cmd) = split(/\s+/, $line, 5);
         my $bin = find_mysqld_binary_unix($cmd);
         if ( !$bin ) {
            MKDEBUG && _d('No mysqld binary in ps line');
            next;
         }
         MKDEBUG && _d('mysqld binary from ps:', $bin);
         push @mysqld_processes,
            { user    => $user,
              pcpu    => $pcpu,
              rss     => $rss,
              vsz     => $vsz,
              cmd     => $cmd,
              '64bit' => `file $bin` =~ m/64-bit/ ? 'Yes' : 'No',
              syslog  => $ps =~ m/logger/ ? 'Yes' : 'No',
            };
      }
   }
   MKDEBUG && _d('mysqld processes:', Dumper(\@mysqld_processes));
   return \@mysqld_processes;
}

sub new {
   my ( $class, $cmd ) = @_;
   my $self = {};
   MKDEBUG && _d('cmd:', $cmd);
   $self->{mysqld_binary} = find_mysqld_binary_unix($cmd)
      or die "No mysqld binary found in $cmd";
   my $file_output  = `file $self->{mysqld_binary} 2>&1`;
   $self->{regsize} = get_register_size($file_output);
   %{ $self->{cmd_line_ops} }
      = map {
           my ( $var, $val ) = m/$option_pattern/o;
           $var =~ s/-/_/go;
           $val ||= $undef_for{$var} || '';
           $var => $val;
        } ($cmd =~ m/--(\S+)/g);
   $self->{cmd_line_ops}->{defaults_file} ||= '';
   $self->{conf_sys_vars}   = {};
   $self->{online_sys_vars} = {};
   MKDEBUG && _d('new MySQLInstance:', Dumper($self));
   return bless $self, $class;
}

sub get_register_size {
   my ( $file_output ) = @_;
   my ( $size ) = $file_output =~ m/\b(\d+)-bit/;
   return $size || 0;
}

sub find_mysqld_binary_unix {
   my ( $cmd ) = @_;
   my ( $binary ) = $cmd =~ m/(\S+mysqld)\b(?=\s|\Z)/;
   return $binary || '';
}

sub load_sys_vars {
   my ( $self, $dbh ) = @_;

   my $mysqld_broken_msg
      = "The mysqld binary may be broken. "
      . "Try manually running the command above.\n"
      . "Information about system variables from the defaults file "
      . "will not be available.\n";

   my ( $defaults_file_op, $tmp_file ) = $self->_defaults_file_op();
   my $cmd = "$self->{mysqld_binary} $defaults_file_op --help --verbose";
   MKDEBUG && _d('Getting sys vars from mysqld:', $cmd);
   my $retval = system("$cmd 1>/dev/null 2>/dev/null");
   $retval = $retval >> 8;
   if ( $retval != 0 ) {
      MKDEBUG && _d('self dump:', Dumper($self));
      warn "Cannot execute $cmd\n" . $mysqld_broken_msg;
   }
   else {
      if ( my $mysqld_output = `$cmd` ) {
         my ($sys_vars) = $mysqld_output =~ m/---\n(.*?)\n\n/ms;
         %{ $self->{conf_sys_vars} }
            = map {
                 my ( $var, $val ) = m/^(\S+)\s+(?:(\S+))?/;
                 $var =~ s/-/_/go;
                 if ( $val && $val =~ m/\(No/ ) { # (No default value)
                    $val = undef;
                 }
                 $val ||= $undef_for{$var} || '';
                 $var => $val;
              } split "\n", $sys_vars;

         $self->_load_default_defaults_files($mysqld_output);
      }
      else {
         warn "MySQL returned no information by running $cmd\n"
            . $mysqld_broken_msg;
      }
   }

   $self->_load_online_sys_vars($dbh);

   $self->{defaults_files_sys_vars}
      = $self->_vars_from_defaults_file($defaults_file_op); 
   foreach my $var_val ( reverse @{ $self->{defaults_file_sys_vars} } ) {
      my ( $var, $val ) = ( $var_val->[0], $var_val->[1] );
      if ( !exists $self->{conf_sys_vars}->{$var} ) {
         $self->{conf_sys_vars}->{$var} = $val;
      }
      if ( !exists $self->{online_sys_vars}->{$var} ) {
         $self->{online_sys_vars}->{$var} = $val;
      }
   }

   return;
}

sub _defaults_file_op {
   my ( $self, $ddf )   = @_;  # ddf = default defaults file (optional)
   my $defaults_file_op = '';
   my $tmp_file         = undef;
   my $defaults_file    = defined $ddf ? $ddf
                        : $self->{cmd_line_ops}->{defaults_file};

   if ( $defaults_file && -f $defaults_file ) {
      $tmp_file = File::Temp->new();
      my $cp_cmd = "cp $defaults_file "
                 . $tmp_file->filename;
      `$cp_cmd`;
      $defaults_file_op = "--defaults-file=" . $tmp_file->filename;

      MKDEBUG && _d('Tmp file for defaults file', $defaults_file, ':',
         $tmp_file->filename);
   }
   else {
      MKDEBUG && _d('Defaults file does not exist:', $defaults_file);
   }

   return ( $defaults_file_op, $tmp_file );
}

sub _load_default_defaults_files {
   my ( $self, $mysqld_output ) = @_;
   my ( $ddf_list ) = $mysqld_output =~ /Default options.+order:\n(.*?)\n/ms;
   if ( !$ddf_list ) {
      die "Cannot parse default defaults files: $mysqld_output\n";
   }
   MKDEBUG && _d('List of default defaults files:', $ddf_list);
   my %have_seen;
   @{ $self->{default_defaults_files} }
      = grep { !$have_seen{$_}++ } split /\s/, $ddf_list;
   return;
}

sub _vars_from_defaults_file {
   my ( $self, $defaults_file_op, $my_print_defaults ) = @_;

   my $my_print_defaults_cmd = $my_print_defaults || 'my_print_defaults';
   my $retval = system("$my_print_defaults_cmd --help 1>/dev/null 2>/dev/null");
   $retval = $retval >> 8;
   if ( $retval != 0 ) {
      MKDEBUG && _d('self dump:', Dumper($self));
      die "Cannot execute my_print_defaults command '$my_print_defaults_cmd'";
   }

   my @defaults_file_ops;
   my @ddf_ops;

   if( !$defaults_file_op ) {

      foreach my $ddf ( @{ $self->{default_defaults_files} } ) {
         my @dfo = $self->_defaults_file_op($ddf);
         if ( defined $dfo[1] ) { # tmp_file handle
            push @ddf_ops, [ @dfo ];
            push @defaults_file_ops, $dfo[0]; # defaults file op
         }
      }
   }
   else {
      $defaults_file_ops[0] = $defaults_file_op;
   }

   if ( scalar @defaults_file_ops == 0 ) {
      MKDEBUG && _d('self dump:', Dumper($self));
      die 'MySQL instance has no valid defaults files.'
   }

   foreach my $defaults_file_op ( @defaults_file_ops ) {
      my $cmd = "$my_print_defaults_cmd $defaults_file_op mysqld";
      MKDEBUG && _d('my_print_defaults cmd:', $cmd);
      if ( my $my_print_defaults_output = `$cmd` ) {
         foreach my $var_val ( split "\n", $my_print_defaults_output ) {
            my ( $var, $val ) = $var_val =~ m/^--$option_pattern/o;
            $var =~ s/-/_/go;
            if ( defined $val && $val =~ /(\d+)([kKmMgGtT]?)/) {
               if ( $2 ) {
                  my %digits_for = (
                     'k'   => 1_024,
                     'K'   => 1_204,
                     'm'   => 1_048_576,
                     'M'   => 1_048_576,
                     'g'   => 1_073_741_824,
                     'G'   => 1_073_741_824,
                     't'   => 1_099_511_627_776,
                     'T'   => 1_099_511_627_776,
                  );
                  $val = $1 * $digits_for{$2};
               }
            }
            $val ||= $undef_for{$var} || '';
            push @{ $self->{defaults_file_sys_vars} }, [ $var, $val ];
         }
      }
   }
   return;
}

sub _load_online_sys_vars {
   my ( $self, $dbh ) = @_;
   %{ $self->{online_sys_vars} }
      = map { $_->{Variable_name} => $_->{Value} }
            @{ $dbh->selectall_arrayref('SHOW /*!40101 GLOBAL*/ VARIABLES',
                                        { Slice => {} })
            };
   return;
}

sub get_DSN {
   my ( $self, $o ) = @_;
   die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
   my $port   = $self->{cmd_line_ops}->{port} || '';
   my $socket = $o->get('socket') || $self->{cmd_line_ops}->{'socket'} || '';
   my $host   = $o->get('socket') ? 'localhost'
              : $port ne 3306     ? '127.0.0.1'
              :                   'localhost';
   return {
      P => $port,
      S => $socket,
      h => $host,
   };
}

sub duplicate_sys_vars {
   my ( $self ) = @_;
   my @duplicate_vars;
   my %have_seen;
   foreach my $var_val ( @{ $self->{defaults_file_sys_vars} } ) {
      my ( $var, $val ) = ( $var_val->[0], $var_val->[1] );
      next if $can_be_duplicate{$var};
      push @duplicate_vars, $var if $have_seen{$var}++ == 1;
   }
   return \@duplicate_vars;
}

sub overriden_sys_vars {
   my ( $self ) = @_;
   my %overriden_vars;
   foreach my $var_val ( @{ $self->{defaults_file_sys_vars} } ) {
      my ( $var, $val ) = ( $var_val->[0], $var_val->[1] );
      if ( !defined $var || !defined $val ) {
         MKDEBUG && _d('Undefined var or val:', Dumper($var_val));
         next;
      }
      if ( exists $self->{cmd_line_ops}->{$var} ) {
         if(    ( !defined $self->{cmd_line_ops}->{$var} && !defined $val)
             || ( $self->{cmd_line_ops}->{$var} ne $val) ) {
            $overriden_vars{$var} = [ $self->{cmd_line_ops}->{$var}, $val ];
         }
      }
   }
   return \%overriden_vars;
}

sub out_of_sync_sys_vars {
   my ( $self ) = @_;
   my %out_of_sync_vars;

   VAR:
   foreach my $var ( keys %{ $self->{conf_sys_vars} } ) {
      next VAR if exists $ignore_sys_var{$var};
      next VAR unless exists $self->{online_sys_vars}->{$var};

      my $conf_val        = $self->{conf_sys_vars}->{$var};
      my $online_val      = $self->{online_sys_vars}->{$var};
      my $var_out_of_sync = 0;


      if ( ($conf_val || $online_val) && ($conf_val ne $online_val) ) {
         $var_out_of_sync = 1;

         if ( exists $eq_for{$var} ) {
            $var_out_of_sync = !$eq_for{$var}->($conf_val, $online_val);
         }
         if ( exists $alias_for{$online_val} ) {
            $var_out_of_sync = 0 if $conf_val eq $alias_for{$online_val};
         }
      }

      if ( $var_out_of_sync ) {
         $out_of_sync_vars{$var} = { online=>$online_val, config=>$conf_val };
      }
   }

   return \%out_of_sync_vars;
}

sub load_status_vals {
   my ( $self, $dbh ) = @_;
   %{ $self->{status_vals} }
      = map { $_->{Variable_name} => $_->{Value} }
            @{ $dbh->selectall_arrayref('SHOW /*!50002 GLOBAL */ STATUS',
                                        { Slice => {} })
            };
   return;
}

sub get_eq_for {
   my ( $var ) = @_;
   if ( exists $eq_for{$var} ) {
      return $eq_for{$var};
   }
   return;
}

sub _veq { 
   my ( $x, $y, $val1, $val2 ) = @_;
   return 1 if ( ($x eq $val1 || $x eq $val2) && ($y eq $val1 || $y eq $val2) );
   return 0;
}

sub _patheq {
   my ( $x, $y ) = @_;
   $x .= '/' if $x !~ m/\/$/;
   $y .= '/' if $y !~ m/\/$/;
   return $x eq $y;
}

sub _eqifon { 
   my ( $x, $y ) = @_;
   return 1 if ( $x && $x eq 'ON' && $y );
   return 1 if ( $y && $y eq 'ON' && $x );
   return 0;
}

sub _eqifconfundef {
   my ( $conf_val, $online_val ) = @_;
   return ($conf_val eq '' ? 1 : 0);
}

sub _numericeq {
   my ( $x, $y ) = @_;
   return ($x == $y ? 1 : 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 MySQLInstance package
# ###########################################################################

# ###########################################################################
# SchemaDiscover package 3467
# ###########################################################################
package SchemaDiscover;

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

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, %args ) = @_;
   foreach my $arg ( qw(du q tp vp) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my $self = {
      %args
   };
   return bless $self, $class;
}

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

   my $schema = {
      dbs         => {},
      counts      => {},
      stored_code => undef,  # may be either arrayref of error string
   };
   my $dbs     = $schema->{dbs};
   my $counts  = $schema->{counts};
   my $du      = $self->{du};
   my $q       = $self->{q};
   my $tp      = $self->{tp};
   my $vp      = $self->{vp};

   %$dbs = map { $_ => {} } $du->get_databases($dbh, $q);

   delete $dbs->{information_schema}
      if exists $dbs->{information_schema};

   $counts->{TOTAL}->{dbs} = scalar keys %{$dbs};

   foreach my $db ( keys %$dbs ) {
      %{$dbs->{$db}}
         = map { $_->{name} => {} } $du->get_table_list($dbh, $q, $db);
      foreach my $tbl_stat ($du->get_table_status($dbh, $q, $db)) {
         %{$dbs->{$db}->{"$tbl_stat->{name}"}} = %$tbl_stat;
      }
      foreach my $table ( keys %{$dbs->{$db}} ) {
         my $ddl        = $du->get_create_table($dbh, $q, $db, $table);
         my $table_info = $tp->parse($ddl);
         my $n_indexes  = scalar keys %{ $table_info->{keys} };

         my $data_size  = $dbs->{$db}->{$table}->{data_length}  ||= 0;
         my $index_size = $dbs->{$db}->{$table}->{index_length} ||= 0;
         my $rows       = $dbs->{$db}->{$table}->{rows}         ||= 0;
         my $engine     = $dbs->{$db}->{$table}->{engine}; 

         $counts->{dbs}->{$db}->{tables}             += 1;
         $counts->{dbs}->{$db}->{indexes}            += $n_indexes;
         $counts->{dbs}->{$db}->{engines}->{$engine} += 1;
         $counts->{dbs}->{$db}->{rows}               += $rows;
         $counts->{dbs}->{$db}->{data_size}          += $data_size;
         $counts->{dbs}->{$db}->{index_size}         += $index_size;

         $counts->{engines}->{$engine}->{tables}     += 1;
         $counts->{engines}->{$engine}->{indexes}    += $n_indexes;
         $counts->{engines}->{$engine}->{data_size}  += $data_size;
         $counts->{engines}->{$engine}->{index_size} += $index_size; 

         $counts->{TOTAL}->{tables}     += 1;
         $counts->{TOTAL}->{indexes}    += $n_indexes;
         $counts->{TOTAL}->{rows}       += $rows;
         $counts->{TOTAL}->{data_size}  += $data_size;
         $counts->{TOTAL}->{index_size} += $index_size;
      }
   }

   if ( $vp->version_ge($dbh, '5.0.0') ) {
      $schema->{stored_code} = $self->discover_stored_code($dbh);
   }
   else {
      $schema->{stored_code}
         = 'This version of MySQL does not support stored code.';
   }

   return $schema;
}

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

   my @stored_code_objs  =
      @{ $dbh->selectall_arrayref(
            "SELECT EVENT_OBJECT_SCHEMA AS db,
            CONCAT(LEFT(LOWER(EVENT_MANIPULATION), 3), '_trg') AS what,
            COUNT(*) AS num
            FROM INFORMATION_SCHEMA.TRIGGERS GROUP BY db, what
            UNION ALL
            SELECT ROUTINE_SCHEMA AS db,
            LEFT(LOWER(ROUTINE_TYPE), 4) AS what,
            COUNT(*) AS num
            FROM INFORMATION_SCHEMA.ROUTINES GROUP BY db, what
            /*!50106
               UNION ALL
               SELECT EVENT_SCHEMA AS db, 'evt' AS what, COUNT(*) AS num
               FROM INFORMATION_SCHEMA.EVENTS GROUP BY db, what
            */")
      };

   my @formatted_code_objs;
   foreach my $code_obj ( @stored_code_objs ) {
      push @formatted_code_objs, "$code_obj->[0] $code_obj->[1] $code_obj->[2]";
   }

   return \@formatted_code_objs;
}

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

# ###########################################################################
# MySQLAdvisor package 3186
# ###########################################################################

package MySQLAdvisor;

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

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

use constant MKDEBUG => $ENV{MKDEBUG};

my %checks = (
   innodb_flush_method =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         return "innodb_flush_method is not set to O_DIRECT"
            if $sys_vars->{innodb_flush_method} ne 'O_DIRECT';
         return 0;
      },
   log_slow_queries =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         return "Slow query logging is disabled (log_slow_queries = OFF)"
            if $sys_vars->{log_slow_queries} eq 'OFF';
         return 0;
      },
   max_connections =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         return "max_connections has been modified from its default (100): "
                . $sys_vars->{max_connections}
            if $sys_vars->{max_connections} != 100;
         return 0;
      },
   thread_cache_size =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         return "Zero thread cache (thread_cache_size = 0)"
            if $sys_vars->{thread_cache_size} == 0;
         return 0;
      },
   'socket' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         if ( ! (-e $sys_vars->{'socket'} && -S $sys_vars->{'socket'}) ) {
            return "Socket is missing ($sys_vars->{socket})";
         }
         return 0;
      },
   'query_cache' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         if ( exists $sys_vars->{query_cache_type} ) {
            if (    $sys_vars->{query_cache_type} eq 'ON'
                 && $sys_vars->{query_cache_size} == 0) {
               return "Query caching is enabled but query_cache_size is zero";
            }
         }
         return 0;
      },
   'Innodb_buffer_pool_pages_free' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         if ( exists $status_vals->{Innodb_buffer_pool_pages_free} ) {
            if ( $status_vals->{Innodb_buffer_pool_pages_free} == 0 ) {
               return "InnoDB: zero free buffer pool pages";
            }
         }
         return 0;
      },
   'skip_name_resolve' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         if ( !exists $sys_vars->{skip_name_resolve} ) {
            return "skip-name-resolve is not set";
         }
         return 0;
      },
   'key_buffer too large' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         return "Key buffer may be too large"
            if $sys_vars->{key_buffer_size}
               > max($counts->{engines}->{MyISAM}->{data_size}, 33554432); # 32M
         return 0;
      },
   'InnoDB buffer pool too small' =>
      sub {
         my ( $sys_vars, $status_vals, $schema, $counts ) = @_;
         if (    exists $sys_vars->{innodb_buffer_pool_size} 
              && exists $counts->{engines}->{InnoDB} ) {
            return "InnoDB: buffer pool too small"
               if $counts->{engines}->{InnoDB}->{data_size}
                  >= $sys_vars->{innodb_buffer_pool_size};
         }
      },
);

sub new {
   my ( $class, $MySQLInstance, $SchemaDiscover ) = @_;
   my $self = {
      sys_vars    => $MySQLInstance->{online_sys_vars},
      status_vals => $MySQLInstance->{status_vals},
      schema      => $SchemaDiscover->{dbs},
      counts      => $SchemaDiscover->{counts},
   };
   return bless $self, $class;
}

sub run_checks {
   my ( $self, $check_name ) = @_;
   my %problems;
   if ( defined $check_name ) {
      if ( exists $checks{$check_name} ) {
         if ( my $problem = $checks{$check_name}->($self->{sys_vars},
                                                   $self->{status_vals},
                                                   $self->{schema},
                                                   $self->{counts}) ) {
            $problems{$check_name} = $problem;
         }
      }
      else {
         $problems{ERROR} = "No check named $check_name exists.";
      }
   }
   else {
      foreach my $check_name ( keys %checks ) {
         if ( my $problem = $checks{$check_name}->($self->{sys_vars},
                                                   $self->{status_vals},
                                                   $self->{schema},
                                                   $self->{counts}) ) {
            $problems{$check_name} = $problem;
         }
      }
   }
   return \%problems;
}

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

# ###########################################################################
# AggregateProcesslist package 3470
# ###########################################################################
package AggregateProcesslist;

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

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, %args ) = @_;
   my $self = {
      undef_val => $args{undef_val} || 'NULL',
   };
   return bless $self, $class;
}

sub aggregate {
   my ( $self, $proclist ) = @_;
   my $aggregate = {};
   foreach my $proc ( @{$proclist} ) {
      foreach my $field ( keys %{ $proc } ) {
         next if $field eq 'Id';
         next if $field eq 'Info';
         next if $field eq 'Time';

         my $val  = $proc->{ $field };
            $val  = $self->{undef_val} if !defined $val;
            $val  = lc $val if ( $field eq 'Command' || $field eq 'State' );
            $val  =~ s/:.*// if $field eq 'Host';

         my $time = $proc->{Time};
            $time = 0 if $time eq 'NULL';

         $field = lc $field;

         $aggregate->{ $field }->{ $val }->{time}  += $time;
         $aggregate->{ $field }->{ $val }->{count} += 1;
      }
   }
   return $aggregate;
}

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

# ###########################################################################
# Grants package 3464
# ###########################################################################
package Grants;

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

use constant MKDEBUG => $ENV{MKDEBUG};

my %check_for_priv = (
   'PROCESS' => sub {
      my ( $dbh ) = @_;
      my $priv =
         grep { m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ }
         @{$dbh->selectcol_arrayref('SHOW GRANTS')};
         return 0 if !$priv;
         return 1;
   },
);
      
sub new {
   my ( $class, %args ) = @_;
   my $self = {};
   return bless $self, $class;
}

sub have_priv {
   my ( $self, $dbh, $priv ) = @_;
   $priv = uc $priv;
   if ( !exists $check_for_priv{$priv} ) {
      die "There is no check for privilege $priv";
   }
   return $check_for_priv{$priv}->($dbh);
}

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

# ###########################################################################
# MySQLInstanceReporter package 3469
# ###########################################################################

package MySQLInstanceReporter;

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

Transformers->import( qw(micro_t shorten secs_to_time) );

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

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

sub report {
   my ( $self, %args ) = @_;
   foreach my $arg ( qw(mi n ps schema ma o proclist) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my $mi       = $args{mi};
   my $n        = $args{n};
   my $ps       = $args{ps};
   my $schema   = $args{schema};
   my $ma       = $args{ma};
   my $o        = $args{o};
   my $proclist = $args{proclist};

format MYSQL_INSTANCE_1 =

____________________________________________________________ MySQL Instance @>>
$n
   Version:  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Architecture: @<-bit
$mi->{online_sys_vars}->{version}, $mi->{regsize}
   Uptime:   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
secs_to_time($mi->{status_vals}->{Uptime})
   ps vals:  user @<<<<<<< cpu% @<<<<< rss @<<<<<< vsz @<<<<<< syslog: @<<
$ps->{user}, $ps->{pcpu}, shorten($ps->{rss} * 1024), shorten($ps->{vsz} * 1024), $ps->{syslog}
   Bin:      @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{mysqld_binary}
   Data dir: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{online_sys_vars}->{datadir}
   PID file: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{online_sys_vars}->{pid_file}
   Socket:   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{online_sys_vars}->{'socket'}
   Port:     @<<<<<<
$mi->{online_sys_vars}->{port}
   Log locations:
      Error:  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{conf_sys_vars}->{log_error} || ''
      Relay:  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{conf_sys_vars}->{relay_log} || ''
      Slow:   @<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
micro_t($mi->{online_sys_vars}->{long_query_time}), $mi->{conf_sys_vars}->{log_slow_queries} || 'OFF'
   Config file location: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$mi->{cmd_line_ops}->{defaults_file}
.

   $FORMAT_NAME = 'MYSQL_INSTANCE_1';
   write;

   if ( $schema->{counts}->{TOTAL}->{dbs} == 0 ) {
      print "This MySQL instance has no databases.\n"
   }
   else {
format MYSQL_INSTANCE_2 =
   SCHEMA ________________________________________________________________
      @<<<<<<      @<<<<<<   @<<<<<<   @<<<<<<    @<<<<<<     @<<<<<<
$schema->{counts}->{TOTAL}->{dbs}, $schema->{counts}->{TOTAL}->{tables}, shorten($schema->{counts}->{TOTAL}->{rows}, d=>1000), $schema->{counts}->{TOTAL}->{indexes} || 'NA', shorten($schema->{counts}->{TOTAL}->{data_size}), shorten($schema->{counts}->{TOTAL}->{index_size})

      Key buffer size        : @<<<<<<
shorten($mi->{online_sys_vars}->{key_buffer_size})
      InnoDB buffer pool size: @<<<<<<
exists $mi->{online_sys_vars}->{innodb_buffer_pool_size} ? shorten($mi->{online_sys_vars}->{innodb_buffer_pool_size}) : ''

.

      $FORMAT_NAME = 'MYSQL_INSTANCE_2';
      write;

      $self->_print_dbs_size_summary($schema, $o);
      $self->_print_tables_size_summary($schema, $o);
      $self->_print_engines_summary($schema, $o);
      $self->_print_stored_code_summary($schema, $o);
   }

   print "\n   PROBLEMS ______________________________________________________________\n";

   my $duplicates = $mi->duplicate_sys_vars();
   if ( scalar @{ $duplicates } ) {
      print "\tDuplicate system variables in config file:\n";
      print "\tVARIABLE\n";
      foreach my $var ( @{ $duplicates } ) {
         print "\t$var\n";
      }
      print "\n";
   }

   my $three_cols = "\t%-20.20s  %-24.24s  %-24.24s\n";

   my $overridens = $mi->overriden_sys_vars();
   if ( scalar keys %{ $overridens } ) {
      print "\tOverridden system variables "
         . "(cmd line value overrides config value):\n";
      printf($three_cols, 'VARIABLE', 'CMD LINE VALUE', 'CONFIG VALUE');
      foreach my $var ( keys %{ $overridens } ) {
         printf($three_cols,
                $var,
                $overridens->{$var}->[0],
                $overridens->{$var}->[1]);
      }
      print "\n";
   }

   my $oos = $mi->out_of_sync_sys_vars();
   if ( scalar keys %{ $oos } ) {
      print "\tOut of sync system variables "
         . "(online value differs from config value):\n";
      printf($three_cols, 'VARIABLE', 'ONLINE VALUE', 'CONFIG VALUE');
      foreach my $var ( keys %{ $oos } ) {
         printf($three_cols,
                $var,
                $oos->{$var}->{online},
                $oos->{$var}->{config});
      }
      print "\n";
   }

   my $failed_checks = $ma->run_checks();
   if ( scalar keys %{ $failed_checks } ) {
      print "\tThings to Note:\n";
      foreach my $check_name ( keys %{ $failed_checks } ) {
         print "\t\t- $failed_checks->{$check_name}\n";
      }
   }

   $self->_print_aggregated_processlist($proclist);

   return;
}

sub _print_dbs_size_summary {
   my ( $self, $schema, $o ) = @_;
   my %dbs = %{ $schema->{counts}->{dbs} }; # copy we can chop
   my $top = $o->get('top');
   my @sorted;
   my ( $db, $size );
   print   "      Top $top largest databases:\n"
         . "         DATABASE             SIZE DATA\n";
format DB_LINE =
         @<<<<<<<<<<<<<<<<<   @<<<<<<<<<<<<<<<<<<<<<<<<<<<
$db, $size
.
   @sorted = sort { $dbs{$b}->{data_size} <=> $dbs{$a}->{data_size} } keys %dbs;
   $FORMAT_NAME = 'DB_LINE';
   foreach $db ( @sorted ) {
      $size = shorten($dbs{$db}->{data_size});
      write;
      delete $dbs{$db};
      last if !--$top;
   }
   my $n_remaining = 0;
   my $r_size      = 0;
   my $r_avg       = 0;
   foreach my $db ( keys %dbs ) {
      $n_remaining++;
      $r_size += $dbs{$db}->{data_size};
   }
   if ($n_remaining) {
      $r_avg = shorten($r_size / $n_remaining);
      $r_size = shorten($r_size);
      $db   = "Remaining $n_remaining";
      $size = "$r_size ($r_avg average)";
      write;
   }
   return;
}

sub _print_tables_size_summary {
   my ( $self, $schema, $o ) = @_;
   my %dbs_tbls;
   my $dbs = $schema->{dbs};
   my $top = $o->get('top');
   my @sorted;
   my ( $db_tbl, $size_data, $size_index, $n_rows, $engine );
   print   "      Top $top largest tables:\n"
         . "         DB.TBL              SIZE DATA  SIZE INDEX  #ROWS    ENGINE\n";
format TBL_LINE =
         @<<<<<<<<<<<<<<<<   @<<<<<<<<  @<<<<<<<<<  @<<<<<<  @<<<<<
$db_tbl, $size_data, $size_index, $n_rows, $engine
.
   foreach my $db ( keys %$dbs ) {
      foreach my $tbl ( keys %{$dbs->{$db}} ) {
         $dbs_tbls{"$db.$tbl"} = $dbs->{$db}->{$tbl}->{data_length};
      }
   }
   @sorted = sort { $dbs_tbls{$b} <=> $dbs_tbls{$a} } keys %dbs_tbls;
   $FORMAT_NAME = 'TBL_LINE';
   foreach $db_tbl ( @sorted ) {
      my ( $db, $tbl ) = split '\.', $db_tbl;
      $size_data  = shorten($dbs_tbls{$db_tbl});
      $size_index = shorten($dbs->{$db}->{$tbl}->{index_length});
      $n_rows     = shorten($dbs->{$db}->{$tbl}->{rows}, d=>1000);
      $engine     = $dbs->{$db}->{$tbl}->{engine};
      write;
      delete $dbs_tbls{$db_tbl};
      last if !--$top;
   }
   my $n_remaining = 0;
   my $r_size      = 0;
   my $r_avg       = 0;
   foreach my $db_tbl ( keys %dbs_tbls ) {
      $n_remaining++;
      $r_size += $dbs_tbls{$db_tbl};
   }
   if ($n_remaining) {
      $r_avg  = shorten($r_size / $n_remaining);
      $r_size = shorten($r_size);
      print "         Remaining $n_remaining        $r_size ($r_avg average)\n";
   }
   return;
}

sub _print_engines_summary {
   my ( $self, $schema, $o ) = @_;
   my $engines = $schema->{counts}->{engines};
   my ($engine, $n_tables, $n_indexes, $size_data, $size_indexes);
   print   "      Engines:\n"
         . "         ENGINE      SIZE DATA   SIZE INDEX   #TABLES   #INDEXES\n";
format ENGINE_LINE =
         @<<<<<<<<<  @<<<<<<     @<<<<<<      @<<<<<<   @<<<<<<
$engine, $size_data, $size_indexes, $n_tables, $n_indexes
.
   $FORMAT_NAME = 'ENGINE_LINE';
   foreach $engine ( keys %{ $engines } ) {
      $size_data    = shorten($engines->{$engine}->{data_size});
      $size_indexes = shorten($engines->{$engine}->{index_size});
      $n_tables     = $engines->{$engine}->{tables};
      $n_indexes    = $engines->{$engine}->{indexes} || 'NA';
      write;
   }
   return;
}

sub _print_stored_code_summary {
   my ( $self, $schema, $o ) = @_;
   my ( $db, $type, $count );

   print   "      Triggers, Routines, Events:\n"
         . "         DATABASE           TYPE      COUNT\n";
format TRE_LINE =
         @<<<<<<<<<<<<<<<<  @<<<<<<   @<<<<<<
$db, $type, $count
.

   if ( ref $schema->{stored_code} ) {
      my @stored_code_objs = @{$schema->{stored_code}};
      if ( @stored_code_objs ) {
         $FORMAT_NAME = 'TRE_LINE';
         foreach my $code_obj ( @stored_code_objs ) {
            ( $db, $type, $count ) = split ' ', $code_obj;
            write;
         }
      }
      else {
         print "         No triggers, routines, or events\n";
      }
   }
   else {
      print "         $schema->{stored_code}\n";
   }

   return;
}

sub _print_aggregated_processlist {
   my ( $self, $ag_pl ) = @_;
   my ( $value, $count, $total_time); # used by format

   print "\n   Aggregated PROCESSLIST ________________________________________________
      FIELD      VALUE                       COUNT   TOTAL TIME (s)\n";

format VALUE_LINE =
                 @<<<<<<<<<<<<<<<<<<<<<<<<   @<<<<   @<<<<
$value, $count, $total_time
.

   if ( ref $ag_pl ) {
      foreach my $field ( keys %{ $ag_pl } ) {
         printf "      %.8s\n", $field;
         $FORMAT_NAME = 'VALUE_LINE';
         foreach $value ( keys %{ $ag_pl->{$field} } ) {
            $count       = $ag_pl->{$field}->{$value}->{count};
            $total_time  = $ag_pl->{$field}->{$value}->{time};
            write;
         }
      }
   }
   else {
      print "   $ag_pl\n";
   }

   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 MySQLInstanceReporter 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_audit;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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

   # #########################################################################
   # Get configuration information.
   # #########################################################################
   my $dp = new DSNParser(); 
   my $o  = new OptionParser(
      description => 'inspects, analyzes and reports on a MySQL server.',
   );
   $o->get_specs();
   $o->get_opts();

   # TODO: implement --host
   die "Sorry, --host is not implemented yet" if $o->got('host');

   $dp->prop('set-vars', $o->get('set-vars'));

   $o->usage_or_errors();

   if ( $o->get('ask-pass') ) {
      $o->set('password', OptionParser::prompt_noecho("Enter password: "));
   }

   # #########################################################################
   # Get and report server specs.
   # #########################################################################
   my $server_specs = ServerSpecs::server_specs();
   report_server_specs($server_specs);

   # #########################################################################
   # Find and report all MySQL instances.
   # #########################################################################
   my $n           = 0; # instance number
   my $mi_reporter = new MySQLInstanceReporter();
   my $vp          = new VersionParser;
   my $du          = new MySQLDump(cache => 0);
   my $q           = new Quoter;
   my $tp          = new TableParser;
   my $apl         = new AggregateProcesslist();
   my $gr          = new Grants();
   my $sd          = new SchemaDiscover(du=>$du, q=>$q, tp=>$tp, vp=>$vp);

   # This sub does the actual work.  It's called below, either in a foreach()
   # loop or once if a specific --host was given.  This sub must be declared
   # here so that it's in the scope of all those objects above (vp, du, etc.)
   my $audit_instance = sub {
      my ( $mysqld_ps, $mi, $dbh ) = @_;

      # Get system variable and status values.
      $mi->load_sys_vars($dbh);
      $mi->load_status_vals($dbh);

      # Get schema info.
      my $schema = $sd->discover($dbh);

      # Get aggregated processlist.
      my $aggregated_proclist;
      if ( $gr->have_priv($dbh, 'PROCESS') ) {
         $aggregated_proclist = $apl->aggregate(
            $dbh->selectall_arrayref('SHOW PROCESSLIST',{ Slice => {} }));
      }
      else {
         $aggregated_proclist
            = "Cannot report aggregated processlist because "
            . "database user does not have PROCESS privilege.\n";
      }

      # Check for problems and oddities.
      my $ma = new MySQLAdvisor($mi, $schema);

      # Finally, report everything.
      $mi_reporter->report(
         ma        => $ma,
         mi        => $mi,
         n         => $n,
         o         => $o,
         ps        => $mysqld_ps,
         schema    => $schema,
         proclist  => $aggregated_proclist,
      );

      return; 
   };


   # Audit every MySQL instance that we can find on the server
   # by looking at ps output.
   my $mysqld_procs = MySQLInstance::mysqld_processes();
   INSTANCE:
   foreach my $mysqld_ps ( @$mysqld_procs ) {
      $n++;

      # Connect to instance.
      my $mi    = new MySQLInstance( $mysqld_ps->{cmd} );
      my $dsn   = $mi->get_DSN($o);
      $dsn->{u} = $o->get('user')     if $o->get('user');
      $dsn->{p} = $o->get('password') if $o->get('password');
      my $dbh;
      eval {
         $dbh = $dp->get_dbh($dp->get_cxn_params($dsn));
      };
      if ( $EVAL_ERROR ) {
         print "Cannot connect to ", $dp->as_string($dsn), ": $EVAL_ERROR\n";
         next INSTANCE;
      }

      $audit_instance->($mysqld_ps, $mi, $dbh);
      
      $dbh->disconnect();
   }

   if ( $n == 0 ) {
      print "No instances of MySQL were found running on this server.\n";
   }


   return 0;
}

# #############################################################################
# Subroutines.
# #############################################################################

sub report_server_specs {
   my ( $server ) = @_;

format SERVER_1 =
__________________________________________________________________ Server Specs
OS: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Architecture: @<-bit
"$server->{os}->{name} $server->{os}->{version}", $server->{os}->{regsize}

CPU: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Architecture: @<-bit
$server->{cpu}->{model}, $server->{cpu}->{regsize}
   Speed: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{cpu}->{speed}
   Cache: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{cpu}->{cache}
   Count: @<<<<<<<<<<<<
$server->{cpu}->{count}
   Cores: @<<<<<<<<<<<<
$server->{cpu}->{cores}

Memory: used @<<<<<< of @<<<<<< total  (@<<<<<< free)
$server->{memory}->{used}, $server->{memory}->{total}, $server->{memory}->{free}
   Buffers: @<<<<<<<<<<
$server->{memory}->{buffers}
   Cached:  @<<<<<<<<<<
$server->{memory}->{cached}
   Shared:  @<<<<<<<<<<
$server->{memory}->{shared}
   Slots: @*
{ local $LIST_SEPARATOR = "\n"; "@{$server->{memory}->{slots}}" }

Storage:
.

format SERVER_2 =
   LVM volume groups: @*
$server->{storage}->{vgs}
   df: @*
$server->{storage}->{df}

libc: @<<<<<<<<<<<<<<<<<
$server->{sw}->{libc}->{ver}
   Compiled by: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{sw}->{libc}->{compiled_by}
   Threading:   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{sw}->{libc}->{threading}
   GNU libpthread version: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{sw}->{libc}->{GNU_LIBPTHREAD_VERSION}

PROBLEMS _________________________________________________________________
.

   # Print SERVER report
   $FORMAT_NAME = 'SERVER_1';
   write;

   # Print RAID information
   # Apparently, the @* field has a 17 line limit
   # hence we must print this stuff manually.
   my $raid_ctrls   = $server->{storage}->{raid};
   my $n_raid_ctrls = scalar keys %$raid_ctrls;
   if ( $n_raid_ctrls == 0 ) {
      print "   No RAID controllers detected.\n";
   }
   else {
      print "   $n_raid_ctrls RAID controllers  detected:\n\n";
      while ( my ($raid_name, $raid_info) = each %$raid_ctrls ) {
         print "$raid_name\n"
            . ('#' x (length $raid_name)) . "\n"
            . "$raid_info\n";
      }
      print "########## End of RAID controllers ##########\n\n";
   }

   $FORMAT_NAME = 'SERVER_2';
   write;
   foreach my $problem ( @{ $server->{problems} } ) {
      print "\t- $problem\n";
   }

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

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

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

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

=pod

=head1 NAME

mk-audit - Analyze, summarize and report on MySQL config, schema and operation

=head1 SYNOPSIS

   mk-audit

=head1 DESCRIPTION

mk-audit summarizes the information a consultant may find useful when analyzing
a MySQL server.  It prints out a report that contains the following information:

=head2 OPERATING SYSTEM

The operating system report shows information about the operating system and
hardware.  The information includes the operating system version and flavor, and
information on CPU, memory and disks as well as some core system libraries.

This is currently very specific to GNU/Linux.

=head2 MYSQL

For each MySQL instance detected on the system, mk-audit reports some
information on the server and the data in it.

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

=over

=item --ask-pass

Prompt for a password when connecting to MySQL.

=item --charset

short form: -A; type: string

Default character set.  If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
NAMES UTF8 after connecting to MySQL.  Any other value sets binmode on STDOUT
without the utf8 layer, and runs SET NAMES after connecting to MySQL.

=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 --defaults-file

short form: -F; type: string

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

=item --help

Show help and exit.

=item --host

short form: -h; type: string

Connect to host.

TODO: Not implemented yet.

=item --password

short form: -p; type: string

Password to use when connecting.

=item --port

short form: -P; type: int

Port number to use for connection.

=item --set-vars

type: string; default: wait_timeout=10000

Set these MySQL variables.  Immediately after connecting to MySQL, this string
will be appended to SET and executed.

=item --socket

short form: -S; type: string

Socket file to use for connection.

=item --top

type: int; default: 5

Show top N largest databases and tables.

=item --user

short form: -u; type: string

User for login if not current user.

=item --version

Show version and exit.

=back

=head1 ENVIRONMENT

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

   MKDEBUG=1 mk-....

=head1 SYSTEM REQUIREMENTS

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

=head1 BUGS

Please use 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 2008-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.

=head1 AUTHOR

Daniel Nichter, Baron Schwartz

=head1 VERSION

This manual page documents Ver 0.9.8 Distrib 4047 $Revision: 3965 $.

=cut
