#!/usr/bin/env perl

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

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

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

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

package DSNParser;

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

use constant MKDEBUG => $ENV{MKDEBUG};

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

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

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

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

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

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

   return \%final_props;
}

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

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

sub usage {
   my ( $self ) = @_;
   my $usage
      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n\n"
      . "  KEY  COPY  MEANING\n"
      . "  ===  ====  =============================================\n";
   my %opts = %{$self->{opts}};
   foreach my $key ( sort keys %opts ) {
      $usage .= "  $key    "
             .  ($opts{$key}->{copy} ? 'yes   ' : 'no    ')
             .  ($opts{$key}->{desc} || '[No description]')
             . "\n";
   }
   $usage .= "\n  If the DSN is a bareword, the word is treated as the 'h' key.\n";
   return $usage;
}

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

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

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

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

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

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

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

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

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

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

   return $dbh;
}

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

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

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

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

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

1;

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

# ###########################################################################
# OptionParser package 3945
# ###########################################################################
package OptionParser;

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

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

use constant MKDEBUG => $ENV{MKDEBUG};

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

my %attributes = (
   'type'       => 1,
   'short form' => 1,
   'group'      => 1,
   'default'    => 1,
   'cumulative' => 1,
   'negatable'  => 1,
);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   return; 
}

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

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

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

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

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

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

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

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

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

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

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

   $self->{errors} = [];

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

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

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

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

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

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

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

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

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

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

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

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

      $self->_validate_type($opt);
   }

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

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

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

   return;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   return bless \%clone;     
}

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

1;

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

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

package Quoter;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

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

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

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

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

1;

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

package main;

use English qw(-no_match_vars);

use constant MKDEBUG => $ENV{MKDEBUG};

$OUTPUT_AUTOFLUSH = 1;

# TODO: implement processes too; then it can be a stale query sniper.
# TODO: add --haskey(col), add --hascol
# TODO: add --keepgoing (in case of an error on --exec)
# TODO: make a way to get a list of DSNs out of a database table, and iterate
# over them.

# ############################################################################
# Get configuration information.
# ############################################################################
my $q  = new Quoter();
my $dp = new DSNParser();
my $o  = new OptionParser(
   strict      => 0,
   prompt      => '[option]... [database...]',
   description => 'searches for MySQL tables and executes actions, like '
                . 'GNU find.  The default action is to print the database '
                . 'and table name.',
);
$o->get_specs();
$o->get_opts();

# Make sure OptionParser understands that these options are used.
# cmin ctime empty kmin ktime mmin mtime exec printf 

if ( $o->get('connection-id') && $o->get('connection-id') !~ m/\(\\d\+\)/ ) { # Ensure there is a capture group
   $o->save_error("--connection-id regex doesn't capture digits with (\\d+)");
}

if ( $o->get('server-id') && $o->get('server-id') !~ m/\(\\d\+\)/ ) { # Ensure there is a capture group
   $o->save_error("--server-id regex doesn't capture digits with (\\d+)");
}

$o->usage_or_errors();

my %arg_for = (
   a => 'Auto_increment',
   A => 'Avg_row_length',
   c => 'Checksum',
   C => 'Create_time',
   D => 'Database',
   d => 'Data_length',
   E => 'Engine',
   F => 'Data_free',
   f => 'Innodb_free',
   I => 'Index_length',
   K => 'Check_time',
   L => 'Collation',
   M => 'Max_data_length',
   N => 'Name',
   O => 'Comment',
   P => 'Create_options',
   R => 'Row_format',
   S => 'Rows',
   T => 'Table_length',
   U => 'Update_time',
   V => 'Version',
);

# Interpolate strings for printf and exec.  At the same time discover whether
# I must use SHOW TABLE STATUS (slower than SHOW TABLES) to fetch data.
my %fmt_for;  # Interpolated strings
my $showstat
   = grep { $o->get($_) } qw( 
      autoinc avgrowlen checksum cmin collation comment createopts ctime
      datasize datafree empty engine indexsize kmin ktime mmin mtime rows
      rowformat tablesize tblversion);
