Merge lp:~percona-toolkit-dev/percona-toolkit/pt-table-usage into lp:percona-toolkit/2.1

[Daniel Nichter]

[Daniel Nichter (daniel-nichter)]

review: Approve

=== added file 'bin/pt-table-usage'
--- bin/pt-table-usage	1970-01-01 00:00:00 +0000
+++ bin/pt-table-usage	2012-03-30 22:48:21 +0000
@@ -0,0 +1,7320 @@
+#!/usr/bin/env perl
+
+# This program is part of Percona Toolkit: http://www.percona.com/software/
+# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
+# notices and disclaimers.
+
+use strict;
+use warnings FATAL => 'all';
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+# ###########################################################################
+# DSNParser package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/DSNParser.pm
+#   t/lib/DSNParser.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package DSNParser;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+use Data::Dumper;
+$Data::Dumper::Indent    = 0;
+$Data::Dumper::Quotekeys = 0;
+
+eval {
+   require DBI;
+};
+my $have_dbi = $EVAL_ERROR ? 0 : 1;
+
+sub new {
+   my ( $class, %args ) = @_;
+   foreach my $arg ( qw(opts) ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my $self = {
+      opts => {}  # h, P, u, etc.  Should come from DSN OPTIONS section in POD.
+   };
+   foreach my $opt ( @{$args{opts}} ) {
+      if ( !$opt->{key} || !$opt->{desc} ) {
+         die "Invalid DSN option: ", Dumper($opt);
+      }
+      PTDEBUG && _d('DSN option:',
+         join(', ',
+            map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
+               keys %$opt
+         )
+      );
+      $self->{opts}->{$opt->{key}} = {
+         dsn  => $opt->{dsn},
+         desc => $opt->{desc},
+         copy => $opt->{copy} || 0,
+      };
+   }
+   return bless $self, $class;
+}
+
+sub prop {
+   my ( $self, $prop, $value ) = @_;
+   if ( @_ > 2 ) {
+      PTDEBUG && _d('Setting', $prop, 'property');
+      $self->{$prop} = $value;
+   }
+   return $self->{$prop};
+}
+
+sub parse {
+   my ( $self, $dsn, $prev, $defaults ) = @_;
+   if ( !$dsn ) {
+      PTDEBUG && _d('No DSN to parse');
+      return;
+   }
+   PTDEBUG && _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 {
+         PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
+         $given_props{h} = $dsn_part;
+      }
+   }
+
+   foreach my $key ( keys %$opts ) {
+      PTDEBUG && _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};
+         PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
+      }
+      if ( !defined $final_props{$key} ) {
+         $final_props{$key} = $defaults->{$key};
+         PTDEBUG && _d('Copying value for', $key, 'from defaults');
+      }
+   }
+
+   foreach my $key ( keys %given_props ) {
+      die "Unknown DSN option '$key' in '$dsn'.  For more details, "
+            . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
+            . "for complete documentation."
+         unless exists $opts->{$key};
+   }
+   if ( (my $required = $self->prop('required')) ) {
+      foreach my $key ( keys %$required ) {
+         die "Missing required DSN option '$key' in '$dsn'.  For more details, "
+               . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
+               . "for complete documentation."
+            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}}
+        );
+   PTDEBUG && _d('DSN string made from options:', $dsn_string);
+   return $self->parse($dsn_string);
+}
+
+sub as_string {
+   my ( $self, $dsn, $props ) = @_;
+   return $dsn unless ref $dsn;
+   my @keys = $props ? @$props : sort keys %$dsn;
+   return join(',',
+      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
+      grep {
+         exists $self->{opts}->{$_}
+         && exists $dsn->{$_}
+         && defined $dsn->{$_}
+      } @keys);
+}
+
+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';
+   }
+   PTDEBUG && _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,
+      ShowErrorStatement => 1,
+      mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
+   };
+   @{$defaults}{ keys %$opts } = values %$opts;
+
+   if ( $opts->{mysql_use_result} ) {
+      $defaults->{mysql_use_result} = 1;
+   }
+
+   if ( !$have_dbi ) {
+      die "Cannot connect to MySQL because the Perl DBI module is not "
+         . "installed or not found.  Run 'perl -MDBI' to see the directories "
+         . "that Perl searches for DBI.  If DBI is not installed, try:\n"
+         . "  Debian/Ubuntu  apt-get install libdbi-perl\n"
+         . "  RHEL/CentOS    yum install perl-DBI\n"
+         . "  OpenSolaris    pgk install pkg:/SUNWpmdbi\n";
+
+   }
+
+   my $dbh;
+   my $tries = 2;
+   while ( !$dbh && $tries-- ) {
+      PTDEBUG && _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 = 'SELECT @@SQL_MODE';
+            PTDEBUG && _d($dbh, $sql);
+            my ($sql_mode) = $dbh->selectrow_array($sql);
+
+            $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
+                 . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
+                 . ($sql_mode ? ",$sql_mode" : '')
+                 . '\'*/';
+            PTDEBUG && _d($dbh, $sql);
+            $dbh->do($sql);
+
+            if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
+               $sql = "/*!40101 SET NAMES $charset*/";
+               PTDEBUG && _d($dbh, ':', $sql);
+               $dbh->do($sql);
+               PTDEBUG && _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('set-vars') ) {
+               $sql = "SET " . $self->prop('set-vars');
+               PTDEBUG && _d($dbh, ':', $sql);
+               $dbh->do($sql);
+            }
+         }
+      };
+      if ( !$dbh && $EVAL_ERROR ) {
+         PTDEBUG && _d($EVAL_ERROR);
+         if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
+            PTDEBUG && _d('Going to try again without utf8 support');
+            delete $defaults->{mysql_enable_utf8};
+         }
+         elsif ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
+            die "Cannot connect to MySQL because the Perl DBD::mysql module is "
+               . "not installed or not found.  Run 'perl -MDBD::mysql' to see "
+               . "the directories that Perl searches for DBD::mysql.  If "
+               . "DBD::mysql is not installed, try:\n"
+               . "  Debian/Ubuntu  apt-get install libdbd-mysql-perl\n"
+               . "  RHEL/CentOS    yum install perl-DBD-MySQL\n"
+               . "  OpenSolaris    pgk install pkg:/SUNWapu13dbd-mysql\n";
+         }
+         if ( !$tries ) {
+            die $EVAL_ERROR;
+         }
+      }
+   }
+
+   PTDEBUG && _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 ) = @_;
+   PTDEBUG && $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
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/OptionParser.pm
+#   t/lib/OptionParser.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package OptionParser;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+use List::Util qw(max);
+use Getopt::Long;
+
+my $POD_link_re = '[LC]<"?([^">]+)"?>';
+
+sub new {
+   my ( $class, %args ) = @_;
+   my @required_args = qw();
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+
+   my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
+   $program_name ||= $PROGRAM_NAME;
+   my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
+
+   my %attributes = (
+      'type'       => 1,
+      'short form' => 1,
+      'group'      => 1,
+      'default'    => 1,
+      'cumulative' => 1,
+      'negatable'  => 1,
+   );
+
+   my $self = {
+      head1             => 'OPTIONS',        # These args are used internally
+      skip_rules        => 0,                # to instantiate another Option-
+      item              => '--(.*)',         # Parser obj that parses the
+      attributes        => \%attributes,     # DSN OPTIONS section.  Tools
+      parse_attributes  => \&_parse_attribs, # don't tinker with these args.
+
+      %args,
+
+      strict            => 1,  # disabled by a special rule
+      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
+      DSNParser         => undef,
+      default_files     => [
+         "/etc/percona-toolkit/percona-toolkit.conf",
+         "/etc/percona-toolkit/$program_name.conf",
+         "$home/.percona-toolkit.conf",
+         "$home/.$program_name.conf",
+      ],
+      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
+         size   => 'z', # size with kMG suffix (powers of 2^10)
+         time   => 'm', # time, with an optional suffix of s/h/m/d
+      },
+   };
+
+   return bless $self, $class;
+}
+
+sub get_specs {
+   my ( $self, $file ) = @_;
+   $file ||= $self->{file} || __FILE__;
+   my @specs = $self->_pod_to_specs($file);
+   $self->_parse_specs(@specs);
+
+   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
+   my $contents = do { local $/ = undef; <$fh> };
+   close $fh;
+   if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
+      PTDEBUG && _d('Parsing DSN OPTIONS');
+      my $dsn_attribs = {
+         dsn  => 1,
+         copy => 1,
+      };
+      my $parse_dsn_attribs = sub {
+         my ( $self, $option, $attribs ) = @_;
+         map {
+            my $val = $attribs->{$_};
+            if ( $val ) {
+               $val    = $val eq 'yes' ? 1
+                       : $val eq 'no'  ? 0
+                       :                 $val;
+               $attribs->{$_} = $val;
+            }
+         } keys %$attribs;
+         return {
+            key => $option,
+            %$attribs,
+         };
+      };
+      my $dsn_o = new OptionParser(
+         description       => 'DSN OPTIONS',
+         head1             => 'DSN OPTIONS',
+         dsn               => 0,         # XXX don't infinitely recurse!
+         item              => '\* (.)',  # key opts are a single character
+         skip_rules        => 1,         # no rules before opts
+         attributes        => $dsn_attribs,
+         parse_attributes  => $parse_dsn_attribs,
+      );
+      my @dsn_opts = map {
+         my $opts = {
+            key  => $_->{spec}->{key},
+            dsn  => $_->{spec}->{dsn},
+            copy => $_->{spec}->{copy},
+            desc => $_->{desc},
+         };
+         $opts;
+      } $dsn_o->_pod_to_specs($file);
+      $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
+   }
+
+   if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
+      $self->{version} = $1;
+      PTDEBUG && _d($self->{version});
+   }
+
+   return;
+}
+
+sub DSNParser {
+   my ( $self ) = @_;
+   return $self->{DSNParser};
+};
+
+sub get_defaults_files {
+   my ( $self ) = @_;
+   return @{$self->{default_files}};
+}
+
+sub _pod_to_specs {
+   my ( $self, $file ) = @_;
+   $file ||= $self->{file} || __FILE__;
+   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
+
+   my @specs = ();
+   my @rules = ();
+   my $para;
+
+   local $INPUT_RECORD_SEPARATOR = '';
+   while ( $para = <$fh> ) {
+      next unless $para =~ m/^=head1 $self->{head1}/;
+      last;
+   }
+
+   while ( $para = <$fh> ) {
+      last if $para =~ m/^=over/;
+      next if $self->{skip_rules};
+      chomp $para;
+      $para =~ s/\s+/ /g;
+      $para =~ s/$POD_link_re/$1/go;
+      PTDEBUG && _d('Option rule:', $para);
+      push @rules, $para;
+   }
+
+   die "POD has no $self->{head1} section" unless $para;
+
+   do {
+      if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
+         chomp $para;
+         PTDEBUG && _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 $self->{attributes}->{$attrib};
+                  ($attrib, $val);
+               } split(/; /, $para);
+            if ( $attribs{'short form'} ) {
+               $attribs{'short form'} =~ s/-//;
+            }
+            $para = <$fh>; # read next paragraph, probably short help desc
+         }
+         else {
+            PTDEBUG && _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;
+         PTDEBUG && _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  => $self->{parse_attributes}->($self, $option, \%attribs), 
+            desc  => $para
+               . (defined $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 $self->{head1}" 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.
+         PTDEBUG && _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 ) {
+            PTDEBUG && _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;
+         PTDEBUG && _d($long, 'type:', $type);
+
+
+         $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
+
+         if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
+            $self->{defaults}->{$long} = defined $def ? $def : 1;
+            PTDEBUG && _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;
+            PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
+         }
+
+         $self->{opts}->{$long} = $opt;
+      }
+      else { # It's an option rule, not a spec.
+         PTDEBUG && _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;
+            PTDEBUG && _d(@participants, 'are mutually exclusive');
+         }
+         if ( $opt =~ m/at least one|one and only one/ ) {
+            $rule_ok = 1;
+            push @{$self->{atleast1}}, \@participants;
+            PTDEBUG && _d(@participants, 'require at least one');
+         }
+         if ( $opt =~ m/default to/ ) {
+            $rule_ok = 1;
+            $self->{defaults_to}->{$participants[0]} = $participants[1];
+            PTDEBUG && _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;
+         }
+         if( $opt =~ m/accepts additional command-line arguments/ ) {
+            $rule_ok = 1;
+            $self->{strict} = 0;
+            PTDEBUG && _d("Strict mode disabled by rule");
+         }
+
+         die "Unrecognized option rule: $opt" unless $rule_ok;
+      }
+   }
+
+   foreach my $long ( keys %disables ) {
+      my @participants = $self->_get_participants($disables{$long});
+      $self->{disables}->{$long} = \@participants;
+      PTDEBUG && _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;
+   }
+   PTDEBUG && _d('Participants for', $str, ':', @participants);
+   return @participants;
+}
+
+sub opts {
+   my ( $self ) = @_;
+   my %opts = %{$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};
+      PTDEBUG && _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;
+   PTDEBUG && _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 @extra_args, $self->_read_config_file($filename);
+         };
+         if ( $EVAL_ERROR ) {
+            if ( $self->got('config') ) {
+               die $EVAL_ERROR;
+            }
+            elsif ( PTDEBUG ) {
+               _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} ) {
+      if ( $self->{version} ) {
+         print $self->{version}, "\n";
+      }
+      else {
+         print "Error parsing version.  See the VERSION section of the tool's documentation.\n";
+      }
+      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");
+      }
+   }
+
+   $self->_check_opts( keys %{$self->{opts}} );
+   $self->{got_opts} = 1;
+   return;
+}
+
+sub _check_opts {
+   my ( $self, @long ) = @_;
+   my $long_last = scalar @long;
+   while ( @long ) {
+      foreach my $i ( 0..$#long ) {
+         my $long = $long[$i];
+         next unless $long;
+         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;
+               PTDEBUG && _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);
+         if ( $opt->{parsed} ) {
+            delete $long[$i];
+         }
+         else {
+            PTDEBUG && _d('Temporarily failed to parse', $long);
+         }
+      }
+
+      die "Failed to parse options, possibly due to circular dependencies"
+         if @long == $long_last;
+      $long_last = @long;
+   }
+
+   return;
+}
+
+sub _validate_type {
+   my ( $self, $opt ) = @_;
+   return unless $opt;
+
+   if ( !$opt->{type} ) {
+      $opt->{parsed} = 1;
+      return;
+   }
+
+   my $val = $opt->{value};
+
+   if ( $val && $opt->{type} eq 'm' ) {  # type time
+      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
+      my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
+      if ( !$suffix ) {
+         my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
+         $suffix = $s || 's';
+         PTDEBUG && _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} = ($prefix || '') . $val;
+         PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
+      }
+      else {
+         $self->save_error("Invalid time suffix for --$opt->{long}");
+      }
+   }
+   elsif ( $val && $opt->{type} eq 'd' ) {  # type DSN
+      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
+      my $prev = {};
+      my $from_key = $self->{defaults_to}->{ $opt->{long} };
+      if ( $from_key ) {
+         PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
+         if ( $self->{opts}->{$from_key}->{parsed} ) {
+            $prev = $self->{opts}->{$from_key}->{value};
+         }
+         else {
+            PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
+               $from_key, 'parsed');
+            return;
+         }
+      }
+      my $defaults = $self->{DSNParser}->parse_options($self);
+      $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
+   }
+   elsif ( $val && $opt->{type} eq 'z' ) {  # type size
+      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
+      $self->_parse_size($opt, $val);
+   }
+   elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
+      $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
+   }
+   elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
+      $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
+   }
+   else {
+      PTDEBUG && _d('Nothing to validate for option',
+         $opt->{long}, 'type', $opt->{type}, 'value', $val);
+   }
+
+   $opt->{parsed} = 1;
+   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;
+   return;
+}
+
+sub errors {
+   my ( $self ) = @_;
+   return $self->{errors};
+}
+
+sub usage {
+   my ( $self ) = @_;
+   warn "No usage string is set" unless $self->{usage}; # XXX
+   return "Usage: " . ($self->{usage} || '') . "\n";
+}
+
+sub descr {
+   my ( $self ) = @_;
+   warn "No description string is set" unless $self->{description}; # XXX
+   my $descr  = ($self->{description} || $self->{program_name} || '')
+              . "  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)
+      unless $ENV{DONT_BREAK_LINES};
+   $descr =~ s/ +$//mg;
+   return $descr;
+}
+
+sub usage_or_errors {
+   my ( $self, $file, $return ) = @_;
+   $file ||= $self->{file} || __FILE__;
+
+   if ( !$self->{description} || !$self->{usage} ) {
+      PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
+      my %synop = $self->_parse_synopsis($file);
+      $self->{description} ||= $synop{description};
+      $self->{usage}       ||= $synop{usage};
+      PTDEBUG && _d("Description:", $self->{description},
+         "\nUsage:", $self->{usage});
+   }
+
+   if ( $self->{opts}->{help}->{got} ) {
+      print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
+      exit 0 unless $return;
+   }
+   elsif ( scalar @{$self->{errors}} ) {
+      print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
+      exit 0 unless $return;
+   }
+
+   return;
+}
+
+sub print_errors {
+   my ( $self ) = @_;
+   my $usage = $self->usage() . "\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})               # option long name
+         + ($_->{is_negatable} ? 4 : 0)   # "[no]" if opt is negatable
+         + ($_->{type} ? 2 : 0)           # "=x" where x is the opt type
+      }
+      @opts);
+
+   my $maxs = max(0,
+      map {
+         length($_)
+         + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+         + ($self->{opts}->{$_}->{type} ? 2 : 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->usage();
+
+   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};
+
+         $long .= $opt->{type} ? "=$opt->{type}" : "";
+
+         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);
+         }
+      }
+   }
+
+   $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
+
+   if ( (my @rules = @{$self->{rules}}) ) {
+      $usage .= "\nRules:\n\n";
+      $usage .= join("\n", map { "  $_" } @rules) . "\n";
+   }
+   if ( $self->{DSNParser} ) {
+      $usage .= "\n" . $self->{DSNParser}->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->{DSNParser}->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;
+}
+
+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 _parse_size {
+   my ( $self, $opt, $val ) = @_;
+
+   if ( lc($val || '') eq 'null' ) {
+      PTDEBUG && _d('NULL size for', $opt->{long});
+      $opt->{value} = 'null';
+      return;
+   }
+
+   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};
+         PTDEBUG && _d('Setting option', $opt->{y},
+            'to num', $num, '* factor', $factor);
+      }
+      $opt->{value} = ($pre || '') . $num;
+   }
+   else {
+      $self->save_error("Invalid size for --$opt->{long}: $val");
+   }
+   return;
+}
+
+sub _parse_attribs {
+   my ( $self, $option, $attribs ) = @_;
+   my $types = $self->{types};
+   return $option
+      . ($attribs->{'short form'} ? '|' . $attribs->{'short form'}   : '' )
+      . ($attribs->{'negatable'}  ? '!'                              : '' )
+      . ($attribs->{'cumulative'} ? '+'                              : '' )
+      . ($attribs->{'type'}       ? '=' . $types->{$attribs->{type}} : '' );
+}
+
+sub _parse_synopsis {
+   my ( $self, $file ) = @_;
+   $file ||= $self->{file} || __FILE__;
+   PTDEBUG && _d("Parsing SYNOPSIS in", $file);
+
+   local $INPUT_RECORD_SEPARATOR = '';  # read paragraphs
+   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
+   my $para;
+   1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
+   die "$file does not contain a SYNOPSIS section" unless $para;
+   my @synop;
+   for ( 1..2 ) {  # 1 for the usage, 2 for the description
+      my $para = <$fh>;
+      push @synop, $para;
+   }
+   close $fh;
+   PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
+   my ($usage, $desc) = @synop;
+   die "The SYNOPSIS section in $file is not formatted properly"
+      unless $usage && $desc;
+
+   $usage =~ s/^\s*Usage:\s+(.+)/$1/;
+   chomp $usage;
+
+   $desc =~ s/\n/ /g;
+   $desc =~ s/\s{2,}/ /g;
+   $desc =~ s/\. ([A-Z][a-z])/.  $1/g;
+   $desc =~ s/\s+$//;
+
+   return (
+      description => $desc,
+      usage       => $usage,
+   );
+};
+
+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";
+}
+
+if ( PTDEBUG ) {
+   print '# ', $^X, ' ', $], "\n";
+   if ( my $uname = `uname -a` ) {
+      $uname =~ s/\s+/ /g;
+      print "# $uname\n";
+   }
+   print '# Arguments: ',
+      join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End OptionParser package
+# ###########################################################################
+
+# ###########################################################################
+# SlowLogParser package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/SlowLogParser.pm
+#   t/lib/SlowLogParser.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package SlowLogParser;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+use Data::Dumper;
+$Data::Dumper::Indent    = 1;
+$Data::Dumper::Sortkeys  = 1;
+$Data::Dumper::Quotekeys = 0;
+
+sub new {
+   my ( $class ) = @_;
+   my $self = {
+      pending => [],
+   };
+   return bless $self, $class;
+}
+
+my $slow_log_ts_line = qr/^# Time: ([0-9: ]{15})/;
+my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]/;
+my $slow_log_hd_line = qr{
+      ^(?:
+      T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix
+      |
+      [/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary)
+      |
+      Time\s+Id\s+Command
+      ).*\n
+   }xm;
+
+sub parse_event {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(next_event tell);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($next_event, $tell) = @args{@required_args};
+
+   my $pending = $self->{pending};
+   local $INPUT_RECORD_SEPARATOR = ";\n#";
+   my $trimlen    = length($INPUT_RECORD_SEPARATOR);
+   my $pos_in_log = $tell->();
+   my $stmt;
+
+   EVENT:
+   while (
+         defined($stmt = shift @$pending)
+      or defined($stmt = $next_event->())
+   ) {
+      my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log);
+      $pos_in_log = $tell->();
+
+      if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log
+         my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt);
+         if ( @chunks > 1 ) {
+            PTDEBUG && _d("Found multiple chunks");
+            $stmt = shift @chunks;
+            unshift @$pending, @chunks;
+         }
+      }
+
+      $stmt = '#' . $stmt unless $stmt =~ m/\A#/;
+      $stmt =~ s/;\n#?\Z//;
+
+
+      my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed);
+      my $pos = 0;
+      my $len = length($stmt);
+      my $found_arg = 0;
+      LINE:
+      while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match.
+         $pos     = pos($stmt);  # Be careful not to mess this up!
+         my $line = $1;          # Necessary for /g and pos() to work.
+         PTDEBUG && _d($line);
+
+         if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) {
+
+            if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) {
+               PTDEBUG && _d("Got ts", $time);
+               push @properties, 'ts', $time;
+               ++$got_ts;
+               if ( !$got_uh
+                  && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
+               ) {
+                  PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
+                  push @properties, 'user', $user, 'host', $host, 'ip', $ip;
+                  ++$got_uh;
+               }
+            }
+
+            elsif ( !$got_uh
+                  && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
+            ) {
+               PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
+               push @properties, 'user', $user, 'host', $host, 'ip', $ip;
+               ++$got_uh;
+            }
+
+            elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) {
+               PTDEBUG && _d("Got admin command");
+               $line =~ s/^#\s+//;  # string leading "# ".
+               push @properties, 'cmd', 'Admin', 'arg', $line;
+               push @properties, 'bytes', length($properties[-1]);
+               ++$found_arg;
+               ++$got_ac;
+            }
+
+            elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap!
+               PTDEBUG && _d("Got some line with properties");
+
+               if ( $line =~ m/Schema:\s+\w+: / ) {
+                  PTDEBUG && _d('Removing empty Schema attrib');
+                  $line =~ s/Schema:\s+//;
+                  PTDEBUG && _d($line);
+               }
+
+               my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g;
+               push @properties, @temp;
+            }
+
+            elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) {
+               PTDEBUG && _d("Got a default database:", $db);
+               push @properties, 'db', $db;
+               ++$got_db;
+            }
+
+            elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) {
+               PTDEBUG && _d("Got some setting:", $setting);
+               push @properties, split(/,|\s*=\s*/, $setting);
+               ++$got_set;
+            }
+
+            if ( !$found_arg && $pos == $len ) {
+               PTDEBUG && _d("Did not find arg, looking for special cases");
+               local $INPUT_RECORD_SEPARATOR = ";\n";
+               if ( defined(my $l = $next_event->()) ) {
+                  chomp $l;
+                  $l =~ s/^\s+//;
+                  PTDEBUG && _d("Found admin statement", $l);
+                  push @properties, 'cmd', 'Admin', 'arg', $l;
+                  push @properties, 'bytes', length($properties[-1]);
+                  $found_arg++;
+               }
+               else {
+                  PTDEBUG && _d("I can't figure out what to do with this line");
+                  next EVENT;
+               }
+            }
+         }
+         else {
+            PTDEBUG && _d("Got the query/arg line");
+            my $arg = substr($stmt, $pos - length($line));
+            push @properties, 'arg', $arg, 'bytes', length($arg);
+            if ( $args{misc} && $args{misc}->{embed}
+               && ( my ($e) = $arg =~ m/($args{misc}->{embed})/)
+            ) {
+               push @properties, $e =~ m/$args{misc}->{capture}/g;
+            }
+            last LINE;
+         }
+      }
+
+      PTDEBUG && _d('Properties of event:', Dumper(\@properties));
+      my $event = { @properties };
+      if ( $args{stats} ) {
+         $args{stats}->{events_read}++;
+         $args{stats}->{events_parsed}++;
+      }
+      return $event;
+   } # EVENT
+
+   @$pending = ();
+   $args{oktorun}->(0) if $args{oktorun};
+   return;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End SlowLogParser package
+# ###########################################################################
+
+# ###########################################################################
+# Transformers package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/Transformers.pm
+#   t/lib/Transformers.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package Transformers;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+use Time::Local qw(timegm timelocal);
+use Digest::MD5 qw(md5_hex);
+
+require Exporter;
+our @ISA         = qw(Exporter);
+our %EXPORT_TAGS = ();
+our @EXPORT      = ();
+our @EXPORT_OK   = qw(
+   micro_t
+   percentage_of
+   secs_to_time
+   time_to_secs
+   shorten
+   ts
+   parse_timestamp
+   unix_timestamp
+   any_unix_timestamp
+   make_checksum
+   crc32
+);
+
+our $mysql_ts  = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
+our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
+our $n_ts      = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
+
+sub micro_t {
+   my ( $t, %args ) = @_;
+   my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0;  # precision for ms vals
+   my $p_s  = defined $args{p_s}  ? $args{p_s}  : 0;  # precision for s vals
+   my $f;
+
+   $t = 0 if $t < 0;
+
+   $t = sprintf('%.17f', $t) if $t =~ /e/;
+
+   $t =~ s/\.(\d{1,6})\d*/\.$1/;
+
+   if ($t > 0 && $t <= 0.000999) {
+      $f = ($t * 1000000) . 'us';
+   }
+   elsif ($t >= 0.001000 && $t <= 0.999999) {
+      $f = sprintf("%.${p_ms}f", $t * 1000);
+      $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
+   }
+   elsif ($t >= 1) {
+      $f = sprintf("%.${p_s}f", $t);
+      $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
+   }
+   else {
+      $f = 0;  # $t should = 0 at this point
+   }
+
+   return $f;
+}
+
+sub percentage_of {
+   my ( $is, $of, %args ) = @_;
+   my $p   = $args{p} || 0; # float precision
+   my $fmt = $p ? "%.${p}f" : "%d";
+   return sprintf $fmt, ($is * 100) / ($of ||= 1);
+}
+
+sub secs_to_time {
+   my ( $secs, $fmt ) = @_;
+   $secs ||= 0;
+   return '00:00' unless $secs;
+
+   $fmt ||= $secs >= 86_400 ? 'd'
+          : $secs >= 3_600  ? 'h'
+          :                   'm';
+
+   return
+      $fmt eq 'd' ? sprintf(
+         "%d+%02d:%02d:%02d",
+         int($secs / 86_400),
+         int(($secs % 86_400) / 3_600),
+         int(($secs % 3_600) / 60),
+         $secs % 60)
+      : $fmt eq 'h' ? sprintf(
+         "%02d:%02d:%02d",
+         int(($secs % 86_400) / 3_600),
+         int(($secs % 3_600) / 60),
+         $secs % 60)
+      : sprintf(
+         "%02d:%02d",
+         int(($secs % 3_600) / 60),
+         $secs % 60);
+}
+
+sub time_to_secs {
+   my ( $val, $default_suffix ) = @_;
+   die "I need a val argument" unless defined $val;
+   my $t = 0;
+   my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
+   $suffix = $suffix || $default_suffix || 's';
+   if ( $suffix =~ m/[smhd]/ ) {
+      $t = $suffix eq 's' ? $num * 1        # Seconds
+         : $suffix eq 'm' ? $num * 60       # Minutes
+         : $suffix eq 'h' ? $num * 3600     # Hours
+         :                  $num * 86400;   # Days
+
+      $t *= -1 if $prefix && $prefix eq '-';
+   }
+   else {
+      die "Invalid suffix for $val: $suffix";
+   }
+   return $t;
+}
+
+sub shorten {
+   my ( $num, %args ) = @_;
+   my $p = defined $args{p} ? $args{p} : 2;     # float precision
+   my $d = defined $args{d} ? $args{d} : 1_024; # divisor
+   my $n = 0;
+   my @units = ('', qw(k M G T P E Z Y));
+   while ( $num >= $d && $n < @units - 1 ) {
+      $num /= $d;
+      ++$n;
+   }
+   return sprintf(
+      $num =~ m/\./ || $n
+         ? "%.${p}f%s"
+         : '%d',
+      $num, $units[$n]);
+}
+
+sub ts {
+   my ( $time, $gmt ) = @_;
+   my ( $sec, $min, $hour, $mday, $mon, $year )
+      = $gmt ? gmtime($time) : localtime($time);
+   $mon  += 1;
+   $year += 1900;
+   my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
+      $year, $mon, $mday, $hour, $min, $sec);
+   if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
+      $us = sprintf("%.6f", $us);
+      $us =~ s/^0\././;
+      $val .= $us;
+   }
+   return $val;
+}
+
+sub parse_timestamp {
+   my ( $val ) = @_;
+   if ( my($y, $m, $d, $h, $i, $s, $f)
+         = $val =~ m/^$mysql_ts$/ )
+   {
+      return sprintf "%d-%02d-%02d %02d:%02d:"
+                     . (defined $f ? '%09.6f' : '%02d'),
+                     $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
+   }
+   return $val;
+}
+
+sub unix_timestamp {
+   my ( $val, $gmt ) = @_;
+   if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
+      $val = $gmt
+         ? timegm($s, $i, $h, $d, $m - 1, $y)
+         : timelocal($s, $i, $h, $d, $m - 1, $y);
+      if ( defined $us ) {
+         $us = sprintf('%.6f', $us);
+         $us =~ s/^0\././;
+         $val .= $us;
+      }
+   }
+   return $val;
+}
+
+sub any_unix_timestamp {
+   my ( $val, $callback ) = @_;
+
+   if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
+      $n = $suffix eq 's' ? $n            # Seconds
+         : $suffix eq 'm' ? $n * 60       # Minutes
+         : $suffix eq 'h' ? $n * 3600     # Hours
+         : $suffix eq 'd' ? $n * 86400    # Days
+         :                  $n;           # default: Seconds
+      PTDEBUG && _d('ts is now - N[shmd]:', $n);
+      return time - $n;
+   }
+   elsif ( $val =~ m/^\d{9,}/ ) {
+      PTDEBUG && _d('ts is already a unix timestamp');
+      return $val;
+   }
+   elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
+      PTDEBUG && _d('ts is MySQL slow log timestamp');
+      $val .= ' 00:00:00' unless $hms;
+      return unix_timestamp(parse_timestamp($val));
+   }
+   elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
+      PTDEBUG && _d('ts is properly formatted timestamp');
+      $val .= ' 00:00:00' unless $hms;
+      return unix_timestamp($val);
+   }
+   else {
+      PTDEBUG && _d('ts is MySQL expression');
+      return $callback->($val) if $callback && ref $callback eq 'CODE';
+   }
+
+   PTDEBUG && _d('Unknown ts type:', $val);
+   return;
+}
+
+sub make_checksum {
+   my ( $val ) = @_;
+   my $checksum = uc substr(md5_hex($val), -16);
+   PTDEBUG && _d($checksum, 'checksum for', $val);
+   return $checksum;
+}
+
+sub crc32 {
+   my ( $string ) = @_;
+   return unless $string;
+   my $poly = 0xEDB88320;
+   my $crc  = 0xFFFFFFFF;
+   foreach my $char ( split(//, $string) ) {
+      my $comp = ($crc ^ ord($char)) & 0xFF;
+      for ( 1 .. 8 ) {
+         $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
+      }
+      $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
+   }
+   return $crc ^ 0xFFFFFFFF;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End Transformers package
+# ###########################################################################
+
+# ###########################################################################
+# QueryRewriter package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/QueryRewriter.pm
+#   t/lib/QueryRewriter.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package QueryRewriter;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+our $verbs   = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT
+                  |UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi;
+my $quote_re = qr/"(?:(?!(?<!\\)").)*"|'(?:(?!(?<!\\)').)*'/; # Costly!
+my $bal;
+$bal         = qr/
+                  \(
+                  (?:
+                     (?> [^()]+ )    # Non-parens without backtracking
+                     |
+                     (??{ $bal })    # Group with matching parens
+                  )*
+                  \)
+                 /x;
+
+my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/;  # One-line comments
+my $mlc_re = qr#/\*[^!].*?\*/#sm;                  # But not /*!version */
+my $vlc_re = qr#/\*.*?[0-9+].*?\*/#sm;             # For SHOW + /*!version */
+my $vlc_rf = qr#^(SHOW).*?/\*![0-9+].*?\*/#sm;     # Variation for SHOW
+
+
+sub new {
+   my ( $class, %args ) = @_;
+   my $self = { %args };
+   return bless $self, $class;
+}
+
+sub strip_comments {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   $query =~ s/$olc_re//go;
+   $query =~ s/$mlc_re//go;
+   if ( $query =~ m/$vlc_rf/i ) { # contains show + version
+      $query =~ s/$vlc_re//go;
+   }
+   return $query;
+}
+
+sub shorten {
+   my ( $self, $query, $length ) = @_;
+   $query =~ s{
+      \A(
+         (?:INSERT|REPLACE)
+         (?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)?
+         (?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\)
+      )
+      \s*,\s*\(.*?(ON\s+DUPLICATE|\Z)}
+      {$1 /*... omitted ...*/$2}xsi;
+
+   return $query unless $query =~ m/IN\s*\(\s*(?!select)/i;
+
+   my $last_length  = 0;
+   my $query_length = length($query);
+   while (
+      $length          > 0
+      && $query_length > $length
+      && $query_length < ( $last_length || $query_length + 1 )
+   ) {
+      $last_length = $query_length;
+      $query =~ s{
+         (\bIN\s*\()    # The opening of an IN list
+         ([^\)]+)       # Contents of the list, assuming no item contains paren
+         (?=\))           # Close of the list
+      }
+      {
+         $1 . __shorten($2)
+      }gexsi;
+   }
+
+   return $query;
+}
+
+sub __shorten {
+   my ( $snippet ) = @_;
+   my @vals = split(/,/, $snippet);
+   return $snippet unless @vals > 20;
+   my @keep = splice(@vals, 0, 20);  # Remove and save the first 20 items
+   return
+      join(',', @keep)
+      . "/*... omitted "
+      . scalar(@vals)
+      . " items ...*/";
+}
+
+sub fingerprint {
+   my ( $self, $query ) = @_;
+
+   $query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query
+      && return 'mysqldump';
+   $query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/#     # pt-table-checksum, etc query
+      && return 'percona-toolkit';
+   $query =~ m/\Aadministrator command: /
+      && return $query;
+   $query =~ m/\A\s*(call\s+\S+)\(/i
+      && return lc($1); # Warning! $1 used, be careful.
+   if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) {
+      $query = $beginning; # Shorten multi-value INSERT statements ASAP
+   }
+  
+   $query =~ s/$olc_re//go;
+   $query =~ s/$mlc_re//go;
+   $query =~ s/\Ause \S+\Z/use ?/i       # Abstract the DB in USE
+      && return $query;
+
+   $query =~ s/\\["']//g;                # quoted strings
+   $query =~ s/".*?"/?/sg;               # quoted strings
+   $query =~ s/'.*?'/?/sg;               # quoted strings
+
+   if ( $self->{match_md5_checksums} ) { 
+      $query =~ s/([._-])[a-f0-9]{32}/$1?/g;
+   }
+
+   if ( !$self->{match_embedded_numbers} ) {
+      $query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g;
+   }
+   else {
+      $query =~ s/\b[0-9+-][0-9a-f.xb+-]*/?/g;
+   }
+
+   if ( $self->{match_md5_checksums} ) {
+      $query =~ s/[xb+-]\?/?/g;                
+   }
+   else {
+      $query =~ s/[xb.+-]\?/?/g;
+   }
+
+   $query =~ s/\A\s+//;                  # Chop off leading whitespace
+   chomp $query;                         # Kill trailing whitespace
+   $query =~ tr[ \n\t\r\f][ ]s;          # Collapse whitespace
+   $query = lc $query;
+   $query =~ s/\bnull\b/?/g;             # Get rid of NULLs
+   $query =~ s{                          # Collapse IN and VALUES lists
+               \b(in|values?)(?:[\s,]*\([\s?,]*\))+
+              }
+              {$1(?+)}gx;
+   $query =~ s{                          # Collapse UNION
+               \b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+
+              }
+              {$1 /*repeat$2*/}xg;
+   $query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT
+
+   if ( $query =~ m/\bORDER BY /gi ) {  # Find, anchor on ORDER BY clause
+      1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query;
+   }
+
+   return $query;
+}
+
+sub distill_verbs {
+   my ( $self, $query ) = @_;
+
+   $query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1";
+   $query =~ m/\A\s*use\s+/          && return "USE";
+   $query =~ m/\A\s*UNLOCK TABLES/i  && return "UNLOCK";
+   $query =~ m/\A\s*xa\s+(\S+)/i     && return "XA_$1";
+
+   if ( $query =~ m/\Aadministrator command:/ ) {
+      $query =~ s/administrator command:/ADMIN/;
+      $query = uc $query;
+      return $query;
+   }
+
+   $query = $self->strip_comments($query);
+
+   if ( $query =~ m/\A\s*SHOW\s+/i ) {
+      PTDEBUG && _d($query);
+
+      $query = uc $query;
+      $query =~ s/\s+(?:GLOBAL|SESSION|FULL|STORAGE|ENGINE)\b/ /g;
+      $query =~ s/\s+COUNT[^)]+\)//g;
+
+      $query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms;
+
+      $query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s;
+      $query =~ s/\s+/ /g;
+      PTDEBUG && _d($query);
+      return $query;
+   }
+
+   eval $QueryParser::data_def_stmts;
+   eval $QueryParser::tbl_ident;
+   my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i;
+   if ( $dds) {
+      my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i;
+      $obj = uc $obj if $obj;
+      PTDEBUG && _d('Data def statment:', $dds, 'obj:', $obj);
+      my ($db_or_tbl)
+         = $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i;
+      PTDEBUG && _d('Matches db or table:', $db_or_tbl);
+      return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl;
+   }
+
+   my @verbs = $query =~ m/\b($verbs)\b/gio;
+   @verbs    = do {
+      my $last = '';
+      grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs;
+   };
+
+   if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) {
+      PTDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]);
+      my $union = grep { $_ eq 'UNION' } @verbs;
+      @verbs    = $union ? qw(SELECT UNION) : qw(SELECT);
+   }
+
+   my $verb_str = join(q{ }, @verbs);
+   return $verb_str;
+}
+
+sub __distill_tables {
+   my ( $self, $query, $table, %args ) = @_;
+   my $qp = $args{QueryParser} || $self->{QueryParser};
+   die "I need a QueryParser argument" unless $qp;
+
+   my @tables = map {
+      $_ =~ s/`//g;
+      $_ =~ s/(_?)[0-9]+/$1?/g;
+      $_;
+   } grep { defined $_ } $qp->get_tables($query);
+
+   push @tables, $table if $table;
+
+   @tables = do {
+      my $last = '';
+      grep { my $pass = $_ ne $last; $last = $_; $pass } @tables;
+   };
+
+   return @tables;
+}
+
+sub distill {
+   my ( $self, $query, %args ) = @_;
+
+   if ( $args{generic} ) {
+      my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/;
+      return '' unless $cmd;
+      $query = (uc $cmd) . ($arg ? " $arg" : '');
+   }
+   else {
+      my ($verbs, $table)  = $self->distill_verbs($query, %args);
+
+      if ( $verbs && $verbs =~ m/^SHOW/ ) {
+         my %alias_for = qw(
+            SCHEMA   DATABASE
+            KEYS     INDEX
+            INDEXES  INDEX
+         );
+         map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for;
+         $query = $verbs;
+      }
+      else {
+         my @tables = $self->__distill_tables($query, $table, %args);
+         $query     = join(q{ }, $verbs, @tables); 
+      } 
+   }
+
+   if ( $args{trf} ) {
+      $query = $args{trf}->($query, %args);
+   }
+
+   return $query;
+}
+
+sub convert_to_select {
+   my ( $self, $query ) = @_;
+   return unless $query;
+
+   return if $query =~ m/=\s*\(\s*SELECT /i;
+
+   $query =~ s{
+                 \A.*?
+                 update(?:\s+(?:low_priority|ignore))?\s+(.*?)
+                 \s+set\b(.*?)
+                 (?:\s*where\b(.*?))?
+                 (limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)?
+                 \Z
+              }
+              {__update_to_select($1, $2, $3, $4)}exsi
+      || $query =~ s{
+                    \A.*?
+                    (?:insert(?:\s+ignore)?|replace)\s+
+                    .*?\binto\b(.*?)\(([^\)]+)\)\s*
+                    values?\s*(\(.*?\))\s*
+                    (?:\blimit\b|on\s+duplicate\s+key.*)?\s*
+                    \Z
+                 }
+                 {__insert_to_select($1, $2, $3)}exsi
+      || $query =~ s{
+                    \A.*?
+                    (?:insert(?:\s+ignore)?|replace)\s+
+                    (?:.*?\binto)\b(.*?)\s*
+                    set\s+(.*?)\s*
+                    (?:\blimit\b|on\s+duplicate\s+key.*)?\s*
+                    \Z
+                 }
+                 {__insert_to_select_with_set($1, $2)}exsi
+      || $query =~ s{
+                    \A.*?
+                    delete\s+(.*?)
+                    \bfrom\b(.*)
+                    \Z
+                 }
+                 {__delete_to_select($1, $2)}exsi;
+   $query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si;
+   $query =~ s/\A.*?(?=\bSELECT\s*\b)//ism;
+   return $query;
+}
+
+sub convert_select_list {
+   my ( $self, $query ) = @_;
+   $query =~ s{
+               \A\s*select(.*?)\bfrom\b
+              }
+              {$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi;
+   return $query;
+}
+
+sub __delete_to_select {
+   my ( $delete, $join ) = @_;
+   if ( $join =~ m/\bjoin\b/ ) {
+      return "select 1 from $join";
+   }
+   return "select * from $join";
+}
+
+sub __insert_to_select {
+   my ( $tbl, $cols, $vals ) = @_;
+   PTDEBUG && _d('Args:', @_);
+   my @cols = split(/,/, $cols);
+   PTDEBUG && _d('Cols:', @cols);
+   $vals =~ s/^\(|\)$//g; # Strip leading/trailing parens
+   my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g;
+   PTDEBUG && _d('Vals:', @vals);
+   if ( @cols == @vals ) {
+      return "select * from $tbl where "
+         . join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols));
+   }
+   else {
+      return "select * from $tbl limit 1";
+   }
+}
+
+sub __insert_to_select_with_set {
+   my ( $from, $set ) = @_;
+   $set =~ s/,/ and /g;
+   return "select * from $from where $set ";
+}
+
+sub __update_to_select {
+   my ( $from, $set, $where, $limit ) = @_;
+   return "select $set from $from "
+      . ( $where ? "where $where" : '' )
+      . ( $limit ? " $limit "      : '' );
+}
+
+sub wrap_in_derived {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   return $query =~ m/\A\s*select/i
+      ? "select 1 from ($query) as x limit 1"
+      : $query;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End QueryRewriter package
+# ###########################################################################
+
+# ###########################################################################
+# QueryParser package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/QueryParser.pm
+#   t/lib/QueryParser.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package QueryParser;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/;
+our $tbl_regex = qr{
+         \b(?:FROM|JOIN|(?<!KEY\s)UPDATE|INTO) # Words that precede table names
+         \b\s*
+         \(?                                   # Optional paren around tables
+         ($tbl_ident
+            (?: (?:\s+ (?:AS\s+)? \w+)?, \s*$tbl_ident )*
+         )
+      }xio;
+our $has_derived = qr{
+      \b(?:FROM|JOIN|,)
+      \s*\(\s*SELECT
+   }xi;
+
+our $data_def_stmts = qr/(?:CREATE|ALTER|TRUNCATE|DROP|RENAME)/i;
+
+our $data_manip_stmts = qr/(?:INSERT|UPDATE|DELETE|REPLACE)/i;
+
+sub new {
+   my ( $class ) = @_;
+   bless {}, $class;
+}
+
+sub get_tables {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   PTDEBUG && _d('Getting tables for', $query);
+
+   my ( $ddl_stmt ) = $query =~ m/^\s*($data_def_stmts)\b/i;
+   if ( $ddl_stmt ) {
+      PTDEBUG && _d('Special table type:', $ddl_stmt);
+      $query =~ s/IF\s+(?:NOT\s+)?EXISTS//i;
+      if ( $query =~ m/$ddl_stmt DATABASE\b/i ) {
+         PTDEBUG && _d('Query alters a database, not a table');
+         return ();
+      }
+      if ( $ddl_stmt =~ m/CREATE/i && $query =~ m/$ddl_stmt\b.+?\bSELECT\b/i ) {
+         my ($select) = $query =~ m/\b(SELECT\b.+)/is;
+         PTDEBUG && _d('CREATE TABLE ... SELECT:', $select);
+         return $self->get_tables($select);
+      }
+      my ($tbl) = $query =~ m/TABLE\s+($tbl_ident)(\s+.*)?/i;
+      PTDEBUG && _d('Matches table:', $tbl);
+      return ($tbl);
+   }
+
+   $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
+
+   if ( $query =~ /^\s*LOCK TABLES/i ) {
+      PTDEBUG && _d('Special table type: LOCK TABLES');
+      $query =~ s/^(\s*LOCK TABLES\s+)//;
+      $query =~ s/\s+(?:READ|WRITE|LOCAL)+\s*//g;
+      PTDEBUG && _d('Locked tables:', $query);
+      $query = "FROM $query";
+   }
+
+   $query =~ s/\\["']//g;                # quoted strings
+   $query =~ s/".*?"/?/sg;               # quoted strings
+   $query =~ s/'.*?'/?/sg;               # quoted strings
+
+   my @tables;
+   foreach my $tbls ( $query =~ m/$tbl_regex/gio ) {
+      PTDEBUG && _d('Match tables:', $tbls);
+
+      next if $tbls =~ m/\ASELECT\b/i;
+
+      foreach my $tbl ( split(',', $tbls) ) {
+         $tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio;
+
+         if ( $tbl !~ m/[a-zA-Z]/ ) {
+            PTDEBUG && _d('Skipping suspicious table name:', $tbl);
+            next;
+         }
+
+         push @tables, $tbl;
+      }
+   }
+   return @tables;
+}
+
+sub has_derived_table {
+   my ( $self, $query ) = @_;
+   my $match = $query =~ m/$has_derived/;
+   PTDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table');
+   return $match;
+}
+
+sub get_aliases {
+   my ( $self, $query, $list ) = @_;
+
+   my $result = {
+      DATABASE => {},
+      TABLE    => {},
+   };
+   return $result unless $query;
+
+   $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
+
+   $query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig;
+
+   my @tbl_refs;
+   my ($tbl_refs, $from) = $query =~ m{
+      (
+         (FROM|INTO|UPDATE)\b\s*   # Keyword before table refs
+         .+?                       # Table refs
+      )
+      (?:\s+|\z)                   # If the query does not end with the table
+      (?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs
+   }ix;
+
+   if ( $tbl_refs ) {
+
+      if ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
+         $tbl_refs =~ s/\([^\)]+\)\s*//;
+      }
+
+      PTDEBUG && _d('tbl refs:', $tbl_refs);
+
+      my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i;
+
+      my $after_tbl  = qr/(?:,|JOIN|ON|USING|\z)/i;
+
+      $tbl_refs =~ s/ = /=/g;
+
+      while (
+         $tbl_refs =~ m{
+            $before_tbl\b\s*
+               ( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? )
+            \s*$after_tbl
+         }xgio )
+      {
+         my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3);
+         PTDEBUG && _d('Match table:', $tbl_ref);
+         push @tbl_refs, $tbl_ref;
+         $alias = $self->trim_identifier($alias);
+
+         if ( $tbl_ref =~ m/^AS\s+\w+/i ) {
+            PTDEBUG && _d('Subquery', $tbl_ref);
+            $result->{TABLE}->{$alias} = undef;
+            next;
+         }
+
+         my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/;
+         $db  = $self->trim_identifier($db);
+         $tbl = $self->trim_identifier($tbl);
+         $result->{TABLE}->{$alias || $tbl} = $tbl;
+         $result->{DATABASE}->{$tbl}        = $db if $db;
+      }
+   }
+   else {
+      PTDEBUG && _d("No tables ref in", $query);
+   }
+
+   if ( $list ) {
+      return \@tbl_refs;
+   }
+   else {
+      return $result;
+   }
+}
+
+sub split {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   $query = $self->clean_query($query);
+   PTDEBUG && _d('Splitting', $query);
+
+   my $verbs = qr{SELECT|INSERT|UPDATE|DELETE|REPLACE|UNION|CREATE}i;
+
+   my @split_statements = grep { $_ } split(m/\b($verbs\b(?!(?:\s*\()))/io, $query);
+
+   my @statements;
+   if ( @split_statements == 1 ) {
+      push @statements, $query;
+   }
+   else {
+      for ( my $i = 0; $i <= $#split_statements; $i += 2 ) {
+         push @statements, $split_statements[$i].$split_statements[$i+1];
+
+         if ( $statements[-2] && $statements[-2] =~ m/on duplicate key\s+$/i ) {
+            $statements[-2] .= pop @statements;
+         }
+      }
+   }
+
+   PTDEBUG && _d('statements:', map { $_ ? "<$_>" : 'none' } @statements);
+   return @statements;
+}
+
+sub clean_query {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   $query =~ s!/\*.*?\*/! !g;  # Remove /* comment blocks */
+   $query =~ s/^\s+//;         # Remove leading spaces
+   $query =~ s/\s+$//;         # Remove trailing spaces
+   $query =~ s/\s{2,}/ /g;     # Remove extra spaces
+   return $query;
+}
+
+sub split_subquery {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   $query = $self->clean_query($query);
+   $query =~ s/;$//;
+
+   my @subqueries;
+   my $sqno = 0;  # subquery number
+   my $pos  = 0;
+   while ( $query =~ m/(\S+)(?:\s+|\Z)/g ) {
+      $pos = pos($query);
+      my $word = $1;
+      PTDEBUG && _d($word, $sqno);
+      if ( $word =~ m/^\(?SELECT\b/i ) {
+         my $start_pos = $pos - length($word) - 1;
+         if ( $start_pos ) {
+            $sqno++;
+            PTDEBUG && _d('Subquery', $sqno, 'starts at', $start_pos);
+            $subqueries[$sqno] = {
+               start_pos => $start_pos,
+               end_pos   => 0,
+               len       => 0,
+               words     => [$word],
+               lp        => 1, # left parentheses
+               rp        => 0, # right parentheses
+               done      => 0,
+            };
+         }
+         else {
+            PTDEBUG && _d('Main SELECT at pos 0');
+         }
+      }
+      else {
+         next unless $sqno;  # next unless we're in a subquery
+         PTDEBUG && _d('In subquery', $sqno);
+         my $sq = $subqueries[$sqno];
+         if ( $sq->{done} ) {
+            PTDEBUG && _d('This subquery is done; SQL is for',
+               ($sqno - 1 ? "subquery $sqno" : "the main SELECT"));
+            next;
+         }
+         push @{$sq->{words}}, $word;
+         my $lp = ($word =~ tr/\(//) || 0;
+         my $rp = ($word =~ tr/\)//) || 0;
+         PTDEBUG && _d('parentheses left', $lp, 'right', $rp);
+         if ( ($sq->{lp} + $lp) - ($sq->{rp} + $rp) == 0 ) {
+            my $end_pos = $pos - 1;
+            PTDEBUG && _d('Subquery', $sqno, 'ends at', $end_pos);
+            $sq->{end_pos} = $end_pos;
+            $sq->{len}     = $end_pos - $sq->{start_pos};
+         }
+      }
+   }
+
+   for my $i ( 1..$#subqueries ) {
+      my $sq = $subqueries[$i];
+      next unless $sq;
+      $sq->{sql} = join(' ', @{$sq->{words}});
+      substr $query,
+         $sq->{start_pos} + 1,  # +1 for (
+         $sq->{len} - 1,        # -1 for )
+         "__subquery_$i";
+   }
+
+   return $query, map { $_->{sql} } grep { defined $_ } @subqueries;
+}
+
+sub query_type {
+   my ( $self, $query, $qr ) = @_;
+   my ($type, undef) = $qr->distill_verbs($query);
+   my $rw;
+   if ( $type =~ m/^SELECT\b/ ) {
+      $rw = 'read';
+   }
+   elsif ( $type =~ m/^$data_manip_stmts\b/
+           || $type =~ m/^$data_def_stmts\b/  ) {
+      $rw = 'write'
+   }
+
+   return {
+      type => $type,
+      rw   => $rw,
+   }
+}
+
+sub get_columns {
+   my ( $self, $query ) = @_;
+   my $cols = [];
+   return $cols unless $query;
+   my $cols_def;
+
+   if ( $query =~ m/^SELECT/i ) {
+      $query =~ s/
+         ^SELECT\s+
+           (?:ALL
+              |DISTINCT
+              |DISTINCTROW
+              |HIGH_PRIORITY
+              |STRAIGHT_JOIN
+              |SQL_SMALL_RESULT
+              |SQL_BIG_RESULT
+              |SQL_BUFFER_RESULT
+              |SQL_CACHE
+              |SQL_NO_CACHE
+              |SQL_CALC_FOUND_ROWS
+           )\s+
+      /SELECT /xgi;
+      ($cols_def) = $query =~ m/^SELECT\s+(.+?)\s+FROM/i;
+   }
+   elsif ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
+      ($cols_def) = $query =~ m/\(([^\)]+)\)\s*VALUE/i;
+   }
+
+   PTDEBUG && _d('Columns:', $cols_def);
+   if ( $cols_def ) {
+      @$cols = split(',', $cols_def);
+      map {
+         my $col = $_;
+         $col = s/^\s+//g;
+         $col = s/\s+$//g;
+         $col;
+      } @$cols;
+   }
+
+   return $cols;
+}
+
+sub parse {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   my $parsed = {};
+
+   $query =~ s/\n/ /g;
+   $query = $self->clean_query($query);
+
+   $parsed->{query}   = $query,
+   $parsed->{tables}  = $self->get_aliases($query, 1);
+   $parsed->{columns} = $self->get_columns($query);
+
+   my ($type) = $query =~ m/^(\w+)/;
+   $parsed->{type} = lc $type;
+
+
+   $parsed->{sub_queries} = [];
+
+   return $parsed;
+}
+
+sub extract_tables {
+   my ( $self, %args ) = @_;
+   my $query      = $args{query};
+   my $default_db = $args{default_db};
+   my $q          = $self->{Quoter} || $args{Quoter};
+   return unless $query;
+   PTDEBUG && _d('Extracting tables');
+   my @tables;
+   my %seen;
+   foreach my $db_tbl ( $self->get_tables($query) ) {
+      next unless $db_tbl;
+      next if $seen{$db_tbl}++; # Unique-ify for issue 337.
+      my ( $db, $tbl ) = $q->split_unquote($db_tbl);
+      push @tables, [ $db || $default_db, $tbl ];
+   }
+   return @tables;
+}
+
+sub trim_identifier {
+   my ($self, $str) = @_;
+   return unless defined $str;
+   $str =~ s/`//g;
+   $str =~ s/^\s+//;
+   $str =~ s/\s+$//;
+   return $str;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End QueryParser package
+# ###########################################################################
+
+# ###########################################################################
+# FileIterator package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/FileIterator.pm
+#   t/lib/FileIterator.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package FileIterator;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+sub new {
+   my ( $class, %args ) = @_;
+   my $self = {
+      %args,
+   };
+   return bless $self, $class;
+}
+
+sub get_file_itr {
+   my ( $self, @filenames ) = @_;
+
+   my @final_filenames;
+   FILENAME:
+   foreach my $fn ( @filenames ) {
+      if ( !defined $fn ) {
+         warn "Skipping undefined filename";
+         next FILENAME;
+      }
+      if ( $fn ne '-' ) {
+         if ( !-e $fn || !-r $fn ) {
+            warn "$fn does not exist or is not readable";
+            next FILENAME;
+         }
+      }
+      push @final_filenames, $fn;
+   }
+
+   if ( !@filenames ) {
+      push @final_filenames, '-';
+      PTDEBUG && _d('Auto-adding "-" to the list of filenames');
+   }
+
+   PTDEBUG && _d('Final filenames:', @final_filenames);
+   return sub {
+      while ( @final_filenames ) {
+         my $fn = shift @final_filenames;
+         PTDEBUG && _d('Filename:', $fn);
+         if ( $fn eq '-' ) { # Magical STDIN filename.
+            return (*STDIN, undef, undef);
+         }
+         open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR";
+         if ( $fh ) {
+            return ( $fh, $fn, -s $fn );
+         }
+      }
+      return (); # Avoids $f being set to 0 in list context.
+   };
+}
+
+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 FileIterator package
+# ###########################################################################
+
+# ###########################################################################
+# SQLParser r0
+# Don't update this package!
+# ###########################################################################
+
+package SQLParser;
+
+{ # package scope
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant MKDEBUG => $ENV{MKDEBUG} || 0;
+
+use Data::Dumper;
+$Data::Dumper::Indent    = 1;
+$Data::Dumper::Sortkeys  = 1;
+$Data::Dumper::Quotekeys = 0;
+
+my $quoted_ident   = qr/`[^`]+`/;
+my $unquoted_ident = qr/
+   \@{0,2}         # optional @ or @@ for variables
+   \w+             # the ident name
+   (?:\([^\)]*\))? # optional function params
+/x;
+
+my $ident_alias = qr/
+  \s+                                 # space before alias
+  (?:(AS)\s+)?                        # optional AS keyword
+  ((?>$quoted_ident|$unquoted_ident)) # alais
+/xi;
+
+my $table_ident = qr/(?:
+   ((?:(?>$quoted_ident|$unquoted_ident)\.?){1,2}) # table
+   (?:$ident_alias)?                               # optional alias
+)/xo;
+
+my $column_ident = qr/(?:
+   ((?:(?>$quoted_ident|$unquoted_ident|\*)\.?){1,3}) # column
+   (?:$ident_alias)?                                  # optional alias
+)/xo;
+
+my $function_ident = qr/
+   \b
+   (
+      \w+      # function name
+      \(       # opening parenthesis
+      [^\)]+   # function args, if any
+      \)       # closing parenthesis
+   )
+/x;
+
+my %ignore_function = (
+   INDEX => 1,
+   KEY   => 1,
+);
+
+sub new {
+   my ( $class, %args ) = @_;
+   my $self = {
+      %args,
+   };
+   return bless $self, $class;
+}
+
+sub parse {
+   my ( $self, $query ) = @_;
+   return unless $query;
+
+   my $allowed_types = qr/(?:
+       DELETE
+      |INSERT
+      |REPLACE
+      |SELECT
+      |UPDATE
+      |CREATE
+   )/xi;
+
+   $query = $self->clean_query($query);
+
+   my $type;
+   if ( $query =~ s/^(\w+)\s+// ) {
+      $type = lc $1;
+      MKDEBUG && _d('Query type:', $type);
+      die "Cannot parse " . uc($type) . " queries"
+         unless $type =~ m/$allowed_types/i;
+   }
+   else {
+      die "Query does not begin with a word";  # shouldn't happen
+   }
+
+   $query = $self->normalize_keyword_spaces($query);
+
+   my @subqueries;
+   if ( $query =~ m/(\(SELECT )/i ) {
+      MKDEBUG && _d('Removing subqueries');
+      @subqueries = $self->remove_subqueries($query);
+      $query      = shift @subqueries;
+   }
+   elsif ( $type eq 'create' && $query =~ m/\s+SELECT/ ) {
+      MKDEBUG && _d('CREATE..SELECT');
+      ($subqueries[0]->{query}) = $query =~ m/\s+(SELECT .+)/;
+      $query =~ s/\s+SELECT.+//;
+   }
+
+   my $parse_func = "parse_$type";
+   my $struct     = $self->$parse_func($query);
+   if ( !$struct ) {
+      MKDEBUG && _d($parse_func, 'failed to parse query');
+      return;
+   }
+   $struct->{type} = $type;
+   $self->_parse_clauses($struct);
+
+   if ( @subqueries ) {
+      MKDEBUG && _d('Parsing subqueries');
+      foreach my $subquery ( @subqueries ) {
+         my $subquery_struct = $self->parse($subquery->{query});
+         @{$subquery_struct}{keys %$subquery} = values %$subquery;
+         push @{$struct->{subqueries}}, $subquery_struct;
+      }
+   }
+
+   MKDEBUG && _d('Query struct:', Dumper($struct));
+   return $struct;
+}
+
+
+sub _parse_clauses {
+   my ( $self, $struct ) = @_;
+   foreach my $clause ( keys %{$struct->{clauses}} ) {
+      if ( $clause =~ m/ / ) {
+         (my $clause_no_space = $clause) =~ s/ /_/g;
+         $struct->{clauses}->{$clause_no_space} = $struct->{clauses}->{$clause};
+         delete $struct->{clauses}->{$clause};
+         $clause = $clause_no_space;
+      }
+
+      my $parse_func     = "parse_$clause";
+      $struct->{$clause} = $self->$parse_func($struct->{clauses}->{$clause});
+
+      if ( $clause eq 'select' ) {
+         MKDEBUG && _d('Parsing subquery clauses');
+         $struct->{select}->{type} = 'select';
+         $self->_parse_clauses($struct->{select});
+      }
+   }
+   return;
+}
+
+sub clean_query {
+   my ( $self, $query ) = @_;
+   return unless $query;
+
+   $query =~ s/^\s*--.*$//gm;  # -- comments
+   $query =~ s/\s+/ /g;        # extra spaces/flatten
+   $query =~ s!/\*.*?\*/!!g;   # /* comments */
+   $query =~ s/^\s+//;         # leading spaces
+   $query =~ s/\s+$//;         # trailing spaces
+
+   return $query;
+}
+
+sub normalize_keyword_spaces {
+   my ( $self, $query ) = @_;
+
+   $query =~ s/\b(VALUE(?:S)?)\(/$1 (/i;
+   $query =~ s/\bON\(/on (/gi;
+   $query =~ s/\bUSING\(/using (/gi;
+
+   $query =~ s/\(\s+SELECT\s+/(SELECT /gi;
+
+   return $query;
+}
+
+sub _parse_query {
+   my ( $self, $query, $keywords, $first_clause, $clauses ) = @_;
+   return unless $query;
+   my $struct = {};
+
+   1 while $query =~ s/$keywords\s+/$struct->{keywords}->{lc $1}=1, ''/gie;
+
+   my @clause = grep { defined $_ }
+      ($query =~ m/\G(.+?)(?:$clauses\s+|\Z)/gci);
+
+   my $clause = $first_clause,
+   my $value  = shift @clause;
+   $struct->{clauses}->{$clause} = $value;
+   MKDEBUG && _d('Clause:', $clause, $value);
+
+   while ( @clause ) {
+      $clause = shift @clause;
+      $value  = shift @clause;
+      $struct->{clauses}->{lc $clause} = $value;
+      MKDEBUG && _d('Clause:', $clause, $value);
+   }
+
+   ($struct->{unknown}) = ($query =~ m/\G(.+)/);
+
+   return $struct;
+}
+
+sub parse_delete {
+   my ( $self, $query ) = @_;
+   if ( $query =~ s/FROM\s+//i ) {
+      my $keywords = qr/(LOW_PRIORITY|QUICK|IGNORE)/i;
+      my $clauses  = qr/(FROM|WHERE|ORDER BY|LIMIT)/i;
+      return $self->_parse_query($query, $keywords, 'from', $clauses);
+   }
+   else {
+      die "DELETE without FROM: $query";
+   }
+}
+
+sub parse_insert {
+   my ( $self, $query ) = @_;
+   return unless $query;
+   my $struct = {};
+
+   my $keywords   = qr/(LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)/i;
+   1 while $query =~ s/$keywords\s+/$struct->{keywords}->{lc $1}=1, ''/gie;
+
+   if ( $query =~ m/ON DUPLICATE KEY UPDATE (.+)/i ) {
+      my $values = $1;
+      die "No values after ON DUPLICATE KEY UPDATE: $query" unless $values;
+      $struct->{clauses}->{on_duplicate} = $values;
+      MKDEBUG && _d('Clause: on duplicate key update', $values);
+
+      $query =~ s/\s+ON DUPLICATE KEY UPDATE.+//;
+   }
+
+   if ( my @into = ($query =~ m/
+            (?:INTO\s+)?            # INTO, optional
+            (.+?)\s+                # table ref
+            (\([^\)]+\)\s+)?        # column list, optional
+            (VALUE.?|SET|SELECT)\s+ # start of next caluse
+         /xgci)
+   ) {
+      my $tbl  = shift @into;  # table ref
+      $struct->{clauses}->{into} = $tbl;
+      MKDEBUG && _d('Clause: into', $tbl);
+
+      my $cols = shift @into;  # columns, maybe
+      if ( $cols ) {
+         $cols =~ s/[\(\)]//g;
+         $struct->{clauses}->{columns} = $cols;
+         MKDEBUG && _d('Clause: columns', $cols);
+      }
+
+      my $next_clause = lc(shift @into);  # VALUES, SET or SELECT
+      die "INSERT/REPLACE without clause after table: $query"
+         unless $next_clause;
+      $next_clause = 'values' if $next_clause eq 'value';
+      my ($values) = ($query =~ m/\G(.+)/gci);
+      die "INSERT/REPLACE without values: $query" unless $values;
+      $struct->{clauses}->{$next_clause} = $values;
+      MKDEBUG && _d('Clause:', $next_clause, $values);
+   }
+
+   ($struct->{unknown}) = ($query =~ m/\G(.+)/);
+
+   return $struct;
+}
+{
+   no warnings;
+   *parse_replace = \&parse_insert;
+}
+
+sub parse_select {
+   my ( $self, $query ) = @_;
+
+   my @keywords;
+   my $final_keywords = qr/(FOR UPDATE|LOCK IN SHARE MODE)/i; 
+   1 while $query =~ s/\s+$final_keywords/(push @keywords, $1), ''/gie;
+
+   my $keywords = qr/(
+       ALL
+      |DISTINCT
+      |DISTINCTROW
+      |HIGH_PRIORITY
+      |STRAIGHT_JOIN
+      |SQL_SMALL_RESULT
+      |SQL_BIG_RESULT
+      |SQL_BUFFER_RESULT
+      |SQL_CACHE
+      |SQL_NO_CACHE
+      |SQL_CALC_FOUND_ROWS
+   )/xi;
+   my $clauses = qr/(
+       FROM
+      |WHERE
+      |GROUP\sBY
+      |HAVING
+      |ORDER\sBY
+      |LIMIT
+      |PROCEDURE
+      |INTO OUTFILE
+   )/xi;
+   my $struct = $self->_parse_query($query, $keywords, 'columns', $clauses);
+
+   map { s/ /_/g; $struct->{keywords}->{lc $_} = 1; } @keywords;
+
+   return $struct;
+}
+
+sub parse_update {
+   my $keywords = qr/(LOW_PRIORITY|IGNORE)/i;
+   my $clauses  = qr/(SET|WHERE|ORDER BY|LIMIT)/i;
+   return _parse_query(@_, $keywords, 'tables', $clauses);
+
+}
+
+sub parse_create {
+   my ($self, $query) = @_;
+   my ($obj, $name) = $query =~ m/
+      (\S+)\s+
+      (?:IF NOT EXISTS\s+)?
+      (\S+)
+   /xi;
+   return {
+      object  => lc $obj,
+      name    => $name,
+      unknown => undef,
+   };
+}
+
+sub parse_from {
+   my ( $self, $from ) = @_;
+   return unless $from;
+   MKDEBUG && _d('Parsing FROM', $from);
+
+   my $using_cols;
+   ($from, $using_cols) = $self->remove_using_columns($from);
+
+   my $funcs;
+   ($from, $funcs) = $self->remove_functions($from);
+
+   my $comma_join = qr/(?>\s*,\s*)/;
+   my $ansi_join  = qr/(?>
+     \s+
+     (?:(?:INNER|CROSS|STRAIGHT_JOIN|LEFT|RIGHT|OUTER|NATURAL)\s+)*
+     JOIN
+     \s+
+   )/xi;
+
+   my @tbls;     # all table refs, a hashref for each
+   my $tbl_ref;  # current table ref hashref
+   my $join;     # join info hahsref for current table ref
+   foreach my $thing ( split /($comma_join|$ansi_join)/io, $from ) {
+      die "Error parsing FROM clause" unless $thing;
+
+      $thing =~ s/^\s+//;
+      $thing =~ s/\s+$//;
+      MKDEBUG && _d('Table thing:', $thing);
+
+      if ( $thing =~ m/\s+(?:ON|USING)\s+/i ) {
+         MKDEBUG && _d("JOIN condition");
+         my ($tbl_ref_txt, $join_condition_verb, $join_condition_value)
+            = $thing =~ m/^(.+?)\s+(ON|USING)\s+(.+)/i;
+
+         $tbl_ref = $self->parse_table_reference($tbl_ref_txt);
+
+         $join->{condition} = lc $join_condition_verb;
+         if ( $join->{condition} eq 'on' ) {
+            $join->{where} = $self->parse_where($join_condition_value, $funcs);
+         }
+         else { # USING
+            $join->{columns} = $self->_parse_csv(shift @$using_cols);
+         }
+      }
+      elsif ( $thing =~ m/(?:,|JOIN)/i ) {
+         if ( $join ) {
+            $tbl_ref->{join} = $join;
+         }
+         push @tbls, $tbl_ref;
+         MKDEBUG && _d("Complete table reference:", Dumper($tbl_ref));
+
+         $tbl_ref = undef;
+         $join    = {};
+
+         $join->{to} = $tbls[-1]->{tbl};
+         if ( $thing eq ',' ) {
+            $join->{type} = 'inner';
+            $join->{ansi} = 0;
+         }
+         else { # ansi join
+            my $type = $thing =~ m/^(.+?)\s+JOIN$/i ? lc $1 : 'inner';
+            $join->{type} = $type;
+            $join->{ansi} = 1;
+         }
+      }
+      else {
+         $tbl_ref = $self->parse_table_reference($thing);
+         MKDEBUG && _d('Table reference:', Dumper($tbl_ref));
+      }
+   }
+
+   if ( $tbl_ref ) {
+      if ( $join ) {
+         $tbl_ref->{join} = $join;
+      }
+      push @tbls, $tbl_ref;
+      MKDEBUG && _d("Complete table reference:", Dumper($tbl_ref));
+   }
+
+   return \@tbls;
+}
+
+sub parse_table_reference {
+   my ( $self, $tbl_ref ) = @_;
+   return unless $tbl_ref;
+   MKDEBUG && _d('Parsing table reference:', $tbl_ref);
+   my %tbl;
+
+   if ( $tbl_ref =~ s/
+         \s+(
+            (?:FORCE|USE|INGORE)\s
+            (?:INDEX|KEY)
+            \s*\([^\)]+\)\s*
+         )//xi)
+   {
+      $tbl{index_hint} = $1;
+      MKDEBUG && _d('Index hint:', $tbl{index_hint});
+   }
+
+   if ( $tbl_ref =~ m/$table_ident/ ) {
+      my ($db_tbl, $as, $alias) = ($1, $2, $3); # XXX
+      my $ident_struct = $self->parse_identifier('table', $db_tbl);
+      $alias =~ s/`//g if $alias;
+      @tbl{keys %$ident_struct} = values %$ident_struct;
+      $tbl{explicit_alias} = 1 if $as;
+      $tbl{alias}          = $alias if $alias;
+   }
+   else {
+      die "Table ident match failed";  # shouldn't happen
+   }
+
+   return \%tbl;
+}
+{
+   no warnings;  # Why? See same line above.
+   *parse_into   = \&parse_from;
+   *parse_tables = \&parse_from;
+}
+
+sub parse_where {
+   my ( $self, $where, $functions ) = @_;
+   return unless $where;
+   MKDEBUG && _d("Parsing WHERE", $where);
+
+   my $op_symbol = qr/
+      (?:
+       <=(?:>)?
+      |>=
+      |<>
+      |!=
+      |<
+      |>
+      |=
+   )/xi;
+   my $op_verb = qr/
+      (?:
+          (?:(?:NOT\s)?LIKE)
+         |(?:IS(?:\sNOT\s)?)
+         |(?:(?:\sNOT\s)?BETWEEN)
+         |(?:(?:NOT\s)?IN)
+      )
+   /xi;
+   my $op_pat = qr/
+   (
+      (?>
+          (?:$op_symbol)  # don't need spaces around the symbols, e.g.: col=1
+         |(?:\s+$op_verb) # must have space before verb op, e.g.: col LIKE ...
+      )
+   )/x;
+
+   my $offset = 0;
+   my $pred   = "";
+   my @pred;
+   my @has_op;
+   while ( $where =~ m/\b(and|or)\b/gi ) {
+      my $pos = (pos $where) - (length $1);  # pos at and|or, not after
+
+      $pred = substr $where, $offset, ($pos-$offset);
+      push @pred, $pred;
+      push @has_op, $pred =~ m/$op_pat/o ? 1 : 0;
+
+      $offset = $pos;
+   }
+   $pred = substr $where, $offset;
+   push @pred, $pred;
+   push @has_op, $pred =~ m/$op_pat/o ? 1 : 0;
+   MKDEBUG && _d("Predicate fragments:", Dumper(\@pred));
+   MKDEBUG && _d("Predicate frags with operators:", @has_op);
+
+   my $n = scalar @pred - 1;
+   for my $i ( 1..$n ) {
+      $i   *= -1;
+      my $j = $i - 1;  # preceding pred frag
+
+      next if $pred[$j] !~ m/\s+between\s+/i  && $self->_is_constant($pred[$i]);
+
+      if ( !$has_op[$i] ) {
+         $pred[$j] .= $pred[$i];
+         $pred[$i]  = undef;
+      }
+   }
+   MKDEBUG && _d("Predicate fragments joined:", Dumper(\@pred));
+
+   for my $i ( 0..@pred ) {
+      $pred = $pred[$i];
+      next unless defined $pred;
+      my $n_single_quotes = ($pred =~ tr/'//);
+      my $n_double_quotes = ($pred =~ tr/"//);
+      if ( ($n_single_quotes % 2) || ($n_double_quotes % 2) ) {
+         $pred[$i]     .= $pred[$i + 1];
+         $pred[$i + 1]  = undef;
+      }
+   }
+   MKDEBUG && _d("Predicate fragments balanced:", Dumper(\@pred));
+
+   my @predicates;
+   foreach my $pred ( @pred ) {
+      next unless defined $pred;
+      $pred =~ s/^\s+//;
+      $pred =~ s/\s+$//;
+      my $conj;
+      if ( $pred =~ s/^(and|or)\s+//i ) {
+         $conj = lc $1;
+      }
+      my ($col, $op, $val) = $pred =~ m/^(.+?)$op_pat(.+)$/o;
+      if ( !$col || !$op ) {
+         if ( $self->_is_constant($pred) ) {
+            $val = lc $pred;
+         }
+         else {
+            die "Failed to parse WHERE condition: $pred";
+         }
+      }
+
+      if ( $col ) {
+         $col =~ s/\s+$//;
+         $col =~ s/^\(+//;  # no unquoted column name begins with (
+      }
+      if ( $op ) {
+         $op  =  lc $op;
+         $op  =~ s/^\s+//;
+         $op  =~ s/\s+$//;
+      }
+      $val =~ s/^\s+//;
+      
+      if ( ($op || '') !~ m/IN/i && $val !~ m/^\w+\([^\)]+\)$/ ) {
+         $val =~ s/\)+$//;
+      }
+
+      if ( $val =~ m/NULL|TRUE|FALSE/i ) {
+         $val = lc $val;
+      }
+
+      if ( $functions ) {
+         $col = shift @$functions if $col =~ m/__FUNC\d+__/;
+         $val = shift @$functions if $val =~ m/__FUNC\d+__/;
+      }
+
+      push @predicates, {
+         predicate => $conj,
+         left_arg  => $col,
+         operator  => $op,
+         right_arg => $val,
+      };
+   }
+
+   return \@predicates;
+}
+
+sub _is_constant {
+   my ( $self, $val ) = @_;
+   return 0 unless defined $val;
+   $val =~ s/^\s*(?:and|or)\s+//;
+   return
+      $val =~ m/^\s*(?:TRUE|FALSE)\s*$/i || $val =~ m/^\s*-?\d+\s*$/ ? 1 : 0;
+}
+
+sub parse_having {
+   my ( $self, $having ) = @_;
+   return $having;
+}
+
+sub parse_group_by {
+   my ( $self, $group_by ) = @_;
+   return unless $group_by;
+   MKDEBUG && _d('Parsing GROUP BY', $group_by);
+
+   my $with_rollup = $group_by =~ s/\s+WITH ROLLUP\s*//i;
+
+   my $idents = $self->parse_identifiers( $self->_parse_csv($group_by) );
+
+   $idents->{with_rollup} = 1 if $with_rollup;
+
+   return $idents;
+}
+
+sub parse_order_by {
+   my ( $self, $order_by ) = @_;
+   return unless $order_by;
+   MKDEBUG && _d('Parsing ORDER BY', $order_by);
+   my $idents = $self->parse_identifiers( $self->_parse_csv($order_by) );
+   return $idents;
+}
+
+sub parse_limit {
+   my ( $self, $limit ) = @_;
+   return unless $limit;
+   my $struct = {
+      row_count => undef,
+   };
+   if ( $limit =~ m/(\S+)\s+OFFSET\s+(\S+)/i ) {
+      $struct->{explicit_offset} = 1;
+      $struct->{row_count}       = $1;
+      $struct->{offset}          = $2;
+   }
+   else {
+      my ($offset, $cnt) = $limit =~ m/(?:(\S+),\s+)?(\S+)/i;
+      $struct->{row_count} = $cnt;
+      $struct->{offset}    = $offset if defined $offset;
+   }
+   return $struct;
+}
+
+sub parse_values {
+   my ( $self, $values ) = @_;
+   return unless $values;
+   $values =~ s/^\s*\(//;
+   $values =~ s/\s*\)//;
+   my $vals = $self->_parse_csv(
+      $values,
+      quoted_values => 1,
+      remove_quotes => 0,
+   );
+   return $vals;
+}
+
+sub parse_set {
+   my ( $self, $set ) = @_;
+   MKDEBUG && _d("Parse SET", $set);
+   return unless $set;
+   my $vals = $self->_parse_csv($set);
+   return unless $vals && @$vals;
+
+   my @set;
+   foreach my $col_val ( @$vals ) {
+      my ($col, $val)  = $col_val =~ m/^([^=]+)\s*=\s*(.+)/;
+      my $ident_struct = $self->parse_identifier('column', $col);
+      my $set_struct   = {
+         %$ident_struct,
+         value => $val,
+      };
+      MKDEBUG && _d("SET:", Dumper($set_struct));
+      push @set, $set_struct;
+   }
+   return \@set;
+}
+
+sub _parse_csv {
+   my ( $self, $vals, %args ) = @_;
+   return unless $vals;
+
+   my @vals;
+   if ( $args{quoted_values} ) {
+      my $quote_char   = '';
+      VAL:
+      foreach my $val ( split(',', $vals) ) {
+         MKDEBUG && _d("Next value:", $val);
+         if ( $quote_char ) {
+            MKDEBUG && _d("Value is part of previous quoted value");
+            $vals[-1] .= ",$val";
+
+            if ( $val =~ m/[^\\]*$quote_char$/ ) {
+               if ( $args{remove_quotes} ) {
+                  $vals[-1] =~ s/^\s*$quote_char//;
+                  $vals[-1] =~ s/$quote_char\s*$//;
+               }
+               MKDEBUG && _d("Previous quoted value is complete:", $vals[-1]);
+               $quote_char = '';
+            }
+
+            next VAL;
+         }
+
+         $val =~ s/^\s+//;
+
+         if ( $val =~ m/^(['"])/ ) {
+            MKDEBUG && _d("Value is quoted");
+            $quote_char = $1;  # XXX
+            if ( $val =~ m/.$quote_char$/ ) {
+               MKDEBUG && _d("Value is complete");
+               $quote_char = '';
+               if ( $args{remove_quotes} ) {
+                  $vals[-1] =~ s/^\s*$quote_char//;
+                  $vals[-1] =~ s/$quote_char\s*$//;
+               }
+            }
+            else {
+               MKDEBUG && _d("Quoted value is not complete");
+            }
+         }
+         else {
+            $val =~ s/\s+$//;
+         }
+
+         MKDEBUG && _d("Saving value", ($quote_char ? "fragment" : ""));
+         push @vals, $val;
+      }
+   }
+   else {
+      @vals = map { s/^\s+//; s/\s+$//; $_ } split(',', $vals);
+   }
+
+   return \@vals;
+}
+{
+   no warnings;  # Why? See same line above.
+   *parse_on_duplicate = \&_parse_csv;
+}
+
+sub parse_columns {
+   my ( $self, $cols ) = @_;
+   MKDEBUG && _d('Parsing columns list:', $cols);
+
+   my @cols;
+   pos $cols = 0;
+   while (pos $cols < length $cols) {
+      if ($cols =~ m/\G\s*$column_ident\s*(?>,|\Z)/gcxo) {
+         my ($db_tbl_col, $as, $alias) = ($1, $2, $3); # XXX
+         my $ident_struct = $self->parse_identifier('column', $db_tbl_col);
+         $alias =~ s/`//g if $alias;
+         my $col_struct = {
+            %$ident_struct,
+            ($as    ? (explicit_alias => 1)      : ()),
+            ($alias ? (alias          => $alias) : ()),
+         };
+         push @cols, $col_struct;
+      }
+      else {
+         die "Column ident match failed";  # shouldn't happen
+      }
+   }
+
+   return \@cols;
+}
+
+sub remove_subqueries {
+   my ( $self, $query ) = @_;
+
+   my @start_pos;
+   while ( $query =~ m/(\(SELECT )/gi ) {
+      my $pos = (pos $query) - (length $1);
+      push @start_pos, $pos;
+   }
+
+   @start_pos = reverse @start_pos;
+   my @end_pos;
+   for my $i ( 0..$#start_pos ) {
+      my $closed = 0;
+      pos $query = $start_pos[$i];
+      while ( $query =~ m/([\(\)])/cg ) {
+         my $c = $1;
+         $closed += ($c eq '(' ? 1 : -1);
+         last unless $closed;
+      }
+      push @end_pos, pos $query;
+   }
+
+   my @subqueries;
+   my $len_adj = 0;
+   my $n    = 0;
+   for my $i ( 0..$#start_pos ) {
+      MKDEBUG && _d('Query:', $query);
+      my $offset = $start_pos[$i];
+      my $len    = $end_pos[$i] - $start_pos[$i] - $len_adj;
+      MKDEBUG && _d("Subquery $n start", $start_pos[$i],
+            'orig end', $end_pos[$i], 'adj', $len_adj, 'adj end',
+            $offset + $len, 'len', $len);
+
+      my $struct   = {};
+      my $token    = '__SQ' . $n . '__';
+      my $subquery = substr($query, $offset, $len, $token);
+      MKDEBUG && _d("Subquery $n:", $subquery);
+
+      my $outer_start = $start_pos[$i + 1];
+      my $outer_end   = $end_pos[$i + 1];
+      if (    $outer_start && ($outer_start < $start_pos[$i])
+           && $outer_end   && ($outer_end   > $end_pos[$i]) ) {
+         MKDEBUG && _d("Subquery $n nested in next subquery");
+         $len_adj += $len - length $token;
+         $struct->{nested} = $i + 1;
+      }
+      else {
+         MKDEBUG && _d("Subquery $n not nested");
+         $len_adj = 0;
+         if ( $subqueries[-1] && $subqueries[-1]->{nested} ) {
+            MKDEBUG && _d("Outermost subquery");
+         }
+      }
+
+      if ( $query =~ m/(?:=|>|<|>=|<=|<>|!=|<=>)\s*$token/ ) {
+         $struct->{context} = 'scalar';
+      }
+      elsif ( $query =~ m/\b(?:IN|ANY|SOME|ALL|EXISTS)\s*$token/i ) {
+         if ( $query !~ m/\($token\)/ ) {
+            $query =~ s/$token/\($token\)/;
+            $len_adj -= 2 if $struct->{nested};
+         }
+         $struct->{context} = 'list';
+      }
+      else {
+         $struct->{context} = 'identifier';
+      }
+      MKDEBUG && _d("Subquery $n context:", $struct->{context});
+
+      $subquery =~ s/^\s*\(//;
+      $subquery =~ s/\s*\)\s*$//;
+
+      $struct->{query} = $subquery;
+      push @subqueries, $struct;
+      $n++;
+   }
+
+   return $query, @subqueries;
+}
+
+sub remove_using_columns {
+   my ($self, $from) = @_;
+   return unless $from;
+   MKDEBUG && _d('Removing cols from USING clauses');
+   my $using = qr/
+      \bUSING
+      \s*
+      \(
+         ([^\)]+)
+      \)
+   /xi;
+   my @cols;
+   $from =~ s/$using/push @cols, $1; "USING ($#cols)"/eg;
+   MKDEBUG && _d('FROM:', $from, Dumper(\@cols));
+   return $from, \@cols;
+}
+
+sub replace_function {
+   my ($func, $funcs) = @_;
+   my ($func_name) = $func =~ m/^(\w+)/;
+   if ( !$ignore_function{uc $func_name} ) {
+      my $n = scalar @$funcs;
+      push @$funcs, $func;
+      return "__FUNC${n}__";
+   }
+   return $func;
+}
+
+sub remove_functions {
+   my ($self, $clause) = @_;
+   return unless $clause;
+   MKDEBUG && _d('Removing functions from clause:', $clause);
+   my @funcs;
+   $clause =~ s/$function_ident/replace_function($1, \@funcs)/eg;
+   MKDEBUG && _d('Function-stripped clause:', $clause, Dumper(\@funcs));
+   return $clause, \@funcs;
+}
+
+sub parse_identifiers {
+   my ( $self, $idents ) = @_;
+   return unless $idents;
+   MKDEBUG && _d("Parsing identifiers");
+
+   my @ident_parts;
+   foreach my $ident ( @$idents ) {
+      MKDEBUG && _d("Identifier:", $ident);
+      my $parts = {};
+
+      if ( $ident =~ s/\s+(ASC|DESC)\s*$//i ) {
+         $parts->{sort} = uc $1;  # XXX
+      }
+
+      if ( $ident =~ m/^\d+$/ ) {      # Position like 5
+         MKDEBUG && _d("Positional ident");
+         $parts->{position} = $ident;
+      }
+      elsif ( $ident =~ m/^\w+\(/ ) {  # Function like MIN(col)
+         MKDEBUG && _d("Expression ident");
+         my ($func, $expr) = $ident =~ m/^(\w+)\(([^\)]*)\)/;
+         $parts->{function}   = uc $func;
+         $parts->{expression} = $expr if $expr;
+      }
+      else {                           # Ref like (table.)column
+         MKDEBUG && _d("Table/column ident");
+         my ($tbl, $col)  = $self->split_unquote($ident);
+         $parts->{table}  = $tbl if $tbl;
+         $parts->{column} = $col;
+      }
+      push @ident_parts, $parts;
+   }
+
+   return \@ident_parts;
+}
+
+sub parse_identifier {
+   my ( $self, $type, $ident ) = @_;
+   return unless $type && $ident;
+   MKDEBUG && _d("Parsing", $type, "identifier:", $ident);
+
+   if ( $ident =~ m/^\w+\(/ ) {  # Function like MIN(col)
+      my ($func, $expr) = $ident =~ m/^(\w+)\(([^\)]*)\)/;
+      MKDEBUG && _d('Function', $func, 'arg', $expr);
+      return { col => $ident } unless $expr;  # NOW()
+      $ident = $expr;  # col from MAX(col)
+   }
+
+   my %ident_struct;
+   my @ident_parts = map { s/`//g; $_; } split /[.]/, $ident;
+   if ( @ident_parts == 3 ) {
+      @ident_struct{qw(db tbl col)} = @ident_parts;
+   }
+   elsif ( @ident_parts == 2 ) {
+      my @parts_for_type = $type eq 'column' ? qw(tbl col)
+                         : $type eq 'table'  ? qw(db  tbl)
+                         : die "Invalid identifier type: $type";
+      @ident_struct{@parts_for_type} = @ident_parts;
+   }
+   elsif ( @ident_parts == 1 ) {
+      my $part = $type eq 'column' ? 'col' : 'tbl';
+      @ident_struct{($part)} = @ident_parts;
+   }
+   else {
+      die "Invalid number of parts in $type reference: $ident";
+   }
+   
+   if ( $self->{SchemaQualifier} ) {
+      if ( $type eq 'column' && !$ident_struct{tbl} ) {
+         my $qcol = $self->{SchemaQualifier}->qualify_column(
+            column => $ident_struct{col},
+         );
+         $ident_struct{db}  = $qcol->{db}  if $qcol->{db};
+         $ident_struct{tbl} = $qcol->{tbl} if $qcol->{tbl};
+      }
+      elsif ( $type eq 'table' && !$ident_struct{db} ) {
+         my $db = $self->{SchemaQualifier}->get_database_for_table(
+            table => $ident_struct{tbl},
+         );
+         $ident_struct{db} = $db if $db;
+      }
+   }
+
+   MKDEBUG && _d($type, "identifier struct:", Dumper(\%ident_struct));
+   return \%ident_struct;
+}
+
+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);
+}
+
+sub is_identifier {
+   my ( $self, $thing ) = @_;
+
+   return 0 unless $thing;
+
+   return 0 if $thing =~ m/\s*['"]/;
+
+   return 0 if $thing =~ m/^\s*\d+(?:\.\d+)?\s*$/;
+
+   return 0 if $thing =~ m/^\s*(?>
+       NULL
+      |DUAL
+   )\s*$/xi;
+
+   return 1 if $thing =~ m/^\s*$column_ident\s*$/;
+
+   return 0;
+}
+
+sub set_SchemaQualifier {
+   my ( $self, $sq ) = @_;
+   $self->{SchemaQualifier} = $sq;
+   return;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+} # package scope
+1;
+
+# ###########################################################################
+# End SQLParser package
+# ###########################################################################
+
+# ###########################################################################
+# TableUsage package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/TableUsage.pm
+#   t/lib/TableUsage.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package TableUsage;
+
+{ # package scope
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+
+use Data::Dumper;
+$Data::Dumper::Indent    = 1;
+$Data::Dumper::Sortkeys  = 1;
+$Data::Dumper::Quotekeys = 0;
+
+use constant MKDEBUG => $ENV{MKDEBUG} || 0;
+
+sub new {
+   my ( $class, %args ) = @_;
+   my @required_args = qw(QueryParser SQLParser);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+
+   my $self = {
+      constant_data_value => 'DUAL',
+
+      %args,
+   };
+
+   return bless $self, $class;
+}
+
+sub get_table_usage {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(query);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($query) = @args{@required_args};
+   MKDEBUG && _d('Getting table access for',
+      substr($query, 0, 100), (length $query > 100 ? '...' : ''));
+
+   $self->{errors}          = [];
+   $self->{query_reparsed}  = 0;     # only explain extended once
+   $self->{ex_query_struct} = undef; # EXplain EXtended query struct
+   $self->{schemas}         = undef; # db->tbl->cols from ^
+   $self->{table_for}       = undef; # table alias from ^
+
+   my $tables;
+   my $query_struct;
+   eval {
+      $query_struct = $self->{SQLParser}->parse($query);
+   };
+   if ( $EVAL_ERROR ) {
+      MKDEBUG && _d('Failed to parse query with SQLParser:', $EVAL_ERROR);
+      if ( $EVAL_ERROR =~ m/Cannot parse/ ) {
+         $tables = $self->_get_tables_used_from_query_parser(%args);
+      }
+      else {
+         die $EVAL_ERROR;
+      }
+   }
+   else {
+      $tables = $self->_get_tables_used_from_query_struct(
+         query_struct => $query_struct,
+         %args,
+      );
+   }
+
+   MKDEBUG && _d('Query table usage:', Dumper($tables));
+   return $tables;
+}
+
+sub errors {
+   my ($self) = @_;
+   return $self->{errors};
+}
+
+sub _get_tables_used_from_query_parser {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(query);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($query) = @args{@required_args};
+   MKDEBUG && _d('Getting tables used from query parser');
+
+   $query = $self->{QueryParser}->clean_query($query);
+   my ($query_type) = $query =~ m/^\s*(\w+)\s+/;
+   $query_type = uc $query_type;
+   die "Query does not begin with a word" unless $query_type; # shouldn't happen
+
+   if ( $query_type eq 'DROP' ) {
+      my ($drop_what) = $query =~ m/^\s*DROP\s+(\w+)\s+/i;
+      die "Invalid DROP query: $query" unless $drop_what;
+      $query_type .= '_' . uc($drop_what);
+   }
+
+   my @tables_used;
+   foreach my $table ( $self->{QueryParser}->get_tables($query) ) {
+      $table =~ s/`//g;
+      push @{$tables_used[0]}, {
+         table   => $table,
+         context => $query_type,
+      };
+   }
+
+   return \@tables_used;
+}
+
+sub _get_tables_used_from_query_struct {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(query_struct query);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($query_struct) = @args{@required_args};
+
+   MKDEBUG && _d('Getting table used from query struct');
+
+   my $query_type = uc $query_struct->{type};
+
+   if ( $query_type eq 'CREATE' ) {
+      MKDEBUG && _d('CREATE query');
+      my $sel_tables;
+      if ( my $sq_struct = $query_struct->{subqueries}->[0] ) {
+         MKDEBUG && _d('CREATE query with SELECT');
+         $sel_tables = $self->_get_tables_used_from_query_struct(
+            %args,
+            query        => $sq_struct->{query},
+            query_struct => $sq_struct,
+         );
+      }
+      return [
+         [
+            {
+               context => 'CREATE',
+               table   => $query_struct->{name},
+            },
+            ($sel_tables ? @{$sel_tables->[0]} : ()),
+         ],
+      ];
+   }
+
+   my $tables     = $self->_get_tables($query_struct);
+   if ( !$tables || @$tables == 0 ) {
+      MKDEBUG && _d("Query does not use any tables");
+      return [
+         [ { context => $query_type, table => $self->{constant_data_value} } ]
+      ];
+   }
+
+   my ($where, $ambig);
+   if ( $query_struct->{where} ) {
+      ($where, $ambig) = $self->_get_tables_used_in_where(
+         %args,
+         tables  => $tables,
+         where   => $query_struct->{where},
+      );
+
+      if ( $ambig && $self->{dbh} && !$self->{query_reparsed} ) {
+         MKDEBUG && _d("Using EXPLAIN EXTENDED to disambiguate columns");
+         if ( $self->_reparse_query(%args) ) {
+            return $self->_get_tables_used_from_query_struct(%args);
+         } 
+         MKDEBUG && _d('Failed to disambiguate columns');
+      }
+   }
+
+   my @tables_used;
+   if ( $query_type eq 'UPDATE' && @{$query_struct->{tables}} > 1 ) {
+      MKDEBUG && _d("Multi-table UPDATE");
+
+      my @join_tables;
+      foreach my $table ( @$tables ) {
+         my $table = $self->_qualify_table_name(
+            %args,
+            tables => $tables,
+            db     => $table->{db},
+            tbl    => $table->{tbl},
+         );
+         my $table_usage = {
+            context => 'JOIN',
+            table   => $table,
+         };
+         MKDEBUG && _d("Table usage from TLIST:", Dumper($table_usage));
+         push @join_tables, $table_usage;
+      }
+      if ( $where && $where->{joined_tables} ) {
+         foreach my $table ( @{$where->{joined_tables}} ) {
+            my $table_usage = {
+               context => $query_type,
+               table   => $table,
+            };
+            MKDEBUG && _d("Table usage from WHERE (implicit join):",
+               Dumper($table_usage));
+            push @join_tables, $table_usage;
+         }
+      }
+
+      my @where_tables;
+      if ( $where && $where->{filter_tables} ) {
+         foreach my $table ( @{$where->{filter_tables}} ) {
+            my $table_usage = {
+               context => 'WHERE',
+               table   => $table,
+            };
+            MKDEBUG && _d("Table usage from WHERE:", Dumper($table_usage));
+            push @where_tables, $table_usage;
+         }
+      }
+
+      my $set_tables = $self->_get_tables_used_in_set(
+         %args,
+         tables  => $tables,
+         set     => $query_struct->{set},
+      );
+      foreach my $table ( @$set_tables ) {
+         my @table_usage = (
+            {  # the written table
+               context => 'UPDATE',
+               table   => $table->{table},
+            },
+            {  # source of data written to the written table
+               context => 'SELECT',
+               table   => $table->{value},
+            },
+         );
+         MKDEBUG && _d("Table usage from UPDATE SET:", Dumper(\@table_usage));
+         push @tables_used, [
+            @table_usage,
+            @join_tables,
+            @where_tables,
+         ];
+      }
+   } # multi-table UPDATE
+   else {
+      if ( $query_type eq 'SELECT' ) {
+         my ($clist_tables, $ambig) = $self->_get_tables_used_in_columns(
+            %args,
+            tables  => $tables,
+            columns => $query_struct->{columns},
+         );
+
+         if ( $ambig && $self->{dbh} && !$self->{query_reparsed} ) {
+            MKDEBUG && _d("Using EXPLAIN EXTENDED to disambiguate columns");
+            if ( $self->_reparse_query(%args) ) {
+               return $self->_get_tables_used_from_query_struct(%args);
+            } 
+            MKDEBUG && _d('Failed to disambiguate columns');
+         }
+
+         foreach my $table ( @$clist_tables ) {
+            my $table_usage = {
+               context => 'SELECT',
+               table   => $table,
+            };
+            MKDEBUG && _d("Table usage from CLIST:", Dumper($table_usage));
+            push @{$tables_used[0]}, $table_usage;
+         }
+      }
+
+      if ( @$tables > 1 || $query_type ne 'SELECT' ) {
+         my $default_context = @$tables > 1 ? 'TLIST' : $query_type;
+         foreach my $table ( @$tables ) {
+            my $qualified_table = $self->_qualify_table_name(
+               %args,
+               tables => $tables,
+               db     => $table->{db},
+               tbl    => $table->{tbl},
+            );
+
+            my $context = $default_context;
+            if ( $table->{join} && $table->{join}->{condition} ) {
+                $context = 'JOIN';
+               if ( $table->{join}->{condition} eq 'using' ) {
+                  MKDEBUG && _d("Table joined with USING condition");
+                  my $joined_table  = $self->_qualify_table_name(
+                     %args,
+                     tables => $tables,
+                     tbl    => $table->{join}->{to},
+                  );
+                  $self->_change_context(
+                     tables      => $tables,
+                     table       => $joined_table,
+                     tables_used => $tables_used[0],
+                     old_context => 'TLIST',
+                     new_context => 'JOIN',
+                  );
+               }
+               elsif ( $table->{join}->{condition} eq 'on' ) {
+                  MKDEBUG && _d("Table joined with ON condition");
+                  my ($on_tables, $ambig) = $self->_get_tables_used_in_where(
+                     %args,
+                     tables => $tables,
+                     where  => $table->{join}->{where},
+                     clause => 'JOIN condition',  # just for debugging
+                  );
+                  MKDEBUG && _d("JOIN ON tables:", Dumper($on_tables));
+
+                  if ( $ambig && $self->{dbh} && !$self->{query_reparsed} ) {
+                     MKDEBUG && _d("Using EXPLAIN EXTENDED",
+                        "to disambiguate columns");
+                     if ( $self->_reparse_query(%args) ) {
+                        return $self->_get_tables_used_from_query_struct(%args);
+                     } 
+                     MKDEBUG && _d('Failed to disambiguate columns'); 
+                  }
+
+                  foreach my $joined_table ( @{$on_tables->{joined_tables}} ) {
+                     $self->_change_context(
+                        tables      => $tables,
+                        table       => $joined_table,
+                        tables_used => $tables_used[0],
+                        old_context => 'TLIST',
+                        new_context => 'JOIN',
+                     );
+                  }
+               }
+               else {
+                  warn "Unknown JOIN condition: $table->{join}->{condition}";
+               }
+            }
+
+            my $table_usage = {
+               context => $context,
+               table   => $qualified_table,
+            };
+            MKDEBUG && _d("Table usage from TLIST:", Dumper($table_usage));
+            push @{$tables_used[0]}, $table_usage;
+         }
+      }
+
+      if ( $where && $where->{joined_tables} ) {
+         foreach my $joined_table ( @{$where->{joined_tables}} ) {
+            MKDEBUG && _d("Table joined implicitly in WHERE:", $joined_table);
+            $self->_change_context(
+               tables      => $tables,
+               table       => $joined_table,
+               tables_used => $tables_used[0],
+               old_context => 'TLIST',
+               new_context => 'JOIN',
+            );
+         }
+      }
+
+      if ( $query_type =~ m/(?:INSERT|REPLACE)/ ) {
+         if ( $query_struct->{select} ) {
+            MKDEBUG && _d("Getting tables used in INSERT-SELECT");
+            my $select_tables = $self->_get_tables_used_from_query_struct(
+               %args,
+               query_struct => $query_struct->{select},
+            );
+            push @{$tables_used[0]}, @{$select_tables->[0]};
+         }
+         else {
+            my $table_usage = {
+               context => 'SELECT',
+               table   => $self->{constant_data_value},
+            };
+            MKDEBUG && _d("Table usage from SET/VALUES:", Dumper($table_usage));
+            push @{$tables_used[0]}, $table_usage;
+         }
+      }
+      elsif ( $query_type eq 'UPDATE' ) {
+         my $set_tables = $self->_get_tables_used_in_set(
+            %args,
+            tables => $tables,
+            set    => $query_struct->{set},
+         );
+         foreach my $table ( @$set_tables ) {
+            my $table_usage = {
+               context => 'SELECT',
+               table   => $table->{value_is_table} ? $table->{table}
+                        :                            $self->{constant_data_value},
+            };
+            MKDEBUG && _d("Table usage from SET:", Dumper($table_usage));
+            push @{$tables_used[0]}, $table_usage;
+         }
+      }
+
+      if ( $where && $where->{filter_tables} ) {
+         foreach my $table ( @{$where->{filter_tables}} ) {
+            my $table_usage = {
+               context => 'WHERE',
+               table   => $table,
+            };
+            MKDEBUG && _d("Table usage from WHERE:", Dumper($table_usage));
+            push @{$tables_used[0]}, $table_usage;
+         }
+      }
+   }
+
+   return \@tables_used;
+}
+
+sub _get_tables_used_in_columns {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(tables columns);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables, $columns) = @args{@required_args};
+
+   MKDEBUG && _d("Getting tables used in CLIST");
+   my @tables;
+   my $ambig = 0;  # found any ambiguous columns?
+   if ( @$tables == 1 ) {
+      MKDEBUG && _d("Single table SELECT:", $tables->[0]->{tbl});
+      my $table = $self->_qualify_table_name(
+         %args,
+         db  => $tables->[0]->{db},
+         tbl => $tables->[0]->{tbl},
+      );
+      @tables = ($table);
+   }
+   elsif ( @$columns == 1 && $columns->[0]->{col} eq '*' ) {
+      if ( $columns->[0]->{tbl} ) {
+         MKDEBUG && _d("SELECT all columns from one table");
+         my $table = $self->_qualify_table_name(
+            %args,
+            db  => $columns->[0]->{db},
+            tbl => $columns->[0]->{tbl},
+         );
+         @tables = ($table);
+      }
+      else {
+         MKDEBUG && _d("SELECT all columns from all tables");
+         foreach my $table ( @$tables ) {
+            my $table = $self->_qualify_table_name(
+               %args,
+               tables => $tables,
+               db     => $table->{db},
+               tbl    => $table->{tbl},
+            );
+            push @tables, $table;
+         }
+      }
+   }
+   else {
+      MKDEBUG && _d(scalar @$tables, "table SELECT");
+      my %seen;
+      my $colno = 0;
+      COLUMN:
+      foreach my $column ( @$columns ) {
+         MKDEBUG && _d('Getting table for column', Dumper($column));
+         if ( $column->{col} eq '*' && !$column->{tbl} ) {
+            MKDEBUG && _d('Ignoring FUNC(*) column');
+            $colno++;
+            next;
+         }
+         $column = $self->_ex_qualify_column(
+            col    => $column,
+            colno  => $colno,
+            n_cols => scalar @$columns,
+         );
+         if ( !$column->{tbl} ) {
+            MKDEBUG && _d("Column", $column->{col}, "is not table-qualified;",
+               "and query has multiple tables; cannot determine its table");
+            $ambig++;
+            next COLUMN;
+         }
+         my $table = $self->_qualify_table_name(
+            %args,
+            db  => $column->{db},
+            tbl => $column->{tbl},
+         );
+         push @tables, $table if $table && !$seen{$table}++;
+         $colno++;
+      }
+   }
+
+   return (\@tables, $ambig);
+}
+
+sub _get_tables_used_in_where {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(tables where);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables, $where) = @args{@required_args};
+   my $sql_parser = $self->{SQLParser};
+
+   MKDEBUG && _d("Getting tables used in", $args{clause} || 'WHERE');
+
+   my %filter_tables;
+   my %join_tables;
+   my $ambig = 0;  # found any ambiguous tables?
+   CONDITION:
+   foreach my $cond ( @$where ) {
+      MKDEBUG && _d("Condition:", Dumper($cond));
+      my @tables;  # tables used in this condition
+      my $n_vals        = 0;
+      my $is_constant   = 0;
+      my $unknown_table = 0;
+      ARG:
+      foreach my $arg ( qw(left_arg right_arg) ) {
+         if ( !defined $cond->{$arg} ) {
+            MKDEBUG && _d($arg, "is a constant value");
+            $is_constant = 1;
+            next ARG;
+         }
+
+         if ( $sql_parser->is_identifier($cond->{$arg}) ) {
+            MKDEBUG && _d($arg, "is an identifier");
+            my $ident_struct = $sql_parser->parse_identifier(
+               'column',
+               $cond->{$arg}
+            );
+            $ident_struct = $self->_ex_qualify_column(
+               col       => $ident_struct,
+               where_arg => $arg,
+            );
+            if ( !$ident_struct->{tbl} ) {
+               if ( @$tables == 1 ) {
+                  MKDEBUG && _d("Condition column is not table-qualified; ",
+                     "using query's only table:", $tables->[0]->{tbl});
+                  $ident_struct->{tbl} = $tables->[0]->{tbl};
+               }
+               else {
+                  MKDEBUG && _d("Condition column is not table-qualified and",
+                     "query has multiple tables; cannot determine its table");
+                  if (  $cond->{$arg} !~ m/\w+\(/       # not a function
+                     && $cond->{$arg} !~ m/^[\d.]+$/) { # not a number
+                     $unknown_table = 1;
+                  }
+                  $ambig++;
+                  next ARG;
+               }
+            }
+
+            if ( !$ident_struct->{db} && @$tables == 1 && $tables->[0]->{db} ) {
+               MKDEBUG && _d("Condition column is not database-qualified; ",
+                  "using its table's database:", $tables->[0]->{db});
+               $ident_struct->{db} = $tables->[0]->{db};
+            }
+
+            my $table = $self->_qualify_table_name(
+               %args,
+               %$ident_struct,
+            );
+            if ( $table ) {
+               push @tables, $table;
+            }
+         }
+         else {
+            MKDEBUG && _d($arg, "is a value");
+            $n_vals++;
+         }
+      }  # ARG
+
+      if ( $is_constant || $n_vals == 2 ) {
+         MKDEBUG && _d("Condition is a constant or two values");
+         $filter_tables{$self->{constant_data_value}} = undef;
+      }
+      else {
+         if ( @tables == 1 ) {
+            if ( $unknown_table ) {
+               MKDEBUG && _d("Condition joins table",
+                  $tables[0], "to column from unknown table");
+               $join_tables{$tables[0]} = undef;
+            }
+            else {
+               MKDEBUG && _d("Condition filters table", $tables[0]);
+               $filter_tables{$tables[0]} = undef;
+            }
+         }
+         elsif ( @tables == 2 ) {
+            MKDEBUG && _d("Condition joins tables",
+               $tables[0], "and", $tables[1]);
+            $join_tables{$tables[0]} = undef;
+            $join_tables{$tables[1]} = undef;
+         }
+      }
+   }  # CONDITION
+
+   return (
+      {
+         filter_tables => [ sort keys %filter_tables ],
+         joined_tables => [ sort keys %join_tables   ],
+      },
+      $ambig,
+   );
+}
+
+sub _get_tables_used_in_set {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(tables set);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables, $set) = @args{@required_args};
+   my $sql_parser = $self->{SQLParser};
+
+   MKDEBUG && _d("Getting tables used in SET");
+
+   my @tables;
+   if ( @$tables == 1 ) {
+      my $table = $self->_qualify_table_name(
+         %args,
+         db  => $tables->[0]->{db},
+         tbl => $tables->[0]->{tbl},
+      );
+      $tables[0] = {
+         table => $table,
+         value => $self->{constant_data_value}
+      };
+   }
+   else {
+      foreach my $cond ( @$set ) {
+         next unless $cond->{tbl};
+         my $table = $self->_qualify_table_name(
+            %args,
+            db  => $cond->{db},
+            tbl => $cond->{tbl},
+         );
+
+         my $value          = $self->{constant_data_value};
+         my $value_is_table = 0;
+         if ( $sql_parser->is_identifier($cond->{value}) ) {
+            my $ident_struct = $sql_parser->parse_identifier(
+               'column',
+               $cond->{value},
+            );
+            $value_is_table = 1;
+            $value          = $self->_qualify_table_name(
+               %args,
+               db  => $ident_struct->{db},
+               tbl => $ident_struct->{tbl},
+            );
+         }
+
+         push @tables, {
+            table          => $table,
+            value          => $value,
+            value_is_table => $value_is_table,
+         };
+      }
+   }
+
+   return \@tables;
+}
+
+sub _get_real_table_name {
+   my ( $self, %args ) = @_;
+   my @required_args = qw(tables name);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables, $name) = @args{@required_args};
+   $name = lc $name;
+
+   foreach my $table ( @$tables ) {
+      if ( lc($table->{tbl}) eq $name
+           || lc($table->{alias} || "") eq $name ) {
+         MKDEBUG && _d("Real table name for", $name, "is", $table->{tbl});
+         return $table->{tbl};
+      }
+   }
+   MKDEBUG && _d("Table", $name, "does not exist in query");
+   return;
+}
+
+sub _qualify_table_name {
+   my ( $self, %args) = @_;
+   my @required_args = qw(tables tbl);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables, $table) = @args{@required_args};
+
+   MKDEBUG && _d("Qualifying table with database:", $table);
+
+   my ($tbl, $db) = reverse split /[.]/, $table;
+
+   if ( $self->{ex_query_struct} ) {
+      $tables = $self->{ex_query_struct}->{from};
+   }
+
+   $tbl = $self->_get_real_table_name(tables => $tables, name => $tbl);
+   return unless $tbl;  # shouldn't happen
+
+   my $db_tbl;
+
+   if ( $db ) {
+      $db_tbl = "$db.$tbl";
+   }
+   elsif ( $args{db} ) {
+      $db_tbl = "$args{db}.$tbl";
+   }
+   else {
+      foreach my $tbl_info ( @$tables ) {
+         if ( ($tbl_info->{tbl} eq $tbl) && $tbl_info->{db} ) {
+            $db_tbl = "$tbl_info->{db}.$tbl";
+            last;
+         }
+      }
+
+      if ( !$db_tbl && $args{default_db} ) { 
+         $db_tbl = "$args{default_db}.$tbl";
+      }
+
+      if ( !$db_tbl ) {
+         MKDEBUG && _d("Cannot determine database for table", $tbl);
+         $db_tbl = $tbl;
+      }
+   }
+
+   MKDEBUG && _d("Table qualified with database:", $db_tbl);
+   return $db_tbl;
+}
+
+sub _change_context {
+   my ( $self, %args) = @_;
+   my @required_args = qw(tables_used table old_context new_context tables);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my ($tables_used, $table, $old_context, $new_context) = @args{@required_args};
+   MKDEBUG && _d("Change context of table", $table, "from", $old_context,
+      "to", $new_context);
+   foreach my $used_table ( @$tables_used ) {
+      if (    $used_table->{table}   eq $table
+           && $used_table->{context} eq $old_context ) {
+         $used_table->{context} = $new_context;
+         return;
+      }
+   }
+   MKDEBUG && _d("Table", $table, "is not used; cannot set its context");
+   return;
+}
+
+sub _explain_query {
+   my ($self, $query, $db) = @_;
+   my $dbh = $self->{dbh};
+
+   my $sql;
+   if ( $db ) {
+      $sql = "USE `$db`";
+      MKDEBUG && _d($dbh, $sql);
+      $dbh->do($sql);
+   }
+
+   $sql = "EXPLAIN EXTENDED $query";
+   MKDEBUG && _d($dbh, $sql);
+   eval {
+      $dbh->do($sql);  # don't need the result
+   };
+   if ( $EVAL_ERROR ) {
+      if ( $EVAL_ERROR =~ m/No database/i ) {
+         MKDEBUG && _d($EVAL_ERROR);
+         push @{$self->{errors}}, 'NO_DB_SELECTED';
+         return;
+      }
+      die $EVAL_ERROR;
+   }
+
+   $sql = "SHOW WARNINGS";
+   MKDEBUG && _d($dbh, $sql);
+   my $warning = $dbh->selectrow_hashref($sql);
+   MKDEBUG && _d(Dumper($warning));
+   if (    ($warning->{level} || "") !~ m/Note/i
+        || ($warning->{code}  || 0)  != 1003 ) {
+      die "EXPLAIN EXTENDED failed:\n"
+         . "  Level: " . ($warning->{level}   || "") . "\n"
+         . "   Code: " . ($warning->{code}    || "") . "\n"
+         . "Message: " . ($warning->{message} || "") . "\n";
+   }
+
+   return $warning->{message};
+}
+
+sub _get_tables {
+   my ( $self, $query_struct ) = @_;
+
+   my $query_type = uc $query_struct->{type};
+   my $tbl_refs   = $query_type =~ m/(?:SELECT|DELETE)/  ? 'from'
+                  : $query_type =~ m/(?:INSERT|REPLACE)/ ? 'into'
+                  : $query_type =~ m/UPDATE/             ? 'tables'
+                  : die "Cannot find table references for $query_type queries";
+
+   return $query_struct->{$tbl_refs};
+}
+
+sub _reparse_query {
+   my ($self, %args) = @_;
+   my @required_args = qw(query query_struct);
+   my ($query, $query_struct) = @args{@required_args};
+   MKDEBUG && _d("Reparsing query with EXPLAIN EXTENDED");
+
+   $self->{query_reparsed} = 1;
+
+   return unless uc($query_struct->{type}) eq 'SELECT';
+
+   my $new_query = $self->_explain_query($query);
+   return unless $new_query;  # failure
+
+   my $schemas         = {};
+   my $table_for       = $self->{table_for};
+   my $ex_query_struct = $self->{SQLParser}->parse($new_query);
+
+   map {
+      if ( $_->{db} && $_->{tbl} ) {
+         $schemas->{lc $_->{db}}->{lc $_->{tbl}} ||= {};
+         if ( $_->{alias} ) {
+            $table_for->{lc $_->{alias}} = {
+               db  => lc $_->{db},
+               tbl => lc $_->{tbl},
+            };
+         }
+      }
+   } @{$ex_query_struct->{from}};
+
+   map {
+      if ( $_->{db} && $_->{tbl} ) {
+         $schemas->{lc $_->{db}}->{lc $_->{tbl}}->{lc $_->{col}} = 1;
+      }
+   } @{$ex_query_struct->{columns}};
+
+   $self->{schemas}         = $schemas;
+   $self->{ex_query_struct} = $ex_query_struct;
+
+   return 1;  # success
+}
+
+sub _ex_qualify_column {
+   my ($self, %args) = @_;
+   my ($col, $colno, $n_cols, $where_arg) = @args{qw(col colno n_cols where_arg)};
+
+   return $col unless $self->{ex_query_struct};
+   my $ex = $self->{ex_query_struct};
+
+   MKDEBUG && _d('Qualifying column',$col->{col},'with EXPLAIN EXTENDED query');
+
+   return unless $col;
+
+   return $col if $col->{db} && $col->{tbl};
+
+   my $colname = lc $col->{col};
+
+   if ( !$col->{tbl} ) {
+      if ( $where_arg ) {
+         MKDEBUG && _d('Searching WHERE conditions for column');
+         CONDITION:
+         foreach my $cond ( @{$ex->{where}} ) {
+            if ( defined $cond->{$where_arg}
+                 && $self->{SQLParser}->is_identifier($cond->{$where_arg}) ) {
+               my $ident_struct = $cond->{"${where_arg}_ident_struct"};
+               if ( !$ident_struct ) {
+                  $ident_struct = $self->{SQLParser}->parse_identifier(
+                     'column',
+                     $cond->{$where_arg},
+                  );
+                  $cond->{"${where_arg}_ident_struct"} = $ident_struct;
+               }
+               if ( lc($ident_struct->{col}) eq $colname ) {
+                  $col = $ident_struct;
+                  last CONDITION;
+               }
+            }
+         }
+      }
+      elsif ( defined $colno
+           && $ex->{columns}->[$colno]
+           && lc($ex->{columns}->[$colno]->{col}) eq $colname ) {
+         MKDEBUG && _d('Exact match by col name and number');
+         $col = $ex->{columns}->[$colno];
+      }
+      elsif ( defined $colno
+              && scalar @{$ex->{columns}} == $n_cols ) {
+         MKDEBUG && _d('Match by column number in CLIST');
+         $col = $ex->{columns}->[$colno];
+      }
+      else {
+         MKDEBUG && _d('Searching for unique column in every db.tbl');
+         my ($uniq_db, $uniq_tbl);
+         my $colcnt  = 0;
+         my $schemas = $self->{schemas};
+         DATABASE:
+         foreach my $db ( keys %$schemas ) {
+            TABLE:
+            foreach my $tbl ( keys %{$schemas->{$db}} ) {
+               if ( $schemas->{$db}->{$tbl}->{$colname} ) {
+                  $uniq_db  = $db;
+                  $uniq_tbl = $tbl;
+                  last DATABASE if ++$colcnt > 1;
+               }
+            }
+         }
+         if ( $colcnt == 1 ) {
+            $col->{db}  = $uniq_db;
+            $col->{tbl} = $uniq_tbl;
+         }
+      }
+   }
+
+   if ( !$col->{db} && $col->{tbl} ) {
+      MKDEBUG && _d('Column has table, needs db');
+      if ( my $real_tbl = $self->{table_for}->{lc $col->{tbl}} ) {
+         MKDEBUG && _d('Table is an alias');
+         $col->{db}  = $real_tbl->{db};
+         $col->{tbl} = $real_tbl->{tbl};
+      }
+      else {
+         MKDEBUG && _d('Searching for unique table in every db');
+         my $real_tbl = $self->_get_real_table_name(
+            tables => $ex->{from},
+            name   => $col->{tbl},
+         );
+         if ( $real_tbl ) {
+            $real_tbl = lc $real_tbl;
+            my $uniq_db;
+            my $dbcnt   = 0;
+            my $schemas = $self->{schemas};
+            DATABASE:
+            foreach my $db ( keys %$schemas ) {
+               if ( exists $schemas->{$db}->{$real_tbl} ) {
+                  $uniq_db  = $db;
+                  last DATABASE if ++$dbcnt > 1;
+               }
+            }
+            if ( $dbcnt == 1 ) {
+               $col->{db}  = $uniq_db;
+               $col->{tbl} = $real_tbl;
+            }
+         }
+      }
+   }
+
+   MKDEBUG && _d('Qualified column:', Dumper($col));
+   return $col;
+}
+
+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";
+}
+
+} # package scope
+1;
+}
+# ###########################################################################
+# End TableUsage package
+# ###########################################################################
+
+# ###########################################################################
+# Daemon package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/Daemon.pm
+#   t/lib/Daemon.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package Daemon;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+use POSIX qw(setsid);
+
+sub new {
+   my ( $class, %args ) = @_;
+   foreach my $arg ( qw(o) ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+   my $o = $args{o};
+   my $self = {
+      o        => $o,
+      log_file => $o->has('log') ? $o->get('log') : undef,
+      PID_file => $o->has('pid') ? $o->get('pid') : undef,
+   };
+
+   check_PID_file(undef, $self->{PID_file});
+
+   PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
+   return bless $self, $class;
+}
+
+sub daemonize {
+   my ( $self ) = @_;
+
+   PTDEBUG && _d('About to fork and daemonize');
+   defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
+   if ( $pid ) {
+      PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
+      exit;
+   }
+
+   PTDEBUG && _d('Daemonizing child PID', $PID);
+   $self->{PID_owner} = $PID;
+   $self->{child}     = 1;
+
+   POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
+   chdir '/'       or die "Cannot chdir to /: $OS_ERROR";
+
+   $self->_make_PID_file();
+
+   $OUTPUT_AUTOFLUSH = 1;
+
+   PTDEBUG && _d('Redirecting STDIN to /dev/null');
+   close STDIN;
+   open  STDIN, '/dev/null'
+      or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
+
+   if ( $self->{log_file} ) {
+      PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
+      close STDOUT;
+      open  STDOUT, '>>', $self->{log_file}
+         or die "Cannot open log file $self->{log_file}: $OS_ERROR";
+
+      close STDERR;
+      open  STDERR, ">&STDOUT"
+         or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; 
+   }
+   else {
+      if ( -t STDOUT ) {
+         PTDEBUG && _d('No log file and STDOUT is a terminal;',
+            'redirecting to /dev/null');
+         close STDOUT;
+         open  STDOUT, '>', '/dev/null'
+            or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
+      }
+      if ( -t STDERR ) {
+         PTDEBUG && _d('No log file and STDERR is a terminal;',
+            'redirecting to /dev/null');
+         close STDERR;
+         open  STDERR, '>', '/dev/null'
+            or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
+      }
+   }
+
+   return;
+}
+
+sub check_PID_file {
+   my ( $self, $file ) = @_;
+   my $PID_file = $self ? $self->{PID_file} : $file;
+   PTDEBUG && _d('Checking PID file', $PID_file);
+   if ( $PID_file && -f $PID_file ) {
+      my $pid;
+      eval { chomp($pid = `cat $PID_file`); };
+      die "Cannot cat $PID_file: $OS_ERROR" if $EVAL_ERROR;
+      PTDEBUG && _d('PID file exists; it contains PID', $pid);
+      if ( $pid ) {
+         my $pid_is_alive = kill 0, $pid;
+         if ( $pid_is_alive ) {
+            die "The PID file $PID_file already exists "
+               . " and the PID that it contains, $pid, is running";
+         }
+         else {
+            warn "Overwriting PID file $PID_file because the PID that it "
+               . "contains, $pid, is not running";
+         }
+      }
+      else {
+         die "The PID file $PID_file already exists but it does not "
+            . "contain a PID";
+      }
+   }
+   else {
+      PTDEBUG && _d('No PID file');
+   }
+   return;
+}
+
+sub make_PID_file {
+   my ( $self ) = @_;
+   if ( exists $self->{child} ) {
+      die "Do not call Daemon::make_PID_file() for daemonized scripts";
+   }
+   $self->_make_PID_file();
+   $self->{PID_owner} = $PID;
+   return;
+}
+
+sub _make_PID_file {
+   my ( $self ) = @_;
+
+   my $PID_file = $self->{PID_file};
+   if ( !$PID_file ) {
+      PTDEBUG && _d('No PID file to create');
+      return;
+   }
+
+   $self->check_PID_file();
+
+   open my $PID_FH, '>', $PID_file
+      or die "Cannot open PID file $PID_file: $OS_ERROR";
+   print $PID_FH $PID
+      or die "Cannot print to PID file $PID_file: $OS_ERROR";
+   close $PID_FH
+      or die "Cannot close PID file $PID_file: $OS_ERROR";
+
+   PTDEBUG && _d('Created PID file:', $self->{PID_file});
+   return;
+}
+
+sub _remove_PID_file {
+   my ( $self ) = @_;
+   if ( $self->{PID_file} && -f $self->{PID_file} ) {
+      unlink $self->{PID_file}
+         or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
+      PTDEBUG && _d('Removed PID file');
+   }
+   else {
+      PTDEBUG && _d('No PID to remove');
+   }
+   return;
+}
+
+sub DESTROY {
+   my ( $self ) = @_;
+
+   $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
+
+   return;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
+}
+
+1;
+}
+# ###########################################################################
+# End Daemon package
+# ###########################################################################
+
+# ###########################################################################
+# Runtime package
+# This package is a copy without comments from the original.  The original
+# with comments and its test file can be found in the Bazaar repository at,
+#   lib/Runtime.pm
+#   t/lib/Runtime.t
+# See https://launchpad.net/percona-toolkit for more information.
+# ###########################################################################
+{
+package Runtime;
+
+use strict;
+use warnings FATAL => 'all';
+use English qw(-no_match_vars);
+use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+
+sub new {
+   my ( $class, %args ) = @_;
+   my @required_args = qw(now);
+   foreach my $arg ( @required_args ) {
+      die "I need a $arg argument" unless $args{$arg};
+   }
+
+   if ( ($args{runtime} || 0) < 0 ) {
+      die "runtime argument must be greater than zero"
+   }
+
+   my $self = {
+      %args,
+      start_time => undef,
+      end_time   => undef,
+      time_left  => undef,
+      stop       => 0,
+   };
+
+   return bless $self, $class;
+}
+
+sub time_left {
+   my ( $self, %args ) = @_;
+
+   if ( $self->{stop} ) {
+      PTDEBUG && _d("No time left because stop was called");
+      return 0;
+   }
+
+   my $now = $self->{now}->(%args);
+   PTDEBUG && _d("Current time:", $now);
+
+   if ( !defined $self->{start_time} ) {
+      $self->{start_time} = $now;
+   }
+
+   return unless defined $now;
+
+   my $runtime = $self->{runtime};
+   return unless defined $runtime;
+
+   if ( !$self->{end_time} ) {
+      $self->{end_time} = $now + $runtime;
+      PTDEBUG && _d("End time:", $self->{end_time});
+   }
+
+   $self->{time_left} = $self->{end_time} - $now;
+   PTDEBUG && _d("Time left:", $self->{time_left});
+   return $self->{time_left};
+}
+
+sub have_time {
+   my ( $self, %args ) = @_;
+   my $time_left = $self->time_left(%args);
+   return 1 if !defined $time_left;  # run forever
+   return $time_left <= 0 ? 0 : 1;   # <=0s means runtime has elapsed
+}
+
+sub time_elapsed {
+   my ( $self, %args ) = @_;
+
+   my $start_time = $self->{start_time};
+   return 0 unless $start_time;
+
+   my $now = $self->{now}->(%args);
+   PTDEBUG && _d("Current time:", $now);
+
+   my $time_elapsed = $now - $start_time;
+   PTDEBUG && _d("Time elapsed:", $time_elapsed);
+   if ( $time_elapsed < 0 ) {
+      warn "Current time $now is earlier than start time $start_time";
+   }
+   return $time_elapsed;
+}
+
+sub reset {
+   my ( $self ) = @_;
+   $self->{start_time} = undef;
+   $self->{end_time}   = undef;
+   $self->{time_left}  = undef;
+   $self->{stop}       = 0;
+   PTDEBUG && _d("Reset runtime");
+   return;
+}
+
+sub stop {
+   my ( $self ) = @_;
+   $self->{stop} = 1;
+   return;
+}
+
+sub start {
+   my ( $self ) = @_;
+   $self->{stop} = 0;
+   return;
+}
+
+sub _d {
+   my ($package, undef, $line) = caller 0;
+   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
+        map { defined $_ ? $_ : 'undef' }
+        @_;
+   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";