#!/usr/bin/env perl

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

# ###########################################################################
# MySQLDump package 2215
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package MySQLDump;

use constant MKDEBUG => $ENV{MKDEBUG};

use English qw(-no_match_vars);

( 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 .= "/*!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, '
         . '@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, "ANSI_QUOTES", ""), ",,", ","), '
         . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
         . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
      MKDEBUG && _d($sql);
      $dbh->do($sql);
      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, '
         . '@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, "ANSI_QUOTES", ""), ",,", ","), '
         . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
         . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
      MKDEBUG && _d($sql);
      $dbh->do($sql);
      $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 ( $line ) = (caller(0))[2];
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } @_;
   print "# MySQLDump:$line $PID ", @_, "\n";
}

1;

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

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

package OptionParser;

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

use constant MKDEBUG => $ENV{MKDEBUG};

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

sub new {
   my ( $class, @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 ) {
         my ( $long, $short ) = $opt->{s} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
         $opt->{k} = $short || $long;
         $key_for{$long} = $opt->{k};
         $long_for{$opt->{k}} = $long;
         $long_for{$long} = $long;
         $opt->{l} = $long;
         die "Duplicate option $opt->{k}" if $key_seen{$opt->{k}}++;
         die "Duplicate long option $opt->{l}" if $long_seen{$opt->{l}}++;
         $opt->{t} = $short;
         $opt->{n} = $opt->{s} =~ m/!/;
         $opt->{g} ||= 'o';
         if ( (my ($y) = $opt->{s} =~ m/=([mdHhAaz])/) ) {
            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 instruction.

         if ( $opt =~ m/at least one|mutually exclusive|one and only one/ ) {
            my @participants = map {
                  die "No such option '$_' in $opt" unless $long_for{$_};
                  $long_for{$_};
               } $class->get_participants($opt);
            if ( $opt =~ m/mutually exclusive|one and only one/ ) {
               push @mutex, \@participants;
               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 ],
      notes        => [],
      instr        => [ grep { !ref $_ } @opts ],
      mutex        => \@mutex,
      defaults     => \%defaults,
      long_for     => \%long_for,
      atleast1     => \@atleast1,
      disables     => \%disables,
      key_for      => \%key_for,
      copyfrom     => \%copyfrom,
      strict       => 1,
      groups       => [ { k => 'o', d => 'Options' } ],
      allowed_with => \@allowed_with,
   };

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

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

   if ( $vals{version} ) {
      my $prog = $self->prog;
      printf("%s  Ver %s Distrib %s Changeset %s\n",
         $prog, $main::VERSION, $main::DISTRIB, $main::SVN_REV)
         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 * 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 if !defined $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 options: $defined_opt (not allowed with $opt)");
         $vals{$defined_opt} = undef;
      }
   }

   return %vals;
}

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

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

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

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

sub usage_or_errors {
   my ( $self, %opts ) = @_;
   if ( $opts{help} ) {
      print $self->usage(%opts)
         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 @notes = @{$self->{notes}}) ) {
      $usage .= join("\n  * ", 'Errors in command-line arguments:', @notes) . "\n";
   }
   return $usage . "\n" . $self->descr();
}

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

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

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

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

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

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

   my %types = (
      'time' => 'm',
      'int'  => 'i',
      string => 's',
      hash   => 'h',
      Hash   => 'H',
      array  => 'a',
      Array  => 'A',
      size   => 'z',
      DSN    => 'd',
      float  => 'f',
   );

   my @spec = ();
   my @special_options = ();
   $file ||= __FILE__;
   open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
   my $para;
   my $option;

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

   while ( $para = <$fh> ) {
      MKDEBUG && _d($para);
      last if $para =~ m/^=over/;
      chomp $para;
      $para =~ s/\s+/ /g;
      $para =~ s/$POD_link_re/$1/go;
      push @special_options, $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/\.$//;
         }
         push @spec, {
            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 @special_options, $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 @spec, @special_options;
}

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

sub _d {
   my ( $line ) = (caller(0))[2];
   print "# OptionParser:$line $PID ", @_, "\n";
}

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

1;

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

# ###########################################################################
# TableParser package 2382
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package TableParser;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   bless {}, shift;
}

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 ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
   MKDEBUG && _d('Storage engine: ', $engine);

   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;
   foreach my $key ( $ddl =~ m/^  ((?:[A-Z]+ )?KEY .*)$/gm ) {

      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("Index $name columns: " . join(', ', @cols));

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

   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}->{unique} <=> !$tbl->{keys}->{$b}->{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 || 'undef'));
   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, $quoter ) = @_;
   my $sql = 'SELECT * FROM ' . $quoter->quote($db, $tbl) . ' LIMIT 0';
   my $href;
   eval { $href = $dbh->selectrow_hashref($sql) };
   return 0 if $EVAL_ERROR;
   return 1;
}