foreach my $thing (qw(exec printf)) {
   next unless $o->get($thing);
   my ($str, $arg_names) = interpolate($o->get($thing));
   $fmt_for{$thing} = { str => $str, arg_names => $arg_names };
   if ( grep { $_ !~ m/^(Database|Name)$/ } @$arg_names ) {
      $showstat = 1;
   }
}

# ############################################################################
# Lookup tables and global variables
# ############################################################################
my %time_for;     # Holds time constants for mmin, mtime etc
my %connections;  # Holds a list of thread IDs connected
my $server_id;    # Holds the server's @@SERVER_ID
my $dbh;          # This program's $dbh
my $exec_dbh;     # The $dbh to use for exec and exec-plus

# Functions to call while evaluating tests.
my %test_for = (
   autoinc => sub {
      my ( $table ) = @_;
      return test_number($table, 'Auto_increment', $o->get('autoinc'));
   },
   avgrowlen => sub {
      my ( $table ) = @_;
      return test_number($table, 'Avg_row_length', $o->get('avgrowlen'));
   },
   checksum => sub {
      my ( $table ) = @_;
      return test_number($table, 'Checksum', $o->get('checksum'));
   },
   cmin => sub {
      my ( $table ) = @_;
      return test_date($table, 'Create_time', 'cmin');
   },
   collation => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Collation', $o->get('collation'));
   },
   comment => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Comment', $o->get('comment'));
   },
   createopts => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Create_options', $o->get('createopts'));
   },
   ctime => sub {
      my ( $table ) = @_;
      return test_date($table, 'Create_time', 'ctime');
   },
   datafree => sub {
      my ( $table ) = @_;
      return test_number($table, 'Data_free', $o->get('datafree'));
   },
   datasize => sub {
      my ( $table ) = @_;
      return test_number($table, 'Data_length', $o->get('datasize'));
   },
   dbregex => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Database', $o->get('dbregex'));
   },
   empty => sub {
      my ( $table ) = @_;
      return test_number($table, 'Rows', '0');
   },
   engine => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Engine', $o->get('engine'));
   },
   indexsize => sub {
      my ( $table ) = @_;
      return test_number($table, 'Index_length', $o->get('indexsize'));
   },
   kmin => sub {
      my ( $table ) = @_;
      return test_date($table, 'Check_time', 'kmin');
   },
   ktime => sub {
      my ( $table ) = @_;
      return test_date($table, 'Check_time', 'ktime');
   },
   mmin => sub {
      my ( $table ) = @_;
      return test_date($table, 'Update_time', 'mmin');
   },
   mtime => sub {
      my ( $table ) = @_;
      return test_date($table, 'Update_time', 'mtime');
   },
   'connection-id' => sub {
      my ( $table ) = @_;
      my $test = $o->get('case-insensitive') ? "(?i)".$o->get('connection-id')
               : $o->get('connection-id');
      my ( $pid ) = $table->{Name} =~ m/$test/;
      return $pid && !exists $connections{$pid};
   },
   rows => sub {
      my ( $table ) = @_;
      return test_number($table, 'Rows', $o->get('rows'));
   },
   rowformat => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Row_format', $o->get('rowformat'));
   },
   'server-id' => sub {
      my ( $table ) = @_;
      my $test = $o->get('case-insensitive') ? "(?i)".$o->get('server-id')
               : $o->get('server-id');
      my ( $sid ) = $table->{Name} =~ m/$test/;
      return $sid && $sid == $server_id;
   },
   tablesize => sub {
      my ( $table ) = @_;
      return test_number($table, 'Table_length', $o->get('tablesize'));
   },
   tblregex => sub {
      my ( $table ) = @_;
      return test_regex($table, 'Name', $o->get('tblregex'));
   },
   tblversion => sub {
      my ( $table ) = @_;
      return test_number($table, 'Version', $o->get('tblversion'));
   },
);

