Merge lp:~percona-toolkit-dev/percona-toolkit/fix-table-status-bug-960513 into lp:percona-toolkit/2.0

[Daniel Nichter]

[Daniel Nichter (daniel-nichter)]

review: Approve

Unmerged revisions

228. By Daniel Nichter on 2012-03-31

Update SchemaIterator, TableParser, and NibbleIterator in tools that use them. All tools' tests still pass.

227. By Daniel Nichter on 2012-03-31

Don't use TABLE STATUS, use CREATE TABLE instead for the table's engine.

226. By Daniel Nichter on 2012-03-31

Update SchemaIterator in pt-table-sync. Make the module handle NAME_lc or not.

225. By Daniel Nichter on 2012-03-30

Add pt-table-usage and update SQLParser.pm from Maatkit.

224. By Daniel Nichter on 2012-03-30

Add pt-fingerprint.

223. By Daniel Nichter on 2012-03-30

Merge fix-no-stalk-bug-955860.

222. By Daniel Nichter on 2012-03-30

Merge fix-pt-upgrade-docs-bug-953461.

221. By Daniel Nichter on 2012-03-30

Merge fix-quoting-bug-967451.

220. By Daniel Nichter on 2012-03-30

Merge fix-risks-docs-bug-949653.

219. By Daniel Nichter on 2012-03-27

Merge lp:~percona-toolkit-dev/percona-toolkit/update-relay-log-space-limit-docs-fix-bug-949154.

=== modified file 'bin/pt-duplicate-key-checker'
--- bin/pt-duplicate-key-checker	2012-03-07 23:41:54 +0000
+++ bin/pt-duplicate-key-checker	2012-03-31 16:07:24 +0000
@@ -199,19 +199,58 @@
    return bless $self, $class;
 }
 
+sub get_create_table {
+   my ( $self, $dbh, $db, $tbl ) = @_;
+   die "I need a dbh parameter" unless $dbh;
+   die "I need a db parameter"  unless $db;
+   die "I need a tbl parameter" unless $tbl;
+   my $q = $self->{Quoter};
+
+   my $new_sql_mode
+      = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
+      . q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
+      . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
+      . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
+
+   my $old_sql_mode = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
+                     . '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
+
+   PTDEBUG && _d($new_sql_mode);
+   eval { $dbh->do($new_sql_mode); };
+   PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
+
+   my $use_sql = 'USE ' . $q->quote($db);
+   PTDEBUG && _d($dbh, $use_sql);
+   $dbh->do($use_sql);
+
+   my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
+   PTDEBUG && _d($show_sql);
+   my $href;
+   eval { $href = $dbh->selectrow_hashref($show_sql); };
+   if ( $EVAL_ERROR ) {
+      PTDEBUG && _d($EVAL_ERROR);
+
+      PTDEBUG && _d($old_sql_mode);
+      $dbh->do($old_sql_mode);
+
+      return;
+   }
+
+   PTDEBUG && _d($old_sql_mode);
+   $dbh->do($old_sql_mode);
+
+   my ($key) = grep { m/create (?:table|view)/i } keys %$href;
+   if ( !$key ) {
+      die "Error: no 'Create Table' or 'Create View' in result set from "
+         . "$show_sql: " . Dumper($href);
+   }
+
+   return $href->{$key};
+}
+
 sub parse {
    my ( $self, $ddl, $opts ) = @_;
    return unless $ddl;
-   if ( ref $ddl eq 'ARRAY' ) {
-      if ( lc $ddl->[0] eq 'table' ) {
-         $ddl = $ddl->[1];
-      }
-      else {
-         return {
-            engine => 'VIEW',
-         };
-      }
-   }
 
    if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
       die "Cannot parse table definition; is ANSI quoting "
@@ -518,41 +557,31 @@
    return $ddl;
 }
 
-sub remove_secondary_indexes {
-   my ( $self, $ddl ) = @_;
-   my $sec_indexes_ddl;
-   my $tbl_struct = $self->parse($ddl);
-
-   if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
-      my $clustered_key = $tbl_struct->{clustered_key};
-      $clustered_key  ||= '';
-
-      my @sec_indexes   = map {
-         my $key_def = $_->{ddl};
-         $key_def =~ s/([\(\)])/\\$1/g;
-         $ddl =~ s/\s+$key_def//i;
-
-         my $key_ddl = "ADD $_->{ddl}";
-         $key_ddl   .= ',' unless $key_ddl =~ m/,$/;
-         $key_ddl;
-      }
-      grep { $_->{name} ne $clustered_key }
-      values %{$tbl_struct->{keys}};
-      PTDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
-
-      if ( @sec_indexes ) {
-         $sec_indexes_ddl = join(' ', @sec_indexes);
-         $sec_indexes_ddl =~ s/,$//;
-      }
-
-      $ddl =~ s/,(\n\) )/$1/s;
-   }
-   else {
-      PTDEBUG && _d('Not removing secondary indexes from',
-         $tbl_struct->{engine}, 'table');
-   }
-
-   return $ddl, $sec_indexes_ddl, $tbl_struct;
+sub get_table_status {
+   my ( $self, $dbh, $db, $like ) = @_;
+   my $q = $self->{Quoter};
+   my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
+   my @params;
+   if ( $like ) {
+      $sql .= ' LIKE ?';
+      push @params, $like;
+   }
+   PTDEBUG && _d($sql, @params);
+   my $sth = $dbh->prepare($sql);
+   eval { $sth->execute(@params); };
+   if ($EVAL_ERROR) {
+      PTDEBUG && _d($EVAL_ERROR);
+      return;
+   }
+   my @tables = @{$sth->fetchall_arrayref({})};
+   @tables = map {
+      my %tbl; # Make a copy with lowercased keys
+      @tbl{ map { lc $_ } keys %$_ } = values %$_;
+      $tbl{engine} ||= $tbl{type} || $tbl{comment};
+      delete $tbl{type};
+      \%tbl;
+   } @tables;
+   return @tables;
 }
 
 sub _d {
@@ -3195,7 +3224,7 @@
 
 sub new {
    my ( $class, %args ) = @_;
-   my @required_args = qw(OptionParser Quoter);
+   my @required_args = qw(OptionParser TableParser Quoter);
    foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    }
@@ -3204,8 +3233,19 @@
    die "I need either a dbh or file_itr argument"
       if (!$dbh && !$file_itr) || ($dbh && $file_itr);
 
+   my %resume;
+   if ( my $table = $args{resume} ) {
+      PTDEBUG && _d('Will resume from or after', $table);
+      my ($db, $tbl) = $args{Quoter}->split_unquote($table);
+      die "Resume table must be database-qualified: $table"
+         unless $db && $tbl;
+      $resume{db}  = $db;
+      $resume{tbl} = $tbl;
+   }
+
    my $self = {
       %args,
+      resume  => \%resume,
       filters => _make_filters(%args),
    };
 
@@ -3266,9 +3306,19 @@
    return \%filters;
 }
 