sub _d {
   my ( $line ) = (caller(0))[2];
   print "# TableParser:$line $PID ", @_, "\n";
}

1;

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

# ###########################################################################
# DSNParser package 2215
# ###########################################################################
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 %vals;
   my %opts = %{$self->{opts}};
   if ( $dsn !~ m/=/ && (my $p = $self->prop('autokey')) ) {
      MKDEBUG && _d("Interpreting $dsn as $p=$dsn");
      $dsn = "$p=$dsn";
   }
   my %hash = map { m/^(.)=(.*)$/g } split(/,/, $dsn);
   foreach my $key ( keys %opts ) {
      MKDEBUG && _d("Finding value for $key");
      $vals{$key} = $hash{$key};
      if ( !defined $vals{$key} && defined $prev->{$key} && $opts{$key}->{copy} ) {
         $vals{$key} = $prev->{$key};
         MKDEBUG && _d("Copying value for $key from previous DSN");
      }
      if ( !defined $vals{$key} ) {
         $vals{$key} = $defaults->{$key};
         MKDEBUG && _d("Copying value for $key from defaults");
      }
   }
   foreach my $key ( keys %hash ) {
      die "Unrecognized DSN part '$key' in '$dsn'\n"
         unless exists $opts{$key};
   }
   if ( (my $required = $self->prop('required')) ) {
      foreach my $key ( keys %$required ) {
         die "Missing DSN part '$key' in '$dsn'\n" unless $vals{$key};
      }
   }
   return \%vals;
}

sub as_string {
   my ( $self, $dsn ) = @_;
   return $dsn unless ref $dsn;
   return join(',',
      map  { "$_=" . ($_ 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=mysql';
   }
   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;
   MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, ' {',
      join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ), '}');
   my $dbh = DBI->connect($cxn_string, $user, $pass, $defaults);
   if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
      my $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";
      }
   }
   my $setvars = $self->prop('setvars');
   if ( $cxn_string =~ m/mysql/i && $setvars ) {
      my $sql = "SET $setvars";
      MKDEBUG && _d("$dbh: $sql");
      $dbh->do($sql);
   }
   MKDEBUG && _d('DBH info: ',
      $dbh,
      Dumper($dbh->selectrow_hashref(
         'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
      ' Connection info: ', ($dbh->{mysql_hostinfo} || 'undef'),
      ' 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 ( $line ) = (caller(0))[2];
   @_ = map { defined $_ ? $_ : 'undef' } @_;
   print "# DSNParser:$line $PID ", @_, "\n";
}

1;

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

# ###########################################################################
# VersionParser package 2215
# ###########################################################################
use strict;
use warnings FATAL => 'all';

package VersionParser;

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 ( $line ) = (caller(0))[2];
   print "# VersionParser:$line $PID ", @_, "\n";
}

1;

# ###########################################################################
# End VersionParser package
# ###########################################################################

# ###########################################################################
# Quoter package 2215
# ###########################################################################
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
   );
}

1;

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

# ###########################################################################
# ServerSpecs package 2426
# ###########################################################################

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

   if ( -f '/sbin/vgs' ) {
      chomp(my $vgs = `vgs`);
      $vgs =~ s/^\s*/\t/g;
      $server{storage}->{vgs} = $vgs;
   }
   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 ) = @_;

   if ( chomp(my $dmesg = `dmesg`) ) {
      my ($raid) = $dmesg =~ m/(Direct-Access\s+MegaRaid.*$)/m;
      $server->{storage}->{raid} = $raid ? $raid : 'unknown';
   }

   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 ) {
      $server->{storage}->{megarc}
         .= ($megarc =~ /^(Product Name.*\n)/m ? $1 : '');
      $server->{storage}->{megarc}
         .= ($megarc =~ /^(BBU.*\n)/m ? $1 : '');
      $server->{storage}->{megarc}
         .= ($megarc =~ /^(Battery Warning.*\n)/m ? $1 : '');
      $server->{storage}->{megarc}
         .= ($megarc =~ /^(Alarm.*\n)/m ? $1 : '');
      $server->{storage}->{megarc}
         .= ($megarc =~ /(Device Present.*?\n)\s+Supported/ms ? $1 : '');
      $server->{storage}->{megarc}
         .= ($megarc =~ /(Battery state.*?\n)isSOHGood/ms ? $1 : '');
   }
   else {
      if ( $server->{storage}->{raid} ne 'unknown' ) {
         $server->{storage}->{megarc}
            .= "\n*** RAID present but unable to check its status";
      }
      else {
         $server->{storage}->{megarc} = '';
      }
   }

   return;
}

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 ( 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 ( $line ) = (caller(0))[2];
   print "# ServerSpecs:$line $PID ", @_, "\n";
}