# Functions to call when doing actions
my %action_for = (
   print => sub {
      my ( $table ) = @_;
      print "$table->{Database}.$table->{Name}\n";
   },
   exec => sub {
      my ( $table ) = @_;
      my $sql = sprintf($fmt_for{exec}->{str},
         map { defined $_ ? $_ : '' }
         @{$table}{@{$fmt_for{exec}->{arg_names}}});
      MKDEBUG && _d($sql);
      $exec_dbh->do($sql);
   },
   printf => sub {
      my ( $table ) = @_;
      printf($fmt_for{printf}->{str},
         map { defined $_ ? $_ : '' }
         @{$table}{@{$fmt_for{printf}->{arg_names}}});
   },
);

# ############################################################################
# Get ready to do the main work.
# ############################################################################

# Connect to the database
if ( !$o->get('password') && $o->get('ask-pass') ) {
   $o->set('password', OptionParser::prompt_noecho("Enter password: "));
}

$dp->prop('setvars', $o->get('set-vars'));
$dbh = $dp->get_dbh(
   $dp->get_cxn_params($dp->parse_options($o)), { AutoCommit => 1 } );
if ( $o->get('exec-dsn') ) {
   $exec_dbh = $dp->get_dbh(
      $dp->get_cxn_params($dp->parse($o->get('exec-dsn'), {$o->opt_values()})),
      { AutoCommit => 1 },
   );
}
else {
   $exec_dbh = $dbh;
}

# If no other action was given, the default action is to print.
if ( !grep { $o->get($_) } qw( exec exec-plus print printf ) ) {
   $o->set('print', 1);
}

# Figure out the time referred to by date/time options
my $basetime;
foreach my $option ( grep { defined $o->get($_) } qw(cmin ctime kmin ktime mmin mtime) ) {
   # Initialize a consistent point in time
   $basetime ||=
      $dbh->selectcol_arrayref(
         "SELECT ".($o->get('day-start') ? 'CURRENT_DATE' : 'CURRENT_TIMESTAMP')
      )->[0];

   my ($val) = $o->get($option) =~ m/(\d+)/;
   my $inter = $option =~ m/min/ ? 'MINUTE' : 'DAY';
   my $query = "SELECT DATE_SUB('$basetime', INTERVAL $val $inter)";
   $time_for{$option} = $dbh->selectcol_arrayref($query)->[0];
}

# Fetch and save a list of processes currently running.
if ( $o->get('connection-id') ) {
   # Ensure I have the PROCESS privilege.
   my $proc =
      grep { m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ }
      @{$dbh->selectcol_arrayref('SHOW GRANTS')};
   if ( !$proc ) {
      die "--connection-id requires the PROCESS privilege for safety.\n";
   }
}

($server_id) = $dbh->selectrow_array('SELECT @@SERVER_ID');

# ############################################################################
# Go do it.
# ############################################################################
my @databases = @ARGV         ? @ARGV
              : $o->get('dblike') ? @{$dbh->selectcol_arrayref('SHOW DATABASES LIKE ?', {}, $o->get('dblike'))}
              :                 @{$dbh->selectcol_arrayref('SHOW DATABASES')};