-sub next_schema_object {
+sub next {
    my ( $self ) = @_;
 
+   if ( !$self->{initialized} ) {
+      $self->{initialized} = 1;
+      if ( $self->{resume}->{tbl}
+           && !$self->table_is_allowed(@{$self->{resume}}{qw(db tbl)}) ) {
+         PTDEBUG && _d('Will resume after',
+            join('.', @{$self->{resume}}{qw(db tbl)}));
+         $self->{resume}->{after} = 1;
+      }
+   }
+
    my $schema_obj;
    if ( $self->{file_itr} ) {
       $schema_obj= $self->_iterate_files();
@@ -3278,24 +3328,18 @@
    }
 
    if ( $schema_obj ) {
-      if ( $schema_obj->{ddl} && $self->{TableParser} ) {
-         $schema_obj->{tbl_struct}
-            = $self->{TableParser}->parse($schema_obj->{ddl});
-      }
-
-      delete $schema_obj->{ddl} unless $self->{keep_ddl};
-
       if ( my $schema = $self->{Schema} ) {
          $schema->add_schema_object($schema_obj);
       }
+      PTDEBUG && _d('Next schema object:',
+         $schema_obj->{db}, $schema_obj->{tbl});
    }
 
-   PTDEBUG && _d('Next schema object:', $schema_obj->{db}, $schema_obj->{tbl});
    return $schema_obj;
 }
 
 sub _iterate_files {
-   my ( $self ) = @_;
+   my ( $self ) = @_; 
 
    if ( !$self->{fh} ) {
       my ($fh, $file) = $self->{file_itr}->();
@@ -3316,7 +3360,8 @@
          my $db = $1; # XXX
          $db =~ s/^`//;  # strip leading `
          $db =~ s/`$//;  # and trailing `
-         if ( $self->database_is_allowed($db) ) {
+         if ( $self->database_is_allowed($db)
+              && $self->_resume_from_database($db) ) {
             $self->{db} = $db;
          }
       }
@@ -3329,21 +3374,22 @@
          my ($tbl) = $chunk =~ m/$tbl_name/;
          $tbl      =~ s/^\s*`//;
          $tbl      =~ s/`\s*$//;
-         if ( $self->table_is_allowed($self->{db}, $tbl) ) {
+         if ( $self->_resume_from_table($tbl)
+              && $self->table_is_allowed($self->{db}, $tbl) ) {
             my ($ddl) = $chunk =~ m/^(?:$open_comment)?(CREATE TABLE.+?;)$/ms;
             if ( !$ddl ) {
                warn "Failed to parse CREATE TABLE from\n" . $chunk;
                next CHUNK;
             }
             $ddl =~ s/ \*\/;\Z/;/;  # remove end of version comment
-
-            my ($engine) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;   
-
-            if ( !$engine || $self->engine_is_allowed($engine) ) {
+            my $tbl_struct = $self->{TableParser}->parse($ddl);
+            if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
                return {
-                  db  => $self->{db},
-                  tbl => $tbl,
-                  ddl => $ddl,
+                  db         => $self->{db},
+                  tbl        => $tbl,
+                  name       => $self->{Quoter}->quote($self->{db}, $tbl),
+                  ddl        => $ddl,
+                  tbl_struct => $tbl_struct,
                };
             }
          }
@@ -3360,6 +3406,7 @@
 sub _iterate_dbh {
    my ( $self ) = @_;
    my $q   = $self->{Quoter};
+   my $tp  = $self->{TableParser};
    my $dbh = $self->{dbh};
    PTDEBUG && _d('Getting next schema object from dbh', $dbh);
 
@@ -3373,7 +3420,9 @@
    }
 
    if ( !$self->{db} ) {
-      $self->{db} = shift @{$self->{dbs}};
+      do {
+         $self->{db} = shift @{$self->{dbs}};
+      } until $self->_resume_from_database($self->{db});
       PTDEBUG && _d('Next database:', $self->{db});
       return unless $self->{db};
    }
@@ -3386,8 +3435,9 @@
       }
       grep {
          my ($tbl, $type) = @$_;
-         $self->table_is_allowed($self->{db}, $tbl)
-            && (!$type || ($type ne 'VIEW'));
+         (!$type || ($type ne 'VIEW'))
+         && $self->_resume_from_table($tbl)
+         && $self->table_is_allowed($self->{db}, $tbl);
       }
       @{$dbh->selectall_arrayref($sql)};
       PTDEBUG && _d('Found', scalar @tbls, 'tables in database', $self->{db});
@@ -3395,27 +3445,15 @@
    }
 
    while ( my $tbl = shift @{$self->{tbls}} ) {
-      my $engine;
-      if ( $self->{filters}->{'engines'}
-           || $self->{filters}->{'ignore-engines'} ) {
-         my $sql = "SHOW TABLE STATUS FROM " . $q->quote($self->{db})
-                 . " LIKE \'$tbl\'";
-         PTDEBUG && _d($sql);
-         $engine = $dbh->selectrow_hashref($sql)->{engine};
-         PTDEBUG && _d($tbl, 'uses', $engine, 'engine');
-      }
-
-
-      if ( !$engine || $self->engine_is_allowed($engine) ) {
-         my $ddl;
-         if ( my $du = $self->{MySQLDump} ) {
-            $ddl = $du->get_create_table($dbh, $q, $self->{db}, $tbl)->[1];
-         }
-
+      my $ddl        = $tp->get_create_table($dbh, $self->{db}, $tbl);
+      my $tbl_struct = $tp->parse($ddl);
+      if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
          return {
-            db  => $self->{db},
-            tbl => $tbl,
-            ddl => $ddl,
+            db         => $self->{db},
+            tbl        => $tbl,
+            name       => $q->quote($self->{db}, $tbl),
+            ddl        => $ddl,
+            tbl_struct => $tbl_struct,
          };
       }
    }
@@ -3476,6 +3514,10 @@
 
    my $filter = $self->{filters};
 
+   if ( $db eq 'mysql' && ($tbl eq 'general_log' || $tbl eq 'slow_log') ) {
+      return 0;
+   }
+
    if ( $filter->{'ignore-tables'}->{$tbl}
         && ($filter->{'ignore-tables'}->{$tbl} eq '*'
             || $filter->{'ignore-tables'}->{$tbl} eq $db) ) {
@@ -3515,7 +3557,11 @@
 
 sub engine_is_allowed {
    my ( $self, $engine ) = @_;
-   die "I need an engine argument" unless $engine;
+
+   if ( !$engine ) {
+      PTDEBUG && _d('No engine specified; allowing the table');
+      return 1;
+   }
 
    $engine = lc $engine;
 
@@ -3535,6 +3581,40 @@
    return 1;
 }
 
+sub _resume_from_database {
+   my ($self, $db) = @_;
+
+   return 1 unless $self->{resume}->{db};
+
+   if ( $db eq $self->{resume}->{db} ) {
+      PTDEBUG && _d('At resume db', $db);
+      delete $self->{resume}->{db};
+      return 1;
+   }
+
+   return 0;
+}
+
+sub _resume_from_table {
+   my ($self, $tbl) = @_;
+
+   return 1 unless $self->{resume}->{tbl};
+
+   if ( $tbl eq $self->{resume}->{tbl} ) {
+      if ( !$self->{resume}->{after} ) {
+         PTDEBUG && _d('Resuming from table', $tbl);
+         delete $self->{resume}->{tbl};
+         return 1;
+      }
+      else {
+         PTDEBUG && _d('Resuming after table', $tbl);
+         delete $self->{resume}->{tbl};
+      }
+   }
+
+   return 0;
+}
+
 sub _d {
    my ($package, undef, $line) = caller 0;
    @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
@@ -3644,11 +3724,10 @@
       MySQLDump    => $du,
       TableParser  => $tp,
       Schema       => $schema,
-      keep_ddl     => 1,
    );
    TABLE:
-   while ( my $tbl = $schema_itr->next_schema_object() ) {
-      $tbl->{engine} = $tp->get_engine($tbl->{ddl});
+   while ( my $tbl = $schema_itr->next() ) {
+      $tbl->{engine} = $tbl->{tbl_struct}->{engine};
 
       my ($keys, $clustered_key, $fks);
       if ( $get_keys ) {

=== added file 'bin/pt-fingerprint'
--- bin/pt-fingerprint	1970-01-01 00:00:00 +0000
+++ bin/pt-fingerprint	2012-03-31 16:07:24 +0000
@@ -0,0 +1,2143 @@
+#!/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 MKDEBUG => $ENV{MKDEBUG} || 0;
+
+# ###########################################################################
+# 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
+# ###########################################################################
+
+# ###########################################################################
+# 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
+# ###########################################################################
+
+# ###########################################################################
+# 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
+# ###########################################################################
+
+# ###########################################################################
+# This is a combination of modules and programs in one -- a runnable module.
+# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
+# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
+#
+# Check at the end of this package for the call to main() which actually runs
+# the program.
+# ###########################################################################
+package pt_fingerprint;
+
+use English qw(-no_match_vars);
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+$OUTPUT_AUTOFLUSH     = 1;
+
+use constant MKDEBUG => $ENV{MKDEBUG} || 0;
+
+sub main {
+   @ARGV    = @_;  # set global ARGV for this package
+
+   # ##########################################################################
+   # Get configuration information.
+   # ##########################################################################
+   my $o = new OptionParser();
+   $o->get_specs();
+   $o->get_opts();
+   $o->usage_or_errors();
+
+   my $qp = new QueryParser();
+   my $qr = new QueryRewriter(
+      QueryParser            => $qp,
+      match_md5_checksums    => $o->get('match-md5-checksums'),
+      match_embedded_numbers => $o->get('match-embedded-numbers'),
+   );
+
+   if ( $o->got('query') ) {
+      print $qr->fingerprint($o->get('query')), "\n";
+   }
+   else {
+      local $INPUT_RECORD_SEPARATOR = ";\n";
+      while ( <> ) {
+         my $query = $_;
+         chomp $query;
+         $query =~ s/^#.+$//mg;
+         $query =~ s/^\s+//;
+         next unless $query =~ m/^\w/;
+         print $qr->fingerprint($query), "\n";
+      }
+   }
+}
+
+# ############################################################################
+# Run the program.
+# ############################################################################
+if ( !caller ) { exit main(@ARGV); }
+
+1; # Because this is a module as well as a script.
+
+# #############################################################################
+# Documentation.
+# #############################################################################
+
+=pod
+
+=head1 NAME
+
+pt-fingerprint - Convert queries into fingerprints.
+
+=head1 SYNOPSIS
+
+Usage: pt-fingerprint [OPTIONS] [FILES]
+
+pt-fingerprint converts queries into fingerprints.  With the --query
+option, converts the option's value into a fingerprint.  With no options, treats
+command-line arguments as FILEs and reads and converts semicolon-separated
+queries from the FILEs. When FILE is -, it read standard input.
+
+Convert a single query:
+
+  pt-fingerprint --query "select a, b, c from users where id = 500"
+
+Convert a file full of queries:
+
+  pt-fingerprint /path/to/file.txt
+
+=head1 RISKS
+
+The following section is included to inform users about the potential risks,
+whether known or unknown, of using this tool.  The two main categories of risks
+are those created by the nature of the tool (e.g. read-only tools vs. read-write
+tools) and those created by bugs.
+
+The pt-fingerprint tool simply reads data and transforms it, so risks are
+minimal.
+
+See also L<"BUGS"> for more information on filing bugs and getting help.
+
+=head1 DESCRIPTION
+
+A query fingerprint is the abstracted form of a query, which makes it possible
+to group similar queries together.  Abstracting a query removes literal values,
+normalizes whitespace, and so on.  For example, consider these two queries:
+
+  SELECT name, password FROM user WHERE id='12823';
+  select name,   password from user
+     where id=5;
+
+Both of those queries will fingerprint to
+
+  select name, password from user where id=?
+
+Once the query's fingerprint is known, we can then talk about a query as though
+it represents all similar queries.
+
+Query fingerprinting accommodates a great many special cases, which have proven
+necessary in the real world.  For example, an IN list with 5 literals is really
+equivalent to one with 4 literals, so lists of literals are collapsed to a
+single one.  If you want to understand more about how and why all of these cases
+are handled, please review the test cases in the Subversion repository.  If you
+find something that is not fingerprinted properly, please submit a bug report
+with a reproducible test case.  Here is a list of transformations during
+fingerprinting, which might not be exhaustive:
+
+=over
+
+=item *
+
+Group all SELECT queries from mysqldump together, even if they are against
+different tables.  Ditto for all of pt-table-checksum's checksum queries.
+
+=item *
+
+Shorten multi-value INSERT statements to a single VALUES() list.
+
+=item *
+
+Strip comments.
+
+=item *
+
+Abstract the databases in USE statements, so all USE statements are grouped
+together.
+
+=item *
+
+Replace all literals, such as quoted strings.  For efficiency, the code that
+replaces literal numbers is somewhat non-selective, and might replace some
+things as numbers when they really are not.  Hexadecimal literals are also
+replaced.  NULL is treated as a literal.  Numbers embedded in identifiers are
+also replaced, so tables named similarly will be fingerprinted to the same
+values (e.g. users_2009 and users_2010 will fingerprint identically).
+
+=item *
+
+Collapse all whitespace into a single space.
+
+=item *
+
+Lowercase the entire query.
+
+=item *
+
+Replace all literals inside of IN() and VALUES() lists with a single
+placeholder, regardless of cardinality.
+
+=item *
+
+Collapse multiple identical UNION queries into a single one.
+
+=back
+
+=head1 OPTIONS
+
+This tool accepts additional command-line arguments.  Refer to the
+L<"SYNOPSIS"> and usage information for details.
+
+=over
+
+=item --config
+
+type: Array
+
+Read this comma-separated list of config files; if specified, this must be the
+first option on the command line.
+
+=item --help
+
+Show help and exit.
+
+=item --match-embedded-numbers
+
+Match numbers embedded in words and replace as single values.  This option
+causes the tool to be more careful about matching numbers so that words
+with numbers, like C<catch22> are matched and replaced as a single C<?>
+placeholder.  Otherwise the default number matching pattern will replace
+C<catch22> as C<catch?>.
+
+This is helpful if database or table names contain numbers.
+
+=item --match-md5-checksums
+
+Match MD5 checksums and replace as single values.  This option causes
+the tool to be more careful about matching numbers so that MD5 checksums
+like C<fbc5e685a5d3d45aa1d0347fdb7c4d35> are matched and replaced as a
+single C<?> placeholder.  Otherwise, the default number matching pattern will
+replace C<fbc5e685a5d3d45aa1d0347fdb7c4d35> as C<fbc?>.
+
+=item --query
+
+type: string
+
+The query to convert into a fingerprint.
+
+=item --version
+
+Show version and exit.
+
+=back
+
+=head1 ENVIRONMENT
+
+The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
+To enable debugging and capture all output to a file, run the tool like:
+
+   PTDEBUG=1 pt-fingerprint ... > FILE 2>&1
+
+Be careful: debugging output is voluminous and can generate several megabytes
+of output.
+
+=head1 SYSTEM REQUIREMENTS
+
+You need Perl, DBI, DBD::mysql, and some core packages that ought to be
+installed in any reasonably new version of Perl.
+
+=head1 BUGS
+
+For a list of known bugs, see L<http://www.percona.com/bugs/pt-fingerprint>.
+
+Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
+Include the following information in your bug report:
+
+=over
+
+=item * Complete command-line used to run the tool
+
+=item * Tool L<"--version">
+
+=item * MySQL version of all servers involved
+
+=item * Output from the tool including STDERR
+
+=item * Input files (log/dump/config files, etc.)
+
+=back
+
+If possible, include debugging output by running the tool with C<PTDEBUG>;
+see L<"ENVIRONMENT">.
+
+=head1 DOWNLOADING
+
+Visit L<http://www.percona.com/software/percona-toolkit/> to download the
+latest release of Percona Toolkit.  Or, get the latest release from the
+command line:
+
+   wget percona.com/get/percona-toolkit.tar.gz
+
+   wget percona.com/get/percona-toolkit.rpm
+
+   wget percona.com/get/percona-toolkit.deb
+
+You can also get individual tools from the latest release:
+
+   wget percona.com/get/TOOL
+
+Replace C<TOOL> with the name of any tool.
+
+=head1 AUTHORS
+
+Baron Schwartz and Daniel Nichter
+
+=head1 ABOUT PERCONA TOOLKIT
+
+This tool is part of Percona Toolkit, a collection of advanced command-line
+tools developed by Percona for MySQL support and consulting.  Percona Toolkit
+was forked from two projects in June, 2011: Maatkit and Aspersa.  Those
+projects were created by Baron Schwartz and developed primarily by him and
+Daniel Nichter, both of whom are employed by Percona.  Visit
+L<http://www.percona.com/software/> for more software developed by Percona.
+
+=head1 COPYRIGHT, LICENSE, AND WARRANTY
+
+This program is copyright 2011-2012 Percona Inc.
+Feedback and improvements are welcome.
+
+THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+This program is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
+systems, you can issue `man perlgpl' or `man perlartistic' to read these
+licenses.
+
+You should have received a copy of the GNU General Public License along with
+this program; if not, write to the Free Software Foundation, Inc., 59 Temple
+Place, Suite 330, Boston, MA  02111-1307  USA.
+
+=head1 VERSION
+
+pt-fingerprint 2.0.0
+
+=cut

=== modified file 'bin/pt-index-usage'
--- bin/pt-index-usage	2012-03-07 23:41:54 +0000
+++ bin/pt-index-usage	2012-03-31 16:07:24 +0000
@@ -2669,19 +2669,58 @@
    return bless $self, $class;
 }
 
+sub get_create_table {
+   my ( $self, $dbh, $db, $tbl ) = @_;
+   die "I need a dbh parameter" unless $dbh;
+   die "I need a db parameter"  unless $db;
+   die "I need a tbl parameter" unless $tbl;
+   my $q = $self->{Quoter};
+
+   my $new_sql_mode
+      = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
+      . q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
+      . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
+      . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
+
+   my $old_sql_mode = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
+                     . '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
+
+   PTDEBUG && _d($new_sql_mode);
+   eval { $dbh->do($new_sql_mode); };
+   PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
+
+   my $use_sql = 'USE ' . $q->quote($db);
+   PTDEBUG && _d($dbh, $use_sql);
+   $dbh->do($use_sql);
+
+   my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
+   PTDEBUG && _d($show_sql);
+   my $href;
+   eval { $href = $dbh->selectrow_hashref($show_sql); };
+   if ( $EVAL_ERROR ) {
+      PTDEBUG && _d($EVAL_ERROR);
+
+      PTDEBUG && _d($old_sql_mode);
+      $dbh->do($old_sql_mode);
+
+      return;
+   }
+
+   PTDEBUG && _d($old_sql_mode);
+   $dbh->do($old_sql_mode);
+
+   my ($key) = grep { m/create (?:table|view)/i } keys %$href;
+   if ( !$key ) {
+      die "Error: no 'Create Table' or 'Create View' in result set from "
+         . "$show_sql: " . Dumper($href);
+   }
+
+   return $href->{$key};
+}
+
 sub parse {
    my ( $self, $ddl, $opts ) = @_;
    return unless $ddl;
-   if ( ref $ddl eq 'ARRAY' ) {
-      if ( lc $ddl->[0] eq 'table' ) {
-         $ddl = $ddl->[1];
-      }
-      else {
-         return {
-            engine => 'VIEW',
-         };
-      }
-   }
 
    if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
       die "Cannot parse table definition; is ANSI quoting "
@@ -2988,41 +3027,31 @@
    return $ddl;
 }
 
-sub remove_secondary_indexes {
-   my ( $self, $ddl ) = @_;
-   my $sec_indexes_ddl;
-   my $tbl_struct = $self->parse($ddl);
-
-   if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
-      my $clustered_key = $tbl_struct->{clustered_key};
-      $clustered_key  ||= '';
-
-      my @sec_indexes   = map {
-         my $key_def = $_->{ddl};
-         $key_def =~ s/([\(\)])/\\$1/g;
-         $ddl =~ s/\s+$key_def//i;
-
-         my $key_ddl = "ADD $_->{ddl}";
-         $key_ddl   .= ',' unless $key_ddl =~ m/,$/;
-         $key_ddl;
-      }
-      grep { $_->{name} ne $clustered_key }
-      values %{$tbl_struct->{keys}};
-      PTDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
-
-      if ( @sec_indexes ) {
-         $sec_indexes_ddl = join(' ', @sec_indexes);
-         $sec_indexes_ddl =~ s/,$//;
-      }
-
-      $ddl =~ s/,(\n\) )/$1/s;
-   }
-   else {
-      PTDEBUG && _d('Not removing secondary indexes from',
-         $tbl_struct->{engine}, 'table');
-   }
-
-   return $ddl, $sec_indexes_ddl, $tbl_struct;
+sub get_table_status {
+   my ( $self, $dbh, $db, $like ) = @_;
+   my $q = $self->{Quoter};
+   my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
+   my @params;
+   if ( $like ) {
+      $sql .= ' LIKE ?';
+      push @params, $like;
+   }
+   PTDEBUG && _d($sql, @params);
+   my $sth = $dbh->prepare($sql);
+   eval { $sth->execute(@params); };
+   if ($EVAL_ERROR) {
+      PTDEBUG && _d($EVAL_ERROR);
+      return;
+   }
+   my @tables = @{$sth->fetchall_arrayref({})};
+   @tables = map {
+      my %tbl; # Make a copy with lowercased keys
+      @tbl{ map { lc $_ } keys %$_ } = values %$_;
+      $tbl{engine} ||= $tbl{type} || $tbl{comment};
+      delete $tbl{type};
+      \%tbl;
+   } @tables;
+   return @tables;
 }
 
 sub _d {
@@ -3912,7 +3941,7 @@
 
 sub new {
    my ( $class, %args ) = @_;
-   my @required_args = qw(OptionParser Quoter);
+   my @required_args = qw(OptionParser TableParser Quoter);
    foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    }
@@ -3921,8 +3950,19 @@
    die "I need either a dbh or file_itr argument"
       if (!$dbh && !$file_itr) || ($dbh && $file_itr);
 
+   my %resume;
+   if ( my $table = $args{resume} ) {
+      PTDEBUG && _d('Will resume from or after', $table);
+      my ($db, $tbl) = $args{Quoter}->split_unquote($table);
+      die "Resume table must be database-qualified: $table"
+         unless $db && $tbl;
+      $resume{db}  = $db;
+      $resume{tbl} = $tbl;
+   }
+
    my $self = {
       %args,
+      resume  => \%resume,
       filters => _make_filters(%args),
    };
 
@@ -3983,9 +4023,19 @@
    return \%filters;
 }
 
-sub next_schema_object {
+sub next {
    my ( $self ) = @_;
 
+   if ( !$self->{initialized} ) {
+      $self->{initialized} = 1;
+      if ( $self->{resume}->{tbl}
+           && !$self->table_is_allowed(@{$self->{resume}}{qw(db tbl)}) ) {
+         PTDEBUG && _d('Will resume after',
+            join('.', @{$self->{resume}}{qw(db tbl)}));
+         $self->{resume}->{after} = 1;
+      }
+   }
+
    my $schema_obj;
    if ( $self->{file_itr} ) {
       $schema_obj= $self->_iterate_files();
@@ -3995,24 +4045,18 @@
    }
 
    if ( $schema_obj ) {
-      if ( $schema_obj->{ddl} && $self->{TableParser} ) {
-         $schema_obj->{tbl_struct}
-            = $self->{TableParser}->parse($schema_obj->{ddl});
-      }
-
-      delete $schema_obj->{ddl} unless $self->{keep_ddl};
-
       if ( my $schema = $self->{Schema} ) {
          $schema->add_schema_object($schema_obj);
       }
+      PTDEBUG && _d('Next schema object:',
+         $schema_obj->{db}, $schema_obj->{tbl});
    }
 
-   PTDEBUG && _d('Next schema object:', $schema_obj->{db}, $schema_obj->{tbl});
    return $schema_obj;
 }
 
 sub _iterate_files {
-   my ( $self ) = @_;
+   my ( $self ) = @_; 
 
    if ( !$self->{fh} ) {
       my ($fh, $file) = $self->{file_itr}->();
@@ -4033,7 +4077,8 @@
          my $db = $1; # XXX
          $db =~ s/^`//;  # strip leading `
          $db =~ s/`$//;  # and trailing `
-         if ( $self->database_is_allowed($db) ) {
+         if ( $self->database_is_allowed($db)
+              && $self->_resume_from_database($db) ) {
             $self->{db} = $db;
          }
       }
@@ -4046,21 +4091,22 @@
          my ($tbl) = $chunk =~ m/$tbl_name/;
          $tbl      =~ s/^\s*`//;
          $tbl      =~ s/`\s*$//;
-         if ( $self->table_is_allowed($self->{db}, $tbl) ) {
+         if ( $self->_resume_from_table($tbl)
+              && $self->table_is_allowed($self->{db}, $tbl) ) {
             my ($ddl) = $chunk =~ m/^(?:$open_comment)?(CREATE TABLE.+?;)$/ms;
             if ( !$ddl ) {
                warn "Failed to parse CREATE TABLE from\n" . $chunk;
                next CHUNK;
             }
             $ddl =~ s/ \*\/;\Z/;/;  # remove end of version comment
-
-            my ($engine) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;   
-
-            if ( !$engine || $self->engine_is_allowed($engine) ) {
+            my $tbl_struct = $self->{TableParser}->parse($ddl);
+            if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
                return {
-                  db  => $self->{db},
-                  tbl => $tbl,
-                  ddl => $ddl,
+                  db         => $self->{db},
+                  tbl        => $tbl,
+                  name       => $self->{Quoter}->quote($self->{db}, $tbl),
+                  ddl        => $ddl,
+                  tbl_struct => $tbl_struct,
                };
             }
          }
@@ -4077,6 +4123,7 @@
 sub _iterate_dbh {
    my ( $self ) = @_;
    my $q   = $self->{Quoter};
+   my $tp  = $self->{TableParser};
    my $dbh = $self->{dbh};
    PTDEBUG && _d('Getting next schema object from dbh', $dbh);
 
@@ -4090,7 +4137,9 @@
    }
 
    if ( !$self->{db} ) {
-      $self->{db} = shift @{$self->{dbs}};
+      do {
+         $self->{db} = shift @{$self->{dbs}};
+      } until $self->_resume_from_database($self->{db});
       PTDEBUG && _d('Next database:', $self->{db});
       return unless $self->{db};
    }
@@ -4103,8 +4152,9 @@
       }
       grep {
          my ($tbl, $type) = @$_;
-         $self->table_is_allowed($self->{db}, $tbl)
-            && (!$type || ($type ne 'VIEW'));
+         (!$type || ($type ne 'VIEW'))
+         && $self->_resume_from_table($tbl)
+         && $self->table_is_allowed($self->{db}, $tbl);
       }
       @{$dbh->selectall_arrayref($sql)};
       PTDEBUG && _d('Found', scalar @tbls, 'tables in database', $self->{db});
@@ -4112,27 +4162,15 @@
    }
 
    while ( my $tbl = shift @{$self->{tbls}} ) {
-      my $engine;
-      if ( $self->{filters}->{'engines'}
-           || $self->{filters}->{'ignore-engines'} ) {
-         my $sql = "SHOW TABLE STATUS FROM " . $q->quote($self->{db})
-                 . " LIKE \'$tbl\'";
-         PTDEBUG && _d($sql);
-         $engine = $dbh->selectrow_hashref($sql)->{engine};
-         PTDEBUG && _d($tbl, 'uses', $engine, 'engine');
-      }
-
-
-      if ( !$engine || $self->engine_is_allowed($engine) ) {
-         my $ddl;
-         if ( my $du = $self->{MySQLDump} ) {
-            $ddl = $du->get_create_table($dbh, $q, $self->{db}, $tbl)->[1];
-         }
-
+      my $ddl        = $tp->get_create_table($dbh, $self->{db}, $tbl);
+      my $tbl_struct = $tp->parse($ddl);
+      if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
          return {
-            db  => $self->{db},
-            tbl => $tbl,
-            ddl => $ddl,
+            db         => $self->{db},
+            tbl        => $tbl,
+            name       => $q->quote($self->{db}, $tbl),
+            ddl        => $ddl,
+            tbl_struct => $tbl_struct,
          };
       }
    }
@@ -4193,6 +4231,10 @@
 
    my $filter = $self->{filters};
 
+   if ( $db eq 'mysql' && ($tbl eq 'general_log' || $tbl eq 'slow_log') ) {
+      return 0;
+   }
+
    if ( $filter->{'ignore-tables'}->{$tbl}
         && ($filter->{'ignore-tables'}->{$tbl} eq '*'
             || $filter->{'ignore-tables'}->{$tbl} eq $db) ) {
@@ -4232,7 +4274,11 @@
 
 sub engine_is_allowed {
    my ( $self, $engine ) = @_;
-   die "I need an engine argument" unless $engine;
+
+   if ( !$engine ) {
+      PTDEBUG && _d('No engine specified; allowing the table');
+      return 1;
+   }
 
    $engine = lc $engine;
 
@@ -4252,6 +4298,40 @@
    return 1;
 }
 
+sub _resume_from_database {
+   my ($self, $db) = @_;
+
+   return 1 unless $self->{resume}->{db};
+
+   if ( $db eq $self->{resume}->{db} ) {
+      PTDEBUG && _d('At resume db', $db);
+      delete $self->{resume}->{db};
+      return 1;
+   }
+
+   return 0;
+}
+
+sub _resume_from_table {
+   my ($self, $tbl) = @_;
+
+   return 1 unless $self->{resume}->{tbl};
+
+   if ( $tbl eq $self->{resume}->{tbl} ) {
+      if ( !$self->{resume}->{after} ) {
+         PTDEBUG && _d('Resuming from table', $tbl);
+         delete $self->{resume}->{tbl};
+         return 1;
+      }
+      else {
+         PTDEBUG && _d('Resuming after table', $tbl);
+         delete $self->{resume}->{tbl};
+      }
+   }
+
+   return 0;
+}
+
 sub _d {
    my ($package, undef, $line) = caller 0;
    @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
@@ -5144,13 +5224,11 @@
       dbh          => $dbh,
       OptionParser => $o,
       Quoter       => $q,
-      MySQLDump    => $du,
       TableParser  => $tp,
       Schema       => $schema,
-      keep_ddl     => 1,
    );
    TALBE:
-   while ( my $tbl = $schema_itr->next_schema_object() ) {
+   while ( my $tbl = $schema_itr->next() ) {
       eval {
          my ($indexes) = $tp->get_keys($tbl->{ddl}, {version => $version});
          $iu->add_indexes(%$tbl, indexes=>$indexes);

=== modified file 'bin/pt-table-checksum'
--- bin/pt-table-checksum	2012-03-30 16:10:23 +0000
+++ bin/pt-table-checksum	2012-03-31 16:07:24 +0000
@@ -3941,22 +3941,15 @@
 
 sub get_row_estimate {
    my (%args) = @_;
-   my @required_args = qw(Cxn tbl OptionParser TableParser Quoter);
-   my ($cxn, $tbl, $o, $tp, $q) = @args{@required_args};
+   my @required_args = qw(Cxn tbl);
+   my ($cxn, $tbl) = @args{@required_args};
 
-   if ( $args{where} ) {
-      PTDEBUG && _d('WHERE clause, using explain plan for row estimate');
-      my $table = $q->quote(@{$tbl}{qw(db tbl)});
-      my $sql   = "EXPLAIN SELECT * FROM $table WHERE $args{where}";
-      PTDEBUG && _d($sql);
-      my $expl = $cxn->dbh()->selectrow_hashref($sql);
-      PTDEBUG && _d(Dumper($expl));
-      return ($expl->{rows} || 0), $expl->{key};
-   }
-   else {
-      PTDEBUG && _d('No WHERE clause, using table status for row estimate');
-      return $tbl->{tbl_status}->{rows} || 0;
-   }
+   my $sql = "EXPLAIN SELECT * FROM $tbl->{name} "
+           . "WHERE " . ($args{where} || '1=1');
+   PTDEBUG && _d($sql);
+   my $expl = $cxn->dbh()->selectrow_hashref($sql);
+   PTDEBUG && _d(Dumper($expl));
+   return ($expl->{rows} || 0), $expl->{key};
 }
 
 sub _prepare_sths {
@@ -4543,7 +4536,7 @@
 
 sub new {
    my ( $class, %args ) = @_;
-   my @required_args = qw(OptionParser Quoter);
+   my @required_args = qw(OptionParser TableParser Quoter);
    foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    }
@@ -4647,25 +4640,18 @@
    }
 
    if ( $schema_obj ) {
-      if ( $schema_obj->{ddl} && $self->{TableParser} ) {
-         $schema_obj->{tbl_struct}
-            = $self->{TableParser}->parse($schema_obj->{ddl});
-      }
-
-      delete $schema_obj->{ddl} unless $self->{keep_ddl};
-      delete $schema_obj->{tbl_status} unless $self->{keep_tbl_status};
-
       if ( my $schema = $self->{Schema} ) {
          $schema->add_schema_object($schema_obj);
       }
-      PTDEBUG && _d('Next schema object:', $schema_obj->{db}, $schema_obj->{tbl});
+      PTDEBUG && _d('Next schema object:',
+         $schema_obj->{db}, $schema_obj->{tbl});
    }
 
    return $schema_obj;
 }
 
 sub _iterate_files {
-   my ( $self ) = @_;
+   my ( $self ) = @_; 
 
    if ( !$self->{fh} ) {
       my ($fh, $file) = $self->{file_itr}->();
@@ -4708,14 +4694,14 @@
                next CHUNK;
             }
             $ddl =~ s/ \*\/;\Z/;/;  # remove end of version comment
-
-            my ($engine) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;   
-
-            if ( !$engine || $self->engine_is_allowed($engine) ) {
+            my $tbl_struct = $self->{TableParser}->parse($ddl);
+            if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
                return {
-                  db  => $self->{db},
-                  tbl => $tbl,
-                  ddl => $ddl,
+                  db         => $self->{db},
+                  tbl        => $tbl,
+                  name       => $self->{Quoter}->quote($self->{db}, $tbl),
+                  ddl        => $ddl,
+                  tbl_struct => $tbl_struct,
                };
             }
          }
@@ -4732,6 +4718,7 @@
 sub _iterate_dbh {
    my ( $self ) = @_;
    my $q   = $self->{Quoter};
+   my $tp  = $self->{TableParser};
    my $dbh = $self->{dbh};
    PTDEBUG && _d('Getting next schema object from dbh', $dbh);
 
@@ -4770,30 +4757,15 @@
    }
 
    while ( my $tbl = shift @{$self->{tbls}} ) {
-      my $tbl_status;
-      if ( $self->{filters}->{'engines'}
-           || $self->{filters}->{'ignore-engines'}
-           || $self->{keep_tbl_status} )
-      {
-         my $sql = "SHOW TABLE STATUS FROM " . $q->quote($self->{db})
-                 . " LIKE \'$tbl\'";
-         PTDEBUG && _d($sql);
-         $tbl_status = $dbh->selectrow_hashref($sql);
-         PTDEBUG && _d(Dumper($tbl_status));
-      }
-
-      if ( !$tbl_status
-           || $self->engine_is_allowed($tbl_status->{engine}) ) {
-         my $ddl;
-         if ( my $tp = $self->{TableParser} ) {
-            $ddl = $tp->get_create_table($dbh, $self->{db}, $tbl);
-         }
-
+      my $ddl        = $tp->get_create_table($dbh, $self->{db}, $tbl);
+      my $tbl_struct = $tp->parse($ddl);
+      if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
          return {
             db         => $self->{db},
             tbl        => $tbl,
+            name       => $q->quote($self->{db}, $tbl),
             ddl        => $ddl,
-            tbl_status => $tbl_status,
+            tbl_struct => $tbl_struct,
          };
       }
    }
@@ -4897,7 +4869,11 @@
 
 sub engine_is_allowed {
    my ( $self, $engine ) = @_;
-   die "I need an engine argument" unless $engine;
+
+   if ( !$engine ) {
+      PTDEBUG && _d('No engine specified; allowing the table');
+      return 1;
+   }
 
    $engine = lc $engine;
 
@@ -6253,13 +6229,12 @@
    }
 
    my $schema_iter = new SchemaIterator(
-      dbh             => $master_dbh,
-      resume          => $last_chunk ? $q->quote(@{$last_chunk}{qw(db tbl)})
-                                     : "",
-      keep_tbl_status => 1,
-      OptionParser    => $o,
-      TableParser     => $tp,
-      Quoter          => $q,
+      dbh          => $master_dbh,
+      resume       => $last_chunk ? $q->quote(@{$last_chunk}{qw(db tbl)})
+                                  : "",
+      OptionParser => $o,
+      TableParser  => $tp,
+      Quoter       => $q,
    );
 
    if ( $last_chunk &&
@@ -6334,13 +6309,13 @@
                my $chunk_size_limit = $o->get('chunk-size-limit');
                my @too_large;
                foreach my $slave ( @$slaves ) {
+                  # get_row_estimate() returns (row_est, index), but
+                  # we only need the row_est.  Maybe in the future we'll
+                  # care what index MySQL will use on a slave.
                   my ($n_rows) = NibbleIterator::get_row_estimate(
-                     Cxn          => $slave,
-                     tbl          => $tbl,
-                     where        => $o->get('where') || "1=1",
-                     OptionParser => $o,
-                     TableParser  => $tp,
-                     Quoter       => $q,
+                     Cxn   => $slave,
+                     tbl   => $tbl,
+                     where => $o->get('where'),
                   );
                   PTDEBUG && _d('Table on', $slave->name(),
                      'has', $n_rows, 'rows');

=== modified file 'bin/pt-table-sync'
--- bin/pt-table-sync	2012-03-30 16:53:51 +0000
+++ bin/pt-table-sync	2012-03-31 16:07:24 +0000
@@ -959,7 +959,7 @@
       $opt->{value} = ($pre || '') . $num;
    }
    else {
-      $self->save_error("Invalid size for --$opt->{long}");
+      $self->save_error("Invalid size for --$opt->{long}: $val");
    }
    return;
 }
@@ -1285,12 +1285,14 @@
 sub as_string {
    my ( $self, $dsn, $props ) = @_;
    return $dsn unless ref $dsn;
-   my %allowed = $props ? map { $_=>1 } @$props : ();
+   my @keys = $props ? @$props : sort keys %$dsn;
    return join(',',
-      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_})  }
-      grep { defined $dsn->{$_} && $self->{opts}->{$_} }
-      grep { !$props || $allowed{$_}                   }
-      sort keys %$dsn );
+      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
+      grep {
+         exists $self->{opts}->{$_}
+         && exists $dsn->{$_}
+         && defined $dsn->{$_}
+      } @keys);
 }
 
 sub usage {
@@ -1741,19 +1743,58 @@
    return bless $self, $class;
 }
 
+sub get_create_table {
+   my ( $self, $dbh, $db, $tbl ) = @_;
+   die "I need a dbh parameter" unless $dbh;
+   die "I need a db parameter"  unless $db;
+   die "I need a tbl parameter" unless $tbl;
+   my $q = $self->{Quoter};
+
+   my $new_sql_mode
+      = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
+      . q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
+      . '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
+      . '@@SQL_QUOTE_SHOW_CREATE := 1 */';
+
+   my $old_sql_mode = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
+                     . '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
+
+   PTDEBUG && _d($new_sql_mode);
+   eval { $dbh->do($new_sql_mode); };
+   PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
+
+   my $use_sql = 'USE ' . $q->quote($db);
+   PTDEBUG && _d($dbh, $use_sql);
+   $dbh->do($use_sql);
+
+   my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
+   PTDEBUG && _d($show_sql);
+   my $href;
+   eval { $href = $dbh->selectrow_hashref($show_sql); };
+   if ( $EVAL_ERROR ) {
+      PTDEBUG && _d($EVAL_ERROR);
+
+      PTDEBUG && _d($old_sql_mode);
+      $dbh->do($old_sql_mode);
+
+      return;
+   }
+
+   PTDEBUG && _d($old_sql_mode);
+   $dbh->do($old_sql_mode);
+
+   my ($key) = grep { m/create (?:table|view)/i } keys %$href;
+   if ( !$key ) {
+      die "Error: no 'Create Table' or 'Create View' in result set from "
+         . "$show_sql: " . Dumper($href);
+   }
+
+   return $href->{$key};
+}
+
 sub parse {
    my ( $self, $ddl, $opts ) = @_;
    return unless $ddl;
-   if ( ref $ddl eq 'ARRAY' ) {
-      if ( lc $ddl->[0] eq 'table' ) {
-         $ddl = $ddl->[1];
-      }
-      else {
-         return {
-            engine => 'VIEW',
-         };
-      }
-   }
 
    if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
       die "Cannot parse table definition; is ANSI quoting "
@@ -2060,41 +2101,31 @@
    return $ddl;
 }
 
-sub remove_secondary_indexes {
-   my ( $self, $ddl ) = @_;
-   my $sec_indexes_ddl;
-   my $tbl_struct = $self->parse($ddl);
-
-   if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
-      my $clustered_key = $tbl_struct->{clustered_key};
-      $clustered_key  ||= '';
-
-      my @sec_indexes   = map {
-         my $key_def = $_->{ddl};
-         $key_def =~ s/([\(\)])/\\$1/g;
-         $ddl =~ s/\s+$key_def//i;
-
-         my $key_ddl = "ADD $_->{ddl}";
-         $key_ddl   .= ',' unless $key_ddl =~ m/,$/;
-         $key_ddl;
-      }
-      grep { $_->{name} ne $clustered_key }
-      values %{$tbl_struct->{keys}};
-      PTDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
-
-      if ( @sec_indexes ) {
-         $sec_indexes_ddl = join(' ', @sec_indexes);
-         $sec_indexes_ddl =~ s/,$//;
-      }
-
-      $ddl =~ s/,(\n\) )/$1/s;
-   }
-   else {
-      PTDEBUG && _d('Not removing secondary indexes from',
-         $tbl_struct->{engine}, 'table');
-   }
-
-   return $ddl, $sec_indexes_ddl, $tbl_struct;
+sub get_table_status {
+   my ( $self, $dbh, $db, $like ) = @_;
+   my $q = $self->{Quoter};
+   my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
+   my @params;
+   if ( $like ) {
+      $sql .= ' LIKE ?';
+      push @params, $like;
+   }
+   PTDEBUG && _d($sql, @params);
+   my $sth = $dbh->prepare($sql);
+   eval { $sth->execute(@params); };
+   if ($EVAL_ERROR) {
+      PTDEBUG && _d($EVAL_ERROR);
+      return;
+   }
+   my @tables = @{$sth->fetchall_arrayref({})};
+   @tables = map {
+      my %tbl; # Make a copy with lowercased keys
+      @tbl{ map { lc $_ } keys %$_ } = values %$_;
+      $tbl{engine} ||= $tbl{type} || $tbl{comment};
+      delete $tbl{type};
+      \%tbl;
+   } @tables;
+   return @tables;
 }
 
 sub _d {
@@ -5445,11 +5476,12 @@
 
    eval {
       if ( my $timeout = $args{wait} ) {
-         my $wait  = $args{wait_retry_args}->{wait}  || 10;
+         my $ms    = $self->{MasterSlave};
          my $tries = $args{wait_retry_args}->{tries} || 3;
+         my $wait;
          $self->{Retry}->retry(
-            wait  => sub { sleep $wait; },
             tries => $tries,
+            wait  => sub { sleep $args{wait_retry_args}->{wait}  || 10 },
             try   => sub {
                my ( %args ) = @_;
 
@@ -5457,12 +5489,18 @@
                   warn "Retrying MASTER_POS_WAIT() for --wait $timeout...";
                }
 
-               my $ms   = $self->{MasterSlave};
-               my $wait = $ms->wait_for_master(
+               $wait = $ms->wait_for_master(
                   master_status => $ms->get_master_status($src->{misc_dbh}),
                   slave_dbh     => $dst->{dbh},
                   timeout       => $timeout,
                );
+               if ( defined $wait->{result} && $wait->{result} != -1 ) {
+                  return;  # slave caught up
+               }
+               die; # call fail
+            },
+            fail => sub {
+               my (%args) = @_;
                if ( !defined $wait->{result} ) {
                   my $msg;
                   if ( $wait->{waited}  ) {
@@ -5477,20 +5515,14 @@
                      $msg .= "  Sleeping $wait seconds then retrying "
                            . ($tries - $args{tryno}) . " more times.";
                   }
-                  warn $msg;
-                  return;
+                  warn "$msg\n";
+                  return 1; # call wait, call try
                }
                elsif ( $wait->{result} == -1 ) {
-                  die "Slave did not catch up to its master after waiting "
-                     . "$timeout seconds with MASTER_POS_WAIT.  Try inceasing "
-                     . "the --wait time, or disable this feature by specifying "
-                     . "--wait 0.";
-               }
-               else {
-                  return $result;  # slave caught up
+                  return 0;  # call final_fail
                }
             },
-            on_failure => sub {
+            final_fail => sub {
                die "Slave did not catch up to its master after $tries attempts "
                   . "of waiting $timeout seconds with MASTER_POS_WAIT.  "
                   . "Check that the slave is running, increase the --wait "
@@ -5603,23 +5635,21 @@
       die "I need a $arg argument" unless defined $args{$arg};
    }
    my ($tbl_struct, $index) = @args{@required_args};
-   my @cols = $args{cols}  ? @{$args{cols}} : @{$tbl_struct->{cols}};
+   my @cols = $args{cols} ? @{$args{cols}} : @{$tbl_struct->{cols}};
    my $q    = $self->{Quoter};
 
    die "Index '$index' does not exist in table"
       unless exists $tbl_struct->{keys}->{$index};
+   PTDEBUG && _d('Will ascend index', $index);  
 
    my @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}};
-   my @asc_slice;
-
-   @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}};
-   PTDEBUG && _d('Will ascend index', $index);
-   PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols));
    if ( $args{asc_first} ) {
       @asc_cols = $asc_cols[0];
       PTDEBUG && _d('Ascending only first column');
    }
+   PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols));
 
+   my @asc_slice;
    my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
    foreach my $col ( @asc_cols ) {
       if ( !exists $col_posn{$col} ) {
@@ -6720,292 +6750,427 @@
 # ###########################################################################
 
 # ###########################################################################
-# SchemaIterator r7141
-# Don't update this package!
+# SchemaIterator 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/SchemaIterator.pm
+#   t/lib/SchemaIterator.t
+# See https://launchpad.net/percona-toolkit for more information.
 # ###########################################################################
+{
 package SchemaIterator;
 
 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;
 
-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
+my $open_comment = qr{/\*!\d{5} };
+my $tbl_name     = qr{
+   CREATE\s+
+   (?:TEMPORARY\s+)?
+   TABLE\s+
+   (?:IF NOT EXISTS\s+)?
+   ([^\(]+)
+}x;
+
 
 sub new {
    my ( $class, %args ) = @_;
-   foreach my $arg ( qw(Quoter) ) {
+   my @required_args = qw(OptionParser TableParser Quoter);
+   foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    }
+
+   my ($file_itr, $dbh) = @args{qw(file_itr dbh)};
+   die "I need either a dbh or file_itr argument"
+      if (!$dbh && !$file_itr) || ($dbh && $file_itr);
+
+   my %resume;
+   if ( my $table = $args{resume} ) {
+      PTDEBUG && _d('Will resume from or after', $table);
+      my ($db, $tbl) = $args{Quoter}->split_unquote($table);
+      die "Resume table must be database-qualified: $table"
+         unless $db && $tbl;
+      $resume{db}  = $db;
+      $resume{tbl} = $tbl;
+   }
+
    my $self = {
       %args,
-      filter => undef,
-      dbs    => [],
+      resume  => \%resume,
+      filters => _make_filters(%args),
    };
+
    return bless $self, $class;
 }
 
-sub make_filter {
-   my ( $self, $o ) = @_;
-   my @lines = (
-      'sub {',
-      '   my ( $dbh, $db, $tbl ) = @_;',
-      '   my $engine = undef;',
-   );
-
-
-   my @permit_dbs = _make_filter('unless', '$db', $o->get('databases'))
-      if $o->has('databases');
-   my @reject_dbs = _make_filter('if', '$db', $o->get('ignore-databases'))
-      if $o->has('ignore-databases');
-   my @dbs_regex;
-   if ( $o->has('databases-regex') && (my $p = $o->get('databases-regex')) ) {
-      push @dbs_regex, "      return 0 unless \$db && (\$db =~ m/$p/o);";
-   }
-   my @reject_dbs_regex;
-   if ( $o->has('ignore-databases-regex')
-        && (my $p = $o->get('ignore-databases-regex')) ) {
-      push @reject_dbs_regex, "      return 0 if \$db && (\$db =~ m/$p/o);";
-   }
-   if ( @permit_dbs || @reject_dbs || @dbs_regex || @reject_dbs_regex ) {
-      push @lines,
-         '   if ( $db ) {',
-            (@permit_dbs        ? @permit_dbs       : ()),
-            (@reject_dbs        ? @reject_dbs       : ()),
-            (@dbs_regex         ? @dbs_regex        : ()),
-            (@reject_dbs_regex  ? @reject_dbs_regex : ()),
-         '   }';
-   }
-
-   if ( $o->has('tables') || $o->has('ignore-tables')
-        || $o->has('ignore-tables-regex') ) {
-
-      my $have_qtbl       = 0;
-      my $have_only_qtbls = 0;
-      my %qtbls;
-
-      my @permit_tbls;
-      my @permit_qtbls;
-      my %permit_qtbls;
-      if ( $o->get('tables') ) {
-         my %tbls;
-         map {
-            if ( $_ =~ m/\./ ) {
-               $permit_qtbls{$_} = 1;
-            }
-            else {
-               $tbls{$_} = 1;
-            }
-         } keys %{ $o->get('tables') };
-         @permit_tbls  = _make_filter('unless', '$tbl', \%tbls);
-         @permit_qtbls = _make_filter('unless', '$qtbl', \%permit_qtbls);
-
-         if ( @permit_qtbls ) {
-            push @lines,
-               '   my $qtbl   = ($db ? "$db." : "") . ($tbl ? $tbl : "");';
-            $have_qtbl = 1;
-         }
-      }
-
-      my @reject_tbls;
-      my @reject_qtbls;
-      my %reject_qtbls;
-      if ( $o->get('ignore-tables') ) {
-         my %tbls;
-         map {
-            if ( $_ =~ m/\./ ) {
-               $reject_qtbls{$_} = 1;
-            }
-            else {
-               $tbls{$_} = 1;
-            }
-         } keys %{ $o->get('ignore-tables') };
-         @reject_tbls= _make_filter('if', '$tbl', \%tbls);
-         @reject_qtbls = _make_filter('if', '$qtbl', \%reject_qtbls);
-
-         if ( @reject_qtbls && !$have_qtbl ) {
-            push @lines,
-               '   my $qtbl   = ($db ? "$db." : "") . ($tbl ? $tbl : "");';
-         }
-      }
-
-      if ( keys %permit_qtbls  && !@permit_dbs ) {
-         my $dbs = {};
-         map {
-            my ($db, undef) = split(/\./, $_);
-            $dbs->{$db} = 1;
-         } keys %permit_qtbls;
-         PTDEBUG && _d('Adding restriction "--databases',
-               (join(',', keys %$dbs) . '"'));
-         if ( keys %$dbs ) {
-            $o->set('databases', $dbs);
-            return $self->make_filter($o);
-         }
-      }
-
-      my @tbls_regex;
-      if ( $o->has('tables-regex') && (my $p = $o->get('tables-regex')) ) {
-         push @tbls_regex, "      return 0 unless \$tbl && (\$tbl =~ m/$p/o);";
-      }
-      my @reject_tbls_regex;
-      if ( $o->has('ignore-tables-regex')
-           && (my $p = $o->get('ignore-tables-regex')) ) {
-         push @reject_tbls_regex,
-            "      return 0 if \$tbl && (\$tbl =~ m/$p/o);";
-      }
-
-      my @get_eng;
-      my @permit_engs;
-      my @reject_engs;
-      if ( ($o->has('engines') && $o->get('engines'))
-           || ($o->has('ignore-engines') && $o->get('ignore-engines')) ) {
-         push @get_eng,
-            '      my $sql = "SHOW TABLE STATUS "',
-            '              . ($db ? "FROM `$db`" : "")',
-            '              . " LIKE \'$tbl\'";',
-            '      PTDEBUG && _d($sql);',
-            '      eval {',
-            '         $engine = $dbh->selectrow_hashref($sql)->{engine};',
-            '      };',
-            '      PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);',
-            '      PTDEBUG && _d($tbl, "uses engine", $engine);',
-            '      $engine = lc $engine if $engine;',
-         @permit_engs
-            = _make_filter('unless', '$engine', $o->get('engines'), 1);
-         @reject_engs
-            = _make_filter('if', '$engine', $o->get('ignore-engines'), 1)
-      }
-
-      if ( @permit_tbls || @permit_qtbls || @reject_tbls || @tbls_regex
-           || @reject_tbls_regex || @permit_engs || @reject_engs ) {
-         push @lines,
-            '   if ( $tbl ) {',
-               (@permit_tbls       ? @permit_tbls        : ()),
-               (@reject_tbls       ? @reject_tbls        : ()),
-               (@tbls_regex        ? @tbls_regex         : ()),
-               (@reject_tbls_regex ? @reject_tbls_regex  : ()),
-               (@permit_qtbls      ? @permit_qtbls       : ()),
-               (@reject_qtbls      ? @reject_qtbls       : ()),
-               (@get_eng           ? @get_eng            : ()),
-               (@permit_engs       ? @permit_engs        : ()),
-               (@reject_engs       ? @reject_engs        : ()),
-            '   }';
-      }
-   }
-
-   push @lines,
-      '   PTDEBUG && _d(\'Passes filters:\', $db, $tbl, $engine, $dbh);',
-      '   return 1;',  '}';
-
-   my $code = join("\n", @lines);
-   PTDEBUG && _d('filter sub:', $code);
-   my $filter_sub= eval $code
-      or die "Error compiling subroutine code:\n$code\n$EVAL_ERROR";
-
-   return $filter_sub;
-}
-
-sub set_filter {
-   my ( $self, $filter_sub ) = @_;
-   $self->{filter} = $filter_sub;
-   PTDEBUG && _d('Set filter sub');
-   return;
-}
-
-sub get_db_itr {
-   my ( $self, %args ) = @_;
-   my @required_args = qw(dbh);
+sub _make_filters {
+   my ( %args ) = @_;
+   my @required_args = qw(OptionParser Quoter);
    foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    }
-   my ($dbh) = @args{@required_args};
-
-   my $filter = $self->{filter};
-   my @dbs;
-   eval {
+   my ($o, $q) = @args{@required_args};
+
+   my %filters;
+
+
+   my @simple_filters = qw(
+      databases         tables         engines
+      ignore-databases  ignore-tables  ignore-engines);
+   FILTER:
+   foreach my $filter ( @simple_filters ) {
+      if ( $o->has($filter) ) {
+         my $objs = $o->get($filter);
+         next FILTER unless $objs && scalar keys %$objs;
+         my $is_table = $filter =~ m/table/ ? 1 : 0;
+         foreach my $obj ( keys %$objs ) {
+            die "Undefined value for --$filter" unless $obj;
+            $obj = lc $obj;
+            if ( $is_table ) {
+               my ($db, $tbl) = $q->split_unquote($obj);
+               $db ||= '*';
+               PTDEBUG && _d('Filter', $filter, 'value:', $db, $tbl);
+               $filters{$filter}->{$tbl} = $db;
+            }
+            else { # database
+               PTDEBUG && _d('Filter', $filter, 'value:', $obj);
+               $filters{$filter}->{$obj} = 1;
+            }
+         }
+      }
+   }
+
+   my @regex_filters = qw(
+      databases-regex         tables-regex
+      ignore-databases-regex  ignore-tables-regex);
+   REGEX_FILTER:
+   foreach my $filter ( @regex_filters ) {
+      if ( $o->has($filter) ) {
+         my $pat = $o->get($filter);
+         next REGEX_FILTER unless $pat;
+         $filters{$filter} = qr/$pat/;
+         PTDEBUG && _d('Filter', $filter, 'value:', $filters{$filter});
+      }
+   }
+
+   PTDEBUG && _d('Schema object filters:', Dumper(\%filters));
+   return \%filters;
+}
+
+sub next {
+   my ( $self ) = @_;
+
+   if ( !$self->{initialized} ) {
+      $self->{initialized} = 1;
+      if ( $self->{resume}->{tbl}
+           && !$self->table_is_allowed(@{$self->{resume}}{qw(db tbl)}) ) {
+         PTDEBUG && _d('Will resume after',
+            join('.', @{$self->{resume}}{qw(db tbl)}));
+         $self->{resume}->{after} = 1;
+      }
+   }
+
+   my $schema_obj;
+   if ( $self->{file_itr} ) {
+      $schema_obj= $self->_iterate_files();
+   }
+   else { # dbh
+      $schema_obj= $self->_iterate_dbh();
+   }
+
+   if ( $schema_obj ) {
+      if ( my $schema = $self->{Schema} ) {
+         $schema->add_schema_object($schema_obj);
+      }
+      PTDEBUG && _d('Next schema object:',
+         $schema_obj->{db}, $schema_obj->{tbl});
+   }
+
+   return $schema_obj;
+}
+
+sub _iterate_files {
+   my ( $self ) = @_; 
+
+   if ( !$self->{fh} ) {
+      my ($fh, $file) = $self->{file_itr}->();
+      if ( !$fh ) {
+         PTDEBUG && _d('No more files to iterate');
+         return;
+      }
+      $self->{fh}   = $fh;
+      $self->{file} = $file;
+   }
+   my $fh = $self->{fh};
+   PTDEBUG && _d('Getting next schema object from', $self->{file});
+
+   local $INPUT_RECORD_SEPARATOR = '';
+   CHUNK:
+   while (defined(my $chunk = <$fh>)) {
+      if ($chunk =~ m/Database: (\S+)/) {
+         my $db = $1; # XXX
+         $db =~ s/^`//;  # strip leading `
+         $db =~ s/`$//;  # and trailing `
+         if ( $self->database_is_allowed($db)
+              && $self->_resume_from_database($db) ) {
+            $self->{db} = $db;
+         }
+      }
+      elsif ($self->{db} && $chunk =~ m/CREATE TABLE/) {
+         if ($chunk =~ m/DROP VIEW IF EXISTS/) {
+            PTDEBUG && _d('Table is a VIEW, skipping');
+            next CHUNK;
+         }
+
+         my ($tbl) = $chunk =~ m/$tbl_name/;
+         $tbl      =~ s/^\s*`//;
+         $tbl      =~ s/`\s*$//;
+         if ( $self->_resume_from_table($tbl)
+              && $self->table_is_allowed($self->{db}, $tbl) ) {
+            my ($ddl) = $chunk =~ m/^(?:$open_comment)?(CREATE TABLE.+?;)$/ms;
+            if ( !$ddl ) {
+               warn "Failed to parse CREATE TABLE from\n" . $chunk;
+               next CHUNK;
+            }
+            $ddl =~ s/ \*\/;\Z/;/;  # remove end of version comment
+            my $tbl_struct = $self->{TableParser}->parse($ddl);
+            if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
+               return {
+                  db         => $self->{db},
+                  tbl        => $tbl,
+                  name       => $self->{Quoter}->quote($self->{db}, $tbl),
+                  ddl        => $ddl,
+                  tbl_struct => $tbl_struct,
+               };
+            }
+         }
+      }
+   }  # CHUNK
+
+   PTDEBUG && _d('No more schema objects in', $self->{file});
+   close $self->{fh};
+   $self->{fh} = undef;
+
+   return $self->_iterate_files();
+}
+
+sub _iterate_dbh {
+   my ( $self ) = @_;
+   my $q   = $self->{Quoter};
+   my $tp  = $self->{TableParser};
+   my $dbh = $self->{dbh};
+   PTDEBUG && _d('Getting next schema object from dbh', $dbh);
+
+   if ( !defined $self->{dbs} ) {
       my $sql = 'SHOW DATABASES';
       PTDEBUG && _d($sql);
-      @dbs =  grep {
-         my $ok = $filter ? $filter->($dbh, $_, undef) : 1;
-         $ok = 0 if $_ =~ m/information_schema|performance_schema|lost\+found/;
-         $ok;
-      } @{ $dbh->selectcol_arrayref($sql) };
+      my @dbs = grep { $self->database_is_allowed($_) }
+                @{$dbh->selectcol_arrayref($sql)};
       PTDEBUG && _d('Found', scalar @dbs, 'databases');
-   };
-
-   PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
-   my $iterator = sub {
-      return shift @dbs;
-   };
-
-   if (wantarray) {
-      return ($iterator, scalar @dbs);
-   }
-   else {
-      return $iterator;
-   }
-}
-
-sub get_tbl_itr {
-   my ( $self, %args ) = @_;
-   my @required_args = qw(dbh db);
-   foreach my $arg ( @required_args ) {
-      die "I need a $arg argument" unless $args{$arg};
-   }
-   my ($dbh, $db, $views) = @args{@required_args, 'views'};
-
-   my $filter = $self->{filter};
-   my @tbls;
-   if ( $db ) {
-      eval {
-         my $sql = 'SHOW /*!50002 FULL*/ TABLES FROM '
-                 . $self->{Quoter}->quote($db);
-         PTDEBUG && _d($sql);
-         @tbls = map {
-            $_->[0]
-         }
-         grep {
-            my ($tbl, $type) = @$_;
-            my $ok = $filter ? $filter->($dbh, $db, $tbl) : 1;
-            if ( !$views ) {
-               $ok = 0 if ($type || '') eq 'VIEW';
-            }
-            $ok;
-         }
-         @{ $dbh->selectall_arrayref($sql) };
-         PTDEBUG && _d('Found', scalar @tbls, 'tables in', $db);
-      };
-      PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
-   }
-   else {
-      PTDEBUG && _d('No db given so no tables');
-   }
-
-   my $iterator = sub {
-      return shift @tbls;
-   };
-
-   if ( wantarray ) {
-      return ($iterator, scalar @tbls);
-   }
-   else {
-      return $iterator;
-   }
-}
-
-sub _make_filter {
-   my ( $cond, $var_name, $objs, $lc ) = @_;
-   my @lines;
-   if ( scalar keys %$objs ) {
-      my $test = join(' || ',
-         map { "$var_name eq '" . ($lc ? lc $_ : $_) ."'" } keys %$objs);
-      push @lines, "      return 0 $cond $var_name && ($test);",
-   }
-   return @lines;
+      $self->{dbs} = \@dbs;
+   }
+
+   if ( !$self->{db} ) {
+      do {
+         $self->{db} = shift @{$self->{dbs}};
+      } until $self->_resume_from_database($self->{db});
+      PTDEBUG && _d('Next database:', $self->{db});
+      return unless $self->{db};
+   }
+
+   if ( !defined $self->{tbls} ) {
+      my $sql = 'SHOW /*!50002 FULL*/ TABLES FROM ' . $q->quote($self->{db});
+      PTDEBUG && _d($sql);
+      my @tbls = map {
+         $_->[0];  # (tbl, type)
+      }
+      grep {
+         my ($tbl, $type) = @$_;
+         (!$type || ($type ne 'VIEW'))
+         && $self->_resume_from_table($tbl)
+         && $self->table_is_allowed($self->{db}, $tbl);
+      }
+      @{$dbh->selectall_arrayref($sql)};
+      PTDEBUG && _d('Found', scalar @tbls, 'tables in database', $self->{db});
+      $self->{tbls} = \@tbls;
+   }
+
+   while ( my $tbl = shift @{$self->{tbls}} ) {
+      my $ddl        = $tp->get_create_table($dbh, $self->{db}, $tbl);
+      my $tbl_struct = $tp->parse($ddl);
+      if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
+         return {
+            db         => $self->{db},
+            tbl        => $tbl,
+            name       => $q->quote($self->{db}, $tbl),
+            ddl        => $ddl,
+            tbl_struct => $tbl_struct,
+         };
+      }
+   }
+
+   PTDEBUG && _d('No more tables in database', $self->{db});
+   $self->{db}   = undef;
+   $self->{tbls} = undef;
+
+   return $self->_iterate_dbh();
+}
+
+sub database_is_allowed {
+   my ( $self, $db ) = @_;
+   die "I need a db argument" unless $db;
+
+   $db = lc $db;
+
+   my $filter = $self->{filters};
+
+   if ( $db =~ m/information_schema|performance_schema|lost\+found/ ) {
+      PTDEBUG && _d('Database', $db, 'is a system database, ignoring');
+      return 0;
+   }
+
+   if ( $self->{filters}->{'ignore-databases'}->{$db} ) {
+      PTDEBUG && _d('Database', $db, 'is in --ignore-databases list');
+      return 0;
+   }
+
+   if ( $filter->{'ignore-databases-regex'}
+        && $db =~ $filter->{'ignore-databases-regex'} ) {
+      PTDEBUG && _d('Database', $db, 'matches --ignore-databases-regex');
+      return 0;
+   }
+
+   if ( $filter->{'databases'}
+        && !$filter->{'databases'}->{$db} ) {
+      PTDEBUG && _d('Database', $db, 'is not in --databases list, ignoring');
+      return 0;
+   }
+
+   if ( $filter->{'databases-regex'}
+        && $db !~ $filter->{'databases-regex'} ) {
+      PTDEBUG && _d('Database', $db, 'does not match --databases-regex, ignoring');
+      return 0;
+   }
+
+   return 1;
+}
+
+sub table_is_allowed {
+   my ( $self, $db, $tbl ) = @_;
+   die "I need a db argument"  unless $db;
+   die "I need a tbl argument" unless $tbl;
+
+   $db  = lc $db;
+   $tbl = lc $tbl;
+
+   my $filter = $self->{filters};
+
+   if ( $db eq 'mysql' && ($tbl eq 'general_log' || $tbl eq 'slow_log') ) {
+      return 0;
+   }
+
+   if ( $filter->{'ignore-tables'}->{$tbl}
+        && ($filter->{'ignore-tables'}->{$tbl} eq '*'
+            || $filter->{'ignore-tables'}->{$tbl} eq $db) ) {
+      PTDEBUG && _d('Table', $tbl, 'is in --ignore-tables list');
+      return 0;
+   }
+
+   if ( $filter->{'ignore-tables-regex'}
+        && $tbl =~ $filter->{'ignore-tables-regex'} ) {
+      PTDEBUG && _d('Table', $tbl, 'matches --ignore-tables-regex');
+      return 0;
+   }
+
+   if ( $filter->{'tables'}
+        && !$filter->{'tables'}->{$tbl} ) { 
+      PTDEBUG && _d('Table', $tbl, 'is not in --tables list, ignoring');
+      return 0;
+   }
+
+   if ( $filter->{'tables-regex'}
+        && $tbl !~ $filter->{'tables-regex'} ) {
+      PTDEBUG && _d('Table', $tbl, 'does not match --tables-regex, ignoring');
+      return 0;
+   }
+
+   if ( $filter->{'tables'}
+        && $filter->{'tables'}->{$tbl}
+        && $filter->{'tables'}->{$tbl} ne '*'
+        && $filter->{'tables'}->{$tbl} ne $db ) {
+      PTDEBUG && _d('Table', $tbl, 'is only allowed in database',
+         $filter->{'tables'}->{$tbl});
+      return 0;
+   }
+
+   return 1;
+}
+
+sub engine_is_allowed {
+   my ( $self, $engine ) = @_;
+
+   if ( !$engine ) {
+      PTDEBUG && _d('No engine specified; allowing the table');
+      return 1;
+   }
+
+   $engine = lc $engine;
+
+   my $filter = $self->{filters};
+
+   if ( $filter->{'ignore-engines'}->{$engine} ) {
+      PTDEBUG && _d('Engine', $engine, 'is in --ignore-databases list');
+      return 0;
+   }
+
+   if ( $filter->{'engines'}
+        && !$filter->{'engines'}->{$engine} ) {
+      PTDEBUG && _d('Engine', $engine, 'is not in --engines list, ignoring');
+      return 0;
+   }
+
+   return 1;
+}
+
+sub _resume_from_database {
+   my ($self, $db) = @_;
+
+   return 1 unless $self->{resume}->{db};
+
+   if ( $db eq $self->{resume}->{db} ) {
+      PTDEBUG && _d('At resume db', $db);
+      delete $self->{resume}->{db};
+      return 1;
+   }
+
+   return 0;
+}
+
+sub _resume_from_table {
+   my ($self, $tbl) = @_;
+
+   return 1 unless $self->{resume}->{tbl};
+
+   if ( $tbl eq $self->{resume}->{tbl} ) {
+      if ( !$self->{resume}->{after} ) {
+         PTDEBUG && _d('Resuming from table', $tbl);
+         delete $self->{resume}->{tbl};
+         return 1;
+      }
+      else {
+         PTDEBUG && _d('Resuming after table', $tbl);
+         delete $self->{resume}->{tbl};
+      }
+   }
+
+   return 0;
 }
 
 sub _d {
@@ -7017,7 +7182,7 @@
 }
 
 1;
-
+}
 # ###########################################################################
 # End SchemaIterator package
 # ###########################################################################
@@ -7304,48 +7469,42 @@
 
 sub retry {
    my ( $self, %args ) = @_;
-   my @required_args = qw(try wait);
+   my @required_args = qw(try fail final_fail);
    foreach my $arg ( @required_args ) {
       die "I need a $arg argument" unless $args{$arg};
    };
-   my ($try, $wait) = @args{@required_args};
+   my ($try, $fail, $final_fail) = @args{@required_args};
+   my $wait  = $args{wait}  || sub { sleep 1; };
    my $tries = $args{tries} || 3;
 
+   my $last_error;
    my $tryno = 0;
+   TRY:
    while ( ++$tryno <= $tries ) {
-      PTDEBUG && _d("Retry", $tryno, "of", $tries);
+      PTDEBUG && _d("Try", $tryno, "of", $tries);
       my $result;
       eval {
          $result = $try->(tryno=>$tryno);
       };
+      if ( $EVAL_ERROR ) {
+         PTDEBUG && _d("Try code failed:", $EVAL_ERROR);
+         $last_error = $EVAL_ERROR;
 
-      if ( defined $result ) {
+         if ( $tryno < $tries ) {   # more retries
+            my $retry = $fail->(tryno=>$tryno, error=>$last_error);
+            last TRY unless $retry;
+            PTDEBUG && _d("Calling wait code");
+            $wait->(tryno=>$tryno);
+         }
+      }
+      else {
          PTDEBUG && _d("Try code succeeded");
-         if ( my $on_success = $args{on_success} ) {
-            PTDEBUG && _d("Calling on_success code");
-            $on_success->(tryno=>$tryno, result=>$result);
-         }
          return $result;
       }
-
-      if ( $EVAL_ERROR ) {
-         PTDEBUG && _d("Try code died:", $EVAL_ERROR);
-         die $EVAL_ERROR unless $args{retry_on_die};
-      }
-
-      if ( $tryno < $tries ) {
-         PTDEBUG && _d("Try code failed, calling wait code");
-         $wait->(tryno=>$tryno);
-      }
-   }
-
-   PTDEBUG && _d("Try code did not succeed");
-   if ( my $on_failure = $args{on_failure} ) {
-      PTDEBUG && _d("Calling on_failure code");
-      $on_failure->();
-   }
-
-   return;
+   }
+
+   PTDEBUG && _d('Try code did not succeed');
+   return $final_fail->(error=>$last_error);
 }
 
 sub _d {
@@ -8006,27 +8165,20 @@
       tbl      => undef,  # set later
    };
 
-   my $si = new SchemaIterator(
-      Quoter => $args{Quoter},
+   my $schema_iter = new SchemaIterator(
+      dbh          => $src->{dbh},
+      OptionParser => $o,
+      TableParser  => $args{TableParser},
+      Quoter       => $args{Quoter},
    );
-   $si->set_filter($si->make_filter($o));
 
    # Make a list of all dbs.tbls on the source.  It's more efficient this
    # way because it avoids open/closing a dbh for each tbl and dsn, unless
    # we pre-opened the dsn.  It would also cause confusing verbose output.
    my @dbs_tbls;
-   my $next_db = $si->get_db_itr(dbh => $src->{dbh});
-   while ( my $db = $next_db->() ) {
-      PTDEBUG && _d('Getting tables from', $db);
-      my $next_tbl = $si->get_tbl_itr(
-         dbh   => $src->{dbh},
-         db    => $db,
-         views => 0,
-      );
-      while ( my $tbl = $next_tbl->() ) {
-         PTDEBUG && _d('Got table', $tbl);
-         push @dbs_tbls, { db => $db, tbl => $tbl };
-      }
+   while ( my $tbl = $schema_iter->next() ) {
+      PTDEBUG && _d('Got table', $tbl->{db}, $tbl->{tbl});
+      push @dbs_tbls, $tbl;
    }
 
    my $exit_status = 0;
@@ -8048,6 +8200,7 @@
       lock_server(src => $src, dst => $dst, %args);
 
       foreach my $db_tbl ( @dbs_tbls ) {
+         $src->{tbl_struct} = $db_tbl->{tbl_struct};
          $src->{db}  = $dst->{db}  = $db_tbl->{db};
          $src->{tbl} = $dst->{tbl} = $db_tbl->{tbl};
 
@@ -8194,8 +8347,9 @@
       $start_ts = get_server_time($src->{dbh}) if $o->get('verbose');
 
       # This will either die if there's a problem or return the tbl struct.
-      my $tbl_struct = ok_to_sync($src, $dst, %args);
-      
+      ok_to_sync($src, $dst, %args);
+      my $tbl_struct = $src->{tbl_struct};
+
       if ( my $diff = $args{diff} ) {
          PTDEBUG && _d('Converting checksum diff to WHERE:', Dumper($diff));
          $args{where} = diff_where(
@@ -8568,35 +8722,30 @@
    }
    my ($src, $dst, $dp, $q, $vp, $tp, $du, $syncer, $o) = @args{@required_args};
 
-   # First things first: check that the src and dst dbs and tbls exist.
-   # This can fail in cases like h=host,D=bad,t=also_bad (i.e. simple
-   # user error).  It can also fail when syncing all dbs/tbls with sync_all()
-   # because the dst db/tbl is assumed to be the same as the src but
-   # this isn't always the case.
-   my $src_tbl_ddl;
-   eval {
-      # FYI: get_create_table() does USE db but doesn't eval it.
-      $src->{dbh}->do("USE `$src->{db}`");
-      $src_tbl_ddl = $du->get_create_table($src->{dbh}, $q,
-         $src->{db}, $src->{tbl});
-   };
-   die $EVAL_ERROR if $EVAL_ERROR;
-
-   my $dst_tbl_ddl;
-   eval {
-      # FYI: get_create_table() does USE db but doesn't eval it.
-      $dst->{dbh}->do("USE `$dst->{db}`");
-      $dst_tbl_ddl = $du->get_create_table($dst->{dbh}, $q,
-         $dst->{db}, $dst->{tbl});
-   };
-   die $EVAL_ERROR if $EVAL_ERROR;
-
-   # This doesn't work at the moment when syncing different table names.
-   # Check that src.db.tbl has the exact same schema as dst.db.tbl.
-   # if ( $o->get('check-schema') && ($src_tbl_ddl ne $dst_tbl_ddl) ) {
-   #   die "Source and destination tables have different schemas";
-   # }
-   my $tbl_struct = $tp->parse($src_tbl_ddl);
+   if ( !$src->{tbl_struct} ) {
+      eval {
+         $src->{ddl} = $tp->get_create_table(
+            $src->{dbh}, $src->{db}, $src->{tbl});
+         $src->{tbl_struct} = $tp->parse($src->{ddl});
+
+      };
+      if ( $EVAL_ERROR ) {
+         die "Error getting table structure for $src->{db}.$src->{tbl} on "
+            . $dp->as_string($src->{dsn}) . "$EVAL_ERROR\nEnsure that "
+            . "the table exists and is accessible.\n";
+      }
+   }
+
+   # Check that the dst has the table.
+   my $dst_has_table = $tp->check_table(
+      dbh => $dst->{dbh},
+      db  => $dst->{db},
+      tbl => $dst->{tbl},
+   );
+   if ( !$dst_has_table ) {
+      die "Table $dst->{db}.$dst->{tbl} does not exist on "
+         . $dp->as_string($dst->{dsn}) . "\n";
+   }
 
    # Check that the user has all the necessary privs on the tbls.
    if ( $o->get('check-privileges') ) {
@@ -8629,7 +8778,7 @@
       }
    }
 
-   return $tbl_struct;
+   return;
 }
 
 # Sub: filter_diffs

=== added file 'bin/pt-table-usage'
--- bin/pt-table-usage	1970-01-01 00:00:00 +0000
+++ bin/pt-table-usage	2012-03-31 16:07:24 +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');
+         }