1;

# ###########################################################################
# End ServerSpecs package
# ###########################################################################

# ###########################################################################
# MySQLInstance package 2429
# ###########################################################################

package MySQLInstance;

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

use English qw(-no_match_vars);
use File::Temp ();
use Carp;
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 = (
   bdb_home                      => '',
   bdb_logdir                    => '',
   bdb_tmpdir                    => '',
   date_format                   => '',
   datetime_format               => '',
   ft_stopword_file              => '',
   init_connect                  => '',
   init_file                     => '',
   init_slave                    => '',
   innodb_data_home_dir          => '',
   innodb_flush_method           => '',
   innodb_log_arch_dir           => '',
   innodb_log_group_home_dir     => '',
   'log'                         => 'OFF',
   log_bin                       => 'OFF',
   log_error                     => '',
   log_slow_queries              => 'OFF',
   log_slave_updates             => 'ON',
   log_queries_not_using_indexes => 'ON',
   log_update                    => 'OFF',
   ndb_connectstring             => '',
   relay_log_index               => '',
   secure_file_priv              => '',
   skip_bdb                      => 0,
   skip_external_locking         => 'ON',
   skip_name_resolve             => 'ON',
   ssl_ca                        => '',
   ssl_capath                    => '',
   ssl_cert                      => '',
   ssl_cipher                    => '',
   ssl_key                       => '',
   time_format                   => '',
   tmpdir                        => '',
);

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');        },
);

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',
            };
      }
   }
   if ( MKDEBUG ) {
      my $mysqld_processes_dump = Dumper(\@mysqld_processes);
      _d("$mysqld_processes_dump");
   }
   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;
           if ( !defined $val && exists $undef_for{$var} ) {
              $val = $undef_for{$var};
           }
           $var => $val;
        } ($cmd =~ m/--(\S+)/g);
   $self->{cmd_line_ops}->{defaults_file} ||= '';
   if ( MKDEBUG ) {
      my $self_dump = Dumper($self);
      _d("$self_dump");
   }
   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 ( $defaults_file_op, $tmp_file ) = $self->_defaults_file_op();
   my $cmd = "$self->{mysqld_binary} $defaults_file_op --help --verbose";
   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;
              }
              if ( !defined $val && exists $undef_for{$var} ) {
                 $val = $undef_for{$var};
              }
              $var => $val;
           } split "\n", $sys_vars;

      $self->_load_default_defaults_files($mysqld_output);
   }

   $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";
   }
   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 ) {
      my $self_dump = Dumper($self);
      MKDEBUG && _d("$self_dump");
      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 ) {
      my $self_dump = Dumper($self);
      MKDEBUG && _d("$self_dump");
      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};
               }
            }
            if ( !defined $val && exists $undef_for{$var} ) {
               $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] );
      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 ) {
         my $dump = Dumper($var_val);
         MKDEBUG && _d("Undefined var or val: $dump");
         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;

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

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

      if ( defined $conf_val && defined $online_val ) {


         if ( exists $eq_for{$var} ) {
            $var_out_of_sync = !$eq_for{$var}->($conf_val, $online_val);
         }
         else {
            if ( $conf_val ne $online_val ) {
               $var_out_of_sync = 1;

               if ( exists $alias_for{$online_val} ) {
                  $var_out_of_sync = 0 if $conf_val eq $alias_for{$online_val};
               }
            }
         }
      }
      else {
         carp "Undefined system variable: $var";
         if ( MKDEBUG ) {
            my $dump_conf   = Dumper($conf_val);
            my $dump_online = Dumper($online_val);
            _d("Undefined val: conf=$dump_conf online=$dump_online");
         }
         next;
      }

      if($var_out_of_sync) {
         $out_of_sync_vars{$var} = [ $online_val, $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 _d {
   my ( $line ) = (caller(0))[2];
   print "# MySQLInstance:$line $PID ", @_, "\n";
}

1;

# ###########################################################################
# End MySQLInstance package
# ###########################################################################

# ###########################################################################
# SchemaDiscover package 2215
# ###########################################################################

package SchemaDiscover;

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

use English qw(-no_match_vars);
use Carp;

use constant MKDEBUG => $ENV{MKDEBUG};

sub new {
   my ( $class, $params ) = @_;
   if ( scalar keys %{ $params } < 4 ) {
      croak   "Error: Not enough parameters for SchemaDiscover::new()\n"
            . "Required keys in named parameters hash: "
            . "dbh, MySQLDump, Quoter, TableParser\n"
            . "Optional: opts\n";
   }
   my $self = {
      %{ $params },
      dbs    => {},
      counts => {},
   };
   my $dbs         = $self->{dbs};
   my $counts      = $self->{counts};
   my $dbh         = $self->{dbh};
   my $MySQLDump   = $self->{MySQLDump};
   my $Quoter      = $self->{Quoter};
   my $TableParser = $self->{TableParser};
   my $opts        = $self->{opts} || {};

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

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

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

   foreach my $db ( keys %{$dbs} ) {
      %{$dbs->{$db}} = map { $_->{name} => {} }
                           $MySQLDump->get_table_list($dbh, $Quoter, $db);
      foreach my $tbl_stat ($MySQLDump->get_table_status($dbh, $Quoter, $db)) {
         %{$dbs->{$db}->{"$tbl_stat->{name}"}} = %$tbl_stat;
      }
      foreach my $table ( keys %{$dbs->{$db}} ) {
         my $ddl = $MySQLDump->get_create_table($dbh, $Quoter, $db, $table);
         my $table_info = TableParser->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;
      } # foreach table
   } # foreach db

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

1;

# ###########################################################################
# End SchemaDiscover package
# ###########################################################################

# ###########################################################################
# MySQLAdvisor package 2416
# ###########################################################################

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 cache enabled but size 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 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 too large' =>
      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;
}

1;

# ###########################################################################
# End MySQLAdvisor package
# ###########################################################################

# ###########################################################################
# AggregateProcessList package 2215
# ###########################################################################

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 ( $line ) = (caller(0))[2];
   print "# AggregateProcessList:$line $PID ", @_, "\n";
}

1;

# ###########################################################################
# End AggregateProcessList package
# ###########################################################################

# ###########################################################################
# Grants package 2420
# ###########################################################################

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

1;

# ###########################################################################
# End Grants package
# ###########################################################################

# ###########################################################################
# Transformers package 2368
# ###########################################################################

# Transformers - Common transformation and beautification subroutines
package Transformers;

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

use constant MKDEBUG => $ENV{MKDEBUG};

require Exporter;
our @ISA         = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT      = ();
our @EXPORT_OK   = qw(float_6 micro_t secs_to_time shorten ts);

sub float_6 {
   my ( $val ) = @_;
   return sprintf('%.6f', $val);
}

sub micro_t {
   my ( $t ) = @_;
   my $f;

   $t = 0 if $t < 0;

   # "Remove" scientific notation so the regex below does not make
   # 6.123456e+18 into 6.123456.
   $t = sprintf('%.17f', $t) if $t =~ /e/;

   # Truncate after 6 decimal places to avoid 0.9999997 becoming 1
   # because sprintf() rounds.
   $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('%.3f', $t * 1000);
      $f = ($f * 1) . ' ms'; # * 1 to remove insignificant zeros
   }
   elsif ($t >= 1) {
      $f = sprintf('%.6f', $t);
      $f = ($f * 1) . ' s'; # * 1 to remove insignificant zeros
   }
   else {
      $f = 0;  # $t should = 0 at this point
   }

   return $f;
}

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

   # Decide what format to use, if not given
   $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 ) = @_;
   my $n = 0;
   while ( $num >= 1_024 ) {
      $num /= 1_024;
      ++$n;
   }
   return sprintf(
      $num =~ m/\./ || $n
         ? "%.2f%s"
         : '%d',
      $num, ('','k','M','G', 'T')[$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 _d {
   my ( $line ) = (caller(0))[2];
   print "# Transformers:$line $PID ", @_, "\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 $md = new MySQLDump;
my $qt = 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   => $md,
                  Quoter      => $qt,
                  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:
   Raid: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$server->{storage}->{raid}
.

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;
   if ( $server->{storage}->{megarc} ) {
      # Apparently, the @* field has a 17 line limit
      # hence we must print this stuff manually.
      print "   MegaRAID:\n--------\n";
      print $server->{storage}->{megarc};
      print "--------\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}, 0), $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}->[0],
                $oos->{$var}->[1]);
      }
      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}, 0);
      $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;
}

# ############################################################################
# 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 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.3 Distrib 2442 $Revision: 2430 $.

=cut