my @exec_plus;
DATABASE:
foreach my $database ( @databases ) {
   next DATABASE if $database =~ m/^(?:information_schema|lost\+found)$/mi;

   my $sta = $showstat ? ' STATUS' : 'S';
   my $sth = $o->get('tbllike')
           ? $dbh->prepare("SHOW TABLE$sta FROM `$database` LIKE ?")
           : $dbh->prepare("SHOW TABLE$sta FROM `$database`");

   $sth->execute($o->get('tbllike') || ());
   my @tables = @{$sth->fetchall_arrayref({})};

   # Must re-fetch every time; there are too many ways things can go wrong
   # otherwise (for example, the counter wraps over the unsigned int boundary).
   if ( $o->get('connection-id') ) {
      %connections = map { $_ => 1 }
         @{$dbh->selectcol_arrayref('SHOW FULL PROCESSLIST')};
   }

   # Make results uniform across MySQL versions, and generate additional
   # properties.
   foreach my $table ( @tables ) {
      if ( $showstat ) {
         my ($ib_free)            = $table->{Comment} && $table->{Comment} =~ m/InnoDB free: (\d+) kB/;
         $table->{Engine}       ||= $table->{Type};
         $table->{Table_length}   = ($table->{Index_length} || 0) + ($table->{Data_length} || 0);
         $table->{Innodb_free}    = $ib_free ? 1_024 * $ib_free : undef;
         delete $table->{Type};
      }
      else {
         my ($name) = values %$table;
         $table = { Name => $name };
      }
      $table->{Database} = $database;
   }

   # Apply the tests to find the matching tables
   @tables = grep {
      my $table = $_;
      my @tests = grep { $o->get($_) } keys %test_for;
      !@tests || ($o->get('or') ? any($table, @tests) : all($table, @tests));
   } @tables;

   # Quote database and table names if desired
   if ( $o->get('quote') ) {
      foreach my $table ( @tables ) {
         $table->{Database} = $q->quote($table->{Database});
         $table->{Name}     = $q->quote($table->{Name});
      }
   }

   foreach my $table ( @tables ) {
      my @actions = grep { $o->get($_) } keys %action_for;
      foreach my $action ( @actions ) {
         $action_for{$action}->($table);
      }
   }

   push @exec_plus, @tables;
}

# Handle exec-plus
if ( $o->get('exec-plus') ) {
   my $table_list = join(', ', map { "$_->{Database}.$_->{Name}" } @exec_plus);
   (my $sql = $o->get('exec-plus')) =~ s/%s/$table_list/g;
   $exec_dbh->do($sql);
}

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

# One test is true
sub any {
   my ( $table, @tests ) = @_;
   foreach my $test ( @tests ) {
      return 1 if $test_for{$test}->($table);
   }
   return 0;
}

# All tests are true
sub all {
   my ( $table, @tests ) = @_;
   foreach my $test ( @tests ) {
      return 0 unless $test_for{$test}->($table);
   }
   return 1;
}

# Checks the given property of the given table to see if it passes the test
sub test_number {
   my ( $table, $prop, $test ) = @_;
   my ($num) = $test =~ m/(\d+)/;
   return defined $table->{$prop} && (
         ( $test =~ m/-/  && $table->{$prop} < $num )
      || ( $test =~ m/\+/ && $table->{$prop} > $num )
      || (                   $table->{$prop} == $num ));
}

# Checks the given property of the given table to see if it passes the test
sub test_date {
   my ( $table, $prop, $test ) = @_;
   return defined $table->{$prop} && (
         ( $o->get($test) =~ m/-/  && $table->{$prop} gt $time_for{$test} )
      || ( $o->get($test) =~ m/\+/ && $table->{$prop} lt $time_for{$test} )
      || (                            $table->{$prop} eq $time_for{$test} ));
}

# Checks the given property of the given table to see if it passes the test
sub test_regex {
   my ( $table, $prop, $test ) = @_;
   if ( $o->get('case-insensitive') ) {
      $test = "(?i)$test";
   }
   return defined $table->{$prop} && $table->{$prop} =~ m/$test/;
}

# Does string-interpolation and stuff.  Returns the string and a list of the
# properties that go into the resulting placeholders.
sub interpolate {
   my ( $str ) = @_;
   my @arg_names;

   # Replace % directives
   $str =~ s/%(.)/(exists $arg_for{$1} && push @arg_names, $arg_for{$1} ) ? '\%s' : "$1"/xge;

   # Get Perl to interpolate escape sequences
   $str =~ s/(?<!\\)"/\\"/g;
   $str = eval qq{"$str"};
   return ( $str, \@arg_names );
}

sub expand {
   my ( $test ) = @_;
   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
   my ($pre, $num, $factor) = $test =~ m/([+-])?(\d+)([kMG])?/;
   if ( $factor ) {
      $num *= $factor_for{$factor};
   }
   return "$pre$num";
}

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

# ############################################################################
# Documentation
# ############################################################################

=pod

=head1 NAME

mk-find - Find MySQL tables and execute actions, like GNU find.

=head1 DESCRIPTION

