#!/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.6';
our $DISTRIB = '3329';
our $SVN_REV = sprintf("%d", (q$Revision: 3298 $ =~ m/(\d+)/g, 0));

# ###########################################################################
# MySQLDump package 3186
# ###########################################################################
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 3297
# ###########################################################################
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 pod_to_spec {
   my ( $self, $file ) = @_;
   $file ||= __FILE__;
   open my $fh, '<', $file or die "Can't 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->{dsn}
      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;
   my $option;

   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('First option rules:', $para);
      push @rules, $para;
   }

   do {
      if ( ($option) = $para =~ m/^=item --(.*)/ ) {
         MKDEBUG && _d($para);
         my %props;
         $para = <$fh>;
         if ( $para =~ m/: / ) {
            $para =~ s/\s+\Z//g;
            %props = map { split(/: /, $_) } split(/; /, $para);
            if ( $props{'short form'} ) {
               $props{'short form'} =~ s/-//;
            }
            $para = <$fh>;
         }
         $para =~ s/\s+\Z//g;
         $para =~ s/\s+/ /g;
         $para =~ s/$POD_link_re/$1/go;
         if ( $para =~ m/^[^.]+\.$/ ) {
            $para =~ s/\.$//;
         }

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

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

         if ( $option ) {
            if ( my ($line)
                  = $para =~ m/(allowed with --$option[:]?.*?)\./ ) {
               1 while ( $line =~ s/$POD_link_re/$1/go );
               push @rules, $line;
            }
         }

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

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

sub new {
   my ( $class, @opts ) = @_;
   my %key_seen;
   my %long_seen;
   my %key_for;
   my %defaults;
   my @mutex;
   my @atleast1;
   my %long_for;
   my %disables;
   my %copyfrom;
   my @allowed_with;

   unshift @opts,
      { s => 'help',    d => 'Show this help message' },
      { s => 'version', d => 'Output version information and exit' };

   foreach my $opt ( @opts ) {
      if ( ref $opt ) { # It's an option spec, not a rule.
         my ( $long, $short ) = $opt->{s} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
         $opt->{k} = $short || $long;
         $key_for{$long} = $opt->{k};
         $long_for{$opt->{k}} = $long;
         $long_for{$long} = $long;
         $opt->{l} = $long;
         die "Duplicate option $opt->{k}" if $key_seen{$opt->{k}}++;
         die "Duplicate long option $opt->{l}" if $long_seen{$opt->{l}}++;
         $opt->{t} = $short;
         $opt->{n} = $opt->{s} =~ m/!/;
         $opt->{c} = $opt->{s} =~ m/\+/;
         $opt->{g} ||= 'o';
         if ( (my ($y) = $opt->{s} =~ m/=([mdHhAaz])/) ) {
            MKDEBUG && _d('Option', $opt->{k}, 'type:', $y);
            $opt->{y} = $y;
            $opt->{s} =~ s/=./=s/;
         }
         if ( $opt->{d} =~ m/required/ ) {
            $opt->{r} = 1;
            MKDEBUG && _d('Option', $opt->{k}, 'is required');
         }
         if ( (my ($def) = $opt->{d} =~ m/default\b(?: ([^)]+))?/) ) {
            $defaults{$opt->{k}} = defined $def ? $def : 1;
            MKDEBUG && _d('Option', $opt->{k}, 'has a default');
         }
         if ( (my ($dis) = $opt->{d} =~ m/(disables .*)/) ) {
            $disables{$opt->{k}} = [ $class->get_participants($dis) ];
            MKDEBUG && _d('Option', $opt->{k}, $dis);
         }
      }
      else { # It's an option rule, not a spec.
         if ( $opt =~ m/at least one|mutually exclusive|one and only one/ ) {
            my @participants = map {
                  die "No such option '$_' in $opt" unless $long_for{$_};
                  $long_for{$_};
               } $class->get_participants($opt);
            if ( $opt =~ m/mutually exclusive|one and only one/ ) {
               push @mutex, \@participants;
               MKDEBUG && _d(@participants, 'are mutually exclusive');
            }
            if ( $opt =~ m/at least one|one and only one/ ) {
               push @atleast1, \@participants;
               MKDEBUG && _d(@participants, 'require at least one');
            }
         }
         elsif ( $opt =~ m/default to/ ) {
            my @participants = map {
                  die "No such option '$_' in $opt" unless $long_for{$_};
                  $key_for{$_};
               } $class->get_participants($opt);
            $copyfrom{$participants[0]} = $participants[1];
            MKDEBUG && _d(@participants, 'copy from each other');
         }
         elsif ( $opt  =~ m/allowed with/ ) {
            my @participants = map {
                  die "No such option '$_' while processing $opt"
                     unless $long_for{$_};
                  $key_for{$_};
               } $class->get_participants($opt);
            push @allowed_with, \@participants;
         }
      }
   }

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

   my $self = {
      specs        => [ grep { ref $_ } @opts ],
      errors       => [],
      instr        => [ grep { !ref $_ } @opts ],
      mutex        => \@mutex,
      defaults     => \%defaults,
      long_for     => \%long_for,
      atleast1     => \@atleast1,
      disables     => \%disables,
      key_for      => \%key_for,
      copyfrom     => \%copyfrom,
      strict       => 1,
      groups       => [ { k => 'o', d => 'Options' } ],
      allowed_with => \@allowed_with,
      given        => {},
   };

   return bless $self, $class;
}

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

sub parse {
   my ( $self, %defaults ) = @_;
   my @specs = @{$self->{specs}};
   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
   my %opt_seen;
   my %vals = %{$self->{defaults}};
   @vals{keys %defaults} = values %defaults;
   foreach my $spec ( @specs ) {
      $vals{$spec->{k}} = undef unless defined $vals{$spec->{k}};
      $opt_seen{$spec->{k}} = 1;
   }

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

   $self->{given} = {}; # in case options are re-parsed

   Getopt::Long::Configure('no_ignore_case', 'bundling');
   GetOptions(
      map {
         my $spec = $_;
         $spec->{s} => sub {
                          my ( $opt, $val ) = @_;
                          if ( $spec->{c} ) {
                             $vals{$spec->{k}}++
                          }
                          else {
                             $vals{$spec->{k}} = $val;
                          }
                          MKDEBUG && _d('Given option:',
                             $opt, '(',$spec->{k},') =', $val);
                          $self->{given}->{$spec->{k}} = $vals{$spec->{k}};
                       }
      } @specs
   ) or $self->error('Error parsing options');

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

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

   foreach my $dis ( grep { defined $vals{$_} } keys %{$self->{disables}} ) {
      my @disses = map { $self->{key_for}->{$_} } @{$self->{disables}->{$dis}};
      MKDEBUG && _d('Unsetting options:', @disses);
      @vals{@disses} = map { undef } @disses;
   }

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

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

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

   foreach my $spec ( grep { $_->{y} && defined $vals{$_->{k}} } @specs ) {
      my $val = $vals{$spec->{k}};
      if ( $spec->{y} eq 'm' ) {
         my ( $num, $suffix ) = $val =~ m/(\d+)([a-z])?$/;
         if ( !$suffix ) {
            my ( $s ) = $spec->{d} =~ m/\(suffix (.)\)/;
            $suffix = $s || 's';
            MKDEBUG && _d('No suffix given; using', $suffix, 'for',
               $spec->{k}, '(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
            $vals{$spec->{k}} = $val;
            MKDEBUG && _d('Setting option', $spec->{k}, 'to', $val);
         }
         else {
            $self->error("Invalid --$spec->{l} argument");
         }
      }
      elsif ( $spec->{y} eq 'd' ) {
         MKDEBUG && _d('Parsing option', $spec->{y}, 'as a DSN');
         my $from_key = $self->{copyfrom}->{$spec->{k}};
         my $default = {};
         if ( $from_key ) {
            MKDEBUG && _d('Option', $spec->{y}, 'DSN copies from option',
               $from_key);
            $default = $self->{dsn}->parse($self->{dsn}->as_string($vals{$from_key}));
         }
         $vals{$spec->{k}} = $self->{dsn}->parse($val, $default);
      }
      elsif ( $spec->{y} eq 'z' ) {
         my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
         if ( defined $num ) {
            if ( $factor ) {
               $num *= $factor_for{$factor};
               MKDEBUG && _d('Setting option', $spec->{y},
                  'to num', $num, '* factor', $factor);
            }
            $vals{$spec->{k}} = ($pre || '') . $num;
         }
         else {
            $self->error("Invalid --$spec->{l} argument");
         }
      }
   }

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

   foreach my $allowed_opts ( @{ $self->{allowed_with} } ) {
      my $opt = $allowed_opts->[0];
      next unless $vals{$opt};
      my %defined_opts = map { $_ => 1 } grep { defined $vals{$_} } keys %vals;
      delete @defined_opts{ @$allowed_opts };
      foreach my $defined_opt ( keys %defined_opts ) {
         MKDEBUG
            && _d('Unsetting option', $defined_opt,
               '; it is not allowed with option', $opt);
         $vals{$defined_opt} = undef;
      }
   }

   return %vals;
}

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

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

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

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

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

sub 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 usage {
   my ( $self, %vals ) = @_;
   my @specs = @{$self->{specs}};

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

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

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

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

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

sub prompt_noecho {
   shift @_ if ref $_[0] eq __PACKAGE__;
   my ( $prompt ) = @_;
   local $OUTPUT_AUTOFLUSH = 1;
   print $prompt
      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;
}

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

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_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 _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 3293
# ###########################################################################
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/`([^`]+)`/g } @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 3186
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package DSNParser;

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

use constant MKDEBUG => $ENV{MKDEBUG};

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

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

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

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

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

   foreach my $key ( keys %given_props ) {
      die "Unrecognized DSN part '$key' in '$dsn'\n"
         unless exists $opts{$key};
   }
   if ( (my $required = $self->prop('required')) ) {
      foreach my $key ( keys %$required ) {
         die "Missing DSN part '$key' in '$dsn'\n" unless $final_props{$key};
      }
   }

   return \%final_props;
}

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

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

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

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

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

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

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

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

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

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

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

   return $dbh;
}

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

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

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

sub _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 3186
# ###########################################################################

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, %opts ) = @_;
   my $port   = $self->{cmd_line_ops}->{port} || '';
   my $socket = $opts{S} || $self->{cmd_line_ops}->{'socket'} || '';
   my $host   = $opts{S}      ? '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 3186
# ###########################################################################

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(dbh MySQLDump Quoter TableParser) ) {
      die "I need a $arg argument" unless $args{$arg};
   }
   my $self = {
      %args,
      dbs    => {},
      counts => {},
   };

   my $dbs     = $self->{dbs};
   my $counts  = $self->{counts};
   my $dbh     = $self->{dbh};
   my $du      = $self->{MySQLDump};
   my $q       = $self->{Quoter};
   my $tp      = $self->{TableParser};

   %$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;
      }
   }

   return bless $self, $class;
}

sub discover_triggers_routines_events {
   my ( $self ) = @_;
   my @tre =
      @{ $self->{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
            */")
      };
   $self->{trigs_routines_events} = ();
   foreach my $x ( @tre ) {
      push @{ $self->{trigs_routines_events} }, "$x->[0] $x->[1] $x->[2]";
   }
   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 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 3186
# ###########################################################################

package AggregateProcessList;

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

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, $dbh, $params ) = @_;
   my $self = defined $params ? { %{ $params } } : {};
   $self->{undef_value} ||= 'NULL';
   return bless $self, $class;
}

sub aggregate_processlist {
   my ( $self, $recset ) = @_;
   my $agg_proclist = {};
   foreach my $proc ( @{ $recset } ) {
      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_value} 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;
         $agg_proclist->{ $field }->{ $val }->{time}  += $time;
         $agg_proclist->{ $field }->{ $val }->{count} += 1;
      }
   }
   return $agg_proclist;
}

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

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 ) = @_;
   bless {}, $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 3186
# ###########################################################################

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)
         = $val =~ m/^(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)$/ )
   {
      return sprintf "%d-%02d-%02d %02d:%02d:%02d",
                     $y + 2000, $m, $d, $h, $i, $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
# ###########################################################################

# ###########################################################################
# And now for the "program".
# ###########################################################################
package main;

use DBI;
use English qw(-no_match_vars);
use List::Util qw(max);
use Data::Dumper;
$Data::Dumper::Indent    = 1;
$Data::Dumper::Quotekeys = 0;
$Data::Dumper::Sortkeys  = 1;

use constant MKDEBUG => $ENV{MKDEBUG};

my $dp = new DSNParser();
my $vp = new VersionParser;
my $du = new MySQLDump(cache => 0);
my $q  = new Quoter;
my $tp = new TableParser;

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

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

my @opt_spec   = OptionParser::pod_to_spec();
my $opt_parser = new OptionParser(@opt_spec);
$opt_parser->{prompt} = '<options>';
$opt_parser->{descr}  = 'inspects, analyzes and reports on a MySQL server.';
my %opts = $opt_parser->parse();
$dp->prop('setvars', $opts{setvars});
$opt_parser->usage_or_errors(%opts);

# ############################################################################
# Server specs
# ############################################################################

my $server_specs = ServerSpecs::server_specs();
report_server_specs($server_specs);

# ############################################################################
# MySQL instances
# ############################################################################

my $n = 0; # MySQL instance number

my $mysqld_processes_ref = MySQLInstance::mysqld_processes();
foreach my $mysqld_ps ( @$mysqld_processes_ref ) {
   $n++;
   my $instance = MySQLInstance->new( $mysqld_ps->{cmd} );
   my $dsn = $instance->get_DSN(%opts);
   $dsn->{u} = $opts{u} if $opts{u};
   $dsn->{p} = $opts{p} if $opts{p};
   if ( !$opts{p} && $opts{askpass} ) {
      $opts{p}  = OptionParser::prompt_noecho("Enter password: ");
      $dsn->{p} = $opts{p};
   }
   my $dbh;
   eval {
      $dbh = $dp->get_dbh($dp->get_cxn_params($dsn));
   };
   if ( $EVAL_ERROR ) {
      chomp $EVAL_ERROR;
      print "Cannot connect to " . $dp->as_string($dsn)
            . ": $EVAL_ERROR\n\n";
      next;
   }
   $instance->load_sys_vars($dbh);
   $instance->load_status_vals($dbh);

   my $params = { dbh         => $dbh,
                  MySQLDump   => $du,
                  Quoter      => $q,
                  TableParser => $tp,
                  opts        => \%opts,
                };
   my $schema = SchemaDiscover->new(%$params);
   if ( $schema->{counts}->{TOTAL}->{dbs} == 0 ) {
      # This can happen of the user doesn't have privs to see any dbs,
      # or in the rare case that there really aren't any dbs. We must
      # catch this error otherwise write_MySQL_instance_report() will
      # cause fatal errors due to undef'ed values.
      print "MySQL instance $n has no databases. "
            . "DSN: " . $dp->as_string($dsn) . "\n\n";
      $dbh->disconnect();
      next;
   }
   if ( $vp->version_ge($dbh, '5.0.0') ) {
      $schema->discover_triggers_routines_events();
   }

   my $advisor = new MySQLAdvisor($instance, $schema);

   $params = { MySQL_instance  => $instance,
               instance_number => $n,
               mysqld_ps       => $mysqld_ps,
               SchemaDiscover  => $schema,
               MySQLAdvisor    => $advisor,
             };
   report_MySQL_instance($params);

   my $gr = new Grants;
   if ( $gr->have_priv($dbh, 'PROCESS') ) {
      my $apl = AggregateProcessList->new();
      my $processlist = $dbh->selectall_arrayref('SHOW PROCESSLIST',
                                                 { Slice => {} } );
      report_aggregated_processlist($apl->aggregate_processlist($processlist));
   }
   else {
      print "\nCannot report aggregated processlist because "
         . "database user does not have PROCESS privilege.\n";
   }

   $dbh->disconnect();
} # foreach mysqld process

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

exit;

# #############################################################################
# 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 report_MySQL_instance {
   my ( $params ) = @_;
   # brevity:
   my $instance  = $params->{MySQL_instance};
   my $inst_num  = $params->{instance_number};
   my $mysqld_ps = $params->{mysqld_ps};
   my $schema    = $params->{SchemaDiscover};
   my $advisor   = $params->{MySQLAdvisor};

format MYSQL_INSTANCE_1 =

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

   SCHEMA ________________________________________________________________
      #DATABASES   #TABLES   #ROWS     #INDEXES   SIZE DATA   SIZE INDEXES
      @<<<<<<      @<<<<<<   @<<<<<<   @<<<<<<    @<<<<<<     @<<<<<<
$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($instance->{online_sys_vars}->{key_buffer_size})
      InnoDB buffer pool size: @<<<<<<
exists $instance->{online_sys_vars}->{innodb_buffer_pool_size} ? shorten($instance->{online_sys_vars}->{innodb_buffer_pool_size}) : ''

.
   # Print the above format
   $FORMAT_NAME = 'MYSQL_INSTANCE_1';
   write;

   dbs_size_summary($schema);
   tables_size_summary($schema);
   engines_summary($schema);
   tre_summary($schema);

   print "\n   PROBLEMS ______________________________________________________________\n";

   my $duplicates = $instance->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 = $instance->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 = $instance->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 = $advisor->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";
      }
   }

   return;
}

sub dbs_size_summary {
   my ( $schema ) = @_;
   my %dbs = %{ $schema->{counts}->{dbs} }; # copy we can chop
   my $top = $opts{t};
   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 tables_size_summary
{
   my ( $schema ) = @_;
   my %dbs_tbls;
   my $dbs = $schema->{dbs};
   my $top = $opts{t};
   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
.
   # Build a schema-wide list of db.table => size
   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 engines_summary {
   my ( $schema ) = @_;
   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 tre_summary {
   my ( $schema ) = @_;
   my ( $db, $type, $count );
   print   "      Triggers, Routines, Events:\n"
         . "         DATABASE           TYPE      COUNT\n";
format TRE_LINE =
         @<<<<<<<<<<<<<<<<  @<<<<<<   @<<<<<<
$db, $type, $count
.
   if ( exists $schema->{trigs_routines_events} ) {
      if ( defined $schema->{trigs_routines_events} ) {
         $FORMAT_NAME = 'TRE_LINE';
         foreach my $db_type_count ( @{ $schema->{trigs_routines_events} } ) {
            ( $db, $type, $count ) = split ' ', $db_type_count;
            write;
         }
      }
      else {
         print "         No triggers, routines, or events\n";
      }
   }
   else {
      print "         Not supported (MySQL version < 5.0.0)\n";
   }
   return;
}

sub report_aggregated_processlist {
   my ( $ag_pl ) = @_;  # aggregated_processlist
   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
.

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

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

=pod

=head1 NAME

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

=head1 SYNOPSIS

   mk-audit
   mk-audit --user root --askpass

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

Prompt for a password when connecting to MySQL.

=item --password

short form: -p; type: string

Password to use when connecting.

=item --setvars

type: string; default: wait_timeout=10000

Set these MySQL variables.

Specify any variables you want to be set immediately after connecting to MySQL.
These will be included in a C<SET> command.

=item --top

short form: -t; 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 --socket

short form: -S; type: string

Socket file to use for connection.

If this is given, mk-audit will attempt to connect via a Unix socket, not
through TCP/IP.

=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/>.

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.6 Distrib 3329 $Revision: 3298 $.

=cut