mk-find looks for MySQL tables that pass the tests you specify, and executes
the actions you specify.  The default action is to print the database and table
name to STDOUT.

mk-find is simpler than GNU find.  It doesn't allow you to specify
complicated expressions on the command line.

mk-find only looks for and processes tables.  If you need it to do
other things, like triggers or columns, file a bug report and I'll add the
features.

mk-find uses SHOW TABLES when possible, and SHOW TABLE STATUS when needed.

=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 OPTION TYPES

There are three types of options: normal options, which determine some behavior
or setting; tests, which determine whether a table should be included in the
list of tables found; and actions, which do something to the tables mk-find
finds.

mk-find uses standard Getopt::Long option parsing, so you should use double
dashes in front of long option names, unlike GNU find.

=head1 OPTIONS

=over

=item --ask-pass

Prompt for a password when connecting to MySQL.

=item --case-insensitive

Specifies that all regular expression searches are case-insensitive.

=item --charset

short form: -A; type: string

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

=item --config

type: Array

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

=item --day-start

Measure times (for L<"--mmin">, etc) from the beginning of today rather than
from the current time.

=item --defaults-file

short form: -F; type: string

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

=item --help

Show help and exit.

=item --host

short form: -h; type: string

Connect to host.

=item --or

Combine tests with OR, not AND.

By default, tests are evaluated as though there were an AND between them.  This
option switches it to OR.

Option parsing is not implemented by mk-find itself, so you cannot specify
complicated expressions with parentheses and mixtures of OR and AND.

=item --password

short form: -p; type: string

Password to use when connecting.

=item --port

short form: -P; type: int

Port number to use for connection.

=item --[no]quote

default: yes

Quotes MySQL identifier names with MySQL's standard backtick character.

Quoting happens after tests are run, and before actions are run.

=item --set-vars

type: string; default: wait_timeout=10000

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

=item --socket

short form: -S; type: string

Socket file to use for connection.

=item --user

short form: -u; type: string

User for login if not current user.

=item --version

Show version and exit.

=back

=head2 TESTS

Most tests check some criterion against a column of SHOW TABLE STATUS output.
Numeric arguments can be specified as +n for greater than n, -n for less than n,
and n for exactly n.  All numeric options can take an optional suffix multiplier
of k, M or G (1_024, 1_048_576, and 1_073_741_824 respectively).  All patterns
are Perl regular expressions (see 'man perlre') unless specified as SQL LIKE
patterns.

Dates and times are all measured relative to the same instant, when mk-find
first asks the database server what time it is.  All date and time manipulation
is done in SQL, so if you say to find tables modified 5 days ago, that
translates to SELECT DATE_SUB(CURRENT_TIMESTAMP, INTERVAL 5 DAY).  If you
specify L<"--day-start">, if course it's relative to CURRENT_DATE instead.

However, table sizes and other metrics are not consistent at an instant in
time.  It can take some time for MySQL to process all the SHOW queries, and
mk-find can't do anything about that.  These measurements are as of the
time they're taken.

If you need some test that's not in this list, file a bug report and I'll
enhance mk-find for you.  It's really easy.

=over

=item --autoinc

type: string; group: Tests

Table's next AUTO_INCREMENT is n.  This tests the Auto_increment column.

=item --avgrowlen

type: size; group: Tests

Table avg row len is n bytes.  This tests the Avg_row_length column.

=item --checksum

type: string; group: Tests

Table checksum is n.  This tests the Checksum column.

=item --cmin

type: size; group: Tests

Table was created n minutes ago.  This tests the Create_time column.

=item --collation

type: string; group: Tests

Table collation matches pattern.  This tests the Collation column.

=item --comment

type: string; group: Tests

Table comment matches pattern.  This tests the Comment column.

=item --connection-id

type: string; group: Tests

Table name has nonexistent MySQL connection ID.  This tests the table name for
a pattern.  The argument to this test must be a Perl regular expression that
captures digits like this: (\d+).  If the table name matches the pattern,
these captured digits are taken to be the MySQL connection ID of some process.
If the connection doesn't exist according to SHOW FULL PROCESSLIST, the test
returns true.  If the connection ID is greater than mk-find's own
connection ID, the test returns false for safety.

Why would you want to do this?  If you use MySQL statement-based replication,
you probably know the trouble temporary tables can cause.  You might choose to
work around this by creating real tables with unique names, instead of
temporary tables.  One way to do this is to append your connection ID to the
end of the table, thusly: scratch_table_12345.  This assures the table name is
unique and lets you have a way to find which connection it was associated
with.  And perhaps most importantly, if the connection no longer exists, you
can assume the connection died without cleaning up its tables, and this table
is a candidate for removal.

This how I manage scratch tables, and that's why I included this test in
mk-find.

The argument I use to L<"--connection-id"> is "\D_(\d+)$".  That finds tables with a series of
numbers at the end, preceded by an underscore and some non-number character (the
latter criterion prevents me from examining tables with a date at the end, which
people tend to do: baron_scratch_2007_05_07 for example).  It's better to keep
the scratch tables separate of course.

If you do this, make sure the user mk-find runs as has the PROCESS privilege!
Otherwise it will only see connections from the same user, and might think some
tables are ready to remove when they're still in use.  For safety, mk-find
checks this for you.

See also L<"--server-id">.

=item --createopts

type: string; group: Tests

Table create option matches pattern.  This tests the Create_options column.

=item --ctime

type: size; group: Tests

Table was created n days ago.  This tests the Create_time column.

=item --datafree

type: size; group: Tests

Table has n bytes of free space.  This tests the Data_free column.

=item --datasize

type: size; group: Tests

Table data uses n bytes of space.  This tests the Data_length column.

=item --dblike

type: string; group: Tests

Database name matches SQL LIKE pattern.

=item --dbregex

type: string; group: Tests

Database name matches this pattern.

=item --empty

group: Tests

Table has no rows.  This tests the Rows column.

=item --engine

type: string; group: Tests

Table storage engine matches this pattern.  This tests the Engine column, or in
earlier versions of MySQL, the Type column.

=item --indexsize

type: size; group: Tests

Table indexes use n bytes of space.  This tests the Index_length column.

=item --kmin

type: size; group: Tests

Table was checked n minutes ago.  This tests the Check_time column.

=item --ktime

type: size; group: Tests

Table was checked n days ago.  This tests the Check_time column.

=item --mmin

type: size; group: Tests

Table was last modified n minutes ago.  This tests the Update_time column.

=item --mtime

type: size; group: Tests

Table was last modified n days ago.  This tests the Update_time column.

=item --rowformat

type: string; group: Tests

Table row format matches pattern.  This tests the Row_format column.

=item --rows

type: size; group: Tests

Table has n rows.  This tests the Rows column.

=item --server-id

type: string; group: Tests

Table name contains the server ID.  If you create temporary tables with the
naming convention explained in L<"--connection-id">, but also add the server ID of the
server on which the tables are created, then you can use this pattern match to
ensure tables are dropped only on the server they're created on.  This prevents
a table from being accidentally dropped on a slave while it's in use (provided
that your server IDs are all unique, which they should be for replication to
work).

For example, on the master (server ID 22) you create a table called
scratch_table_22_12345.  If you see this table on the slave (server ID 23), you
might think it can be dropped safely if there's no such connection 12345.  But
if you also force the name to match the server ID with C<--server-id '\D_(\d+)_\d+$'>,
the table won't be dropped on the slave.

=item --tablesize

type: size; group: Tests

Table uses n bytes of space.  This tests the sum of the Data_length and
Index_length columns.

=item --tbllike

type: string; group: Tests

Table name matches SQL LIKE pattern.

=item --tblregex

type: string; group: Tests

Table name matches this pattern.

=item --tblversion

type: size; group: Tests

Table version is n.  This tests the Version column.

=back

=head2 ACTIONS

The L<"--exec-plus"> action happens after everything else, but otherwise actions
happen in an indeterminate order.  If you need determinism, file a bug report
and I'll add this feature.

=over

=item --exec

type: string; group: Actions

Execute this SQL with each item found.  The SQL can contain escapes and
formatting directives (see L<"--printf">).

=item --exec-dsn

type: string; group: Actions

Specify a DSN in key-value format to use when executing SQL with L<"--exec"> and
L<"--exec-plus">.  Any values not specified are inherited from command-line
arguments.

=item --exec-plus

type: string; group: Actions

Execute this SQL with all items at once.  This option is unlike L<"--exec">.  There
are no escaping or formatting directives; there is only one special placeholder
for the list of database and table names, %s.  The list of tables found will be
joined together with commas and substituted wherever you place %s.

You might use this, for example, to drop all the tables you found:

   DROP TABLE %s

This is sort of like GNU find's "-exec command {} +" syntax.  Only it's not
totally cryptic.  And it doesn't require me to write a command-line parser.

=item --print

group: Actions

Print the database and table name, followed by a newline.  This is the default
action if no other action is specified.

=item --printf

type: string; group: Actions

Print format on the standard output, interpreting '\' escapes and '%'
directives.  Escapes are backslashed characters, like \n and \t.  Perl
interprets these, so you can use any escapes Perl knows about.  Directives are
replaced by %s, and as of this writing, you can't add any special formatting
instructions, like field widths or alignment (though I'm musing over ways to do
that).

Here is a list of the directives.  Note that most of them simply come from
columns of SHOW TABLE STATUS.  If the column is NULL or doesn't exist, you get
an empty string in the output.  A % character followed by any character not in
the following list is discarded (but the other character is printed).

   CHAR DATA SOURCE        NOTES
   ---- ------------------ ------------------------------------------
   a    Auto_increment
   A    Avg_row_length
   c    Checksum
   C    Create_time
   D    Database           The database name in which the table lives
   d    Data_length
   E    Engine             In older versions of MySQL, this is Type
   F    Data_free
   f    Innodb_free        Parsed from the Comment field
   I    Index_length
   K    Check_time
   L    Collation
   M    Max_data_length
   N    Name
   O    Comment
   P    Create_options
   R    Row_format
   S    Rows
   T    Table_length       Data_length+Index_length
   U    Update_time
   V    Version

=back

=head1 EXAMPLES

Find all tables created more than a day ago, which use the MyISAM engine, and
print their names:

  mk-find --ctime +1 --engine MyISAM

Find InnoDB tables that haven't been updated in a month, and convert them to
MyISAM storage engine (data warehousing, anyone?):

  mk-find --mtime +30 --engine InnoDB --exec "ALTER TABLE %D.%N ENGINE=MyISAM"

Find tables created by a process that no longer exists, following the
name_sid_pid naming convention, and remove them.

  mk-find --connection-id '\D_\d+_(\d+)$' --server-id '\D_(\d+)_\d+$' --exec-plus "DROP TABLE %s"

Find empty tables in the test and junk databases, and delete them:

  mk-find --empty junk test --exec-plus "DROP TABLE %s"

Find tables more than five gigabytes in total size:

  mk-find --tablesize +5G

Find all tables and print their total data and index size, and sort largest
tables first (sort is a different program, by the way).

  mk-find --printf "%T\t%D.%N\n" | sort -rn

As above, but this time, insert the data back into the database for posterity:

  mk-find --noquote --exec "INSERT INTO sysdata.tblsize(db, tbl, size) VALUES('%D', '%N', %T)"

=head1 ENVIRONMENT

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

   MKDEBUG=1 mk-....

=head1 BUGS

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

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

=head1 SYSTEM REQUIREMENTS

You need the following Perl modules: DBI and DBD::mysql.

=head1 LICENSE

This program is copyright 2007-2009 Baron Schwartz.
Feedback and improvements are welcome (see L<"BUGS">).

THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
systems, you can issue `man perlgpl' or `man perlartistic' to read these
licenses.

You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place, Suite 330, Boston, MA  02111-1307  USA.

=head1 AUTHOR

Baron Schwartz.

=head1 VERSION

This manual page documents Ver 0.9.17 Distrib 4047 $Revision: 4045 $.

=cut
