1#!/usr/bin/env perl
2
3# This program is part of Percona Toolkit: http://www.percona.com/software/
4# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
5# notices and disclaimers.
6
7use strict;
8use warnings FATAL => 'all';
9
10# This tool is "fat-packed": most of its dependent modules are embedded
11# in this file.  Setting %INC to this file for each module makes Perl aware
12# of this so it will not try to load the module from @INC.  See the tool's
13# documentation for a full list of dependencies.
14BEGIN {
15   $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
16      Percona::Toolkit
17      Lmo::Utils
18      Lmo::Meta
19      Lmo::Object
20      Lmo::Types
21      Lmo
22      OptionParser
23      TableParser
24      DSNParser
25      VersionParser
26      Quoter
27      TableNibbler
28      Daemon
29      MasterSlave
30      FlowControlWaiter
31      Cxn
32      HTTP::Micro
33      VersionCheck
34   ));
35}
36
37# ###########################################################################
38# Percona::Toolkit package
39# This package is a copy without comments from the original.  The original
40# with comments and its test file can be found in the Bazaar repository at,
41#   lib/Percona/Toolkit.pm
42#   t/lib/Percona/Toolkit.t
43# See https://launchpad.net/percona-toolkit for more information.
44# ###########################################################################
45{
46package Percona::Toolkit;
47
48our $VERSION = '3.3.0';
49
50use strict;
51use warnings FATAL => 'all';
52use English qw(-no_match_vars);
53use constant PTDEBUG => $ENV{PTDEBUG} || 0;
54
55use Carp qw(carp cluck);
56use Data::Dumper qw();
57
58require Exporter;
59our @ISA         = qw(Exporter);
60our @EXPORT_OK   = qw(
61   have_required_args
62   Dumper
63   _d
64);
65
66sub have_required_args {
67   my ($args, @required_args) = @_;
68   my $have_required_args = 1;
69   foreach my $arg ( @required_args ) {
70      if ( !defined $args->{$arg} ) {
71         $have_required_args = 0;
72         carp "Argument $arg is not defined";
73      }
74   }
75   cluck unless $have_required_args;  # print backtrace
76   return $have_required_args;
77}
78
79sub Dumper {
80   local $Data::Dumper::Indent    = 1;
81   local $Data::Dumper::Sortkeys  = 1;
82   local $Data::Dumper::Quotekeys = 0;
83   Data::Dumper::Dumper(@_);
84}
85
86sub _d {
87   my ($package, undef, $line) = caller 0;
88   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
89        map { defined $_ ? $_ : 'undef' }
90        @_;
91   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
92}
93
941;
95}
96# ###########################################################################
97# End Percona::Toolkit package
98# ###########################################################################
99
100# ###########################################################################
101# Lmo::Utils package
102# This package is a copy without comments from the original.  The original
103# with comments and its test file can be found in the Bazaar repository at,
104#   lib/Lmo/Utils.pm
105#   t/lib/Lmo/Utils.t
106# See https://launchpad.net/percona-toolkit for more information.
107# ###########################################################################
108{
109package Lmo::Utils;
110
111use strict;
112use warnings qw( FATAL all );
113require Exporter;
114our (@ISA, @EXPORT, @EXPORT_OK);
115
116BEGIN {
117   @ISA = qw(Exporter);
118   @EXPORT = @EXPORT_OK = qw(
119      _install_coderef
120      _unimport_coderefs
121      _glob_for
122      _stash_for
123   );
124}
125
126{
127   no strict 'refs';
128   sub _glob_for {
129      return \*{shift()}
130   }
131
132   sub _stash_for {
133      return \%{ shift() . "::" };
134   }
135}
136
137sub _install_coderef {
138   my ($to, $code) = @_;
139
140   return *{ _glob_for $to } = $code;
141}
142
143sub _unimport_coderefs {
144   my ($target, @names) = @_;
145   return unless @names;
146   my $stash = _stash_for($target);
147   foreach my $name (@names) {
148      if ($stash->{$name} and defined(&{$stash->{$name}})) {
149         delete $stash->{$name};
150      }
151   }
152}
153
1541;
155}
156# ###########################################################################
157# End Lmo::Utils package
158# ###########################################################################
159
160# ###########################################################################
161# Lmo::Meta package
162# This package is a copy without comments from the original.  The original
163# with comments and its test file can be found in the Bazaar repository at,
164#   lib/Lmo/Meta.pm
165#   t/lib/Lmo/Meta.t
166# See https://launchpad.net/percona-toolkit for more information.
167# ###########################################################################
168{
169package Lmo::Meta;
170use strict;
171use warnings qw( FATAL all );
172
173my %metadata_for;
174
175sub new {
176   my $class = shift;
177   return bless { @_ }, $class
178}
179
180sub metadata_for {
181   my $self    = shift;
182   my ($class) = @_;
183
184   return $metadata_for{$class} ||= {};
185}
186
187sub class { shift->{class} }
188
189sub attributes {
190   my $self = shift;
191   return keys %{$self->metadata_for($self->class)}
192}
193
194sub attributes_for_new {
195   my $self = shift;
196   my @attributes;
197
198   my $class_metadata = $self->metadata_for($self->class);
199   while ( my ($attr, $meta) = each %$class_metadata ) {
200      if ( exists $meta->{init_arg} ) {
201         push @attributes, $meta->{init_arg}
202               if defined $meta->{init_arg};
203      }
204      else {
205         push @attributes, $attr;
206      }
207   }
208   return @attributes;
209}
210
2111;
212}
213# ###########################################################################
214# End Lmo::Meta package
215# ###########################################################################
216
217# ###########################################################################
218# Lmo::Object package
219# This package is a copy without comments from the original.  The original
220# with comments and its test file can be found in the Bazaar repository at,
221#   lib/Lmo/Object.pm
222#   t/lib/Lmo/Object.t
223# See https://launchpad.net/percona-toolkit for more information.
224# ###########################################################################
225{
226package Lmo::Object;
227
228use strict;
229use warnings qw( FATAL all );
230
231use Carp ();
232use Scalar::Util qw(blessed);
233
234use Lmo::Meta;
235use Lmo::Utils qw(_glob_for);
236
237sub new {
238   my $class = shift;
239   my $args  = $class->BUILDARGS(@_);
240
241   my $class_metadata = Lmo::Meta->metadata_for($class);
242
243   my @args_to_delete;
244   while ( my ($attr, $meta) = each %$class_metadata ) {
245      next unless exists $meta->{init_arg};
246      my $init_arg = $meta->{init_arg};
247
248      if ( defined $init_arg ) {
249         $args->{$attr} = delete $args->{$init_arg};
250      }
251      else {
252         push @args_to_delete, $attr;
253      }
254   }
255
256   delete $args->{$_} for @args_to_delete;
257
258   for my $attribute ( keys %$args ) {
259      if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
260         $args->{$attribute} = $coerce->($args->{$attribute});
261      }
262      if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
263         my ($check_name, $check_sub) = @$isa_check;
264         $check_sub->($args->{$attribute});
265      }
266   }
267
268   while ( my ($attribute, $meta) = each %$class_metadata ) {
269      next unless $meta->{required};
270      Carp::confess("Attribute ($attribute) is required for $class")
271         if ! exists $args->{$attribute}
272   }
273
274   my $self = bless $args, $class;
275
276   my @build_subs;
277   my $linearized_isa = mro::get_linear_isa($class);
278
279   for my $isa_class ( @$linearized_isa ) {
280      unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
281   }
282   my @args = %$args;
283   for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
284      $sub->( $self, @args);
285   }
286   return $self;
287}
288
289sub BUILDARGS {
290   shift; # No need for the classname
291   if ( @_ == 1 && ref($_[0]) ) {
292      Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
293         unless ref($_[0]) eq ref({});
294      return {%{$_[0]}} # We want a new reference, always
295   }
296   else {
297      return { @_ };
298   }
299}
300
301sub meta {
302   my $class = shift;
303   $class    = Scalar::Util::blessed($class) || $class;
304   return Lmo::Meta->new(class => $class);
305}
306
3071;
308}
309# ###########################################################################
310# End Lmo::Object package
311# ###########################################################################
312
313# ###########################################################################
314# Lmo::Types package
315# This package is a copy without comments from the original.  The original
316# with comments and its test file can be found in the Bazaar repository at,
317#   lib/Lmo/Types.pm
318#   t/lib/Lmo/Types.t
319# See https://launchpad.net/percona-toolkit for more information.
320# ###########################################################################
321{
322package Lmo::Types;
323
324use strict;
325use warnings qw( FATAL all );
326
327use Carp ();
328use Scalar::Util qw(looks_like_number blessed);
329
330
331our %TYPES = (
332   Bool   => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
333   Num    => sub { defined $_[0] && looks_like_number($_[0]) },
334   Int    => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
335   Str    => sub { defined $_[0] },
336   Object => sub { defined $_[0] && blessed($_[0]) },
337   FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
338
339   map {
340      my $type = /R/ ? $_ : uc $_;
341      $_ . "Ref" => sub { ref $_[0] eq $type }
342   } qw(Array Code Hash Regexp Glob Scalar)
343);
344
345sub check_type_constaints {
346   my ($attribute, $type_check, $check_name, $val) = @_;
347   ( ref($type_check) eq 'CODE'
348      ? $type_check->($val)
349      : (ref $val eq $type_check
350         || ($val && $val eq $type_check)
351         || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
352   )
353   || Carp::confess(
354        qq<Attribute ($attribute) does not pass the type constraint because: >
355      . qq<Validation failed for '$check_name' with value >
356      . (defined $val ? Lmo::Dumper($val) : 'undef') )
357}
358
359sub _nested_constraints {
360   my ($attribute, $aggregate_type, $type) = @_;
361
362   my $inner_types;
363   if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
364      $inner_types = _nested_constraints($1, $2);
365   }
366   else {
367      $inner_types = $TYPES{$type};
368   }
369
370   if ( $aggregate_type eq 'ArrayRef' ) {
371      return sub {
372         my ($val) = @_;
373         return unless ref($val) eq ref([]);
374
375         if ($inner_types) {
376            for my $value ( @{$val} ) {
377               return unless $inner_types->($value)
378            }
379         }
380         else {
381            for my $value ( @{$val} ) {
382               return unless $value && ($value eq $type
383                        || (Scalar::Util::blessed($value) && $value->isa($type)));
384            }
385         }
386         return 1;
387      };
388   }
389   elsif ( $aggregate_type eq 'Maybe' ) {
390      return sub {
391         my ($value) = @_;
392         return 1 if ! defined($value);
393         if ($inner_types) {
394            return unless $inner_types->($value)
395         }
396         else {
397            return unless $value eq $type
398                        || (Scalar::Util::blessed($value) && $value->isa($type));
399         }
400         return 1;
401      }
402   }
403   else {
404      Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
405   }
406}
407
4081;
409}
410# ###########################################################################
411# End Lmo::Types package
412# ###########################################################################
413
414# ###########################################################################
415# Lmo package
416# This package is a copy without comments from the original.  The original
417# with comments and its test file can be found in the Bazaar repository at,
418#   lib/Lmo.pm
419#   t/lib/Lmo.t
420# See https://launchpad.net/percona-toolkit for more information.
421# ###########################################################################
422{
423BEGIN {
424$INC{"Lmo.pm"} = __FILE__;
425package Lmo;
426our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
427
428
429use strict;
430use warnings qw( FATAL all );
431
432use Carp ();
433use Scalar::Util qw(looks_like_number blessed);
434
435use Lmo::Meta;
436use Lmo::Object;
437use Lmo::Types;
438
439use Lmo::Utils;
440
441my %export_for;
442sub import {
443   warnings->import(qw(FATAL all));
444   strict->import();
445
446   my $caller     = scalar caller(); # Caller's package
447   my %exports = (
448      extends  => \&extends,
449      has      => \&has,
450      with     => \&with,
451      override => \&override,
452      confess  => \&Carp::confess,
453   );
454
455   $export_for{$caller} = \%exports;
456
457   for my $keyword ( keys %exports ) {
458      _install_coderef "${caller}::$keyword" => $exports{$keyword};
459   }
460
461   if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
462      @_ = "Lmo::Object";
463      goto *{ _glob_for "${caller}::extends" }{CODE};
464   }
465}
466
467sub extends {
468   my $caller = scalar caller();
469   for my $class ( @_ ) {
470      _load_module($class);
471   }
472   _set_package_isa($caller, @_);
473   _set_inherited_metadata($caller);
474}
475
476sub _load_module {
477   my ($class) = @_;
478
479   (my $file = $class) =~ s{::|'}{/}g;
480   $file .= '.pm';
481   { local $@; eval { require "$file" } } # or warn $@;
482   return;
483}
484
485sub with {
486   my $package = scalar caller();
487   require Role::Tiny;
488   for my $role ( @_ ) {
489      _load_module($role);
490      _role_attribute_metadata($package, $role);
491   }
492   Role::Tiny->apply_roles_to_package($package, @_);
493}
494
495sub _role_attribute_metadata {
496   my ($package, $role) = @_;
497
498   my $package_meta = Lmo::Meta->metadata_for($package);
499   my $role_meta    = Lmo::Meta->metadata_for($role);
500
501   %$package_meta = (%$role_meta, %$package_meta);
502}
503
504sub has {
505   my $names  = shift;
506   my $caller = scalar caller();
507
508   my $class_metadata = Lmo::Meta->metadata_for($caller);
509
510   for my $attribute ( ref $names ? @$names : $names ) {
511      my %args   = @_;
512      my $method = ($args{is} || '') eq 'ro'
513         ? sub {
514            Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
515               if $#_;
516            return $_[0]{$attribute};
517         }
518         : sub {
519            return $#_
520                  ? $_[0]{$attribute} = $_[1]
521                  : $_[0]{$attribute};
522         };
523
524      $class_metadata->{$attribute} = ();
525
526      if ( my $type_check = $args{isa} ) {
527         my $check_name = $type_check;
528
529         if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
530            $type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
531         }
532
533         my $check_sub = sub {
534            my ($new_val) = @_;
535            Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
536         };
537
538         $class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
539         my $orig_method = $method;
540         $method = sub {
541            $check_sub->($_[1]) if $#_;
542            goto &$orig_method;
543         };
544      }
545
546      if ( my $builder = $args{builder} ) {
547         my $original_method = $method;
548         $method = sub {
549               $#_
550                  ? goto &$original_method
551                  : ! exists $_[0]{$attribute}
552                     ? $_[0]{$attribute} = $_[0]->$builder
553                     : goto &$original_method
554         };
555      }
556
557      if ( my $code = $args{default} ) {
558         Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
559               unless ref($code) eq 'CODE';
560         my $original_method = $method;
561         $method = sub {
562               $#_
563                  ? goto &$original_method
564                  : ! exists $_[0]{$attribute}
565                     ? $_[0]{$attribute} = $_[0]->$code
566                     : goto &$original_method
567         };
568      }
569
570      if ( my $role = $args{does} ) {
571         my $original_method = $method;
572         $method = sub {
573            if ( $#_ ) {
574               Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
575                  unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
576            }
577            goto &$original_method
578         };
579      }
580
581      if ( my $coercion = $args{coerce} ) {
582         $class_metadata->{$attribute}{coerce} = $coercion;
583         my $original_method = $method;
584         $method = sub {
585            if ( $#_ ) {
586               return $original_method->($_[0], $coercion->($_[1]))
587            }
588            goto &$original_method;
589         }
590      }
591
592      _install_coderef "${caller}::$attribute" => $method;
593
594      if ( $args{required} ) {
595         $class_metadata->{$attribute}{required} = 1;
596      }
597
598      if ($args{clearer}) {
599         _install_coderef "${caller}::$args{clearer}"
600            => sub { delete shift->{$attribute} }
601      }
602
603      if ($args{predicate}) {
604         _install_coderef "${caller}::$args{predicate}"
605            => sub { exists shift->{$attribute} }
606      }
607
608      if ($args{handles}) {
609         _has_handles($caller, $attribute, \%args);
610      }
611
612      if (exists $args{init_arg}) {
613         $class_metadata->{$attribute}{init_arg} = $args{init_arg};
614      }
615   }
616}
617
618sub _has_handles {
619   my ($caller, $attribute, $args) = @_;
620   my $handles = $args->{handles};
621
622   my $ref = ref $handles;
623   my $kv;
624   if ( $ref eq ref [] ) {
625         $kv = { map { $_,$_ } @{$handles} };
626   }
627   elsif ( $ref eq ref {} ) {
628         $kv = $handles;
629   }
630   elsif ( $ref eq ref qr// ) {
631         Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
632            unless $args->{isa};
633         my $target_class = $args->{isa};
634         $kv = {
635            map   { $_, $_     }
636            grep  { $_ =~ $handles }
637            grep  { !exists $Lmo::Object::{$_} && $target_class->can($_) }
638            grep  { !$export_for{$target_class}->{$_} }
639            keys %{ _stash_for $target_class }
640         };
641   }
642   else {
643         Carp::confess("handles for $ref not yet implemented");
644   }
645
646   while ( my ($method, $target) = each %{$kv} ) {
647         my $name = _glob_for "${caller}::$method";
648         Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
649            if defined &$name;
650
651         my ($target, @curried_args) = ref($target) ? @$target : $target;
652         *$name = sub {
653            my $self        = shift;
654            my $delegate_to = $self->$attribute();
655            my $error = "Cannot delegate $method to $target because the value of $attribute";
656            Carp::confess("$error is not defined") unless $delegate_to;
657            Carp::confess("$error is not an object (got '$delegate_to')")
658               unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
659            return $delegate_to->$target(@curried_args, @_);
660         }
661   }
662}
663
664sub _set_package_isa {
665   my ($package, @new_isa) = @_;
666   my $package_isa  = \*{ _glob_for "${package}::ISA" };
667   @{*$package_isa} = @new_isa;
668}
669
670sub _set_inherited_metadata {
671   my $class = shift;
672   my $class_metadata = Lmo::Meta->metadata_for($class);
673   my $linearized_isa = mro::get_linear_isa($class);
674   my %new_metadata;
675
676   for my $isa_class (reverse @$linearized_isa) {
677      my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
678      %new_metadata = (
679         %new_metadata,
680         %$isa_metadata,
681      );
682   }
683   %$class_metadata = %new_metadata;
684}
685
686sub unimport {
687   my $caller = scalar caller();
688   my $target = caller;
689  _unimport_coderefs($target, keys %{$export_for{$caller}});
690}
691
692sub Dumper {
693   require Data::Dumper;
694   local $Data::Dumper::Indent    = 0;
695   local $Data::Dumper::Sortkeys  = 0;
696   local $Data::Dumper::Quotekeys = 0;
697   local $Data::Dumper::Terse     = 1;
698
699   Data::Dumper::Dumper(@_)
700}
701
702BEGIN {
703   if ($] >= 5.010) {
704      { local $@; require mro; }
705   }
706   else {
707      local $@;
708      eval {
709         require MRO::Compat;
710      } or do {
711         *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
712            no strict 'refs';
713
714            my $classname = shift;
715
716            my @lin = ($classname);
717            my %stored;
718            foreach my $parent (@{"$classname\::ISA"}) {
719               my $plin = mro::get_linear_isa_dfs($parent);
720               foreach (@$plin) {
721                     next if exists $stored{$_};
722                     push(@lin, $_);
723                     $stored{$_} = 1;
724               }
725            }
726            return \@lin;
727         };
728      }
729   }
730}
731
732sub override {
733   my ($methods, $code) = @_;
734   my $caller          = scalar caller;
735
736   for my $method ( ref($methods) ? @$methods : $methods ) {
737      my $full_method     = "${caller}::${method}";
738      *{_glob_for $full_method} = $code;
739   }
740}
741
742}
7431;
744}
745# ###########################################################################
746# End Lmo package
747# ###########################################################################
748
749# ###########################################################################
750# OptionParser package
751# This package is a copy without comments from the original.  The original
752# with comments and its test file can be found in the Bazaar repository at,
753#   lib/OptionParser.pm
754#   t/lib/OptionParser.t
755# See https://launchpad.net/percona-toolkit for more information.
756# ###########################################################################
757{
758package OptionParser;
759
760use strict;
761use warnings FATAL => 'all';
762use English qw(-no_match_vars);
763use constant PTDEBUG => $ENV{PTDEBUG} || 0;
764
765use List::Util qw(max);
766use Getopt::Long;
767use Data::Dumper;
768
769my $POD_link_re = '[LC]<"?([^">]+)"?>';
770
771sub new {
772   my ( $class, %args ) = @_;
773   my @required_args = qw();
774   foreach my $arg ( @required_args ) {
775      die "I need a $arg argument" unless $args{$arg};
776   }
777
778   my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
779   $program_name ||= $PROGRAM_NAME;
780   my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
781
782   my %attributes = (
783      'type'       => 1,
784      'short form' => 1,
785      'group'      => 1,
786      'default'    => 1,
787      'cumulative' => 1,
788      'negatable'  => 1,
789      'repeatable' => 1,  # means it can be specified more than once
790   );
791
792   my $self = {
793      head1             => 'OPTIONS',        # These args are used internally
794      skip_rules        => 0,                # to instantiate another Option-
795      item              => '--(.*)',         # Parser obj that parses the
796      attributes        => \%attributes,     # DSN OPTIONS section.  Tools
797      parse_attributes  => \&_parse_attribs, # don't tinker with these args.
798
799      %args,
800
801      strict            => 1,  # disabled by a special rule
802      program_name      => $program_name,
803      opts              => {},
804      got_opts          => 0,
805      short_opts        => {},
806      defaults          => {},
807      groups            => {},
808      allowed_groups    => {},
809      errors            => [],
810      rules             => [],  # desc of rules for --help
811      mutex             => [],  # rule: opts are mutually exclusive
812      atleast1          => [],  # rule: at least one opt is required
813      disables          => {},  # rule: opt disables other opts
814      defaults_to       => {},  # rule: opt defaults to value of other opt
815      DSNParser         => undef,
816      default_files     => [
817         "/etc/percona-toolkit/percona-toolkit.conf",
818         "/etc/percona-toolkit/$program_name.conf",
819         "$home/.percona-toolkit.conf",
820         "$home/.$program_name.conf",
821      ],
822      types             => {
823         string => 's', # standard Getopt type
824         int    => 'i', # standard Getopt type
825         float  => 'f', # standard Getopt type
826         Hash   => 'H', # hash, formed from a comma-separated list
827         hash   => 'h', # hash as above, but only if a value is given
828         Array  => 'A', # array, similar to Hash
829         array  => 'a', # array, similar to hash
830         DSN    => 'd', # DSN
831         size   => 'z', # size with kMG suffix (powers of 2^10)
832         time   => 'm', # time, with an optional suffix of s/h/m/d
833      },
834   };
835
836   return bless $self, $class;
837}
838
839sub get_specs {
840   my ( $self, $file ) = @_;
841   $file ||= $self->{file} || __FILE__;
842   my @specs = $self->_pod_to_specs($file);
843   $self->_parse_specs(@specs);
844
845   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
846   my $contents = do { local $/ = undef; <$fh> };
847   close $fh;
848   if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
849      PTDEBUG && _d('Parsing DSN OPTIONS');
850      my $dsn_attribs = {
851         dsn  => 1,
852         copy => 1,
853      };
854      my $parse_dsn_attribs = sub {
855         my ( $self, $option, $attribs ) = @_;
856         map {
857            my $val = $attribs->{$_};
858            if ( $val ) {
859               $val    = $val eq 'yes' ? 1
860                       : $val eq 'no'  ? 0
861                       :                 $val;
862               $attribs->{$_} = $val;
863            }
864         } keys %$attribs;
865         return {
866            key => $option,
867            %$attribs,
868         };
869      };
870      my $dsn_o = new OptionParser(
871         description       => 'DSN OPTIONS',
872         head1             => 'DSN OPTIONS',
873         dsn               => 0,         # XXX don't infinitely recurse!
874         item              => '\* (.)',  # key opts are a single character
875         skip_rules        => 1,         # no rules before opts
876         attributes        => $dsn_attribs,
877         parse_attributes  => $parse_dsn_attribs,
878      );
879      my @dsn_opts = map {
880         my $opts = {
881            key  => $_->{spec}->{key},
882            dsn  => $_->{spec}->{dsn},
883            copy => $_->{spec}->{copy},
884            desc => $_->{desc},
885         };
886         $opts;
887      } $dsn_o->_pod_to_specs($file);
888      $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
889   }
890
891   if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
892      $self->{version} = $1;
893      PTDEBUG && _d($self->{version});
894   }
895
896   return;
897}
898
899sub DSNParser {
900   my ( $self ) = @_;
901   return $self->{DSNParser};
902};
903
904sub get_defaults_files {
905   my ( $self ) = @_;
906   return @{$self->{default_files}};
907}
908
909sub _pod_to_specs {
910   my ( $self, $file ) = @_;
911   $file ||= $self->{file} || __FILE__;
912   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
913
914   my @specs = ();
915   my @rules = ();
916   my $para;
917
918   local $INPUT_RECORD_SEPARATOR = '';
919   while ( $para = <$fh> ) {
920      next unless $para =~ m/^=head1 $self->{head1}/;
921      last;
922   }
923
924   while ( $para = <$fh> ) {
925      last if $para =~ m/^=over/;
926      next if $self->{skip_rules};
927      chomp $para;
928      $para =~ s/\s+/ /g;
929      $para =~ s/$POD_link_re/$1/go;
930      PTDEBUG && _d('Option rule:', $para);
931      push @rules, $para;
932   }
933
934   die "POD has no $self->{head1} section" unless $para;
935
936   do {
937      if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
938         chomp $para;
939         PTDEBUG && _d($para);
940         my %attribs;
941
942         $para = <$fh>; # read next paragraph, possibly attributes
943
944         if ( $para =~ m/: / ) { # attributes
945            $para =~ s/\s+\Z//g;
946            %attribs = map {
947                  my ( $attrib, $val) = split(/: /, $_);
948                  die "Unrecognized attribute for --$option: $attrib"
949                     unless $self->{attributes}->{$attrib};
950                  ($attrib, $val);
951               } split(/; /, $para);
952            if ( $attribs{'short form'} ) {
953               $attribs{'short form'} =~ s/-//;
954            }
955            $para = <$fh>; # read next paragraph, probably short help desc
956         }
957         else {
958            PTDEBUG && _d('Option has no attributes');
959         }
960
961         $para =~ s/\s+\Z//g;
962         $para =~ s/\s+/ /g;
963         $para =~ s/$POD_link_re/$1/go;
964
965         $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
966         PTDEBUG && _d('Short help:', $para);
967
968         die "No description after option spec $option" if $para =~ m/^=item/;
969
970         if ( my ($base_option) =  $option =~ m/^\[no\](.*)/ ) {
971            $option = $base_option;
972            $attribs{'negatable'} = 1;
973         }
974
975         push @specs, {
976            spec  => $self->{parse_attributes}->($self, $option, \%attribs),
977            desc  => $para
978               . (defined $attribs{default} ? " (default $attribs{default})" : ''),
979            group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
980            attributes => \%attribs
981         };
982      }
983      while ( $para = <$fh> ) {
984         last unless $para;
985         if ( $para =~ m/^=head1/ ) {
986            $para = undef; # Can't 'last' out of a do {} block.
987            last;
988         }
989         last if $para =~ m/^=item /;
990      }
991   } while ( $para );
992
993   die "No valid specs in $self->{head1}" unless @specs;
994
995   close $fh;
996   return @specs, @rules;
997}
998
999sub _parse_specs {
1000   my ( $self, @specs ) = @_;
1001   my %disables; # special rule that requires deferred checking
1002
1003   foreach my $opt ( @specs ) {
1004      if ( ref $opt ) { # It's an option spec, not a rule.
1005         PTDEBUG && _d('Parsing opt spec:',
1006            map { ($_, '=>', $opt->{$_}) } keys %$opt);
1007
1008         my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
1009         if ( !$long ) {
1010            die "Cannot parse long option from spec $opt->{spec}";
1011         }
1012         $opt->{long} = $long;
1013
1014         die "Duplicate long option --$long" if exists $self->{opts}->{$long};
1015         $self->{opts}->{$long} = $opt;
1016
1017         if ( length $long == 1 ) {
1018            PTDEBUG && _d('Long opt', $long, 'looks like short opt');
1019            $self->{short_opts}->{$long} = $long;
1020         }
1021
1022         if ( $short ) {
1023            die "Duplicate short option -$short"
1024               if exists $self->{short_opts}->{$short};
1025            $self->{short_opts}->{$short} = $long;
1026            $opt->{short} = $short;
1027         }
1028         else {
1029            $opt->{short} = undef;
1030         }
1031
1032         $opt->{is_negatable}  = $opt->{spec} =~ m/!/        ? 1 : 0;
1033         $opt->{is_cumulative} = $opt->{spec} =~ m/\+/       ? 1 : 0;
1034         $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0;
1035         $opt->{is_required}   = $opt->{desc} =~ m/required/ ? 1 : 0;
1036
1037         $opt->{group} ||= 'default';
1038         $self->{groups}->{ $opt->{group} }->{$long} = 1;
1039
1040         $opt->{value} = undef;
1041         $opt->{got}   = 0;
1042
1043         my ( $type ) = $opt->{spec} =~ m/=(.)/;
1044         $opt->{type} = $type;
1045         PTDEBUG && _d($long, 'type:', $type);
1046
1047
1048         $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
1049
1050         if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
1051            $self->{defaults}->{$long} = defined $def ? $def : 1;
1052            PTDEBUG && _d($long, 'default:', $def);
1053         }
1054
1055         if ( $long eq 'config' ) {
1056            $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
1057         }
1058
1059         if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
1060            $disables{$long} = $dis;
1061            PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
1062         }
1063
1064         $self->{opts}->{$long} = $opt;
1065      }
1066      else { # It's an option rule, not a spec.
1067         PTDEBUG && _d('Parsing rule:', $opt);
1068         push @{$self->{rules}}, $opt;
1069         my @participants = $self->_get_participants($opt);
1070         my $rule_ok = 0;
1071
1072         if ( $opt =~ m/mutually exclusive|one and only one/ ) {
1073            $rule_ok = 1;
1074            push @{$self->{mutex}}, \@participants;
1075            PTDEBUG && _d(@participants, 'are mutually exclusive');
1076         }
1077         if ( $opt =~ m/at least one|one and only one/ ) {
1078            $rule_ok = 1;
1079            push @{$self->{atleast1}}, \@participants;
1080            PTDEBUG && _d(@participants, 'require at least one');
1081         }
1082         if ( $opt =~ m/default to/ ) {
1083            $rule_ok = 1;
1084            $self->{defaults_to}->{$participants[0]} = $participants[1];
1085            PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
1086         }
1087         if ( $opt =~ m/restricted to option groups/ ) {
1088            $rule_ok = 1;
1089            my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
1090            my @groups = split(',', $groups);
1091            %{$self->{allowed_groups}->{$participants[0]}} = map {
1092               s/\s+//;
1093               $_ => 1;
1094            } @groups;
1095         }
1096         if( $opt =~ m/accepts additional command-line arguments/ ) {
1097            $rule_ok = 1;
1098            $self->{strict} = 0;
1099            PTDEBUG && _d("Strict mode disabled by rule");
1100         }
1101
1102         die "Unrecognized option rule: $opt" unless $rule_ok;
1103      }
1104   }
1105
1106   foreach my $long ( keys %disables ) {
1107      my @participants = $self->_get_participants($disables{$long});
1108      $self->{disables}->{$long} = \@participants;
1109      PTDEBUG && _d('Option', $long, 'disables', @participants);
1110   }
1111
1112   return;
1113}
1114
1115sub _get_participants {
1116   my ( $self, $str ) = @_;
1117   my @participants;
1118   foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
1119      die "Option --$long does not exist while processing rule $str"
1120         unless exists $self->{opts}->{$long};
1121      push @participants, $long;
1122   }
1123   PTDEBUG && _d('Participants for', $str, ':', @participants);
1124   return @participants;
1125}
1126
1127sub opts {
1128   my ( $self ) = @_;
1129   my %opts = %{$self->{opts}};
1130   return %opts;
1131}
1132
1133sub short_opts {
1134   my ( $self ) = @_;
1135   my %short_opts = %{$self->{short_opts}};
1136   return %short_opts;
1137}
1138
1139sub set_defaults {
1140   my ( $self, %defaults ) = @_;
1141   $self->{defaults} = {};
1142   foreach my $long ( keys %defaults ) {
1143      die "Cannot set default for nonexistent option $long"
1144         unless exists $self->{opts}->{$long};
1145      $self->{defaults}->{$long} = $defaults{$long};
1146      PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
1147   }
1148   return;
1149}
1150
1151sub get_defaults {
1152   my ( $self ) = @_;
1153   return $self->{defaults};
1154}
1155
1156sub get_groups {
1157   my ( $self ) = @_;
1158   return $self->{groups};
1159}
1160
1161sub _set_option {
1162   my ( $self, $opt, $val ) = @_;
1163   my $long = exists $self->{opts}->{$opt}       ? $opt
1164            : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
1165            : die "Getopt::Long gave a nonexistent option: $opt";
1166   $opt = $self->{opts}->{$long};
1167   if ( $opt->{is_cumulative} ) {
1168      $opt->{value}++;
1169   }
1170   elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
1171      my $next_opt = $1;
1172      if (    exists $self->{opts}->{$next_opt}
1173           || exists $self->{short_opts}->{$next_opt} ) {
1174         $self->save_error("--$long requires a string value");
1175         return;
1176      }
1177      else {
1178         if ($opt->{is_repeatable}) {
1179            push @{$opt->{value}} , $val;
1180         }
1181         else {
1182            $opt->{value} = $val;
1183         }
1184      }
1185   }
1186   else {
1187      if ($opt->{is_repeatable}) {
1188         push @{$opt->{value}} , $val;
1189      }
1190      else {
1191         $opt->{value} = $val;
1192      }
1193   }
1194   $opt->{got} = 1;
1195   PTDEBUG && _d('Got option', $long, '=', $val);
1196}
1197
1198sub get_opts {
1199   my ( $self ) = @_;
1200
1201   foreach my $long ( keys %{$self->{opts}} ) {
1202      $self->{opts}->{$long}->{got} = 0;
1203      $self->{opts}->{$long}->{value}
1204         = exists $self->{defaults}->{$long}       ? $self->{defaults}->{$long}
1205         : $self->{opts}->{$long}->{is_cumulative} ? 0
1206         : undef;
1207   }
1208   $self->{got_opts} = 0;
1209
1210   $self->{errors} = [];
1211
1212   if ( @ARGV && $ARGV[0] =~/^--config=/ ) {
1213      $ARGV[0] = substr($ARGV[0],9);
1214      $ARGV[0] =~ s/^'(.*)'$/$1/;
1215      $ARGV[0] =~ s/^"(.*)"$/$1/;
1216      $self->_set_option('config', shift @ARGV);
1217   }
1218   if ( @ARGV && $ARGV[0] eq "--config" ) {
1219      shift @ARGV;
1220      $self->_set_option('config', shift @ARGV);
1221   }
1222   if ( $self->has('config') ) {
1223      my @extra_args;
1224      foreach my $filename ( split(',', $self->get('config')) ) {
1225         eval {
1226            push @extra_args, $self->_read_config_file($filename);
1227         };
1228         if ( $EVAL_ERROR ) {
1229            if ( $self->got('config') ) {
1230               die $EVAL_ERROR;
1231            }
1232            elsif ( PTDEBUG ) {
1233               _d($EVAL_ERROR);
1234            }
1235         }
1236      }
1237      unshift @ARGV, @extra_args;
1238   }
1239
1240   Getopt::Long::Configure('no_ignore_case', 'bundling');
1241   GetOptions(
1242      map    { $_->{spec} => sub { $self->_set_option(@_); } }
1243      grep   { $_->{long} ne 'config' } # --config is handled specially above.
1244      values %{$self->{opts}}
1245   ) or $self->save_error('Error parsing options');
1246
1247   if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
1248      if ( $self->{version} ) {
1249         print $self->{version}, "\n";
1250         exit 0;
1251      }
1252      else {
1253         print "Error parsing version.  See the VERSION section of the tool's documentation.\n";
1254         exit 1;
1255      }
1256   }
1257
1258   if ( @ARGV && $self->{strict} ) {
1259      $self->save_error("Unrecognized command-line options @ARGV");
1260   }
1261
1262   foreach my $mutex ( @{$self->{mutex}} ) {
1263      my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
1264      if ( @set > 1 ) {
1265         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
1266                      @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
1267                 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
1268                 . ' are mutually exclusive.';
1269         $self->save_error($err);
1270      }
1271   }
1272
1273   foreach my $required ( @{$self->{atleast1}} ) {
1274      my @set = grep { $self->{opts}->{$_}->{got} } @$required;
1275      if ( @set == 0 ) {
1276         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
1277                      @{$required}[ 0 .. scalar(@$required) - 2] )
1278                 .' or --'.$self->{opts}->{$required->[-1]}->{long};
1279         $self->save_error("Specify at least one of $err");
1280      }
1281   }
1282
1283   $self->_check_opts( keys %{$self->{opts}} );
1284   $self->{got_opts} = 1;
1285   return;
1286}
1287
1288sub _check_opts {
1289   my ( $self, @long ) = @_;
1290   my $long_last = scalar @long;
1291   while ( @long ) {
1292      foreach my $i ( 0..$#long ) {
1293         my $long = $long[$i];
1294         next unless $long;
1295         my $opt  = $self->{opts}->{$long};
1296         if ( $opt->{got} ) {
1297            if ( exists $self->{disables}->{$long} ) {
1298               my @disable_opts = @{$self->{disables}->{$long}};
1299               map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
1300               PTDEBUG && _d('Unset options', @disable_opts,
1301                  'because', $long,'disables them');
1302            }
1303
1304            if ( exists $self->{allowed_groups}->{$long} ) {
1305
1306               my @restricted_groups = grep {
1307                  !exists $self->{allowed_groups}->{$long}->{$_}
1308               } keys %{$self->{groups}};
1309
1310               my @restricted_opts;
1311               foreach my $restricted_group ( @restricted_groups ) {
1312                  RESTRICTED_OPT:
1313                  foreach my $restricted_opt (
1314                     keys %{$self->{groups}->{$restricted_group}} )
1315                  {
1316                     next RESTRICTED_OPT if $restricted_opt eq $long;
1317                     push @restricted_opts, $restricted_opt
1318                        if $self->{opts}->{$restricted_opt}->{got};
1319                  }
1320               }
1321
1322               if ( @restricted_opts ) {
1323                  my $err;
1324                  if ( @restricted_opts == 1 ) {
1325                     $err = "--$restricted_opts[0]";
1326                  }
1327                  else {
1328                     $err = join(', ',
1329                               map { "--$self->{opts}->{$_}->{long}" }
1330                               grep { $_ }
1331                               @restricted_opts[0..scalar(@restricted_opts) - 2]
1332                            )
1333                          . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
1334                  }
1335                  $self->save_error("--$long is not allowed with $err");
1336               }
1337            }
1338
1339         }
1340         elsif ( $opt->{is_required} ) {
1341            $self->save_error("Required option --$long must be specified");
1342         }
1343
1344         $self->_validate_type($opt);
1345         if ( $opt->{parsed} ) {
1346            delete $long[$i];
1347         }
1348         else {
1349            PTDEBUG && _d('Temporarily failed to parse', $long);
1350         }
1351      }
1352
1353      die "Failed to parse options, possibly due to circular dependencies"
1354         if @long == $long_last;
1355      $long_last = @long;
1356   }
1357
1358   return;
1359}
1360
1361sub _validate_type {
1362   my ( $self, $opt ) = @_;
1363   return unless $opt;
1364
1365   if ( !$opt->{type} ) {
1366      $opt->{parsed} = 1;
1367      return;
1368   }
1369
1370   my $val = $opt->{value};
1371
1372   if ( $val && $opt->{type} eq 'm' ) {  # type time
1373      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
1374      my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
1375      if ( !$suffix ) {
1376         my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
1377         $suffix = $s || 's';
1378         PTDEBUG && _d('No suffix given; using', $suffix, 'for',
1379            $opt->{long}, '(value:', $val, ')');
1380      }
1381      if ( $suffix =~ m/[smhd]/ ) {
1382         $val = $suffix eq 's' ? $num            # Seconds
1383              : $suffix eq 'm' ? $num * 60       # Minutes
1384              : $suffix eq 'h' ? $num * 3600     # Hours
1385              :                  $num * 86400;   # Days
1386         $opt->{value} = ($prefix || '') . $val;
1387         PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
1388      }
1389      else {
1390         $self->save_error("Invalid time suffix for --$opt->{long}");
1391      }
1392   }
1393   elsif ( $val && $opt->{type} eq 'd' ) {  # type DSN
1394      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
1395      my $prev = {};
1396      my $from_key = $self->{defaults_to}->{ $opt->{long} };
1397      if ( $from_key ) {
1398         PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
1399         if ( $self->{opts}->{$from_key}->{parsed} ) {
1400            $prev = $self->{opts}->{$from_key}->{value};
1401         }
1402         else {
1403            PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
1404               $from_key, 'parsed');
1405            return;
1406         }
1407      }
1408      my $defaults = $self->{DSNParser}->parse_options($self);
1409      if (!$opt->{attributes}->{repeatable}) {
1410          $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
1411      } else {
1412          my $values = [];
1413          for my $dsn_string (@$val) {
1414              push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults);
1415          }
1416          $opt->{value} = $values;
1417      }
1418   }
1419   elsif ( $val && $opt->{type} eq 'z' ) {  # type size
1420      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
1421      $self->_parse_size($opt, $val);
1422   }
1423   elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
1424      $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
1425   }
1426   elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
1427      $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
1428   }
1429   else {
1430      PTDEBUG && _d('Nothing to validate for option',
1431         $opt->{long}, 'type', $opt->{type}, 'value', $val);
1432   }
1433
1434   $opt->{parsed} = 1;
1435   return;
1436}
1437
1438sub get {
1439   my ( $self, $opt ) = @_;
1440   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1441   die "Option $opt does not exist"
1442      unless $long && exists $self->{opts}->{$long};
1443   return $self->{opts}->{$long}->{value};
1444}
1445
1446sub got {
1447   my ( $self, $opt ) = @_;
1448   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1449   die "Option $opt does not exist"
1450      unless $long && exists $self->{opts}->{$long};
1451   return $self->{opts}->{$long}->{got};
1452}
1453
1454sub has {
1455   my ( $self, $opt ) = @_;
1456   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1457   return defined $long ? exists $self->{opts}->{$long} : 0;
1458}
1459
1460sub set {
1461   my ( $self, $opt, $val ) = @_;
1462   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1463   die "Option $opt does not exist"
1464      unless $long && exists $self->{opts}->{$long};
1465   $self->{opts}->{$long}->{value} = $val;
1466   return;
1467}
1468
1469sub save_error {
1470   my ( $self, $error ) = @_;
1471   push @{$self->{errors}}, $error;
1472   return;
1473}
1474
1475sub errors {
1476   my ( $self ) = @_;
1477   return $self->{errors};
1478}
1479
1480sub usage {
1481   my ( $self ) = @_;
1482   warn "No usage string is set" unless $self->{usage}; # XXX
1483   return "Usage: " . ($self->{usage} || '') . "\n";
1484}
1485
1486sub descr {
1487   my ( $self ) = @_;
1488   warn "No description string is set" unless $self->{description}; # XXX
1489   my $descr  = ($self->{description} || $self->{program_name} || '')
1490              . "  For more details, please use the --help option, "
1491              . "or try 'perldoc $PROGRAM_NAME' "
1492              . "for complete documentation.";
1493   $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
1494      unless $ENV{DONT_BREAK_LINES};
1495   $descr =~ s/ +$//mg;
1496   return $descr;
1497}
1498
1499sub usage_or_errors {
1500   my ( $self, $file, $return ) = @_;
1501   $file ||= $self->{file} || __FILE__;
1502
1503   if ( !$self->{description} || !$self->{usage} ) {
1504      PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
1505      my %synop = $self->_parse_synopsis($file);
1506      $self->{description} ||= $synop{description};
1507      $self->{usage}       ||= $synop{usage};
1508      PTDEBUG && _d("Description:", $self->{description},
1509         "\nUsage:", $self->{usage});
1510   }
1511
1512   if ( $self->{opts}->{help}->{got} ) {
1513      print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
1514      exit 0 unless $return;
1515   }
1516   elsif ( scalar @{$self->{errors}} ) {
1517      print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
1518      exit 1 unless $return;
1519   }
1520
1521   return;
1522}
1523
1524sub print_errors {
1525   my ( $self ) = @_;
1526   my $usage = $self->usage() . "\n";
1527   if ( (my @errors = @{$self->{errors}}) ) {
1528      $usage .= join("\n  * ", 'Errors in command-line arguments:', @errors)
1529              . "\n";
1530   }
1531   return $usage . "\n" . $self->descr();
1532}
1533
1534sub print_usage {
1535   my ( $self ) = @_;
1536   die "Run get_opts() before print_usage()" unless $self->{got_opts};
1537   my @opts = values %{$self->{opts}};
1538
1539   my $maxl = max(
1540      map {
1541         length($_->{long})               # option long name
1542         + ($_->{is_negatable} ? 4 : 0)   # "[no]" if opt is negatable
1543         + ($_->{type} ? 2 : 0)           # "=x" where x is the opt type
1544      }
1545      @opts);
1546
1547   my $maxs = max(0,
1548      map {
1549         length($_)
1550         + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
1551         + ($self->{opts}->{$_}->{type} ? 2 : 0)
1552      }
1553      values %{$self->{short_opts}});
1554
1555   my $lcol = max($maxl, ($maxs + 3));
1556   my $rcol = 80 - $lcol - 6;
1557   my $rpad = ' ' x ( 80 - $rcol );
1558
1559   $maxs = max($lcol - 3, $maxs);
1560
1561   my $usage = $self->descr() . "\n" . $self->usage();
1562
1563   my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
1564   push @groups, 'default';
1565
1566   foreach my $group ( reverse @groups ) {
1567      $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
1568      foreach my $opt (
1569         sort { $a->{long} cmp $b->{long} }
1570         grep { $_->{group} eq $group }
1571         @opts )
1572      {
1573         my $long  = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
1574         my $short = $opt->{short};
1575         my $desc  = $opt->{desc};
1576
1577         $long .= $opt->{type} ? "=$opt->{type}" : "";
1578
1579         if ( $opt->{type} && $opt->{type} eq 'm' ) {
1580            my ($s) = $desc =~ m/\(suffix (.)\)/;
1581            $s    ||= 's';
1582            $desc =~ s/\s+\(suffix .\)//;
1583            $desc .= ".  Optional suffix s=seconds, m=minutes, h=hours, "
1584                   . "d=days; if no suffix, $s is used.";
1585         }
1586         $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
1587         $desc =~ s/ +$//mg;
1588         if ( $short ) {
1589            $usage .= sprintf("  --%-${maxs}s -%s  %s\n", $long, $short, $desc);
1590         }
1591         else {
1592            $usage .= sprintf("  --%-${lcol}s  %s\n", $long, $desc);
1593         }
1594      }
1595   }
1596
1597   $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
1598
1599   if ( (my @rules = @{$self->{rules}}) ) {
1600      $usage .= "\nRules:\n\n";
1601      $usage .= join("\n", map { "  $_" } @rules) . "\n";
1602   }
1603   if ( $self->{DSNParser} ) {
1604      $usage .= "\n" . $self->{DSNParser}->usage();
1605   }
1606   $usage .= "\nOptions and values after processing arguments:\n\n";
1607   foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
1608      my $val   = $opt->{value};
1609      my $type  = $opt->{type} || '';
1610      my $bool  = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
1611      $val      = $bool              ? ( $val ? 'TRUE' : 'FALSE' )
1612                : !defined $val      ? '(No value)'
1613                : $type eq 'd'       ? $self->{DSNParser}->as_string($val)
1614                : $type =~ m/H|h/    ? join(',', sort keys %$val)
1615                : $type =~ m/A|a/    ? join(',', @$val)
1616                :                    $val;
1617      $usage .= sprintf("  --%-${lcol}s  %s\n", $opt->{long}, $val);
1618   }
1619   return $usage;
1620}
1621
1622sub prompt_noecho {
1623   shift @_ if ref $_[0] eq __PACKAGE__;
1624   my ( $prompt ) = @_;
1625   local $OUTPUT_AUTOFLUSH = 1;
1626   print STDERR $prompt
1627      or die "Cannot print: $OS_ERROR";
1628   my $response;
1629   eval {
1630      require Term::ReadKey;
1631      Term::ReadKey::ReadMode('noecho');
1632      chomp($response = <STDIN>);
1633      Term::ReadKey::ReadMode('normal');
1634      print "\n"
1635         or die "Cannot print: $OS_ERROR";
1636   };
1637   if ( $EVAL_ERROR ) {
1638      die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
1639   }
1640   return $response;
1641}
1642
1643sub _read_config_file {
1644   my ( $self, $filename ) = @_;
1645   open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
1646   my @args;
1647   my $prefix = '--';
1648   my $parse  = 1;
1649
1650   LINE:
1651   while ( my $line = <$fh> ) {
1652      chomp $line;
1653      next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
1654      $line =~ s/\s+#.*$//g;
1655      $line =~ s/^\s+|\s+$//g;
1656      if ( $line eq '--' ) {
1657         $prefix = '';
1658         $parse  = 0;
1659         next LINE;
1660      }
1661
1662      if (  $parse
1663            && !$self->has('version-check')
1664            && $line =~ /version-check/
1665      ) {
1666         next LINE;
1667      }
1668
1669      if ( $parse
1670         && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
1671      ) {
1672         push @args, grep { defined $_ } ("$prefix$opt", $arg);
1673      }
1674      elsif ( $line =~ m/./ ) {
1675         push @args, $line;
1676      }
1677      else {
1678         die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
1679      }
1680   }
1681   close $fh;
1682   return @args;
1683}
1684
1685sub read_para_after {
1686   my ( $self, $file, $regex ) = @_;
1687   open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
1688   local $INPUT_RECORD_SEPARATOR = '';
1689   my $para;
1690   while ( $para = <$fh> ) {
1691      next unless $para =~ m/^=pod$/m;
1692      last;
1693   }
1694   while ( $para = <$fh> ) {
1695      next unless $para =~ m/$regex/;
1696      last;
1697   }
1698   $para = <$fh>;
1699   chomp($para);
1700   close $fh or die "Can't close $file: $OS_ERROR";
1701   return $para;
1702}
1703
1704sub clone {
1705   my ( $self ) = @_;
1706
1707   my %clone = map {
1708      my $hashref  = $self->{$_};
1709      my $val_copy = {};
1710      foreach my $key ( keys %$hashref ) {
1711         my $ref = ref $hashref->{$key};
1712         $val_copy->{$key} = !$ref           ? $hashref->{$key}
1713                           : $ref eq 'HASH'  ? { %{$hashref->{$key}} }
1714                           : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
1715                           : $hashref->{$key};
1716      }
1717      $_ => $val_copy;
1718   } qw(opts short_opts defaults);
1719
1720   foreach my $scalar ( qw(got_opts) ) {
1721      $clone{$scalar} = $self->{$scalar};
1722   }
1723
1724   return bless \%clone;
1725}
1726
1727sub _parse_size {
1728   my ( $self, $opt, $val ) = @_;
1729
1730   if ( lc($val || '') eq 'null' ) {
1731      PTDEBUG && _d('NULL size for', $opt->{long});
1732      $opt->{value} = 'null';
1733      return;
1734   }
1735
1736   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
1737   my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
1738   if ( defined $num ) {
1739      if ( $factor ) {
1740         $num *= $factor_for{$factor};
1741         PTDEBUG && _d('Setting option', $opt->{y},
1742            'to num', $num, '* factor', $factor);
1743      }
1744      $opt->{value} = ($pre || '') . $num;
1745   }
1746   else {
1747      $self->save_error("Invalid size for --$opt->{long}: $val");
1748   }
1749   return;
1750}
1751
1752sub _parse_attribs {
1753   my ( $self, $option, $attribs ) = @_;
1754   my $types = $self->{types};
1755   return $option
1756      . ($attribs->{'short form'} ? '|' . $attribs->{'short form'}   : '' )
1757      . ($attribs->{'negatable'}  ? '!'                              : '' )
1758      . ($attribs->{'cumulative'} ? '+'                              : '' )
1759      . ($attribs->{'type'}       ? '=' . $types->{$attribs->{type}} : '' );
1760}
1761
1762sub _parse_synopsis {
1763   my ( $self, $file ) = @_;
1764   $file ||= $self->{file} || __FILE__;
1765   PTDEBUG && _d("Parsing SYNOPSIS in", $file);
1766
1767   local $INPUT_RECORD_SEPARATOR = '';  # read paragraphs
1768   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1769   my $para;
1770   1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
1771   die "$file does not contain a SYNOPSIS section" unless $para;
1772   my @synop;
1773   for ( 1..2 ) {  # 1 for the usage, 2 for the description
1774      my $para = <$fh>;
1775      push @synop, $para;
1776   }
1777   close $fh;
1778   PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
1779   my ($usage, $desc) = @synop;
1780   die "The SYNOPSIS section in $file is not formatted properly"
1781      unless $usage && $desc;
1782
1783   $usage =~ s/^\s*Usage:\s+(.+)/$1/;
1784   chomp $usage;
1785
1786   $desc =~ s/\n/ /g;
1787   $desc =~ s/\s{2,}/ /g;
1788   $desc =~ s/\. ([A-Z][a-z])/.  $1/g;
1789   $desc =~ s/\s+$//;
1790
1791   return (
1792      description => $desc,
1793      usage       => $usage,
1794   );
1795};
1796
1797sub set_vars {
1798   my ($self, $file) = @_;
1799   $file ||= $self->{file} || __FILE__;
1800
1801   my %user_vars;
1802   my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
1803   if ( $user_vars ) {
1804      foreach my $var_val ( @$user_vars ) {
1805         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1806         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1807         $user_vars{$var} = {
1808            val     => $val,
1809            default => 0,
1810         };
1811      }
1812   }
1813
1814   my %default_vars;
1815   my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
1816   if ( $default_vars ) {
1817      %default_vars = map {
1818         my $var_val = $_;
1819         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1820         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1821         $var => {
1822            val     => $val,
1823            default => 1,
1824         };
1825      } split("\n", $default_vars);
1826   }
1827
1828   my %vars = (
1829      %default_vars, # first the tool's defaults
1830      %user_vars,    # then the user's which overwrite the defaults
1831   );
1832   PTDEBUG && _d('--set-vars:', Dumper(\%vars));
1833   return \%vars;
1834}
1835
1836sub _d {
1837   my ($package, undef, $line) = caller 0;
1838   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1839        map { defined $_ ? $_ : 'undef' }
1840        @_;
1841   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1842}
1843
1844if ( PTDEBUG ) {
1845   print STDERR '# ', $^X, ' ', $], "\n";
1846   if ( my $uname = `uname -a` ) {
1847      $uname =~ s/\s+/ /g;
1848      print STDERR "# $uname\n";
1849   }
1850   print STDERR '# Arguments: ',
1851      join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
1852}
1853
18541;
1855}
1856# ###########################################################################
1857# End OptionParser package
1858# ###########################################################################
1859
1860# ###########################################################################
1861# TableParser package
1862# This package is a copy without comments from the original.  The original
1863# with comments and its test file can be found in the Bazaar repository at,
1864#   lib/TableParser.pm
1865#   t/lib/TableParser.t
1866# See https://launchpad.net/percona-toolkit for more information.
1867# ###########################################################################
1868{
1869package TableParser;
1870
1871use strict;
1872use warnings FATAL => 'all';
1873use English qw(-no_match_vars);
1874use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1875
1876use Data::Dumper;
1877$Data::Dumper::Indent    = 1;
1878$Data::Dumper::Sortkeys  = 1;
1879$Data::Dumper::Quotekeys = 0;
1880
1881local $EVAL_ERROR;
1882eval {
1883   require Quoter;
1884};
1885
1886sub new {
1887   my ( $class, %args ) = @_;
1888   my $self = { %args };
1889   $self->{Quoter} ||= Quoter->new();
1890   return bless $self, $class;
1891}
1892
1893sub Quoter { shift->{Quoter} }
1894
1895sub get_create_table {
1896   my ( $self, $dbh, $db, $tbl ) = @_;
1897   die "I need a dbh parameter" unless $dbh;
1898   die "I need a db parameter"  unless $db;
1899   die "I need a tbl parameter" unless $tbl;
1900   my $q = $self->{Quoter};
1901
1902   my $new_sql_mode
1903      = q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
1904      . q{@@SQL_MODE := '', }
1905      . q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
1906      . q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
1907
1908   my $old_sql_mode
1909      = q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
1910      . q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
1911
1912   PTDEBUG && _d($new_sql_mode);
1913   eval { $dbh->do($new_sql_mode); };
1914   PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
1915
1916   my $use_sql = 'USE ' . $q->quote($db);
1917   PTDEBUG && _d($dbh, $use_sql);
1918   $dbh->do($use_sql);
1919
1920   my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
1921   PTDEBUG && _d($show_sql);
1922   my $href;
1923   eval { $href = $dbh->selectrow_hashref($show_sql); };
1924   if ( my $e = $EVAL_ERROR ) {
1925      PTDEBUG && _d($old_sql_mode);
1926      $dbh->do($old_sql_mode);
1927
1928      die $e;
1929   }
1930
1931   PTDEBUG && _d($old_sql_mode);
1932   $dbh->do($old_sql_mode);
1933
1934   my ($key) = grep { m/create (?:table|view)/i } keys %$href;
1935   if ( !$key ) {
1936      die "Error: no 'Create Table' or 'Create View' in result set from "
1937         . "$show_sql: " . Dumper($href);
1938   }
1939
1940   return $href->{$key};
1941}
1942
1943sub parse {
1944   my ( $self, $ddl, $opts ) = @_;
1945   return unless $ddl;
1946
1947   if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
1948      $ddl = $self->ansi_to_legacy($ddl);
1949   }
1950   elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
1951      die "TableParser doesn't handle CREATE TABLE without quoting.";
1952   }
1953
1954   my ($name)     = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
1955   (undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
1956
1957   $ddl =~ s/(`[^`\n]+`)/\L$1/gm;
1958
1959   my $engine = $self->get_engine($ddl);
1960
1961   my @defs   = $ddl =~ m/^(\s+`.*?),?$/gm;
1962   my @cols   = map { $_ =~ m/`([^`]+)`/ } @defs;
1963   PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
1964
1965   my %def_for;
1966   @def_for{@cols} = @defs;
1967
1968   my (@nums, @null, @non_generated);
1969   my (%type_for, %is_nullable, %is_numeric, %is_autoinc, %is_generated);
1970   foreach my $col ( @cols ) {
1971      my $def = $def_for{$col};
1972
1973      $def =~ s/``//g;
1974
1975      my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
1976      die "Can't determine column type for $def" unless $type;
1977      $type_for{$col} = $type;
1978      if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
1979         push @nums, $col;
1980         $is_numeric{$col} = 1;
1981      }
1982      if ( $def !~ m/NOT NULL/ ) {
1983         push @null, $col;
1984         $is_nullable{$col} = 1;
1985      }
1986      if ( remove_quoted_text($def) =~ m/\WGENERATED\W/i ) {
1987          $is_generated{$col} = 1;
1988      } else {
1989          push @non_generated, $col;
1990      }
1991      $is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
1992   }
1993
1994   my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
1995
1996   my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
1997
1998   return {
1999      name               => $name,
2000      cols               => \@cols,
2001      col_posn           => { map { $cols[$_] => $_ } 0..$#cols },
2002      is_col             => { map { $_ => 1 } @non_generated },
2003      null_cols          => \@null,
2004      is_nullable        => \%is_nullable,
2005      non_generated_cols => \@non_generated,
2006      is_autoinc         => \%is_autoinc,
2007      is_generated       => \%is_generated,
2008      clustered_key      => $clustered_key,
2009      keys               => $keys,
2010      defs               => \%def_for,
2011      numeric_cols       => \@nums,
2012      is_numeric         => \%is_numeric,
2013      engine             => $engine,
2014      type_for           => \%type_for,
2015      charset            => $charset,
2016   };
2017}
2018
2019sub remove_quoted_text {
2020   my ($string) = @_;
2021   $string =~ s/[^\\]`[^`]*[^\\]`//g;
2022   $string =~ s/[^\\]"[^"]*[^\\]"//g;
2023   $string =~ s/[^\\]'[^']*[^\\]'//g;
2024   return $string;
2025}
2026
2027sub sort_indexes {
2028   my ( $self, $tbl ) = @_;
2029
2030   my @indexes
2031      = sort {
2032         (($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
2033         || ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
2034         || ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
2035         || ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
2036      }
2037      grep {
2038         $tbl->{keys}->{$_}->{type} eq 'BTREE'
2039      }
2040      sort keys %{$tbl->{keys}};
2041
2042   PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
2043   return @indexes;
2044}
2045
2046sub find_best_index {
2047   my ( $self, $tbl, $index ) = @_;
2048   my $best;
2049   if ( $index ) {
2050      ($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
2051   }
2052   if ( !$best ) {
2053      if ( $index ) {
2054         die "Index '$index' does not exist in table";
2055      }
2056      else {
2057         ($best) = $self->sort_indexes($tbl);
2058      }
2059   }
2060   PTDEBUG && _d('Best index found is', $best);
2061   return $best;
2062}
2063
2064sub find_possible_keys {
2065   my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
2066   return () unless $where;
2067   my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
2068      . ' WHERE ' . $where;
2069   PTDEBUG && _d($sql);
2070   my $expl = $dbh->selectrow_hashref($sql);
2071   $expl = { map { lc($_) => $expl->{$_} } keys %$expl };
2072   if ( $expl->{possible_keys} ) {
2073      PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
2074      my @candidates = split(',', $expl->{possible_keys});
2075      my %possible   = map { $_ => 1 } @candidates;
2076      if ( $expl->{key} ) {
2077         PTDEBUG && _d('MySQL chose', $expl->{key});
2078         unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
2079         PTDEBUG && _d('Before deduping:', join(', ', @candidates));
2080         my %seen;
2081         @candidates = grep { !$seen{$_}++ } @candidates;
2082      }
2083      PTDEBUG && _d('Final list:', join(', ', @candidates));
2084      return @candidates;
2085   }
2086   else {
2087      PTDEBUG && _d('No keys in possible_keys');
2088      return ();
2089   }
2090}
2091
2092sub check_table {
2093   my ( $self, %args ) = @_;
2094   my @required_args = qw(dbh db tbl);
2095   foreach my $arg ( @required_args ) {
2096      die "I need a $arg argument" unless $args{$arg};
2097   }
2098   my ($dbh, $db, $tbl) = @args{@required_args};
2099   my $q      = $self->{Quoter} || 'Quoter';
2100   my $db_tbl = $q->quote($db, $tbl);
2101   PTDEBUG && _d('Checking', $db_tbl);
2102
2103   $self->{check_table_error} = undef;
2104
2105   my $sql = "SHOW TABLES FROM " . $q->quote($db)
2106           . ' LIKE ' . $q->literal_like($tbl);
2107   PTDEBUG && _d($sql);
2108   my $row;
2109   eval {
2110      $row = $dbh->selectrow_arrayref($sql);
2111   };
2112   if ( my $e = $EVAL_ERROR ) {
2113      PTDEBUG && _d($e);
2114      $self->{check_table_error} = $e;
2115      return 0;
2116   }
2117   if ( !$row->[0] || $row->[0] ne $tbl ) {
2118      PTDEBUG && _d('Table does not exist');
2119      return 0;
2120   }
2121
2122   PTDEBUG && _d('Table', $db, $tbl, 'exists');
2123   return 1;
2124
2125}
2126
2127sub get_engine {
2128   my ( $self, $ddl, $opts ) = @_;
2129   my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
2130   PTDEBUG && _d('Storage engine:', $engine);
2131   return $engine || undef;
2132}
2133
2134sub get_keys {
2135   my ( $self, $ddl, $opts, $is_nullable ) = @_;
2136   my $engine        = $self->get_engine($ddl);
2137   my $keys          = {};
2138   my $clustered_key = undef;
2139
2140   KEY:
2141   foreach my $key ( $ddl =~ m/^  ((?:[A-Z]+ )?KEY .*)$/gm ) {
2142
2143      next KEY if $key =~ m/FOREIGN/;
2144
2145      my $key_ddl = $key;
2146      PTDEBUG && _d('Parsed key:', $key_ddl);
2147
2148      if ( !$engine || $engine !~ m/MEMORY|HEAP/ ) {
2149         $key =~ s/USING HASH/USING BTREE/;
2150      }
2151
2152      my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
2153      my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
2154      $type = $type || $special || 'BTREE';
2155      my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
2156      my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
2157      my @cols;
2158      my @col_prefixes;
2159      foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
2160         my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
2161         push @cols, $name;
2162         push @col_prefixes, $prefix;
2163      }
2164      $name =~ s/`//g;
2165
2166      PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
2167
2168      $keys->{$name} = {
2169         name         => $name,
2170         type         => $type,
2171         colnames     => $cols,
2172         cols         => \@cols,
2173         col_prefixes => \@col_prefixes,
2174         is_unique    => $unique,
2175         is_nullable  => scalar(grep { $is_nullable->{$_} } @cols),
2176         is_col       => { map { $_ => 1 } @cols },
2177         ddl          => $key_ddl,
2178      };
2179
2180      if ( ($engine || '') =~ m/InnoDB/i && !$clustered_key ) {
2181         my $this_key = $keys->{$name};
2182         if ( $this_key->{name} eq 'PRIMARY' ) {
2183            $clustered_key = 'PRIMARY';
2184         }
2185         elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
2186            $clustered_key = $this_key->{name};
2187         }
2188         PTDEBUG && $clustered_key && _d('This key is the clustered key');
2189      }
2190   }
2191
2192   return $keys, $clustered_key;
2193}
2194
2195sub get_fks {
2196   my ( $self, $ddl, $opts ) = @_;
2197   my $q   = $self->{Quoter};
2198   my $fks = {};
2199
2200   foreach my $fk (
2201      $ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
2202   {
2203      my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
2204      my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
2205      my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
2206
2207      my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
2208      my %parent_tbl = (tbl => $tbl);
2209      $parent_tbl{db} = $db if $db;
2210
2211      if ( $parent !~ m/\./ && $opts->{database} ) {
2212         $parent = $q->quote($opts->{database}) . ".$parent";
2213      }
2214
2215      $fks->{$name} = {
2216         name           => $name,
2217         colnames       => $cols,
2218         cols           => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
2219         parent_tbl     => \%parent_tbl,
2220         parent_tblname => $parent,
2221         parent_cols    => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
2222         parent_colnames=> $parent_cols,
2223         ddl            => $fk,
2224      };
2225   }
2226
2227   return $fks;
2228}
2229
2230sub remove_auto_increment {
2231   my ( $self, $ddl ) = @_;
2232   $ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
2233   return $ddl;
2234}
2235
2236sub get_table_status {
2237   my ( $self, $dbh, $db, $like ) = @_;
2238   my $q = $self->{Quoter};
2239   my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
2240   my @params;
2241   if ( $like ) {
2242      $sql .= ' LIKE ?';
2243      push @params, $like;
2244   }
2245   PTDEBUG && _d($sql, @params);
2246   my $sth = $dbh->prepare($sql);
2247   eval { $sth->execute(@params); };
2248   if ($EVAL_ERROR) {
2249      PTDEBUG && _d($EVAL_ERROR);
2250      return;
2251   }
2252   my @tables = @{$sth->fetchall_arrayref({})};
2253   @tables = map {
2254      my %tbl; # Make a copy with lowercased keys
2255      @tbl{ map { lc $_ } keys %$_ } = values %$_;
2256      $tbl{engine} ||= $tbl{type} || $tbl{comment};
2257      delete $tbl{type};
2258      \%tbl;
2259   } @tables;
2260   return @tables;
2261}
2262
2263my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
2264sub ansi_to_legacy {
2265   my ($self, $ddl) = @_;
2266   $ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
2267   return $ddl;
2268}
2269
2270sub ansi_quote_replace {
2271   my ($val) = @_;
2272   $val =~ s/^"|"$//g;
2273   $val =~ s/`/``/g;
2274   $val =~ s/""/"/g;
2275   return "`$val`";
2276}
2277
2278sub _d {
2279   my ($package, undef, $line) = caller 0;
2280   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2281        map { defined $_ ? $_ : 'undef' }
2282        @_;
2283   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2284}
2285
22861;
2287}
2288# ###########################################################################
2289# End TableParser package
2290# ###########################################################################
2291
2292# ###########################################################################
2293# DSNParser package
2294# This package is a copy without comments from the original.  The original
2295# with comments and its test file can be found in the Bazaar repository at,
2296#   lib/DSNParser.pm
2297#   t/lib/DSNParser.t
2298# See https://launchpad.net/percona-toolkit for more information.
2299# ###########################################################################
2300{
2301package DSNParser;
2302
2303use strict;
2304use warnings FATAL => 'all';
2305use English qw(-no_match_vars);
2306use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2307
2308use Data::Dumper;
2309$Data::Dumper::Indent    = 0;
2310$Data::Dumper::Quotekeys = 0;
2311
2312my $dsn_sep = qr/(?<!\\),/;
2313
2314eval {
2315   require DBI;
2316};
2317my $have_dbi = $EVAL_ERROR ? 0 : 1;
2318
2319sub new {
2320   my ( $class, %args ) = @_;
2321   foreach my $arg ( qw(opts) ) {
2322      die "I need a $arg argument" unless $args{$arg};
2323   }
2324   my $self = {
2325      opts => {}  # h, P, u, etc.  Should come from DSN OPTIONS section in POD.
2326   };
2327   foreach my $opt ( @{$args{opts}} ) {
2328      if ( !$opt->{key} || !$opt->{desc} ) {
2329         die "Invalid DSN option: ", Dumper($opt);
2330      }
2331      PTDEBUG && _d('DSN option:',
2332         join(', ',
2333            map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
2334               keys %$opt
2335         )
2336      );
2337      $self->{opts}->{$opt->{key}} = {
2338         dsn  => $opt->{dsn},
2339         desc => $opt->{desc},
2340         copy => $opt->{copy} || 0,
2341      };
2342   }
2343   return bless $self, $class;
2344}
2345
2346sub prop {
2347   my ( $self, $prop, $value ) = @_;
2348   if ( @_ > 2 ) {
2349      PTDEBUG && _d('Setting', $prop, 'property');
2350      $self->{$prop} = $value;
2351   }
2352   return $self->{$prop};
2353}
2354
2355sub parse {
2356   my ( $self, $dsn, $prev, $defaults ) = @_;
2357   if ( !$dsn ) {
2358      PTDEBUG && _d('No DSN to parse');
2359      return;
2360   }
2361   PTDEBUG && _d('Parsing', $dsn);
2362   $prev     ||= {};
2363   $defaults ||= {};
2364   my %given_props;
2365   my %final_props;
2366   my $opts = $self->{opts};
2367
2368   foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
2369      $dsn_part =~ s/\\,/,/g;
2370      if ( my ($prop_key, $prop_val) = $dsn_part =~  m/^(.)=(.*)$/ ) {
2371         $given_props{$prop_key} = $prop_val;
2372      }
2373      else {
2374         PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
2375         $given_props{h} = $dsn_part;
2376      }
2377   }
2378
2379   foreach my $key ( keys %$opts ) {
2380      PTDEBUG && _d('Finding value for', $key);
2381      $final_props{$key} = $given_props{$key};
2382      if ( !defined $final_props{$key}
2383           && defined $prev->{$key} && $opts->{$key}->{copy} )
2384      {
2385         $final_props{$key} = $prev->{$key};
2386         PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
2387      }
2388      if ( !defined $final_props{$key} ) {
2389         $final_props{$key} = $defaults->{$key};
2390         PTDEBUG && _d('Copying value for', $key, 'from defaults');
2391      }
2392   }
2393
2394   foreach my $key ( keys %given_props ) {
2395      die "Unknown DSN option '$key' in '$dsn'.  For more details, "
2396            . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2397            . "for complete documentation."
2398         unless exists $opts->{$key};
2399   }
2400   if ( (my $required = $self->prop('required')) ) {
2401      foreach my $key ( keys %$required ) {
2402         die "Missing required DSN option '$key' in '$dsn'.  For more details, "
2403               . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2404               . "for complete documentation."
2405            unless $final_props{$key};
2406      }
2407   }
2408
2409   return \%final_props;
2410}
2411
2412sub parse_options {
2413   my ( $self, $o ) = @_;
2414   die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
2415   my $dsn_string
2416      = join(',',
2417          map  { "$_=".$o->get($_); }
2418          grep { $o->has($_) && $o->get($_) }
2419          keys %{$self->{opts}}
2420        );
2421   PTDEBUG && _d('DSN string made from options:', $dsn_string);
2422   return $self->parse($dsn_string);
2423}
2424
2425sub as_string {
2426   my ( $self, $dsn, $props ) = @_;
2427   return $dsn unless ref $dsn;
2428   my @keys = $props ? @$props : sort keys %$dsn;
2429   return join(',',
2430      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
2431      grep {
2432         exists $self->{opts}->{$_}
2433         && exists $dsn->{$_}
2434         && defined $dsn->{$_}
2435      } @keys);
2436}
2437
2438sub usage {
2439   my ( $self ) = @_;
2440   my $usage
2441      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n\n"
2442      . "  KEY  COPY  MEANING\n"
2443      . "  ===  ====  =============================================\n";
2444   my %opts = %{$self->{opts}};
2445   foreach my $key ( sort keys %opts ) {
2446      $usage .= "  $key    "
2447             .  ($opts{$key}->{copy} ? 'yes   ' : 'no    ')
2448             .  ($opts{$key}->{desc} || '[No description]')
2449             . "\n";
2450   }
2451   $usage .= "\n  If the DSN is a bareword, the word is treated as the 'h' key.\n";
2452   return $usage;
2453}
2454
2455sub get_cxn_params {
2456   my ( $self, $info ) = @_;
2457   my $dsn;
2458   my %opts = %{$self->{opts}};
2459   my $driver = $self->prop('dbidriver') || '';
2460   if ( $driver eq 'Pg' ) {
2461      $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
2462         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
2463                     grep { defined $info->{$_} }
2464                     qw(h P));
2465   }
2466   else {
2467      $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
2468         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
2469                     grep { defined $info->{$_} }
2470                     qw(F h P S A))
2471         . ';mysql_read_default_group=client'
2472         . ($info->{L} ? ';mysql_local_infile=1' : '');
2473   }
2474   PTDEBUG && _d($dsn);
2475   return ($dsn, $info->{u}, $info->{p});
2476}
2477
2478sub fill_in_dsn {
2479   my ( $self, $dbh, $dsn ) = @_;
2480   my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
2481   my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
2482   $user =~ s/@.*//;
2483   $dsn->{h} ||= $vars->{hostname}->{Value};
2484   $dsn->{S} ||= $vars->{'socket'}->{Value};
2485   $dsn->{P} ||= $vars->{port}->{Value};
2486   $dsn->{u} ||= $user;
2487   $dsn->{D} ||= $db;
2488}
2489
2490sub get_dbh {
2491   my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
2492   $opts ||= {};
2493   my $defaults = {
2494      AutoCommit         => 0,
2495      RaiseError         => 1,
2496      PrintError         => 0,
2497      ShowErrorStatement => 1,
2498      mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
2499   };
2500   @{$defaults}{ keys %$opts } = values %$opts;
2501   if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
2502      $defaults->{mysql_local_infile} = 1;
2503   }
2504
2505   if ( $opts->{mysql_use_result} ) {
2506      $defaults->{mysql_use_result} = 1;
2507   }
2508
2509   if ( !$have_dbi ) {
2510      die "Cannot connect to MySQL because the Perl DBI module is not "
2511         . "installed or not found.  Run 'perl -MDBI' to see the directories "
2512         . "that Perl searches for DBI.  If DBI is not installed, try:\n"
2513         . "  Debian/Ubuntu  apt-get install libdbi-perl\n"
2514         . "  RHEL/CentOS    yum install perl-DBI\n"
2515         . "  OpenSolaris    pkg install pkg:/SUNWpmdbi\n";
2516
2517   }
2518
2519   my $dbh;
2520   my $tries = 2;
2521   while ( !$dbh && $tries-- ) {
2522      PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
2523         join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
2524
2525      $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
2526
2527      if ( !$dbh && $EVAL_ERROR ) {
2528         if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
2529            die "Cannot connect to MySQL because the Perl DBD::mysql module is "
2530               . "not installed or not found.  Run 'perl -MDBD::mysql' to see "
2531               . "the directories that Perl searches for DBD::mysql.  If "
2532               . "DBD::mysql is not installed, try:\n"
2533               . "  Debian/Ubuntu  apt-get install libdbd-mysql-perl\n"
2534               . "  RHEL/CentOS    yum install perl-DBD-MySQL\n"
2535               . "  OpenSolaris    pgk install pkg:/SUNWapu13dbd-mysql\n";
2536         }
2537         elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
2538            PTDEBUG && _d('Going to try again without utf8 support');
2539            delete $defaults->{mysql_enable_utf8};
2540         }
2541         if ( !$tries ) {
2542            die $EVAL_ERROR;
2543         }
2544      }
2545   }
2546
2547   if ( $cxn_string =~ m/mysql/i ) {
2548      my $sql;
2549
2550      if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
2551         $sql = qq{/*!40101 SET NAMES "$charset"*/};
2552         PTDEBUG && _d($dbh, $sql);
2553         eval { $dbh->do($sql) };
2554         if ( $EVAL_ERROR ) {
2555            die "Error setting NAMES to $charset: $EVAL_ERROR";
2556         }
2557         PTDEBUG && _d('Enabling charset for STDOUT');
2558         if ( $charset eq 'utf8' ) {
2559            binmode(STDOUT, ':utf8')
2560               or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
2561         }
2562         else {
2563            binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
2564         }
2565      }
2566
2567      if ( my $vars = $self->prop('set-vars') ) {
2568         $self->set_vars($dbh, $vars);
2569      }
2570
2571      $sql = 'SELECT @@SQL_MODE';
2572      PTDEBUG && _d($dbh, $sql);
2573      my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
2574      if ( $EVAL_ERROR ) {
2575         die "Error getting the current SQL_MODE: $EVAL_ERROR";
2576      }
2577
2578      $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
2579            . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
2580            . ($sql_mode ? ",$sql_mode" : '')
2581            . '\'*/';
2582      PTDEBUG && _d($dbh, $sql);
2583      eval { $dbh->do($sql) };
2584      if ( $EVAL_ERROR ) {
2585         die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
2586           . ($sql_mode ? " and $sql_mode" : '')
2587           . ": $EVAL_ERROR";
2588      }
2589   }
2590   my ($mysql_version) = eval { $dbh->selectrow_array('SELECT VERSION()') };
2591   if ($EVAL_ERROR) {
2592       die "Cannot get MySQL version: $EVAL_ERROR";
2593   }
2594
2595   my (undef, $character_set_server) = eval { $dbh->selectrow_array("SHOW VARIABLES LIKE 'character_set_server'") };
2596   if ($EVAL_ERROR) {
2597       die "Cannot get MySQL var character_set_server: $EVAL_ERROR";
2598   }
2599
2600   if ($mysql_version =~ m/^(\d+)\.(\d)\.(\d+).*/) {
2601       if ($1 >= 8 && $character_set_server =~ m/^utf8/) {
2602           $dbh->{mysql_enable_utf8} = 1;
2603           my $msg = "MySQL version $mysql_version >= 8 and character_set_server = $character_set_server\n".
2604                     "Setting: SET NAMES $character_set_server";
2605           PTDEBUG && _d($msg);
2606           eval { $dbh->do("SET NAMES 'utf8mb4'") };
2607           if ($EVAL_ERROR) {
2608               die "Cannot SET NAMES $character_set_server: $EVAL_ERROR";
2609           }
2610       }
2611   }
2612
2613   PTDEBUG && _d('DBH info: ',
2614      $dbh,
2615      Dumper($dbh->selectrow_hashref(
2616         'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
2617      'Connection info:',      $dbh->{mysql_hostinfo},
2618      'Character set info:',   Dumper($dbh->selectall_arrayref(
2619                     "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
2620      '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
2621      '$DBI::VERSION:',        $DBI::VERSION,
2622   );
2623
2624   return $dbh;
2625}
2626
2627sub get_hostname {
2628   my ( $self, $dbh ) = @_;
2629   if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
2630      return $host;
2631   }
2632   my ( $hostname, $one ) = $dbh->selectrow_array(
2633      'SELECT /*!50038 @@hostname, */ 1');
2634   return $hostname;
2635}
2636
2637sub disconnect {
2638   my ( $self, $dbh ) = @_;
2639   PTDEBUG && $self->print_active_handles($dbh);
2640   $dbh->disconnect;
2641}
2642
2643sub print_active_handles {
2644   my ( $self, $thing, $level ) = @_;
2645   $level ||= 0;
2646   printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
2647      $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
2648      or die "Cannot print: $OS_ERROR";
2649   foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
2650      $self->print_active_handles( $handle, $level + 1 );
2651   }
2652}
2653
2654sub copy {
2655   my ( $self, $dsn_1, $dsn_2, %args ) = @_;
2656   die 'I need a dsn_1 argument' unless $dsn_1;
2657   die 'I need a dsn_2 argument' unless $dsn_2;
2658   my %new_dsn = map {
2659      my $key = $_;
2660      my $val;
2661      if ( $args{overwrite} ) {
2662         $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
2663      }
2664      else {
2665         $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
2666      }
2667      $key => $val;
2668   } keys %{$self->{opts}};
2669   return \%new_dsn;
2670}
2671
2672sub set_vars {
2673   my ($self, $dbh, $vars) = @_;
2674
2675   return unless $vars;
2676
2677   foreach my $var ( sort keys %$vars ) {
2678      my $val = $vars->{$var}->{val};
2679
2680      (my $quoted_var = $var) =~ s/_/\\_/;
2681      my ($var_exists, $current_val);
2682      eval {
2683         ($var_exists, $current_val) = $dbh->selectrow_array(
2684            "SHOW VARIABLES LIKE '$quoted_var'");
2685      };
2686      my $e = $EVAL_ERROR;
2687      if ( $e ) {
2688         PTDEBUG && _d($e);
2689      }
2690
2691      if ( $vars->{$var}->{default} && !$var_exists ) {
2692         PTDEBUG && _d('Not setting default var', $var,
2693            'because it does not exist');
2694         next;
2695      }
2696
2697      if ( $current_val && $current_val eq $val ) {
2698         PTDEBUG && _d('Not setting var', $var, 'because its value',
2699            'is already', $val);
2700         next;
2701      }
2702
2703      my $sql = "SET SESSION $var=$val";
2704      PTDEBUG && _d($dbh, $sql);
2705      eval { $dbh->do($sql) };
2706      if ( my $set_error = $EVAL_ERROR ) {
2707         chomp($set_error);
2708         $set_error =~ s/ at \S+ line \d+//;
2709         my $msg = "Error setting $var: $set_error";
2710         if ( $current_val ) {
2711            $msg .= "  The current value for $var is $current_val.  "
2712                  . "If the variable is read only (not dynamic), specify "
2713                  . "--set-vars $var=$current_val to avoid this warning, "
2714                  . "else manually set the variable and restart MySQL.";
2715         }
2716         warn $msg . "\n\n";
2717      }
2718   }
2719
2720   return;
2721}
2722
2723sub _d {
2724   my ($package, undef, $line) = caller 0;
2725   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2726        map { defined $_ ? $_ : 'undef' }
2727        @_;
2728   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2729}
2730
27311;
2732}
2733# ###########################################################################
2734# End DSNParser package
2735# ###########################################################################
2736
2737# ###########################################################################
2738# VersionParser package
2739# This package is a copy without comments from the original.  The original
2740# with comments and its test file can be found in the Bazaar repository at,
2741#   lib/VersionParser.pm
2742#   t/lib/VersionParser.t
2743# See https://launchpad.net/percona-toolkit for more information.
2744# ###########################################################################
2745{
2746package VersionParser;
2747
2748use Lmo;
2749use Scalar::Util qw(blessed);
2750use English qw(-no_match_vars);
2751use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2752
2753use overload (
2754   '""'     => "version",
2755   '<=>'    => "cmp",
2756   'cmp'    => "cmp",
2757   fallback => 1,
2758);
2759
2760use Carp ();
2761
2762our $VERSION = 0.01;
2763
2764has major => (
2765    is       => 'ro',
2766    isa      => 'Int',
2767    required => 1,
2768);
2769
2770has [qw( minor revision )] => (
2771    is  => 'ro',
2772    isa => 'Num',
2773);
2774
2775has flavor => (
2776    is      => 'ro',
2777    isa     => 'Str',
2778    default => sub { 'Unknown' },
2779);
2780
2781has innodb_version => (
2782    is      => 'ro',
2783    isa     => 'Str',
2784    default => sub { 'NO' },
2785);
2786
2787sub series {
2788   my $self = shift;
2789   return $self->_join_version($self->major, $self->minor);
2790}
2791
2792sub version {
2793   my $self = shift;
2794   return $self->_join_version($self->major, $self->minor, $self->revision);
2795}
2796
2797sub is_in {
2798   my ($self, $target) = @_;
2799
2800   return $self eq $target;
2801}
2802
2803sub _join_version {
2804    my ($self, @parts) = @_;
2805
2806    return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
2807}
2808sub _split_version {
2809   my ($self, $str) = @_;
2810   my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
2811   return @version_parts[0..2];
2812}
2813
2814sub normalized_version {
2815   my ( $self ) = @_;
2816   my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
2817                                                      $self->minor,
2818                                                      $self->revision);
2819   PTDEBUG && _d($self->version, 'normalizes to', $result);
2820   return $result;
2821}
2822
2823sub comment {
2824   my ( $self, $cmd ) = @_;
2825   my $v = $self->normalized_version();
2826
2827   return "/*!$v $cmd */"
2828}
2829
2830my @methods = qw(major minor revision);
2831sub cmp {
2832   my ($left, $right) = @_;
2833   my $right_obj = (blessed($right) && $right->isa(ref($left)))
2834                   ? $right
2835                   : ref($left)->new($right);
2836
2837   my $retval = 0;
2838   for my $m ( @methods ) {
2839      last unless defined($left->$m) && defined($right_obj->$m);
2840      $retval = $left->$m <=> $right_obj->$m;
2841      last if $retval;
2842   }
2843   return $retval;
2844}
2845
2846sub BUILDARGS {
2847   my $self = shift;
2848
2849   if ( @_ == 1 ) {
2850      my %args;
2851      if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
2852         PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
2853         my $dbh = $_[0];
2854         local $dbh->{FetchHashKeyName} = 'NAME_lc';
2855         my $query = eval {
2856            $dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
2857         };
2858         if ( $query ) {
2859            $query = { map { $_->{variable_name} => $_->{value} } @$query };
2860            @args{@methods} = $self->_split_version($query->{version});
2861            $args{flavor} = delete $query->{version_comment}
2862                  if $query->{version_comment};
2863         }
2864         elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
2865            @args{@methods} = $self->_split_version($query);
2866         }
2867         else {
2868            Carp::confess("Couldn't get the version from the dbh while "
2869                        . "creating a VersionParser object: $@");
2870         }
2871         $args{innodb_version} = eval { $self->_innodb_version($dbh) };
2872      }
2873      elsif ( !ref($_[0]) ) {
2874         @args{@methods} = $self->_split_version($_[0]);
2875      }
2876
2877      for my $method (@methods) {
2878         delete $args{$method} unless defined $args{$method};
2879      }
2880      @_ = %args if %args;
2881   }
2882
2883   return $self->SUPER::BUILDARGS(@_);
2884}
2885
2886sub _innodb_version {
2887   my ( $self, $dbh ) = @_;
2888   return unless $dbh;
2889   my $innodb_version = "NO";
2890
2891   my ($innodb) =
2892      grep { $_->{engine} =~ m/InnoDB/i }
2893      map  {
2894         my %hash;
2895         @hash{ map { lc $_ } keys %$_ } = values %$_;
2896         \%hash;
2897      }
2898      @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
2899   if ( $innodb ) {
2900      PTDEBUG && _d("InnoDB support:", $innodb->{support});
2901      if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
2902         my $vars = $dbh->selectrow_hashref(
2903            "SHOW VARIABLES LIKE 'innodb_version'");
2904         $innodb_version = !$vars ? "BUILTIN"
2905                         :          ($vars->{Value} || $vars->{value});
2906      }
2907      else {
2908         $innodb_version = $innodb->{support};  # probably DISABLED or NO
2909      }
2910   }
2911
2912   PTDEBUG && _d("InnoDB version:", $innodb_version);
2913   return $innodb_version;
2914}
2915
2916sub _d {
2917   my ($package, undef, $line) = caller 0;
2918   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2919        map { defined $_ ? $_ : 'undef' }
2920        @_;
2921   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2922}
2923
2924no Lmo;
29251;
2926}
2927# ###########################################################################
2928# End VersionParser package
2929# ###########################################################################
2930
2931# ###########################################################################
2932# Quoter package
2933# This package is a copy without comments from the original.  The original
2934# with comments and its test file can be found in the Bazaar repository at,
2935#   lib/Quoter.pm
2936#   t/lib/Quoter.t
2937# See https://launchpad.net/percona-toolkit for more information.
2938# ###########################################################################
2939{
2940package Quoter;
2941
2942use strict;
2943use warnings FATAL => 'all';
2944use English qw(-no_match_vars);
2945use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2946
2947use Data::Dumper;
2948$Data::Dumper::Indent    = 1;
2949$Data::Dumper::Sortkeys  = 1;
2950$Data::Dumper::Quotekeys = 0;
2951
2952sub new {
2953   my ( $class, %args ) = @_;
2954   return bless {}, $class;
2955}
2956
2957sub quote {
2958   my ( $self, @vals ) = @_;
2959   foreach my $val ( @vals ) {
2960      $val =~ s/`/``/g;
2961   }
2962   return join('.', map { '`' . $_ . '`' } @vals);
2963}
2964
2965sub quote_val {
2966   my ( $self, $val, %args ) = @_;
2967
2968   return 'NULL' unless defined $val;          # undef = NULL
2969   return "''" if $val eq '';                  # blank string = ''
2970   return $val if $val =~ m/^0x[0-9a-fA-F]+$/  # quote hex data
2971                  && !$args{is_char};          # unless is_char is true
2972
2973   $val =~ s/(['\\])/\\$1/g;
2974   return "'$val'";
2975}
2976
2977sub split_unquote {
2978   my ( $self, $db_tbl, $default_db ) = @_;
2979   my ( $db, $tbl ) = split(/[.]/, $db_tbl);
2980   if ( !$tbl ) {
2981      $tbl = $db;
2982      $db  = $default_db;
2983   }
2984   for ($db, $tbl) {
2985      next unless $_;
2986      s/\A`//;
2987      s/`\z//;
2988      s/``/`/g;
2989   }
2990
2991   return ($db, $tbl);
2992}
2993
2994sub literal_like {
2995   my ( $self, $like ) = @_;
2996   return unless $like;
2997   $like =~ s/([%_])/\\$1/g;
2998   return "'$like'";
2999}
3000
3001sub join_quote {
3002   my ( $self, $default_db, $db_tbl ) = @_;
3003   return unless $db_tbl;
3004   my ($db, $tbl) = split(/[.]/, $db_tbl);
3005   if ( !$tbl ) {
3006      $tbl = $db;
3007      $db  = $default_db;
3008   }
3009   $db  = "`$db`"  if $db  && $db  !~ m/^`/;
3010   $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
3011   return $db ? "$db.$tbl" : $tbl;
3012}
3013
3014sub serialize_list {
3015   my ( $self, @args ) = @_;
3016   PTDEBUG && _d('Serializing', Dumper(\@args));
3017   return unless @args;
3018
3019   my @parts;
3020   foreach my $arg  ( @args ) {
3021      if ( defined $arg ) {
3022         $arg =~ s/,/\\,/g;      # escape commas
3023         $arg =~ s/\\N/\\\\N/g;  # escape literal \N
3024         push @parts, $arg;
3025      }
3026      else {
3027         push @parts, '\N';
3028      }
3029   }
3030
3031   my $string = join(',', @parts);
3032   PTDEBUG && _d('Serialized: <', $string, '>');
3033   return $string;
3034}
3035
3036sub deserialize_list {
3037   my ( $self, $string ) = @_;
3038   PTDEBUG && _d('Deserializing <', $string, '>');
3039   die "Cannot deserialize an undefined string" unless defined $string;
3040
3041   my @parts;
3042   foreach my $arg ( split(/(?<!\\),/, $string) ) {
3043      if ( $arg eq '\N' ) {
3044         $arg = undef;
3045      }
3046      else {
3047         $arg =~ s/\\,/,/g;
3048         $arg =~ s/\\\\N/\\N/g;
3049      }
3050      push @parts, $arg;
3051   }
3052
3053   if ( !@parts ) {
3054      my $n_empty_strings = $string =~ tr/,//;
3055      $n_empty_strings++;
3056      PTDEBUG && _d($n_empty_strings, 'empty strings');
3057      map { push @parts, '' } 1..$n_empty_strings;
3058   }
3059   elsif ( $string =~ m/(?<!\\),$/ ) {
3060      PTDEBUG && _d('Last value is an empty string');
3061      push @parts, '';
3062   }
3063
3064   PTDEBUG && _d('Deserialized', Dumper(\@parts));
3065   return @parts;
3066}
3067
3068sub _d {
3069   my ($package, undef, $line) = caller 0;
3070   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3071        map { defined $_ ? $_ : 'undef' }
3072        @_;
3073   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3074}
3075
30761;
3077}
3078# ###########################################################################
3079# End Quoter package
3080# ###########################################################################
3081
3082# ###########################################################################
3083# TableNibbler package
3084# This package is a copy without comments from the original.  The original
3085# with comments and its test file can be found in the Bazaar repository at,
3086#   lib/TableNibbler.pm
3087#   t/lib/TableNibbler.t
3088# See https://launchpad.net/percona-toolkit for more information.
3089# ###########################################################################
3090{
3091package TableNibbler;
3092
3093use strict;
3094use warnings FATAL => 'all';
3095use English qw(-no_match_vars);
3096use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3097
3098sub new {
3099   my ( $class, %args ) = @_;
3100   my @required_args = qw(TableParser Quoter);
3101   foreach my $arg ( @required_args ) {
3102      die "I need a $arg argument" unless $args{$arg};
3103   }
3104   my $self = { %args };
3105   return bless $self, $class;
3106}
3107
3108sub generate_asc_stmt {
3109   my ( $self, %args ) = @_;
3110   my @required_args = qw(tbl_struct index);
3111   foreach my $arg ( @required_args ) {
3112      die "I need a $arg argument" unless defined $args{$arg};
3113   }
3114   my ($tbl_struct, $index) = @args{@required_args};
3115   my @cols = $args{cols} ? @{$args{cols}} : @{$tbl_struct->{cols}};
3116   my $q    = $self->{Quoter};
3117
3118   die "Index '$index' does not exist in table"
3119      unless exists $tbl_struct->{keys}->{$index};
3120   PTDEBUG && _d('Will ascend index', $index);
3121
3122   my @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}};
3123   if ( $args{asc_first} ) {
3124      PTDEBUG && _d('Ascending only first column');
3125      @asc_cols = $asc_cols[0];
3126   }
3127   elsif ( my $n = $args{n_index_cols} ) {
3128      $n = scalar @asc_cols if $n > @asc_cols;
3129      PTDEBUG && _d('Ascending only first', $n, 'columns');
3130      @asc_cols = @asc_cols[0..($n-1)];
3131   }
3132   PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols));
3133
3134   my @asc_slice;
3135   my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
3136   foreach my $col ( @asc_cols ) {
3137      if ( !exists $col_posn{$col} ) {
3138         push @cols, $col;
3139         $col_posn{$col} = $#cols;
3140      }
3141      push @asc_slice, $col_posn{$col};
3142   }
3143   PTDEBUG && _d('Will ascend, in ordinal position:', join(', ', @asc_slice));
3144
3145   my $asc_stmt = {
3146      cols  => \@cols,
3147      index => $index,
3148      where => '',
3149      slice => [],
3150      scols => [],
3151   };
3152
3153   if ( @asc_slice ) {
3154      my $cmp_where;
3155      foreach my $cmp ( qw(< <= >= >) ) {
3156         $cmp_where = $self->generate_cmp_where(
3157            type        => $cmp,
3158            slice       => \@asc_slice,
3159            cols        => \@cols,
3160            quoter      => $q,
3161            is_nullable => $tbl_struct->{is_nullable},
3162            type_for    => $tbl_struct->{type_for},
3163         );
3164         $asc_stmt->{boundaries}->{$cmp} = $cmp_where->{where};
3165      }
3166      my $cmp = $args{asc_only} ? '>' : '>=';
3167      $asc_stmt->{where} = $asc_stmt->{boundaries}->{$cmp};
3168      $asc_stmt->{slice} = $cmp_where->{slice};
3169      $asc_stmt->{scols} = $cmp_where->{scols};
3170   }
3171
3172   return $asc_stmt;
3173}
3174
3175sub generate_cmp_where {
3176   my ( $self, %args ) = @_;
3177   foreach my $arg ( qw(type slice cols is_nullable) ) {
3178      die "I need a $arg arg" unless defined $args{$arg};
3179   }
3180   my @slice       = @{$args{slice}};
3181   my @cols        = @{$args{cols}};
3182   my $is_nullable = $args{is_nullable};
3183   my $type_for    = $args{type_for};
3184   my $type        = $args{type};
3185   my $q           = $self->{Quoter};
3186
3187   (my $cmp = $type) =~ s/=//;
3188
3189   my @r_slice;    # Resulting slice columns, by ordinal
3190   my @r_scols;    # Ditto, by name
3191
3192   my @clauses;
3193   foreach my $i ( 0 .. $#slice ) {
3194      my @clause;
3195
3196      foreach my $j ( 0 .. $i - 1 ) {
3197         my $ord = $slice[$j];
3198         my $col = $cols[$ord];
3199         my $quo = $q->quote($col);
3200         my $val = ($col && ($type_for->{$col} || '')) eq 'enum' ? "CAST(? AS UNSIGNED)" : "?";
3201         if ( $is_nullable->{$col} ) {
3202            push @clause, "(($val IS NULL AND $quo IS NULL) OR ($quo = $val))";
3203            push @r_slice, $ord, $ord;
3204            push @r_scols, $col, $col;
3205         }
3206         else {
3207            push @clause, "$quo = $val";
3208            push @r_slice, $ord;
3209            push @r_scols, $col;
3210         }
3211      }
3212
3213      my $ord = $slice[$i];
3214      my $col = $cols[$ord];
3215      my $quo = $q->quote($col);
3216      my $end = $i == $#slice; # Last clause of the whole group.
3217      my $val = ($col && ($type_for->{$col} || '')) eq 'enum' ? "CAST(? AS UNSIGNED)" : "?";
3218      if ( $is_nullable->{$col} ) {
3219         if ( $type =~ m/=/ && $end ) {
3220            push @clause, "($val IS NULL OR $quo $type $val)";
3221         }
3222         elsif ( $type =~ m/>/ ) {
3223            push @clause, "($val IS NULL AND $quo IS NOT NULL) OR ($quo $cmp $val)";
3224         }
3225         else { # If $type =~ m/</ ) {
3226            push @clauses, "(($val IS NOT NULL AND $quo IS NULL) OR ($quo $cmp $val))";
3227         }
3228         push @r_slice, $ord, $ord;
3229         push @r_scols, $col, $col;
3230      }
3231      else {
3232         push @r_slice, $ord;
3233         push @r_scols, $col;
3234         push @clause, ($type =~ m/=/ && $end ? "$quo $type $val" : "$quo $cmp $val");
3235      }
3236
3237      push @clauses, '(' . join(' AND ', @clause) . ')' if @clause;
3238   }
3239   my $result = '(' . join(' OR ', @clauses) . ')';
3240   my $where = {
3241      slice => \@r_slice,
3242      scols => \@r_scols,
3243      where => $result,
3244   };
3245   return $where;
3246}
3247
3248sub generate_del_stmt {
3249   my ( $self, %args ) = @_;
3250
3251   my $tbl  = $args{tbl_struct};
3252   my @cols = $args{cols} ? @{$args{cols}} : ();
3253   my $tp   = $self->{TableParser};
3254   my $q    = $self->{Quoter};
3255
3256   my @del_cols;
3257   my @del_slice;
3258
3259   my $index = $tp->find_best_index($tbl, $args{index});
3260   die "Cannot find an ascendable index in table" unless $index;
3261
3262   if ( $index && $tbl->{keys}->{$index}->{is_unique}) {
3263      @del_cols = @{$tbl->{keys}->{$index}->{cols}};
3264   }
3265   else {
3266      @del_cols = @{$tbl->{cols}};
3267   }
3268   PTDEBUG && _d('Columns needed for DELETE:', join(', ', @del_cols));
3269
3270   my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
3271   foreach my $col ( @del_cols ) {
3272      if ( !exists $col_posn{$col} ) {
3273         push @cols, $col;
3274         $col_posn{$col} = $#cols;
3275      }
3276      push @del_slice, $col_posn{$col};
3277   }
3278   PTDEBUG && _d('Ordinals needed for DELETE:', join(', ', @del_slice));
3279
3280   my $del_stmt = {
3281      cols  => \@cols,
3282      index => $index,
3283      where => '',
3284      slice => [],
3285      scols => [],
3286   };
3287
3288   my @clauses;
3289   foreach my $i ( 0 .. $#del_slice ) {
3290      my $ord = $del_slice[$i];
3291      my $col = $cols[$ord];
3292      my $quo = $q->quote($col);
3293      if ( $tbl->{is_nullable}->{$col} ) {
3294         push @clauses, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))";
3295         push @{$del_stmt->{slice}}, $ord, $ord;
3296         push @{$del_stmt->{scols}}, $col, $col;
3297      }
3298      else {
3299         push @clauses, "$quo = ?";
3300         push @{$del_stmt->{slice}}, $ord;
3301         push @{$del_stmt->{scols}}, $col;
3302      }
3303   }
3304
3305   $del_stmt->{where} = '(' . join(' AND ', @clauses) . ')';
3306
3307   return $del_stmt;
3308}
3309
3310sub generate_ins_stmt {
3311   my ( $self, %args ) = @_;
3312   foreach my $arg ( qw(ins_tbl sel_cols) ) {
3313      die "I need a $arg argument" unless $args{$arg};
3314   }
3315   my $ins_tbl  = $args{ins_tbl};
3316   my @sel_cols = @{$args{sel_cols}};
3317
3318   die "You didn't specify any SELECT columns" unless @sel_cols;
3319
3320   my @ins_cols;
3321   my @ins_slice;
3322   for my $i ( 0..$#sel_cols ) {
3323      next unless $ins_tbl->{is_col}->{$sel_cols[$i]};
3324      push @ins_cols, $sel_cols[$i];
3325      push @ins_slice, $i;
3326   }
3327
3328   return {
3329      cols  => \@ins_cols,
3330      slice => \@ins_slice,
3331   };
3332}
3333
3334sub _d {
3335   my ($package, undef, $line) = caller 0;
3336   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3337        map { defined $_ ? $_ : 'undef' }
3338        @_;
3339   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3340}
3341
33421;
3343}
3344# ###########################################################################
3345# End TableNibbler package
3346# ###########################################################################
3347
3348# ###########################################################################
3349# Daemon package
3350# This package is a copy without comments from the original.  The original
3351# with comments and its test file can be found in the Bazaar repository at,
3352#   lib/Daemon.pm
3353#   t/lib/Daemon.t
3354# See https://launchpad.net/percona-toolkit for more information.
3355# ###########################################################################
3356{
3357package Daemon;
3358
3359use strict;
3360use warnings FATAL => 'all';
3361use English qw(-no_match_vars);
3362use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3363
3364use POSIX qw(setsid);
3365
3366sub new {
3367   my ( $class, %args ) = @_;
3368   foreach my $arg ( qw(o) ) {
3369      die "I need a $arg argument" unless $args{$arg};
3370   }
3371   my $o = $args{o};
3372   my $self = {
3373      o        => $o,
3374      log_file => $o->has('log') ? $o->get('log') : undef,
3375      PID_file => $o->has('pid') ? $o->get('pid') : undef,
3376   };
3377
3378   check_PID_file(undef, $self->{PID_file});
3379
3380   PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
3381   return bless $self, $class;
3382}
3383
3384sub daemonize {
3385   my ( $self ) = @_;
3386
3387   PTDEBUG && _d('About to fork and daemonize');
3388   defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
3389   if ( $pid ) {
3390      PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
3391      exit;
3392   }
3393
3394   PTDEBUG && _d('Daemonizing child PID', $PID);
3395   $self->{PID_owner} = $PID;
3396   $self->{child}     = 1;
3397
3398   POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
3399   chdir '/'       or die "Cannot chdir to /: $OS_ERROR";
3400
3401   $self->_make_PID_file();
3402
3403   $OUTPUT_AUTOFLUSH = 1;
3404
3405   PTDEBUG && _d('Redirecting STDIN to /dev/null');
3406   close STDIN;
3407   open  STDIN, '/dev/null'
3408      or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
3409
3410   if ( $self->{log_file} ) {
3411      PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
3412      close STDOUT;
3413      open  STDOUT, '>>', $self->{log_file}
3414         or die "Cannot open log file $self->{log_file}: $OS_ERROR";
3415
3416      close STDERR;
3417      open  STDERR, ">&STDOUT"
3418         or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
3419   }
3420   else {
3421      if ( -t STDOUT ) {
3422         PTDEBUG && _d('No log file and STDOUT is a terminal;',
3423            'redirecting to /dev/null');
3424         close STDOUT;
3425         open  STDOUT, '>', '/dev/null'
3426            or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
3427      }
3428      if ( -t STDERR ) {
3429         PTDEBUG && _d('No log file and STDERR is a terminal;',
3430            'redirecting to /dev/null');
3431         close STDERR;
3432         open  STDERR, '>', '/dev/null'
3433            or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
3434      }
3435   }
3436
3437   return;
3438}
3439
3440sub check_PID_file {
3441   my ( $self, $file ) = @_;
3442   my $PID_file = $self ? $self->{PID_file} : $file;
3443   PTDEBUG && _d('Checking PID file', $PID_file);
3444   if ( $PID_file && -f $PID_file ) {
3445      my $pid;
3446      eval {
3447         chomp($pid = (slurp_file($PID_file) || ''));
3448      };
3449      if ( $EVAL_ERROR ) {
3450         die "The PID file $PID_file already exists but it cannot be read: "
3451            . $EVAL_ERROR;
3452      }
3453      PTDEBUG && _d('PID file exists; it contains PID', $pid);
3454      if ( $pid ) {
3455         my $pid_is_alive = kill 0, $pid;
3456         if ( $pid_is_alive ) {
3457            die "The PID file $PID_file already exists "
3458               . " and the PID that it contains, $pid, is running";
3459         }
3460         else {
3461            warn "Overwriting PID file $PID_file because the PID that it "
3462               . "contains, $pid, is not running";
3463         }
3464      }
3465      else {
3466         die "The PID file $PID_file already exists but it does not "
3467            . "contain a PID";
3468      }
3469   }
3470   else {
3471      PTDEBUG && _d('No PID file');
3472   }
3473   return;
3474}
3475
3476sub make_PID_file {
3477   my ( $self ) = @_;
3478   if ( exists $self->{child} ) {
3479      die "Do not call Daemon::make_PID_file() for daemonized scripts";
3480   }
3481   $self->_make_PID_file();
3482   $self->{PID_owner} = $PID;
3483   return;
3484}
3485
3486sub _make_PID_file {
3487   my ( $self ) = @_;
3488
3489   my $PID_file = $self->{PID_file};
3490   if ( !$PID_file ) {
3491      PTDEBUG && _d('No PID file to create');
3492      return;
3493   }
3494
3495   $self->check_PID_file();
3496
3497   open my $PID_FH, '>', $PID_file
3498      or die "Cannot open PID file $PID_file: $OS_ERROR";
3499   print $PID_FH $PID
3500      or die "Cannot print to PID file $PID_file: $OS_ERROR";
3501   close $PID_FH
3502      or die "Cannot close PID file $PID_file: $OS_ERROR";
3503
3504   PTDEBUG && _d('Created PID file:', $self->{PID_file});
3505   return;
3506}
3507
3508sub _remove_PID_file {
3509   my ( $self ) = @_;
3510   if ( $self->{PID_file} && -f $self->{PID_file} ) {
3511      unlink $self->{PID_file}
3512         or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
3513      PTDEBUG && _d('Removed PID file');
3514   }
3515   else {
3516      PTDEBUG && _d('No PID to remove');
3517   }
3518   return;
3519}
3520
3521sub DESTROY {
3522   my ( $self ) = @_;
3523
3524   $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
3525
3526   return;
3527}
3528
3529sub slurp_file {
3530   my ($file) = @_;
3531   return unless $file;
3532   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
3533   return do { local $/; <$fh> };
3534}
3535
3536sub _d {
3537   my ($package, undef, $line) = caller 0;
3538   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3539        map { defined $_ ? $_ : 'undef' }
3540        @_;
3541   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3542}
3543
35441;
3545}
3546# ###########################################################################
3547# End Daemon package
3548# ###########################################################################
3549
3550# ###########################################################################
3551# MasterSlave package
3552# This package is a copy without comments from the original.  The original
3553# with comments and its test file can be found in the Bazaar repository at,
3554#   lib/MasterSlave.pm
3555#   t/lib/MasterSlave.t
3556# See https://launchpad.net/percona-toolkit for more information.
3557# ###########################################################################
3558{
3559package MasterSlave;
3560
3561use strict;
3562use warnings FATAL => 'all';
3563use English qw(-no_match_vars);
3564use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3565
3566sub check_recursion_method {
3567   my ($methods) = @_;
3568   if ( @$methods != 1 ) {
3569      if ( grep({ !m/processlist|hosts/i } @$methods)
3570            && $methods->[0] !~ /^dsn=/i )
3571      {
3572         die  "Invalid combination of recursion methods: "
3573            . join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". "
3574            . "Only hosts and processlist may be combined.\n"
3575      }
3576   }
3577   else {
3578      my ($method) = @$methods;
3579      die "Invalid recursion method: " . ( $method || 'undef' )
3580         unless $method && $method =~ m/^(?:processlist$|hosts$|none$|cluster$|dsn=)/i;
3581   }
3582}
3583
3584sub new {
3585   my ( $class, %args ) = @_;
3586   my @required_args = qw(OptionParser DSNParser Quoter);
3587   foreach my $arg ( @required_args ) {
3588      die "I need a $arg argument" unless $args{$arg};
3589   }
3590   my $self = {
3591      %args,
3592      replication_thread => {},
3593   };
3594   return bless $self, $class;
3595}
3596
3597sub get_slaves {
3598   my ($self, %args) = @_;
3599   my @required_args = qw(make_cxn);
3600   foreach my $arg ( @required_args ) {
3601      die "I need a $arg argument" unless $args{$arg};
3602   }
3603   my ($make_cxn) = @args{@required_args};
3604
3605   my $slaves  = [];
3606   my $dp      = $self->{DSNParser};
3607   my $methods = $self->_resolve_recursion_methods($args{dsn});
3608
3609   return $slaves unless @$methods;
3610
3611   if ( grep { m/processlist|hosts/i } @$methods ) {
3612      my @required_args = qw(dbh dsn);
3613      foreach my $arg ( @required_args ) {
3614         die "I need a $arg argument" unless $args{$arg};
3615      }
3616      my ($dbh, $dsn) = @args{@required_args};
3617      my $o = $self->{OptionParser};
3618
3619      $self->recurse_to_slaves(
3620         {  dbh            => $dbh,
3621            dsn            => $dsn,
3622            slave_user     => $o->got('slave-user') ? $o->get('slave-user') : '',
3623            slave_password => $o->got('slave-password') ? $o->get('slave-password') : '',
3624            callback  => sub {
3625               my ( $dsn, $dbh, $level, $parent ) = @_;
3626               return unless $level;
3627               PTDEBUG && _d('Found slave:', $dp->as_string($dsn));
3628               my $slave_dsn = $dsn;
3629               if ($o->got('slave-user')) {
3630                  $slave_dsn->{u} = $o->get('slave-user');
3631                  PTDEBUG && _d("Using slave user ".$o->get('slave-user')." on ".$slave_dsn->{h}.":".$slave_dsn->{P});
3632               }
3633               if ($o->got('slave-password')) {
3634                  $slave_dsn->{p} = $o->get('slave-password');
3635                  PTDEBUG && _d("Slave password set");
3636               }
3637               push @$slaves, $make_cxn->(dsn => $slave_dsn, dbh => $dbh);
3638               return;
3639            },
3640         }
3641      );
3642   } elsif ( $methods->[0] =~ m/^dsn=/i ) {
3643      (my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i;
3644      $slaves = $self->get_cxn_from_dsn_table(
3645         %args,
3646         dsn_table_dsn => $dsn_table_dsn,
3647      );
3648   }
3649   elsif ( $methods->[0] =~ m/none/i ) {
3650      PTDEBUG && _d('Not getting to slaves');
3651   }
3652   else {
3653      die "Unexpected recursion methods: @$methods";
3654   }
3655
3656   return $slaves;
3657}
3658
3659sub _resolve_recursion_methods {
3660   my ($self, $dsn) = @_;
3661   my $o = $self->{OptionParser};
3662   if ( $o->got('recursion-method') ) {
3663      return $o->get('recursion-method');
3664   }
3665   elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) {
3666      PTDEBUG && _d('Port number is non-standard; using only hosts method');
3667      return [qw(hosts)];
3668   }
3669   else {
3670      return $o->get('recursion-method');
3671   }
3672}
3673
3674sub recurse_to_slaves {
3675   my ( $self, $args, $level ) = @_;
3676   $level ||= 0;
3677   my $dp = $self->{DSNParser};
3678   my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse');
3679   my $dsn = $args->{dsn};
3680   my $slave_user = $args->{slave_user} || '';
3681   my $slave_password = $args->{slave_password} || '';
3682
3683   my $methods = $self->_resolve_recursion_methods($dsn);
3684   PTDEBUG && _d('Recursion methods:', @$methods);
3685   if ( lc($methods->[0]) eq 'none' ) {
3686      PTDEBUG && _d('Not recursing to slaves');
3687      return;
3688   }
3689
3690   my $slave_dsn = $dsn;
3691   if ($slave_user) {
3692      $slave_dsn->{u} = $slave_user;
3693      PTDEBUG && _d("Using slave user $slave_user on ".$slave_dsn->{h}.":".$slave_dsn->{P});
3694   }
3695   if ($slave_password) {
3696      $slave_dsn->{p} = $slave_password;
3697      PTDEBUG && _d("Slave password set");
3698   }
3699
3700   my $dbh;
3701   eval {
3702      $dbh = $args->{dbh} || $dp->get_dbh(
3703         $dp->get_cxn_params($slave_dsn), { AutoCommit => 1 });
3704      PTDEBUG && _d('Connected to', $dp->as_string($slave_dsn));
3705   };
3706   if ( $EVAL_ERROR ) {
3707      print STDERR "Cannot connect to ", $dp->as_string($slave_dsn), "\n"
3708         or die "Cannot print: $OS_ERROR";
3709      return;
3710   }
3711
3712   my $sql  = 'SELECT @@SERVER_ID';
3713   PTDEBUG && _d($sql);
3714   my ($id) = $dbh->selectrow_array($sql);
3715   PTDEBUG && _d('Working on server ID', $id);
3716   my $master_thinks_i_am = $dsn->{server_id};
3717   if ( !defined $id
3718       || ( defined $master_thinks_i_am && $master_thinks_i_am != $id )
3719       || $args->{server_ids_seen}->{$id}++
3720   ) {
3721      PTDEBUG && _d('Server ID seen, or not what master said');
3722      if ( $args->{skip_callback} ) {
3723         $args->{skip_callback}->($dsn, $dbh, $level, $args->{parent});
3724      }
3725      return;
3726   }
3727
3728   $args->{callback}->($dsn, $dbh, $level, $args->{parent});
3729
3730   if ( !defined $recurse || $level < $recurse ) {
3731
3732      my @slaves =
3733         grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves.
3734         $self->find_slave_hosts($dp, $dbh, $dsn, $methods);
3735
3736      foreach my $slave ( @slaves ) {
3737         PTDEBUG && _d('Recursing from',
3738            $dp->as_string($dsn), 'to', $dp->as_string($slave));
3739         $self->recurse_to_slaves(
3740            { %$args, dsn => $slave, dbh => undef, parent => $dsn, slave_user => $slave_user, $slave_password => $slave_password }, $level + 1 );
3741      }
3742   }
3743}
3744
3745sub find_slave_hosts {
3746   my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_;
3747
3748   PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn),
3749      'using methods', @$methods);
3750
3751   my @slaves;
3752   METHOD:
3753   foreach my $method ( @$methods ) {
3754      my $find_slaves = "_find_slaves_by_$method";
3755      PTDEBUG && _d('Finding slaves with', $find_slaves);
3756      @slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn);
3757      last METHOD if @slaves;
3758   }
3759
3760   PTDEBUG && _d('Found', scalar(@slaves), 'slaves');
3761   return @slaves;
3762}
3763
3764sub _find_slaves_by_processlist {
3765   my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
3766   my @connected_slaves = $self->get_connected_slaves($dbh);
3767   my @slaves = $self->_process_slaves_list($dsn_parser, $dsn, \@connected_slaves);
3768   return @slaves;
3769}
3770
3771sub _process_slaves_list {
3772   my ($self, $dsn_parser, $dsn, $connected_slaves) = @_;
3773   my @slaves = map  {
3774      my $slave        = $dsn_parser->parse("h=$_", $dsn);
3775      $slave->{source} = 'processlist';
3776      $slave;
3777   }
3778   grep { $_ }
3779   map  {
3780      my ( $host ) = $_->{host} =~ m/^(.*):\d+$/;
3781      if ( $host eq 'localhost' ) {
3782         $host = '127.0.0.1'; # Replication never uses sockets.
3783      }
3784      if ($host =~ m/::/) {
3785          $host = '['.$host.']';
3786      }
3787      $host;
3788   } @$connected_slaves;
3789
3790   return @slaves;
3791}
3792
3793sub _find_slaves_by_hosts {
3794   my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
3795
3796   my @slaves;
3797   my $sql = 'SHOW SLAVE HOSTS';
3798   PTDEBUG && _d($dbh, $sql);
3799   @slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })};
3800
3801   if ( @slaves ) {
3802      PTDEBUG && _d('Found some SHOW SLAVE HOSTS info');
3803      @slaves = map {
3804         my %hash;
3805         @hash{ map { lc $_ } keys %$_ } = values %$_;
3806         my $spec = "h=$hash{host},P=$hash{port}"
3807            . ( $hash{user} ? ",u=$hash{user}" : '')
3808            . ( $hash{password} ? ",p=$hash{password}" : '');
3809         my $dsn           = $dsn_parser->parse($spec, $dsn);
3810         $dsn->{server_id} = $hash{server_id};
3811         $dsn->{master_id} = $hash{master_id};
3812         $dsn->{source}    = 'hosts';
3813         $dsn;
3814      } @slaves;
3815   }
3816
3817   return @slaves;
3818}
3819
3820sub get_connected_slaves {
3821   my ( $self, $dbh ) = @_;
3822
3823   my $show = "SHOW GRANTS FOR ";
3824   my $user = 'CURRENT_USER()';
3825   my $sql = $show . $user;
3826   PTDEBUG && _d($dbh, $sql);
3827
3828   my $proc;
3829   eval {
3830      $proc = grep {
3831         m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
3832      } @{$dbh->selectcol_arrayref($sql)};
3833   };
3834   if ( $EVAL_ERROR ) {
3835
3836      if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) {
3837         PTDEBUG && _d('Retrying SHOW GRANTS without host; error:',
3838            $EVAL_ERROR);
3839         ($user) = split('@', $user);
3840         $sql    = $show . $user;
3841         PTDEBUG && _d($sql);
3842         eval {
3843            $proc = grep {
3844               m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
3845            } @{$dbh->selectcol_arrayref($sql)};
3846         };
3847      }
3848
3849      die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR;
3850   }
3851   if ( !$proc ) {
3852      die "You do not have the PROCESS privilege";
3853   }
3854
3855   $sql = 'SHOW FULL PROCESSLIST';
3856   PTDEBUG && _d($dbh, $sql);
3857   grep { $_->{command} =~ m/Binlog Dump/i }
3858   map  { # Lowercase the column names
3859      my %hash;
3860      @hash{ map { lc $_ } keys %$_ } = values %$_;
3861      \%hash;
3862   }
3863   @{$dbh->selectall_arrayref($sql, { Slice => {} })};
3864}
3865
3866sub is_master_of {
3867   my ( $self, $master, $slave ) = @_;
3868   my $master_status = $self->get_master_status($master)
3869      or die "The server specified as a master is not a master";
3870   my $slave_status  = $self->get_slave_status($slave)
3871      or die "The server specified as a slave is not a slave";
3872   my @connected     = $self->get_connected_slaves($master)
3873      or die "The server specified as a master has no connected slaves";
3874   my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'");
3875
3876   if ( $port != $slave_status->{master_port} ) {
3877      die "The slave is connected to $slave_status->{master_port} "
3878         . "but the master's port is $port";
3879   }
3880
3881   if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) {
3882      die "I don't see any slave I/O thread connected with user "
3883         . $slave_status->{master_user};
3884   }
3885
3886   if ( ($slave_status->{slave_io_state} || '')
3887      eq 'Waiting for master to send event' )
3888   {
3889      my ( $master_log_name, $master_log_num )
3890         = $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
3891      my ( $slave_log_name, $slave_log_num )
3892         = $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
3893      if ( $master_log_name ne $slave_log_name
3894         || abs($master_log_num - $slave_log_num) > 1 )
3895      {
3896         die "The slave thinks it is reading from "
3897            . "$slave_status->{master_log_file},  but the "
3898            . "master is writing to $master_status->{file}";
3899      }
3900   }
3901   return 1;
3902}
3903
3904sub get_master_dsn {
3905   my ( $self, $dbh, $dsn, $dsn_parser ) = @_;
3906   my $master = $self->get_slave_status($dbh) or return undef;
3907   my $spec   = "h=$master->{master_host},P=$master->{master_port}";
3908   return       $dsn_parser->parse($spec, $dsn);
3909}
3910
3911sub get_slave_status {
3912   my ( $self, $dbh ) = @_;
3913
3914   if ( !$self->{not_a_slave}->{$dbh} ) {
3915      my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS}
3916            ||= $dbh->prepare('SHOW SLAVE STATUS');
3917      PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS');
3918      $sth->execute();
3919      my ($sss_rows) = $sth->fetchall_arrayref({}); # Show Slave Status rows
3920
3921      my $ss;
3922      if ( $sss_rows && @$sss_rows ) {
3923          if (scalar @$sss_rows > 1) {
3924              if (!$self->{channel}) {
3925                  die 'This server returned more than one row for SHOW SLAVE STATUS but "channel" was not specified on the command line';
3926              }
3927              my $slave_use_channels;
3928              for my $row (@$sss_rows) {
3929                  $row = { map { lc($_) => $row->{$_} } keys %$row }; # lowercase the keys
3930                  if ($row->{channel_name}) {
3931                      $slave_use_channels = 1;
3932                  }
3933                  if ($row->{channel_name} eq $self->{channel}) {
3934                      $ss = $row;
3935                      last;
3936                  }
3937              }
3938              if (!$ss && $slave_use_channels) {
3939                 die 'This server is using replication channels but "channel" was not specified on the command line';
3940              }
3941          } else {
3942              if ($sss_rows->[0]->{channel_name} && $sss_rows->[0]->{channel_name} ne $self->{channel}) {
3943                  die 'This server is using replication channels but "channel" was not specified on the command line';
3944              } else {
3945                  $ss = $sss_rows->[0];
3946              }
3947          }
3948
3949          if ( $ss && %$ss ) {
3950             $ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys
3951             return $ss;
3952          }
3953          if (!$ss && $self->{channel}) {
3954              die "Specified channel name is invalid";
3955          }
3956      }
3957
3958      PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS');
3959      $self->{not_a_slave}->{$dbh}++;
3960  }
3961}
3962
3963sub get_master_status {
3964   my ( $self, $dbh ) = @_;
3965
3966   if ( $self->{not_a_master}->{$dbh} ) {
3967      PTDEBUG && _d('Server on dbh', $dbh, 'is not a master');
3968      return;
3969   }
3970
3971   my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS}
3972         ||= $dbh->prepare('SHOW MASTER STATUS');
3973   PTDEBUG && _d($dbh, 'SHOW MASTER STATUS');
3974   $sth->execute();
3975   my ($ms) = @{$sth->fetchall_arrayref({})};
3976   PTDEBUG && _d(
3977      $ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms
3978          : '');
3979
3980   if ( !$ms || scalar keys %$ms < 2 ) {
3981      PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master');
3982      $self->{not_a_master}->{$dbh}++;
3983   }
3984
3985  return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys
3986}
3987
3988sub wait_for_master {
3989   my ( $self, %args ) = @_;
3990   my @required_args = qw(master_status slave_dbh);
3991   foreach my $arg ( @required_args ) {
3992      die "I need a $arg argument" unless $args{$arg};
3993   }
3994   my ($master_status, $slave_dbh) = @args{@required_args};
3995   my $timeout       = $args{timeout} || 60;
3996
3997   my $result;
3998   my $waited;
3999   if ( $master_status ) {
4000      my $slave_status;
4001      eval {
4002          $slave_status = $self->get_slave_status($slave_dbh);
4003      };
4004      if ($EVAL_ERROR) {
4005          return {
4006              result => undef,
4007              waited => 0,
4008              error  =>'Wait for master: this is a multi-master slave but "channel" was not specified on the command line',
4009          };
4010      }
4011      my $server_version = VersionParser->new($slave_dbh);
4012      my $channel_sql = $server_version > '5.6' && $self->{channel} ? ", '$self->{channel}'" : '';
4013      my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', $master_status->{position}, $timeout $channel_sql)";
4014      PTDEBUG && _d($slave_dbh, $sql);
4015      my $start = time;
4016      ($result) = $slave_dbh->selectrow_array($sql);
4017
4018      $waited = time - $start;
4019
4020      PTDEBUG && _d('Result of waiting:', $result);
4021      PTDEBUG && _d("Waited", $waited, "seconds");
4022   }
4023   else {
4024      PTDEBUG && _d('Not waiting: this server is not a master');
4025   }
4026
4027   return {
4028      result => $result,
4029      waited => $waited,
4030   };
4031}
4032
4033sub stop_slave {
4034   my ( $self, $dbh ) = @_;
4035   my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE}
4036         ||= $dbh->prepare('STOP SLAVE');
4037   PTDEBUG && _d($dbh, $sth->{Statement});
4038   $sth->execute();
4039}
4040
4041sub start_slave {
4042   my ( $self, $dbh, $pos ) = @_;
4043   if ( $pos ) {
4044      my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', "
4045              . "MASTER_LOG_POS=$pos->{position}";
4046      PTDEBUG && _d($dbh, $sql);
4047      $dbh->do($sql);
4048   }
4049   else {
4050      my $sth = $self->{sths}->{$dbh}->{START_SLAVE}
4051            ||= $dbh->prepare('START SLAVE');
4052      PTDEBUG && _d($dbh, $sth->{Statement});
4053      $sth->execute();
4054   }
4055}
4056
4057sub catchup_to_master {
4058   my ( $self, $slave, $master, $timeout ) = @_;
4059   $self->stop_slave($master);
4060   $self->stop_slave($slave);
4061   my $slave_status  = $self->get_slave_status($slave);
4062   my $slave_pos     = $self->repl_posn($slave_status);
4063   my $master_status = $self->get_master_status($master);
4064   my $master_pos    = $self->repl_posn($master_status);
4065   PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos),
4066      'Slave position:', $self->pos_to_string($slave_pos));
4067
4068   my $result;
4069   if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) {
4070      PTDEBUG && _d('Waiting for slave to catch up to master');
4071      $self->start_slave($slave, $master_pos);
4072
4073      $result = $self->wait_for_master(
4074            master_status => $master_status,
4075            slave_dbh     => $slave,
4076            timeout       => $timeout,
4077            master_status => $master_status
4078      );
4079      if ($result->{error}) {
4080          die $result->{error};
4081      }
4082      if ( !defined $result->{result} ) {
4083         $slave_status = $self->get_slave_status($slave);
4084         if ( !$self->slave_is_running($slave_status) ) {
4085            PTDEBUG && _d('Master position:',
4086               $self->pos_to_string($master_pos),
4087               'Slave position:', $self->pos_to_string($slave_pos));
4088            $slave_pos = $self->repl_posn($slave_status);
4089            if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) {
4090               die "MASTER_POS_WAIT() returned NULL but slave has not "
4091                  . "caught up to master";
4092            }
4093            PTDEBUG && _d('Slave is caught up to master and stopped');
4094         }
4095         else {
4096            die "Slave has not caught up to master and it is still running";
4097         }
4098      }
4099   }
4100   else {
4101      PTDEBUG && _d("Slave is already caught up to master");
4102   }
4103
4104   return $result;
4105}
4106
4107sub catchup_to_same_pos {
4108   my ( $self, $s1_dbh, $s2_dbh ) = @_;
4109   $self->stop_slave($s1_dbh);
4110   $self->stop_slave($s2_dbh);
4111   my $s1_status = $self->get_slave_status($s1_dbh);
4112   my $s2_status = $self->get_slave_status($s2_dbh);
4113   my $s1_pos    = $self->repl_posn($s1_status);
4114   my $s2_pos    = $self->repl_posn($s2_status);
4115   if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) {
4116      $self->start_slave($s1_dbh, $s2_pos);
4117   }
4118   elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) {
4119      $self->start_slave($s2_dbh, $s1_pos);
4120   }
4121
4122   $s1_status = $self->get_slave_status($s1_dbh);
4123   $s2_status = $self->get_slave_status($s2_dbh);
4124   $s1_pos    = $self->repl_posn($s1_status);
4125   $s2_pos    = $self->repl_posn($s2_status);
4126
4127   if ( $self->slave_is_running($s1_status)
4128     || $self->slave_is_running($s2_status)
4129     || $self->pos_cmp($s1_pos, $s2_pos) != 0)
4130   {
4131      die "The servers aren't both stopped at the same position";
4132   }
4133
4134}
4135
4136sub slave_is_running {
4137   my ( $self, $slave_status ) = @_;
4138   return ($slave_status->{slave_sql_running} || 'No') eq 'Yes';
4139}
4140
4141sub has_slave_updates {
4142   my ( $self, $dbh ) = @_;
4143   my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'};
4144   PTDEBUG && _d($dbh, $sql);
4145   my ($name, $value) = $dbh->selectrow_array($sql);
4146   return $value && $value =~ m/^(1|ON)$/;
4147}
4148
4149sub repl_posn {
4150   my ( $self, $status ) = @_;
4151   if ( exists $status->{file} && exists $status->{position} ) {
4152      return {
4153         file     => $status->{file},
4154         position => $status->{position},
4155      };
4156   }
4157   else {
4158      return {
4159         file     => $status->{relay_master_log_file},
4160         position => $status->{exec_master_log_pos},
4161      };
4162   }
4163}
4164
4165sub get_slave_lag {
4166   my ( $self, $dbh ) = @_;
4167   my $stat = $self->get_slave_status($dbh);
4168   return unless $stat;  # server is not a slave
4169   return $stat->{seconds_behind_master};
4170}
4171
4172sub pos_cmp {
4173   my ( $self, $a, $b ) = @_;
4174   return $self->pos_to_string($a) cmp $self->pos_to_string($b);
4175}
4176
4177sub short_host {
4178   my ( $self, $dsn ) = @_;
4179   my ($host, $port);
4180   if ( $dsn->{master_host} ) {
4181      $host = $dsn->{master_host};
4182      $port = $dsn->{master_port};
4183   }
4184   else {
4185      $host = $dsn->{h};
4186      $port = $dsn->{P};
4187   }
4188   return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" );
4189}
4190
4191sub is_replication_thread {
4192   my ( $self, $query, %args ) = @_;
4193   return unless $query;
4194
4195   my $type = lc($args{type} || 'all');
4196   die "Invalid type: $type"
4197      unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i;
4198
4199   my $match = 0;
4200   if ( $type =~ m/binlog_dump|all/i ) {
4201      $match = 1
4202         if ($query->{Command} || $query->{command} || '') eq "Binlog Dump";
4203   }
4204   if ( !$match ) {
4205      if ( ($query->{User} || $query->{user} || '') eq "system user" ) {
4206         PTDEBUG && _d("Slave replication thread");
4207         if ( $type ne 'all' ) {
4208            my $state = $query->{State} || $query->{state} || '';
4209
4210            if ( $state =~ m/^init|end$/ ) {
4211               PTDEBUG && _d("Special state:", $state);
4212               $match = 1;
4213            }
4214            else {
4215               my ($slave_sql) = $state =~ m/
4216                  ^(Waiting\sfor\sthe\snext\sevent
4217                   |Reading\sevent\sfrom\sthe\srelay\slog
4218                   |Has\sread\sall\srelay\slog;\swaiting
4219                   |Making\stemp\sfile
4220                   |Waiting\sfor\sslave\smutex\son\sexit)/xi;
4221
4222               $match = $type eq 'slave_sql' &&  $slave_sql ? 1
4223                      : $type eq 'slave_io'  && !$slave_sql ? 1
4224                      :                                       0;
4225            }
4226         }
4227         else {
4228            $match = 1;
4229         }
4230      }
4231      else {
4232         PTDEBUG && _d('Not system user');
4233      }
4234
4235      if ( !defined $args{check_known_ids} || $args{check_known_ids} ) {
4236         my $id = $query->{Id} || $query->{id};
4237         if ( $match ) {
4238            $self->{replication_thread}->{$id} = 1;
4239         }
4240         else {
4241            if ( $self->{replication_thread}->{$id} ) {
4242               PTDEBUG && _d("Thread ID is a known replication thread ID");
4243               $match = 1;
4244            }
4245         }
4246      }
4247   }
4248
4249   PTDEBUG && _d('Matches', $type, 'replication thread:',
4250      ($match ? 'yes' : 'no'), '; match:', $match);
4251
4252   return $match;
4253}
4254
4255
4256sub get_replication_filters {
4257   my ( $self, %args ) = @_;
4258   my @required_args = qw(dbh);
4259   foreach my $arg ( @required_args ) {
4260      die "I need a $arg argument" unless $args{$arg};
4261   }
4262   my ($dbh) = @args{@required_args};
4263
4264   my %filters = ();
4265
4266   my $status = $self->get_master_status($dbh);
4267   if ( $status ) {
4268      map { $filters{$_} = $status->{$_} }
4269      grep { defined $status->{$_} && $status->{$_} ne '' }
4270      qw(
4271         binlog_do_db
4272         binlog_ignore_db
4273      );
4274   }
4275
4276   $status = $self->get_slave_status($dbh);
4277   if ( $status ) {
4278      map { $filters{$_} = $status->{$_} }
4279      grep { defined $status->{$_} && $status->{$_} ne '' }
4280      qw(
4281         replicate_do_db
4282         replicate_ignore_db
4283         replicate_do_table
4284         replicate_ignore_table
4285         replicate_wild_do_table
4286         replicate_wild_ignore_table
4287      );
4288
4289      my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'";
4290      PTDEBUG && _d($dbh, $sql);
4291      my $row = $dbh->selectrow_arrayref($sql);
4292      $filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF';
4293   }
4294
4295   return \%filters;
4296}
4297
4298
4299sub pos_to_string {
4300   my ( $self, $pos ) = @_;
4301   my $fmt  = '%s/%020d';
4302   return sprintf($fmt, @{$pos}{qw(file position)});
4303}
4304
4305sub reset_known_replication_threads {
4306   my ( $self ) = @_;
4307   $self->{replication_thread} = {};
4308   return;
4309}
4310
4311sub get_cxn_from_dsn_table {
4312   my ($self, %args) = @_;
4313   my @required_args = qw(dsn_table_dsn make_cxn);
4314   foreach my $arg ( @required_args ) {
4315      die "I need a $arg argument" unless $args{$arg};
4316   }
4317   my ($dsn_table_dsn, $make_cxn) = @args{@required_args};
4318   PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn);
4319
4320   my $dp = $self->{DSNParser};
4321   my $q  = $self->{Quoter};
4322
4323   my $dsn = $dp->parse($dsn_table_dsn);
4324   my $dsn_table;
4325   if ( $dsn->{D} && $dsn->{t} ) {
4326      $dsn_table = $q->quote($dsn->{D}, $dsn->{t});
4327   }
4328   elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) {
4329      $dsn_table = $q->quote($q->split_unquote($dsn->{t}));
4330   }
4331   else {
4332      die "DSN table DSN does not specify a database (D) "
4333        . "or a database-qualified table (t)";
4334   }
4335
4336   my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn);
4337   my $dbh         = $dsn_tbl_cxn->connect();
4338   my $sql         = "SELECT dsn FROM $dsn_table ORDER BY id";
4339   PTDEBUG && _d($sql);
4340   my $dsn_strings = $dbh->selectcol_arrayref($sql);
4341   my @cxn;
4342   if ( $dsn_strings ) {
4343      foreach my $dsn_string ( @$dsn_strings ) {
4344         PTDEBUG && _d('DSN from DSN table:', $dsn_string);
4345         push @cxn, $make_cxn->(dsn_string => $dsn_string);
4346      }
4347   }
4348   return \@cxn;
4349}
4350
4351sub _d {
4352   my ($package, undef, $line) = caller 0;
4353   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4354        map { defined $_ ? $_ : 'undef' }
4355        @_;
4356   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4357}
4358
43591;
4360}
4361# ###########################################################################
4362# End MasterSlave package
4363# ###########################################################################
4364
4365# ###########################################################################
4366# FlowControlWaiter package
4367# This package is a copy without comments from the original.  The original
4368# with comments and its test file can be found in the Bazaar repository at,
4369#   lib/FlowControlWaiter.pm
4370#   t/lib/FlowControlWaiter.t
4371# See https://launchpad.net/percona-toolkit for more information.
4372# ###########################################################################
4373{
4374package FlowControlWaiter;
4375
4376use strict;
4377use warnings FATAL => 'all';
4378use English qw(-no_match_vars);
4379use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4380
4381use Time::HiRes qw(sleep time);
4382use Data::Dumper;
4383
4384sub new {
4385   my ( $class, %args ) = @_;
4386   my @required_args = qw(oktorun node sleep max_flow_ctl);
4387   foreach my $arg ( @required_args ) {
4388      die "I need a $arg argument" unless defined $args{$arg};
4389   }
4390
4391   my $self = {
4392      %args
4393   };
4394
4395   $self->{last_time} = time();
4396
4397   my (undef, $last_fc_ns) = $self->{node}->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
4398
4399   $self->{last_fc_secs} = $last_fc_ns/1000_000_000;
4400
4401   return bless $self, $class;
4402}
4403
4404sub wait {
4405   my ( $self, %args ) = @_;
4406   my @required_args = qw();
4407   foreach my $arg ( @required_args ) {
4408      die "I need a $arg argument" unless $args{$arg};
4409   }
4410   my $pr = $args{Progress};
4411
4412   my $oktorun       = $self->{oktorun};
4413   my $sleep         = $self->{sleep};
4414   my $node          = $self->{node};
4415   my $max_avg       = $self->{max_flow_ctl}/100;
4416
4417   my $too_much_fc = 1;
4418
4419   my $pr_callback;
4420   if ( $pr ) {
4421      $pr_callback = sub {
4422         print STDERR "Pausing because PXC Flow Control is active\n";
4423         return;
4424      };
4425      $pr->set_callback($pr_callback);
4426   }
4427
4428   while ( $oktorun->() && $too_much_fc ) {
4429      my $current_time = time();
4430      my (undef, $current_fc_ns) = $node->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
4431      my $current_fc_secs = $current_fc_ns/1000_000_000;
4432      my $current_avg = ($current_fc_secs - $self->{last_fc_secs}) / ($current_time - $self->{last_time});
4433      if ( $current_avg > $max_avg ) {
4434         if ( $pr ) {
4435            $pr->update(sub { return 0; });
4436         }
4437         PTDEBUG && _d('Calling sleep callback');
4438         if ( $self->{simple_progress} ) {
4439            print STDERR "Waiting for Flow Control to abate\n";
4440         }
4441         $sleep->();
4442      } else {
4443         $too_much_fc = 0;
4444      }
4445      $self->{last_time} = $current_time;
4446      $self->{last_fc_secs} = $current_fc_secs;
4447
4448
4449   }
4450
4451   PTDEBUG && _d('Flow Control is Ok');
4452   return;
4453}
4454
4455sub _d {
4456   my ($package, undef, $line) = caller 0;
4457   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4458        map { defined $_ ? $_ : 'undef' }
4459        @_;
4460   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4461}
4462
44631;
4464}
4465# ###########################################################################
4466# End FlowControlWaiter package
4467# ###########################################################################
4468
4469# ###########################################################################
4470# Cxn package
4471# This package is a copy without comments from the original.  The original
4472# with comments and its test file can be found in the Bazaar repository at,
4473#   lib/Cxn.pm
4474#   t/lib/Cxn.t
4475# See https://launchpad.net/percona-toolkit for more information.
4476# ###########################################################################
4477{
4478package Cxn;
4479
4480use strict;
4481use warnings FATAL => 'all';
4482use English qw(-no_match_vars);
4483use Scalar::Util qw(blessed);
4484use constant {
4485   PTDEBUG => $ENV{PTDEBUG} || 0,
4486   PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
4487};
4488
4489sub new {
4490   my ( $class, %args ) = @_;
4491   my @required_args = qw(DSNParser OptionParser);
4492   foreach my $arg ( @required_args ) {
4493      die "I need a $arg argument" unless $args{$arg};
4494   };
4495   my ($dp, $o) = @args{@required_args};
4496
4497   my $dsn_defaults = $dp->parse_options($o);
4498   my $prev_dsn     = $args{prev_dsn};
4499   my $dsn          = $args{dsn};
4500   if ( !$dsn ) {
4501      $args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
4502
4503      $dsn = $dp->parse(
4504         $args{dsn_string}, $prev_dsn, $dsn_defaults);
4505   }
4506   elsif ( $prev_dsn ) {
4507      $dsn = $dp->copy($prev_dsn, $dsn);
4508   }
4509
4510   my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
4511               || $dp->as_string($dsn, [qw(F)])
4512               || '';
4513
4514   my $self = {
4515      dsn             => $dsn,
4516      dbh             => $args{dbh},
4517      dsn_name        => $dsn_name,
4518      hostname        => '',
4519      set             => $args{set},
4520      NAME_lc         => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
4521      dbh_set         => 0,
4522      ask_pass        => $o->get('ask-pass'),
4523      DSNParser       => $dp,
4524      is_cluster_node => undef,
4525      parent          => $args{parent},
4526   };
4527
4528   return bless $self, $class;
4529}
4530
4531sub connect {
4532   my ( $self, %opts ) = @_;
4533   my $dsn = $opts{dsn} || $self->{dsn};
4534   my $dp  = $self->{DSNParser};
4535
4536   my $dbh = $self->{dbh};
4537   if ( !$dbh || !$dbh->ping() ) {
4538      if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
4539         $dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
4540         $self->{asked_for_pass} = 1;
4541      }
4542      $dbh = $dp->get_dbh(
4543         $dp->get_cxn_params($dsn),
4544         {
4545            AutoCommit => 1,
4546            %opts,
4547         },
4548      );
4549   }
4550
4551   $dbh = $self->set_dbh($dbh);
4552   if ( $opts{dsn} ) {
4553      $self->{dsn}      = $dsn;
4554      $self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
4555                       || $dp->as_string($dsn, [qw(F)])
4556                       || '';
4557
4558   }
4559   PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
4560   return $dbh;
4561}
4562
4563sub set_dbh {
4564   my ($self, $dbh) = @_;
4565
4566   if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
4567      PTDEBUG && _d($dbh, 'Already set dbh');
4568      return $dbh;
4569   }
4570
4571   PTDEBUG && _d($dbh, 'Setting dbh');
4572
4573   $dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
4574
4575   my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
4576   PTDEBUG && _d($dbh, $sql);
4577   my ($server_id, $hostname) = $dbh->selectrow_array($sql);
4578   PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
4579   if ( $hostname ) {
4580      $self->{hostname} = $hostname;
4581   }
4582
4583   if ( $self->{parent} ) {
4584      PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
4585      $dbh->{InactiveDestroy} = 1;
4586   }
4587
4588   if ( my $set = $self->{set}) {
4589      $set->($dbh);
4590   }
4591
4592   $self->{dbh}     = $dbh;
4593   $self->{dbh_set} = 1;
4594   return $dbh;
4595}
4596
4597sub lost_connection {
4598   my ($self, $e) = @_;
4599   return 0 unless $e;
4600   return $e =~ m/MySQL server has gone away/
4601       || $e =~ m/Lost connection to MySQL server/
4602       || $e =~ m/Server shutdown in progress/;
4603}
4604
4605sub dbh {
4606   my ($self) = @_;
4607   return $self->{dbh};
4608}
4609
4610sub dsn {
4611   my ($self) = @_;
4612   return $self->{dsn};
4613}
4614
4615sub name {
4616   my ($self) = @_;
4617   return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
4618   return $self->{hostname} || $self->{dsn_name} || 'unknown host';
4619}
4620
4621sub description {
4622   my ($self) = @_;
4623   return sprintf("%s -> %s:%s", $self->name(), $self->{dsn}->{h}, $self->{dsn}->{P} || 'socket');
4624}
4625
4626sub get_id {
4627   my ($self, $cxn) = @_;
4628
4629   $cxn ||= $self;
4630
4631   my $unique_id;
4632   if ($cxn->is_cluster_node()) {  # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
4633      my $sql  = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
4634      my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
4635      PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
4636      $unique_id = $wsrep_local_index."|";
4637      foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
4638         my $sql = "SHOW VARIABLES LIKE '$val'";
4639         PTDEBUG && _d($cxn->name, $sql);
4640         my (undef, $val) = $cxn->dbh->selectrow_array($sql);
4641         $unique_id .= "|$val";
4642      }
4643   } else {
4644      my $sql  = 'SELECT @@SERVER_ID';
4645      PTDEBUG && _d($sql);
4646      $unique_id = $cxn->dbh->selectrow_array($sql);
4647   }
4648   PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
4649   return $unique_id;
4650}
4651
4652
4653sub is_cluster_node {
4654   my ($self, $cxn) = @_;
4655
4656   $cxn ||= $self;
4657
4658   my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
4659
4660   my $dbh;
4661   if ($cxn->isa('DBI::db')) {
4662      $dbh = $cxn;
4663      PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn!
4664   }
4665   else {
4666      $dbh = $cxn->dbh();
4667      PTDEBUG && _d($cxn->name, $sql);
4668   }
4669
4670   my $row = $dbh->selectrow_arrayref($sql);
4671   return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
4672
4673}
4674
4675sub remove_duplicate_cxns {
4676   my ($self, %args) = @_;
4677   my @cxns     = @{$args{cxns}};
4678   my $seen_ids = $args{seen_ids} || {};
4679   PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
4680   my @trimmed_cxns;
4681
4682   for my $cxn ( @cxns ) {
4683
4684      my $id = $cxn->get_id();
4685      PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
4686
4687      if ( ! $seen_ids->{$id}++ ) {
4688         push @trimmed_cxns, $cxn
4689      }
4690      else {
4691         PTDEBUG && _d("Removing ", $cxn->name,
4692                       ", ID ", $id, ", because we've already seen it");
4693      }
4694   }
4695
4696   return \@trimmed_cxns;
4697}
4698
4699sub DESTROY {
4700   my ($self) = @_;
4701
4702   PTDEBUG && _d('Destroying cxn');
4703
4704   if ( $self->{parent} ) {
4705      PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
4706   }
4707   elsif ( $self->{dbh}
4708           && blessed($self->{dbh})
4709           && $self->{dbh}->can("disconnect") )
4710   {
4711      PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
4712         $self->{dsn_name});
4713      $self->{dbh}->disconnect();
4714   }
4715
4716   return;
4717}
4718
4719sub _d {
4720   my ($package, undef, $line) = caller 0;
4721   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4722        map { defined $_ ? $_ : 'undef' }
4723        @_;
4724   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4725}
4726
47271;
4728}
4729# ###########################################################################
4730# End Cxn package
4731# ###########################################################################
4732
4733
4734# ###########################################################################
4735# HTTP::Micro package
4736# This package is a copy without comments from the original.  The original
4737# with comments and its test file can be found in the Bazaar repository at,
4738#   lib/HTTP/Micro.pm
4739#   t/lib/HTTP/Micro.t
4740# See https://launchpad.net/percona-toolkit for more information.
4741# ###########################################################################
4742{
4743package HTTP::Micro;
4744
4745our $VERSION = '0.01';
4746
4747use strict;
4748use warnings FATAL => 'all';
4749use English qw(-no_match_vars);
4750use Carp ();
4751
4752my @attributes;
4753BEGIN {
4754    @attributes = qw(agent timeout);
4755    no strict 'refs';
4756    for my $accessor ( @attributes ) {
4757        *{$accessor} = sub {
4758            @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
4759        };
4760    }
4761}
4762
4763sub new {
4764    my($class, %args) = @_;
4765    (my $agent = $class) =~ s{::}{-}g;
4766    my $self = {
4767        agent        => $agent . "/" . ($class->VERSION || 0),
4768        timeout      => 60,
4769    };
4770    for my $key ( @attributes ) {
4771        $self->{$key} = $args{$key} if exists $args{$key}
4772    }
4773    return bless $self, $class;
4774}
4775
4776my %DefaultPort = (
4777    http => 80,
4778    https => 443,
4779);
4780
4781sub request {
4782    my ($self, $method, $url, $args) = @_;
4783    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
4784      or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
4785    $args ||= {}; # we keep some state in this during _request
4786
4787    my $response;
4788    for ( 0 .. 1 ) {
4789        $response = eval { $self->_request($method, $url, $args) };
4790        last unless $@ && $method eq 'GET'
4791            && $@ =~ m{^(?:Socket closed|Unexpected end)};
4792    }
4793
4794    if (my $e = "$@") {
4795        $response = {
4796            success => q{},
4797            status  => 599,
4798            reason  => 'Internal Exception',
4799            content => $e,
4800            headers => {
4801                'content-type'   => 'text/plain',
4802                'content-length' => length $e,
4803            }
4804        };
4805    }
4806    return $response;
4807}
4808
4809sub _request {
4810    my ($self, $method, $url, $args) = @_;
4811
4812    my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
4813
4814    my $request = {
4815        method    => $method,
4816        scheme    => $scheme,
4817        host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
4818        uri       => $path_query,
4819        headers   => {},
4820    };
4821
4822    my $handle  = HTTP::Micro::Handle->new(timeout => $self->{timeout});
4823
4824    $handle->connect($scheme, $host, $port);
4825
4826    $self->_prepare_headers_and_cb($request, $args);
4827    $handle->write_request_header(@{$request}{qw/method uri headers/});
4828    $handle->write_content_body($request) if $request->{content};
4829
4830    my $response;
4831    do { $response = $handle->read_response_header }
4832        until (substr($response->{status},0,1) ne '1');
4833
4834    if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
4835        $response->{content} = '';
4836        $handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
4837    }
4838
4839    $handle->close;
4840    $response->{success} = substr($response->{status},0,1) eq '2';
4841    return $response;
4842}
4843
4844sub _prepare_headers_and_cb {
4845    my ($self, $request, $args) = @_;
4846
4847    for ($args->{headers}) {
4848        next unless defined;
4849        while (my ($k, $v) = each %$_) {
4850            $request->{headers}{lc $k} = $v;
4851        }
4852    }
4853    $request->{headers}{'host'}         = $request->{host_port};
4854    $request->{headers}{'connection'}   = "close";
4855    $request->{headers}{'user-agent'} ||= $self->{agent};
4856
4857    if (defined $args->{content}) {
4858        $request->{headers}{'content-type'} ||= "application/octet-stream";
4859        utf8::downgrade($args->{content}, 1)
4860            or Carp::croak(q/Wide character in request message body/);
4861        $request->{headers}{'content-length'} = length $args->{content};
4862        $request->{content} = $args->{content};
4863    }
4864    return;
4865}
4866
4867sub _split_url {
4868    my $url = pop;
4869
4870    my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
4871      or Carp::croak(qq/Cannot parse URL: '$url'/);
4872
4873    $scheme     = lc $scheme;
4874    $path_query = "/$path_query" unless $path_query =~ m<\A/>;
4875
4876    my $host = (length($authority)) ? lc $authority : 'localhost';
4877       $host =~ s/\A[^@]*@//;   # userinfo
4878    my $port = do {
4879       $host =~ s/:([0-9]*)\z// && length $1
4880         ? $1
4881         : $DefaultPort{$scheme}
4882    };
4883
4884    return ($scheme, $host, $port, $path_query);
4885}
4886
4887} # HTTP::Micro
4888
4889{
4890   package HTTP::Micro::Handle;
4891
4892   use strict;
4893   use warnings FATAL => 'all';
4894   use English qw(-no_match_vars);
4895
4896   use Carp       qw(croak);
4897   use Errno      qw(EINTR EPIPE);
4898   use IO::Socket qw(SOCK_STREAM);
4899
4900   sub BUFSIZE () { 32768 }
4901
4902   my $Printable = sub {
4903       local $_ = shift;
4904       s/\r/\\r/g;
4905       s/\n/\\n/g;
4906       s/\t/\\t/g;
4907       s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
4908       $_;
4909   };
4910
4911   sub new {
4912       my ($class, %args) = @_;
4913       return bless {
4914           rbuf          => '',
4915           timeout       => 60,
4916           max_line_size => 16384,
4917           %args
4918       }, $class;
4919   }
4920
4921   my $ssl_verify_args = {
4922       check_cn         => "when_only",
4923       wildcards_in_alt => "anywhere",
4924       wildcards_in_cn  => "anywhere"
4925   };
4926
4927   sub connect {
4928       @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
4929       my ($self, $scheme, $host, $port) = @_;
4930
4931       if ( $scheme eq 'https' ) {
4932           eval "require IO::Socket::SSL"
4933               unless exists $INC{'IO/Socket/SSL.pm'};
4934           croak(qq/IO::Socket::SSL must be installed for https support\n/)
4935               unless $INC{'IO/Socket/SSL.pm'};
4936       }
4937       elsif ( $scheme ne 'http' ) {
4938         croak(qq/Unsupported URL scheme '$scheme'\n/);
4939       }
4940
4941       $self->{fh} = IO::Socket::INET->new(
4942           PeerHost  => $host,
4943           PeerPort  => $port,
4944           Proto     => 'tcp',
4945           Type      => SOCK_STREAM,
4946           Timeout   => $self->{timeout}
4947       ) or croak(qq/Could not connect to '$host:$port': $@/);
4948
4949       binmode($self->{fh})
4950         or croak(qq/Could not binmode() socket: '$!'/);
4951
4952       if ( $scheme eq 'https') {
4953           IO::Socket::SSL->start_SSL($self->{fh});
4954           ref($self->{fh}) eq 'IO::Socket::SSL'
4955               or die(qq/SSL connection failed for $host\n/);
4956           if ( $self->{fh}->can("verify_hostname") ) {
4957               $self->{fh}->verify_hostname( $host, $ssl_verify_args )
4958                  or die(qq/SSL certificate not valid for $host\n/);
4959           }
4960           else {
4961            my $fh = $self->{fh};
4962            _verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
4963                  or die(qq/SSL certificate not valid for $host\n/);
4964            }
4965       }
4966
4967       $self->{host} = $host;
4968       $self->{port} = $port;
4969
4970       return $self;
4971   }
4972
4973   sub close {
4974       @_ == 1 || croak(q/Usage: $handle->close()/);
4975       my ($self) = @_;
4976       CORE::close($self->{fh})
4977         or croak(qq/Could not close socket: '$!'/);
4978   }
4979
4980   sub write {
4981       @_ == 2 || croak(q/Usage: $handle->write(buf)/);
4982       my ($self, $buf) = @_;
4983
4984       my $len = length $buf;
4985       my $off = 0;
4986
4987       local $SIG{PIPE} = 'IGNORE';
4988
4989       while () {
4990           $self->can_write
4991             or croak(q/Timed out while waiting for socket to become ready for writing/);
4992           my $r = syswrite($self->{fh}, $buf, $len, $off);
4993           if (defined $r) {
4994               $len -= $r;
4995               $off += $r;
4996               last unless $len > 0;
4997           }
4998           elsif ($! == EPIPE) {
4999               croak(qq/Socket closed by remote server: $!/);
5000           }
5001           elsif ($! != EINTR) {
5002               croak(qq/Could not write to socket: '$!'/);
5003           }
5004       }
5005       return $off;
5006   }
5007
5008   sub read {
5009       @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
5010       my ($self, $len) = @_;
5011
5012       my $buf  = '';
5013       my $got = length $self->{rbuf};
5014
5015       if ($got) {
5016           my $take = ($got < $len) ? $got : $len;
5017           $buf  = substr($self->{rbuf}, 0, $take, '');
5018           $len -= $take;
5019       }
5020
5021       while ($len > 0) {
5022           $self->can_read
5023             or croak(q/Timed out while waiting for socket to become ready for reading/);
5024           my $r = sysread($self->{fh}, $buf, $len, length $buf);
5025           if (defined $r) {
5026               last unless $r;
5027               $len -= $r;
5028           }
5029           elsif ($! != EINTR) {
5030               croak(qq/Could not read from socket: '$!'/);
5031           }
5032       }
5033       if ($len) {
5034           croak(q/Unexpected end of stream/);
5035       }
5036       return $buf;
5037   }
5038
5039   sub readline {
5040       @_ == 1 || croak(q/Usage: $handle->readline()/);
5041       my ($self) = @_;
5042
5043       while () {
5044           if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
5045               return $1;
5046           }
5047           $self->can_read
5048             or croak(q/Timed out while waiting for socket to become ready for reading/);
5049           my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
5050           if (defined $r) {
5051               last unless $r;
5052           }
5053           elsif ($! != EINTR) {
5054               croak(qq/Could not read from socket: '$!'/);
5055           }
5056       }
5057       croak(q/Unexpected end of stream while looking for line/);
5058   }
5059
5060   sub read_header_lines {
5061       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
5062       my ($self, $headers) = @_;
5063       $headers ||= {};
5064       my $lines   = 0;
5065       my $val;
5066
5067       while () {
5068            my $line = $self->readline;
5069
5070            if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
5071                my ($field_name) = lc $1;
5072                $val = \($headers->{$field_name} = $2);
5073            }
5074            elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
5075                $val
5076                  or croak(q/Unexpected header continuation line/);
5077                next unless length $1;
5078                $$val .= ' ' if length $$val;
5079                $$val .= $1;
5080            }
5081            elsif ($line =~ /\A \x0D?\x0A \z/x) {
5082               last;
5083            }
5084            else {
5085               croak(q/Malformed header line: / . $Printable->($line));
5086            }
5087       }
5088       return $headers;
5089   }
5090
5091   sub write_header_lines {
5092       (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
5093       my($self, $headers) = @_;
5094
5095       my $buf = '';
5096       while (my ($k, $v) = each %$headers) {
5097           my $field_name = lc $k;
5098            $field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
5099               or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
5100            $field_name =~ s/\b(\w)/\u$1/g;
5101            $buf .= "$field_name: $v\x0D\x0A";
5102       }
5103       $buf .= "\x0D\x0A";
5104       return $self->write($buf);
5105   }
5106
5107   sub read_content_body {
5108       @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
5109       my ($self, $cb, $response, $len) = @_;
5110       $len ||= $response->{headers}{'content-length'};
5111
5112       croak("No content-length in the returned response, and this "
5113           . "UA doesn't implement chunking") unless defined $len;
5114
5115       while ($len > 0) {
5116           my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
5117           $cb->($self->read($read), $response);
5118           $len -= $read;
5119       }
5120
5121       return;
5122   }
5123
5124   sub write_content_body {
5125       @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
5126       my ($self, $request) = @_;
5127       my ($len, $content_length) = (0, $request->{headers}{'content-length'});
5128
5129       $len += $self->write($request->{content});
5130
5131       $len == $content_length
5132         or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
5133
5134       return $len;
5135   }
5136
5137   sub read_response_header {
5138       @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
5139       my ($self) = @_;
5140
5141       my $line = $self->readline;
5142
5143       $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
5144         or croak(q/Malformed Status-Line: / . $Printable->($line));
5145
5146       my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
5147
5148       return {
5149           status   => $status,
5150           reason   => $reason,
5151           headers  => $self->read_header_lines,
5152           protocol => $protocol,
5153       };
5154   }
5155
5156   sub write_request_header {
5157       @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
5158       my ($self, $method, $request_uri, $headers) = @_;
5159
5160       return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
5161            + $self->write_header_lines($headers);
5162   }
5163
5164   sub _do_timeout {
5165       my ($self, $type, $timeout) = @_;
5166       $timeout = $self->{timeout}
5167           unless defined $timeout && $timeout >= 0;
5168
5169       my $fd = fileno $self->{fh};
5170       defined $fd && $fd >= 0
5171         or croak(q/select(2): 'Bad file descriptor'/);
5172
5173       my $initial = time;
5174       my $pending = $timeout;
5175       my $nfound;
5176
5177       vec(my $fdset = '', $fd, 1) = 1;
5178
5179       while () {
5180           $nfound = ($type eq 'read')
5181               ? select($fdset, undef, undef, $pending)
5182               : select(undef, $fdset, undef, $pending) ;
5183           if ($nfound == -1) {
5184               $! == EINTR
5185                 or croak(qq/select(2): '$!'/);
5186               redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
5187               $nfound = 0;
5188           }
5189           last;
5190       }
5191       $! = 0;
5192       return $nfound;
5193   }
5194
5195   sub can_read {
5196       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
5197       my $self = shift;
5198       return $self->_do_timeout('read', @_)
5199   }
5200
5201   sub can_write {
5202       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
5203       my $self = shift;
5204       return $self->_do_timeout('write', @_)
5205   }
5206}  # HTTP::Micro::Handle
5207
5208my $prog = <<'EOP';
5209BEGIN {
5210   if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
5211      *CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
5212   }
5213   else {
5214      constant->import( CAN_IPV6 => '' );
5215   }
5216   my %const = (
5217      NID_CommonName => 13,
5218      GEN_DNS => 2,
5219      GEN_IPADD => 7,
5220   );
5221   while ( my ($name,$value) = each %const ) {
5222      no strict 'refs';
5223      *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
5224   }
5225}
5226{
5227   use Carp qw(croak);
5228   my %dispatcher = (
5229      issuer =>  sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
5230      subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
5231   );
5232   if ( $Net::SSLeay::VERSION >= 1.30 ) {
5233      $dispatcher{commonName} = sub {
5234         my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
5235            Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
5236         $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
5237         $cn;
5238      }
5239   } else {
5240      $dispatcher{commonName} = sub {
5241         croak "you need at least Net::SSLeay version 1.30 for getting commonName"
5242      }
5243   }
5244
5245   if ( $Net::SSLeay::VERSION >= 1.33 ) {
5246      $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
5247   } else {
5248      $dispatcher{subjectAltNames} = sub {
5249         return;
5250      };
5251   }
5252
5253   $dispatcher{authority} = $dispatcher{issuer};
5254   $dispatcher{owner}     = $dispatcher{subject};
5255   $dispatcher{cn}        = $dispatcher{commonName};
5256
5257   sub _peer_certificate {
5258      my ($self, $field) = @_;
5259      my $ssl = $self->_get_ssl_object or return;
5260
5261      my $cert = ${*$self}{_SSL_certificate}
5262         ||= Net::SSLeay::get_peer_certificate($ssl)
5263         or return $self->error("Could not retrieve peer certificate");
5264
5265      if ($field) {
5266         my $sub = $dispatcher{$field} or croak
5267            "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
5268            "\nMaybe you need to upgrade your Net::SSLeay";
5269         return $sub->($cert);
5270      } else {
5271         return $cert
5272      }
5273   }
5274
5275
5276   my %scheme = (
5277      ldap => {
5278         wildcards_in_cn    => 0,
5279         wildcards_in_alt => 'leftmost',
5280         check_cn         => 'always',
5281      },
5282      http => {
5283         wildcards_in_cn    => 'anywhere',
5284         wildcards_in_alt => 'anywhere',
5285         check_cn         => 'when_only',
5286      },
5287      smtp => {
5288         wildcards_in_cn    => 0,
5289         wildcards_in_alt => 0,
5290         check_cn         => 'always'
5291      },
5292      none => {}, # do not check
5293   );
5294
5295   $scheme{www}  = $scheme{http}; # alias
5296   $scheme{xmpp} = $scheme{http}; # rfc 3920
5297   $scheme{pop3} = $scheme{ldap}; # rfc 2595
5298   $scheme{imap} = $scheme{ldap}; # rfc 2595
5299   $scheme{acap} = $scheme{ldap}; # rfc 2595
5300   $scheme{nntp} = $scheme{ldap}; # rfc 4642
5301   $scheme{ftp}  = $scheme{http}; # rfc 4217
5302
5303
5304   sub _verify_hostname_of_cert {
5305      my $identity = shift;
5306      my $cert = shift;
5307      my $scheme = shift || 'none';
5308      if ( ! ref($scheme) ) {
5309         $scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
5310      }
5311
5312      return 1 if ! %$scheme; # 'none'
5313
5314      my $commonName = $dispatcher{cn}->($cert);
5315      my @altNames   = $dispatcher{subjectAltNames}->($cert);
5316
5317      if ( my $sub = $scheme->{callback} ) {
5318         return $sub->($identity,$commonName,@altNames);
5319      }
5320
5321
5322      my $ipn;
5323      if ( CAN_IPV6 and $identity =~m{:} ) {
5324         $ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
5325            or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
5326      } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
5327         $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
5328      } else {
5329         if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
5330            $identity =~m{\0} and croak("name '$identity' has \\0 byte");
5331            $identity = IO::Socket::SSL::idn_to_ascii($identity) or
5332               croak "Warning: Given name '$identity' could not be converted to IDNA!";
5333         }
5334      }
5335
5336      my $check_name = sub {
5337         my ($name,$identity,$wtyp) = @_;
5338         $wtyp ||= '';
5339         my $pattern;
5340         if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
5341            $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
5342         } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
5343            $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
5344         } else {
5345            $pattern = qr{^\Q$name\E$}i;
5346         }
5347         return $identity =~ $pattern;
5348      };
5349
5350      my $alt_dnsNames = 0;
5351      while (@altNames) {
5352         my ($type, $name) = splice (@altNames, 0, 2);
5353         if ( $ipn and $type == GEN_IPADD ) {
5354            return 1 if $ipn eq $name;
5355
5356         } elsif ( ! $ipn and $type == GEN_DNS ) {
5357            $name =~s/\s+$//; $name =~s/^\s+//;
5358            $alt_dnsNames++;
5359            $check_name->($name,$identity,$scheme->{wildcards_in_alt})
5360               and return 1;
5361         }
5362      }
5363
5364      if ( ! $ipn and (
5365         $scheme->{check_cn} eq 'always' or
5366         $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
5367         $check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
5368            and return 1;
5369      }
5370
5371      return 0; # no match
5372   }
5373}
5374EOP
5375
5376eval { require IO::Socket::SSL };
5377if ( $INC{"IO/Socket/SSL.pm"} ) {
5378   eval $prog;
5379   die $@ if $@;
5380}
5381
53821;
5383# ###########################################################################
5384# End HTTP::Micro package
5385# ###########################################################################
5386
5387# ###########################################################################
5388# VersionCheck package
5389# This package is a copy without comments from the original.  The original
5390# with comments and its test file can be found in the Bazaar repository at,
5391#   lib/VersionCheck.pm
5392#   t/lib/VersionCheck.t
5393# See https://launchpad.net/percona-toolkit for more information.
5394# ###########################################################################
5395{
5396package VersionCheck;
5397
5398
5399use strict;
5400use warnings FATAL => 'all';
5401use English qw(-no_match_vars);
5402
5403use constant PTDEBUG => $ENV{PTDEBUG} || 0;
5404
5405use Data::Dumper;
5406local $Data::Dumper::Indent    = 1;
5407local $Data::Dumper::Sortkeys  = 1;
5408local $Data::Dumper::Quotekeys = 0;
5409
5410use Digest::MD5 qw(md5_hex);
5411use Sys::Hostname qw(hostname);
5412use File::Basename qw();
5413use File::Spec;
5414use FindBin qw();
5415
5416eval {
5417   require Percona::Toolkit;
5418   require HTTP::Micro;
5419};
5420
5421my $home    = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
5422my @vc_dirs = (
5423   '/etc/percona',
5424   '/etc/percona-toolkit',
5425   '/tmp',
5426   "$home",
5427);
5428
5429{
5430   my $file    = 'percona-version-check';
5431
5432   sub version_check_file {
5433      foreach my $dir ( @vc_dirs ) {
5434         if ( -d $dir && -w $dir ) {
5435            PTDEBUG && _d('Version check file', $file, 'in', $dir);
5436            return $dir . '/' . $file;
5437         }
5438      }
5439      PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
5440      return $file;  # in the CWD
5441   }
5442}
5443
5444sub version_check_time_limit {
5445   return 60 * 60 * 24;  # one day
5446}
5447
5448
5449sub version_check {
5450   my (%args) = @_;
5451
5452   my $instances = $args{instances} || [];
5453   my $instances_to_check;
5454
5455   PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
5456   if ( !$args{force} ) {
5457      if ( $FindBin::Bin
5458           && (-d "$FindBin::Bin/../.bzr"    ||
5459               -d "$FindBin::Bin/../../.bzr" ||
5460               -d "$FindBin::Bin/../.git"    ||
5461               -d "$FindBin::Bin/../../.git"
5462              )
5463         ) {
5464         PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
5465         return;
5466      }
5467   }
5468
5469   eval {
5470      foreach my $instance ( @$instances ) {
5471         my ($name, $id) = get_instance_id($instance);
5472         $instance->{name} = $name;
5473         $instance->{id}   = $id;
5474      }
5475
5476      push @$instances, { name => 'system', id => 0 };
5477
5478      $instances_to_check = get_instances_to_check(
5479         instances => $instances,
5480         vc_file   => $args{vc_file},  # testing
5481         now       => $args{now},      # testing
5482      );
5483      PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
5484      return unless @$instances_to_check;
5485
5486      my $protocol = 'https';
5487      eval { require IO::Socket::SSL; };
5488      if ( $EVAL_ERROR ) {
5489         PTDEBUG && _d($EVAL_ERROR);
5490         PTDEBUG && _d("SSL not available, won't run version_check");
5491         return;
5492      }
5493      PTDEBUG && _d('Using', $protocol);
5494
5495      my $advice = pingback(
5496         instances => $instances_to_check,
5497         protocol  => $protocol,
5498         url       => $args{url}                       # testing
5499                   || $ENV{PERCONA_VERSION_CHECK_URL}  # testing
5500                   || "$protocol://v.percona.com",
5501      );
5502      if ( $advice ) {
5503         PTDEBUG && _d('Advice:', Dumper($advice));
5504         if ( scalar @$advice > 1) {
5505            print "\n# " . scalar @$advice . " software updates are "
5506               . "available:\n";
5507         }
5508         else {
5509            print "\n# A software update is available:\n";
5510         }
5511         print join("\n", map { "#   * $_" } @$advice), "\n\n";
5512      }
5513   };
5514   if ( $EVAL_ERROR ) {
5515      PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
5516   }
5517
5518   if ( @$instances_to_check ) {
5519      eval {
5520         update_check_times(
5521            instances => $instances_to_check,
5522            vc_file   => $args{vc_file},  # testing
5523            now       => $args{now},      # testing
5524         );
5525      };
5526      if ( $EVAL_ERROR ) {
5527         PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
5528      }
5529   }
5530
5531   if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
5532      warn "Exiting because the PTDEBUG_VERSION_CHECK "
5533         . "environment variable is defined.\n";
5534      exit 255;
5535   }
5536
5537   return;
5538}
5539
5540sub get_instances_to_check {
5541   my (%args) = @_;
5542
5543   my $instances = $args{instances};
5544   my $now       = $args{now}     || int(time);
5545   my $vc_file   = $args{vc_file} || version_check_file();
5546
5547   if ( !-f $vc_file ) {
5548      PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
5549         'version checking all instances');
5550      return $instances;
5551   }
5552
5553   open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
5554   chomp(my $file_contents = do { local $/ = undef; <$fh> });
5555   PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
5556   close $fh;
5557   my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
5558
5559   my $check_time_limit = version_check_time_limit();
5560   my @instances_to_check;
5561   foreach my $instance ( @$instances ) {
5562      my $last_check_time = $last_check_time_for{ $instance->{id} };
5563      PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
5564         $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
5565         'hours until next check',
5566         sprintf '%.2f',
5567            ($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
5568      if ( !defined $last_check_time
5569           || ($now - $last_check_time) >= $check_time_limit ) {
5570         PTDEBUG && _d('Time to check', Dumper($instance));
5571         push @instances_to_check, $instance;
5572      }
5573   }
5574
5575   return \@instances_to_check;
5576}
5577
5578sub update_check_times {
5579   my (%args) = @_;
5580
5581   my $instances = $args{instances};
5582   my $now       = $args{now}     || int(time);
5583   my $vc_file   = $args{vc_file} || version_check_file();
5584   PTDEBUG && _d('Updating last check time:', $now);
5585
5586   my %all_instances = map {
5587      $_->{id} => { name => $_->{name}, ts => $now }
5588   } @$instances;
5589
5590   if ( -f $vc_file ) {
5591      open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
5592      my $contents = do { local $/ = undef; <$fh> };
5593      close $fh;
5594
5595      foreach my $line ( split("\n", ($contents || '')) ) {
5596         my ($id, $ts) = split(',', $line);
5597         if ( !exists $all_instances{$id} ) {
5598            $all_instances{$id} = { ts => $ts };  # original ts, not updated
5599         }
5600      }
5601   }
5602
5603   open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
5604   foreach my $id ( sort keys %all_instances ) {
5605      PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
5606      print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
5607   }
5608   close $fh;
5609
5610   return;
5611}
5612
5613sub get_instance_id {
5614   my ($instance) = @_;
5615
5616   my $dbh = $instance->{dbh};
5617   my $dsn = $instance->{dsn};
5618
5619   my $sql = q{SELECT CONCAT(@@hostname, @@port)};
5620   PTDEBUG && _d($sql);
5621   my ($name) = eval { $dbh->selectrow_array($sql) };
5622   if ( $EVAL_ERROR ) {
5623      PTDEBUG && _d($EVAL_ERROR);
5624      $sql = q{SELECT @@hostname};
5625      PTDEBUG && _d($sql);
5626      ($name) = eval { $dbh->selectrow_array($sql) };
5627      if ( $EVAL_ERROR ) {
5628         PTDEBUG && _d($EVAL_ERROR);
5629         $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
5630      }
5631      else {
5632         $sql = q{SHOW VARIABLES LIKE 'port'};
5633         PTDEBUG && _d($sql);
5634         my (undef, $port) = eval { $dbh->selectrow_array($sql) };
5635         PTDEBUG && _d('port:', $port);
5636         $name .= $port || '';
5637      }
5638   }
5639   my $id = md5_hex($name);
5640
5641   PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
5642
5643   return $name, $id;
5644}
5645
5646
5647sub get_uuid {
5648    my $uuid_file = '/.percona-toolkit.uuid';
5649    foreach my $dir (@vc_dirs) {
5650        my $filename = $dir.$uuid_file;
5651        my $uuid=_read_uuid($filename);
5652        return $uuid if $uuid;
5653    }
5654
5655    my $filename = $ENV{"HOME"} . $uuid_file;
5656    my $uuid = _generate_uuid();
5657
5658    open(my $fh, '>', $filename) or die "Could not open file '$filename' $!";
5659    print $fh $uuid;
5660    close $fh;
5661
5662    return $uuid;
5663}
5664
5665sub _generate_uuid {
5666    return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7;
5667}
5668
5669sub _read_uuid {
5670    my $filename = shift;
5671    my $fh;
5672
5673    eval {
5674        open($fh, '<:encoding(UTF-8)', $filename);
5675    };
5676    return if ($EVAL_ERROR);
5677
5678    my $uuid;
5679    eval { $uuid = <$fh>; };
5680    return if ($EVAL_ERROR);
5681
5682    chomp $uuid;
5683    return $uuid;
5684}
5685
5686
5687sub pingback {
5688   my (%args) = @_;
5689   my @required_args = qw(url instances);
5690   foreach my $arg ( @required_args ) {
5691      die "I need a $arg arugment" unless $args{$arg};
5692   }
5693   my $url       = $args{url};
5694   my $instances = $args{instances};
5695
5696   my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
5697
5698   my $response = $ua->request('GET', $url);
5699   PTDEBUG && _d('Server response:', Dumper($response));
5700   die "No response from GET $url"
5701      if !$response;
5702   die("GET on $url returned HTTP status $response->{status}; expected 200\n",
5703       ($response->{content} || '')) if $response->{status} != 200;
5704   die("GET on $url did not return any programs to check")
5705      if !$response->{content};
5706
5707   my $items = parse_server_response(
5708      response => $response->{content}
5709   );
5710   die "Failed to parse server requested programs: $response->{content}"
5711      if !scalar keys %$items;
5712
5713   my $versions = get_versions(
5714      items     => $items,
5715      instances => $instances,
5716   );
5717   die "Failed to get any program versions; should have at least gotten Perl"
5718      if !scalar keys %$versions;
5719
5720   my $client_content = encode_client_response(
5721      items      => $items,
5722      versions   => $versions,
5723      general_id => get_uuid(),
5724   );
5725
5726   my $client_response = {
5727      headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
5728      content => $client_content,
5729   };
5730   PTDEBUG && _d('Client response:', Dumper($client_response));
5731
5732   $response = $ua->request('POST', $url, $client_response);
5733   PTDEBUG && _d('Server suggestions:', Dumper($response));
5734   die "No response from POST $url $client_response"
5735      if !$response;
5736   die "POST $url returned HTTP status $response->{status}; expected 200"
5737      if $response->{status} != 200;
5738
5739   return unless $response->{content};
5740
5741   $items = parse_server_response(
5742      response   => $response->{content},
5743      split_vars => 0,
5744   );
5745   die "Failed to parse server suggestions: $response->{content}"
5746      if !scalar keys %$items;
5747   my @suggestions = map { $_->{vars} }
5748                     sort { $a->{item} cmp $b->{item} }
5749                     values %$items;
5750
5751   return \@suggestions;
5752}
5753
5754sub encode_client_response {
5755   my (%args) = @_;
5756   my @required_args = qw(items versions general_id);
5757   foreach my $arg ( @required_args ) {
5758      die "I need a $arg arugment" unless $args{$arg};
5759   }
5760   my ($items, $versions, $general_id) = @args{@required_args};
5761
5762   my @lines;
5763   foreach my $item ( sort keys %$items ) {
5764      next unless exists $versions->{$item};
5765      if ( ref($versions->{$item}) eq 'HASH' ) {
5766         my $mysql_versions = $versions->{$item};
5767         for my $id ( sort keys %$mysql_versions ) {
5768            push @lines, join(';', $id, $item, $mysql_versions->{$id});
5769         }
5770      }
5771      else {
5772         push @lines, join(';', $general_id, $item, $versions->{$item});
5773      }
5774   }
5775
5776   my $client_response = join("\n", @lines) . "\n";
5777   return $client_response;
5778}
5779
5780sub parse_server_response {
5781   my (%args) = @_;
5782   my @required_args = qw(response);
5783   foreach my $arg ( @required_args ) {
5784      die "I need a $arg arugment" unless $args{$arg};
5785   }
5786   my ($response) = @args{@required_args};
5787
5788   my %items = map {
5789      my ($item, $type, $vars) = split(";", $_);
5790      if ( !defined $args{split_vars} || $args{split_vars} ) {
5791         $vars = [ split(",", ($vars || '')) ];
5792      }
5793      $item => {
5794         item => $item,
5795         type => $type,
5796         vars => $vars,
5797      };
5798   } split("\n", $response);
5799
5800   PTDEBUG && _d('Items:', Dumper(\%items));
5801
5802   return \%items;
5803}
5804
5805my %sub_for_type = (
5806   os_version          => \&get_os_version,
5807   perl_version        => \&get_perl_version,
5808   perl_module_version => \&get_perl_module_version,
5809   mysql_variable      => \&get_mysql_variable,
5810);
5811
5812sub valid_item {
5813   my ($item) = @_;
5814   return unless $item;
5815   if ( !exists $sub_for_type{ $item->{type} } ) {
5816      PTDEBUG && _d('Invalid type:', $item->{type});
5817      return 0;
5818   }
5819   return 1;
5820}
5821
5822sub get_versions {
5823   my (%args) = @_;
5824   my @required_args = qw(items);
5825   foreach my $arg ( @required_args ) {
5826      die "I need a $arg arugment" unless $args{$arg};
5827   }
5828   my ($items) = @args{@required_args};
5829
5830   my %versions;
5831   foreach my $item ( values %$items ) {
5832      next unless valid_item($item);
5833      eval {
5834         my $version = $sub_for_type{ $item->{type} }->(
5835            item      => $item,
5836            instances => $args{instances},
5837         );
5838         if ( $version ) {
5839            chomp $version unless ref($version);
5840            $versions{$item->{item}} = $version;
5841         }
5842      };
5843      if ( $EVAL_ERROR ) {
5844         PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
5845      }
5846   }
5847
5848   return \%versions;
5849}
5850
5851
5852sub get_os_version {
5853   if ( $OSNAME eq 'MSWin32' ) {
5854      require Win32;
5855      return Win32::GetOSDisplayName();
5856   }
5857
5858  chomp(my $platform = `uname -s`);
5859  PTDEBUG && _d('platform:', $platform);
5860  return $OSNAME unless $platform;
5861
5862   chomp(my $lsb_release
5863            = `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
5864   PTDEBUG && _d('lsb_release:', $lsb_release);
5865
5866   my $release = "";
5867
5868   if ( $platform eq 'Linux' ) {
5869      if ( -f "/etc/fedora-release" ) {
5870         $release = `cat /etc/fedora-release`;
5871      }
5872      elsif ( -f "/etc/redhat-release" ) {
5873         $release = `cat /etc/redhat-release`;
5874      }
5875      elsif ( -f "/etc/system-release" ) {
5876         $release = `cat /etc/system-release`;
5877      }
5878      elsif ( $lsb_release ) {
5879         $release = `$lsb_release -ds`;
5880      }
5881      elsif ( -f "/etc/lsb-release" ) {
5882         $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
5883         $release =~ s/^\w+="([^"]+)".+/$1/;
5884      }
5885      elsif ( -f "/etc/debian_version" ) {
5886         chomp(my $rel = `cat /etc/debian_version`);
5887         $release = "Debian $rel";
5888         if ( -f "/etc/apt/sources.list" ) {
5889             chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`);
5890             $release .= " ($code_name)" if $code_name;
5891         }
5892      }
5893      elsif ( -f "/etc/os-release" ) { # openSUSE
5894         chomp($release = `grep PRETTY_NAME /etc/os-release`);
5895         $release =~ s/^PRETTY_NAME="(.+)"$/$1/;
5896      }
5897      elsif ( `ls /etc/*release 2>/dev/null` ) {
5898         if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
5899            $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
5900         }
5901         else {
5902            $release = `cat /etc/*release | head -n1`;
5903         }
5904      }
5905   }
5906   elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
5907      my $rel = `uname -r`;
5908      $release = "$platform $rel";
5909   }
5910   elsif ( $platform eq "SunOS" ) {
5911      my $rel = `head -n1 /etc/release` || `uname -r`;
5912      $release = "$platform $rel";
5913   }
5914
5915   if ( !$release ) {
5916      PTDEBUG && _d('Failed to get the release, using platform');
5917      $release = $platform;
5918   }
5919   chomp($release);
5920
5921   $release =~ s/^"|"$//g;
5922
5923   PTDEBUG && _d('OS version =', $release);
5924   return $release;
5925}
5926
5927sub get_perl_version {
5928   my (%args) = @_;
5929   my $item = $args{item};
5930   return unless $item;
5931
5932   my $version = sprintf '%vd', $PERL_VERSION;
5933   PTDEBUG && _d('Perl version', $version);
5934   return $version;
5935}
5936
5937sub get_perl_module_version {
5938   my (%args) = @_;
5939   my $item = $args{item};
5940   return unless $item;
5941
5942   my $var     = '$' . $item->{item} . '::VERSION';
5943   my $version = eval "use $item->{item}; $var;";
5944   PTDEBUG && _d('Perl version for', $var, '=', $version);
5945   return $version;
5946}
5947
5948sub get_mysql_variable {
5949   return get_from_mysql(
5950      show => 'VARIABLES',
5951      @_,
5952   );
5953}
5954
5955sub get_from_mysql {
5956   my (%args) = @_;
5957   my $show      = $args{show};
5958   my $item      = $args{item};
5959   my $instances = $args{instances};
5960   return unless $show && $item;
5961
5962   if ( !$instances || !@$instances ) {
5963      PTDEBUG && _d('Cannot check', $item,
5964         'because there are no MySQL instances');
5965      return;
5966   }
5967
5968   if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
5969      @{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
5970   }
5971
5972
5973   my @versions;
5974   my %version_for;
5975   foreach my $instance ( @$instances ) {
5976      next unless $instance->{id};  # special system instance has id=0
5977      my $dbh = $instance->{dbh};
5978      local $dbh->{FetchHashKeyName} = 'NAME_lc';
5979      my $sql = qq/SHOW $show/;
5980      PTDEBUG && _d($sql);
5981      my $rows = $dbh->selectall_hashref($sql, 'variable_name');
5982
5983      my @versions;
5984      foreach my $var ( @{$item->{vars}} ) {
5985         $var = lc($var);
5986         my $version = $rows->{$var}->{value};
5987         PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
5988            'on', $instance->{name});
5989         push @versions, $version;
5990      }
5991      $version_for{ $instance->{id} } = join(' ', @versions);
5992   }
5993
5994   return \%version_for;
5995}
5996
5997sub _d {
5998   my ($package, undef, $line) = caller 0;
5999   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
6000        map { defined $_ ? $_ : 'undef' }
6001        @_;
6002   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
6003}
6004
60051;
6006}
6007# ###########################################################################
6008# End VersionCheck package
6009# ###########################################################################
6010
6011# ###########################################################################
6012# This is a combination of modules and programs in one -- a runnable module.
6013# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
6014# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
6015#
6016# Check at the end of this package for the call to main() which actually runs
6017# the program.
6018# ###########################################################################
6019package pt_archiver;
6020
6021use utf8;
6022use English qw(-no_match_vars);
6023use List::Util qw(max);
6024use IO::File;
6025use sigtrap qw(handler finish untrapped normal-signals);
6026use Time::HiRes qw(gettimeofday sleep time);
6027use Data::Dumper;
6028$Data::Dumper::Indent    = 1;
6029$Data::Dumper::Quotekeys = 0;
6030
6031use Percona::Toolkit;
6032use constant PTDEBUG => $ENV{PTDEBUG} || 0;
6033
6034# Global variables; as few as possible.
6035my $oktorun   = 1;
6036my $txn_cnt   = 0;
6037my $cnt       = 0;
6038my $can_retry = 1;
6039my $archive_fh;
6040my $get_sth;
6041my ( $OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = ( 0, -1, 1 );
6042my ( $src, $dst );
6043my $pxc_version = '0';
6044my $fields_separated_by = "\t";
6045my $optionally_enclosed_by;
6046
6047# Holds the arguments for the $sth's bind variables, so it can be re-tried
6048# easily.
6049my @beginning_of_txn;
6050my $q  = new Quoter;
6051
6052sub main {
6053   local @ARGV = @_;  # set global ARGV for this package
6054
6055   # Reset global vars else tests, which run this tool as a module,
6056   # may encounter weird results.
6057   $oktorun          = 1;
6058   $txn_cnt          = 0;
6059   $cnt              = 0;
6060   $can_retry        = 1;
6061   $archive_fh       = undef;
6062   $get_sth          = undef;
6063   ($src, $dst)      = (undef, undef);
6064   @beginning_of_txn = ();
6065   undef *trace;
6066   ($OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = (0, -1, 1);
6067
6068
6069   # ########################################################################
6070   # Get configuration information.
6071   # ########################################################################
6072   my $o = new OptionParser();
6073   $o->get_specs();
6074   $o->get_opts();
6075
6076   my $dp = $o->DSNParser();
6077   $dp->prop('set-vars', $o->set_vars());
6078
6079   # Frequently used options.
6080   $src             = $o->get('source');
6081   $dst             = $o->get('dest');
6082   my $sentinel     = $o->get('sentinel');
6083   my $bulk_del     = $o->get('bulk-delete');
6084   my $commit_each  = $o->get('commit-each');
6085   my $limit        = $o->get('limit');
6086   my $archive_file = $o->get('file');
6087   my $txnsize      = $o->get('txn-size');
6088   my $quiet        = $o->get('quiet');
6089   my $got_charset  = $o->get('charset');
6090
6091   # First things first: if --stop was given, create the sentinel file.
6092   if ( $o->get('stop') ) {
6093      my $sentinel_fh = IO::File->new($sentinel, ">>")
6094         or die "Cannot open $sentinel: $OS_ERROR\n";
6095      print $sentinel_fh "Remove this file to permit pt-archiver to run\n"
6096         or die "Cannot write to $sentinel: $OS_ERROR\n";
6097      close $sentinel_fh
6098         or die "Cannot close $sentinel: $OS_ERROR\n";
6099      print STDOUT "Successfully created file $sentinel\n"
6100         unless $quiet;
6101      return 0;
6102   }
6103
6104   # Generate a filename with sprintf-like formatting codes.
6105   if ( $archive_file ) {
6106      my @time = localtime();
6107      my %fmt = (
6108         d => sprintf('%02d', $time[3]),
6109         H => sprintf('%02d', $time[2]),
6110         i => sprintf('%02d', $time[1]),
6111         m => sprintf('%02d', $time[4] + 1),
6112         s => sprintf('%02d', $time[0]),
6113         Y => $time[5] + 1900,
6114         D => $src && $src->{D} ? $src->{D} : '',
6115         t => $src && $src->{t} ? $src->{t} : '',
6116      );
6117      $archive_file =~ s/%([dHimsYDt])/$fmt{$1}/g;
6118   }
6119
6120
6121   if ( !$o->got('help') ) {
6122      $o->save_error("--source DSN requires a 't' (table) part")
6123         unless $src->{t};
6124
6125      if ( $dst ) {
6126         # Ensure --source and --dest don't point to the same place
6127         my $same = 1;
6128         foreach my $arg ( qw(h P D t S) ) {
6129            if ( defined $src->{$arg} && defined $dst->{$arg}
6130                 && $src->{$arg} ne $dst->{$arg} ) {
6131               $same = 0;
6132               last;
6133            }
6134         }
6135         if ( $same ) {
6136            $o->save_error("--source and --dest refer to the same table");
6137         }
6138      }
6139      if ( $o->get('bulk-insert') ) {
6140         $o->save_error("--bulk-insert is meaningless without a destination")
6141            unless $dst;
6142         $bulk_del = 1; # VERY IMPORTANT for safety.
6143      }
6144      if ( $bulk_del && $limit < 2 ) {
6145         $o->save_error("--bulk-delete is meaningless with --limit 1");
6146      }
6147      if ( $o->got('purge') && $o->got('no-delete') ) {
6148         $o->save_error("--purge and --no-delete are mutually exclusive");
6149      }
6150   }
6151
6152   if ( $bulk_del || $o->get('bulk-insert') ) {
6153      $o->set('commit-each', 1);
6154   }
6155
6156   $o->usage_or_errors();
6157
6158   # ########################################################################
6159   # If --pid, check it first since we'll die if it already exits.
6160   # ########################################################################
6161   my $daemon;
6162   if ( $o->get('pid') ) {
6163      # We're not daemoninzing, it just handles PID stuff.  Keep $daemon
6164      # in the the scope of main() because when it's destroyed it automatically
6165      # removes the PID file.
6166      $daemon = new Daemon(o=>$o);
6167      $daemon->make_PID_file();
6168   }
6169
6170   # ########################################################################
6171   # Set up statistics.
6172   # ########################################################################
6173   my %statistics = ();
6174   my $stat_start;
6175
6176   if ( $o->get('statistics') ) {
6177      my $start    = gettimeofday();
6178      my $obs_cost = gettimeofday() - $start; # cost of observation
6179
6180      *trace = sub {
6181         my ( $thing, $sub ) = @_;
6182         my $start = gettimeofday();
6183         $sub->();
6184         $statistics{$thing . '_time'}
6185            += (gettimeofday() - $start - $obs_cost);
6186         ++$statistics{$thing . '_count'};
6187         $stat_start ||= $start;
6188      }
6189   }
6190   else { # Generate a version that doesn't do any timing
6191      *trace = sub {
6192         my ( $thing, $sub ) = @_;
6193         $sub->();
6194      }
6195   }
6196
6197   # ########################################################################
6198   # Inspect DB servers and tables.
6199   # ########################################################################
6200
6201   my $tp = new TableParser(Quoter => $q);
6202   foreach my $table ( grep { $_ } ($src, $dst) ) {
6203      my $ac = !$txnsize && !$commit_each;
6204      if ( !defined $table->{p} && $o->get('ask-pass') ) {
6205         $table->{p} = OptionParser::prompt_noecho("Enter password: ");
6206      }
6207      my $dbh = $dp->get_dbh(
6208         $dp->get_cxn_params($table), { AutoCommit => $ac });
6209      PTDEBUG && _d('Inspecting table on', $dp->as_string($table));
6210
6211      # Set options that can enable removing data on the master
6212      # and archiving it on the slaves.
6213      if ( $table->{a} ) {
6214         $dbh->do("USE $table->{a}");
6215      }
6216      if ( $table->{b} ) {
6217         $dbh->do("SET SQL_LOG_BIN=0");
6218      }
6219
6220      my ($dbh_version) =  $dbh->selectrow_array("SELECT version()");
6221      #if ($dbh_version =~ m/^(\d+\.\d+)\.\d+.*/ && $1 ge '8.0' && !$o->get('charset')) {
6222      if ($dbh_version =~ m/^(\d+\.\d+)\.\d+.*/ && $1 ge '8.0') {
6223         PTDEBUG && _d("MySQL 8.0+ detected and charset was not specified.\n Setting character_set_client = utf8mb4 and --charset=utf8");
6224         $dbh->do('/*!40101 SET character_set_connection = utf8mb4 */;');
6225         $o->set('charset', 'utf8');
6226      }
6227
6228      $table->{dbh}  = $dbh;
6229      $table->{irot} = get_irot($dbh);
6230
6231      $can_retry = $can_retry && !$table->{irot};
6232
6233      $table->{db_tbl} = $q->quote(
6234         map  { $_ =~ s/(^`|`$)//g; $_; }
6235         grep { $_ }
6236         ( $table->{D}, $table->{t} )
6237      );
6238
6239      # Create objects for archivable and dependency handling, BEFORE getting
6240      # the tbl structure (because the object might do some setup, including
6241      # creating the table to be archived).
6242      if ( $table->{m} ) {
6243         eval "require $table->{m}";
6244         die $EVAL_ERROR if $EVAL_ERROR;
6245
6246         trace('plugin_start', sub {
6247            $table->{plugin} = $table->{m}->new(
6248               dbh          => $table->{dbh},
6249               db           => $table->{D},
6250               tbl          => $table->{t},
6251               OptionParser => $o,
6252               DSNParser    => $dp,
6253               Quoter       => $q,
6254            );
6255         });
6256      }
6257
6258      $table->{info} = $tp->parse(
6259         $tp->get_create_table( $dbh, $table->{D}, $table->{t} ));
6260
6261      if ( $o->get('check-charset') ) {
6262         my $sql = 'SELECT CONCAT(/*!40100 @@session.character_set_connection, */ "")';
6263         PTDEBUG && _d($sql);
6264         my ($dbh_charset) =  $table->{dbh}->selectrow_array($sql);
6265
6266         if ( ($dbh_charset || "") ne ($table->{info}->{charset} || "") &&
6267              !($dbh_charset eq "utf8mb4" && ($table->{info}->{charset} || "") eq ("utf8"))
6268         ) {
6269            $src->{dbh}->disconnect() if $src && $src->{dbh};
6270            $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6271            die "Character set mismatch: "
6272               . ($src && $table eq $src ? "--source " : "--dest ")
6273               . "DSN uses "     . ($dbh_charset || "")
6274               . ", table uses " . ($table->{info}->{charset} || "")
6275               . ".  You can disable this check by specifying "
6276               . "--no-check-charset.\n";
6277         }
6278      }
6279   }
6280
6281   if ( $o->get('primary-key-only')
6282        && !exists $src->{info}->{keys}->{PRIMARY} ) {
6283      $src->{dbh}->disconnect();
6284      $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6285      die "--primary-key-only was specified by the --source table "
6286         . "$src->{db_tbl} does not have a PRIMARY KEY";
6287   }
6288
6289   if ( $dst && $o->get('check-columns') ) {
6290      my @not_in_src = grep {
6291         !$src->{info}->{is_col}->{$_}
6292      } @{$dst->{info}->{cols}};
6293      if ( @not_in_src ) {
6294         $src->{dbh}->disconnect();
6295         $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6296         die "The following columns exist in --dest but not --source: "
6297            . join(', ', @not_in_src)
6298            . "\n";
6299      }
6300      my @not_in_dst = grep {
6301         !$dst->{info}->{is_col}->{$_}
6302      } @{$src->{info}->{cols}};
6303      if ( @not_in_dst ) {
6304         $src->{dbh}->disconnect();
6305         $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6306         die "The following columns exist in --source but not --dest: "
6307            . join(', ', @not_in_dst)
6308            . "\n";
6309      }
6310   }
6311
6312   # ########################################################################
6313   # Get lag dbh.
6314   # ########################################################################
6315   my @lag_dbh;
6316   my $ms;
6317   if ( $o->get('check-slave-lag') ) {
6318      my $dsn_defaults = $dp->parse_options($o);
6319      my $lag_slaves_dsn = $o->get('check-slave-lag');
6320      $ms = new MasterSlave(
6321         OptionParser => $o,
6322         DSNParser    => $dp,
6323         Quoter       => $q,
6324         channel      => $o->get('channel'),
6325      );
6326      # we get each slave's connection handler (and its id, for debug and reporting)
6327      for my $slave (@$lag_slaves_dsn) {
6328         my $dsn                 = $dp->parse($slave, $dsn_defaults);
6329         my $lag_dbh             = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 });
6330         my $lag_id              = $ms->short_host($dsn);
6331         push @lag_dbh , {'dbh' => $lag_dbh, 'id' => $lag_id}
6332      }
6333   }
6334
6335   # #######################################################################
6336   # Check if it's a cluster and if so get version
6337   # Create FlowControlWaiter object if max-flow-ctl was specified and
6338   # PXC version supports it
6339   # #######################################################################
6340
6341   my $flow_ctl;
6342   if ( $src && $src->{dbh} && Cxn::is_cluster_node($src->{dbh}) ) {
6343         $pxc_version = VersionParser->new($src->{'dbh'});
6344         if ( $o->got('max-flow-ctl') ) {
6345            if ( $pxc_version < '5.6' ) {
6346               die "Option '--max-flow-ctl' is only available for PXC version 5.6 "
6347                  . "or higher."
6348            } else {
6349               $flow_ctl = new FlowControlWaiter(
6350                  node          => $src->{'dbh'},
6351                  max_flow_ctl  => $o->get('max-flow-ctl'),
6352                  oktorun       => sub { return $oktorun },
6353                  sleep         => sub { sleep($o->get('check-interval')) },
6354                  simple_progress => $o->got('progress') ? 1 : 0,
6355               );
6356           }
6357        }
6358    }
6359
6360   if ( $src && $src->{dbh} && !Cxn::is_cluster_node($src->{dbh}) && $o->got('max-flow-ctl') ) {
6361         die "Option '--max-flow-ctl' is for use with PXC clusters."
6362    }
6363
6364   # ########################################################################
6365   # Set up general plugin.
6366   # ########################################################################
6367   my $plugin;
6368   if ( $o->get('plugin') ) {
6369      eval "require " . $o->get('plugin');
6370      die $EVAL_ERROR if $EVAL_ERROR;
6371      $plugin = $o->get('plugin')->new(
6372         src  => $src,
6373         dst  => $dst,
6374         opts => $o,
6375      );
6376   }
6377
6378   # ########################################################################
6379   # Design SQL statements.
6380   # ########################################################################
6381   my $dbh = $src->{dbh};
6382   my $nibbler = new TableNibbler(
6383      TableParser => $tp,
6384      Quoter      => $q,
6385   );
6386   my ($first_sql, $next_sql, $del_sql, $ins_sql);
6387   my ($sel_stmt, $ins_stmt, $del_stmt);
6388   my (@asc_slice, @sel_slice, @del_slice, @bulkdel_slice, @ins_slice);
6389   my @sel_cols = $o->get('columns')          ? @{$o->get('columns')}    # Explicit
6390                : $o->get('primary-key-only') ? @{$src->{info}->{keys}->{PRIMARY}->{cols}}
6391                :                               @{$src->{info}->{cols}}; # All
6392   PTDEBUG && _d("sel cols: ", @sel_cols);
6393
6394   $del_stmt = $nibbler->generate_del_stmt(
6395      tbl_struct => $src->{info},
6396      cols       => \@sel_cols,
6397      index      => $o->get('primary-key-only') ? 'PRIMARY' : $src->{i},
6398   );
6399   @del_slice = @{$del_stmt->{slice}};
6400
6401   # Generate statement for ascending index, if desired
6402   if ( !$o->get('no-ascend') ) {
6403      $sel_stmt = $nibbler->generate_asc_stmt(
6404         tbl_struct => $src->{info},
6405         cols       => $del_stmt->{cols},
6406         index      => $del_stmt->{index},
6407         asc_first  => $o->get('ascend-first'),
6408         # A plugin might prevent rows in the source from being deleted
6409         # when doing single delete, but it cannot prevent rows from
6410         # being deleted when doing a bulk delete.
6411         asc_only   => $o->get('no-delete') ?  1
6412                    : $src->{m}             ? ($o->get('bulk-delete') ? 0 : 1)
6413                    :                          0,
6414      )
6415   }
6416   else {
6417      $sel_stmt = {
6418         cols  => $del_stmt->{cols},
6419         index => undef,
6420         where => '1=1',
6421         slice => [], # No-ascend = no bind variables in the WHERE clause.
6422         scols => [], # No-ascend = no bind variables in the WHERE clause.
6423      };
6424   }
6425   @asc_slice = @{$sel_stmt->{slice}};
6426   @sel_slice = 0..$#sel_cols;
6427
6428   $first_sql
6429      = 'SELECT' . ( $o->get('high-priority-select') ? ' HIGH_PRIORITY' : '' )
6430      . ' /*!40001 SQL_NO_CACHE */ '
6431      . join(',', map { $q->quote($_) } @{$sel_stmt->{cols}} )
6432      . " FROM $src->{db_tbl}"
6433      . ( $sel_stmt->{index}
6434         ? ((VersionParser->new($dbh) >= '4.0.9' ? " FORCE" : " USE")
6435            . " INDEX(`$sel_stmt->{index}`)")
6436         : '')
6437      . " WHERE (".$o->get('where').")";
6438
6439   if ( $o->get('safe-auto-increment')
6440         && $sel_stmt->{index}
6441         && scalar(@{$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}}) == 1
6442         && $src->{info}->{is_autoinc}->{
6443            $src->{info}->{keys}->{$sel_stmt->{index}}->{cols}->[0]
6444         }
6445   ) {
6446      my $col = $q->quote($sel_stmt->{scols}->[0]);
6447      my ($val) = $dbh->selectrow_array("SELECT MAX($col) FROM $src->{db_tbl}");
6448      $first_sql .= " AND ($col < " . $q->quote_val($val) . ")";
6449   }
6450
6451   $next_sql = $first_sql;
6452   if ( !$o->get('no-ascend') ) {
6453      $next_sql .= " AND $sel_stmt->{where}";
6454   }
6455
6456   # Obtain index cols so we can order them when ascending
6457   # this ensures returned sets are disjoint when ran on partitioned tables
6458   # issue 1376561
6459   my $index_cols;
6460   if (  $sel_stmt->{index} && $src->{info}->{keys}->{$sel_stmt->{index}}->{cols} ) {
6461      $index_cols = join(",",map { "`$_`" } @{$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}});
6462   }
6463
6464   foreach my $thing ( $first_sql, $next_sql ) {
6465      $thing .= " ORDER BY $index_cols" if $index_cols;
6466      $thing .= " LIMIT $limit";
6467      if ( $o->get('for-update') ) {
6468         $thing .= ' FOR UPDATE';
6469      }
6470      elsif ( $o->get('share-lock') ) {
6471         $thing .= ' LOCK IN SHARE MODE';
6472      }
6473   }
6474
6475   PTDEBUG && _d("Index for DELETE:", $del_stmt->{index});
6476   if ( !$bulk_del ) {
6477      # The LIMIT might be 1 here, because even though a SELECT can return
6478      # many rows, an INSERT only does one at a time.  It would not be safe to
6479      # iterate over a SELECT that was LIMIT-ed to 500 rows, read and INSERT
6480      # one, and then delete with a LIMIT of 500.  Only one row would be written
6481      # to the file; only one would be INSERT-ed at the destination.  But
6482      # LIMIT 1 is actually only needed when the index is not unique
6483      # (http://code.google.com/p/maatkit/issues/detail?id=1166).
6484      $del_sql = 'DELETE'
6485         . ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '')
6486         . ($o->get('quick-delete')        ? ' QUICK'        : '')
6487         . " FROM $src->{db_tbl} WHERE $del_stmt->{where}";
6488
6489         if ( $src->{info}->{keys}->{$del_stmt->{index}}->{is_unique} ) {
6490            PTDEBUG && _d("DELETE index is unique; LIMIT 1 is not needed");
6491         }
6492         else {
6493            PTDEBUG && _d("Adding LIMIT 1 to DELETE because DELETE index "
6494               . "is not unique");
6495            $del_sql .= " LIMIT 1";
6496         }
6497   }
6498   else {
6499      # Unless, of course, it's a bulk DELETE, in which case the 500 rows have
6500      # already been INSERT-ed.
6501      my $asc_stmt = $nibbler->generate_asc_stmt(
6502         tbl_struct => $src->{info},
6503         cols       => $del_stmt->{cols},
6504         index      => $del_stmt->{index},
6505         asc_first  => 0,
6506      );
6507      $del_sql = 'DELETE'
6508         . ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '')
6509         . ($o->get('quick-delete')        ? ' QUICK'        : '')
6510         . " FROM $src->{db_tbl} WHERE ("
6511         . $asc_stmt->{boundaries}->{'>='}
6512         . ') AND (' . $asc_stmt->{boundaries}->{'<='}
6513         # Unlike the row-at-a-time DELETE, this one must include the user's
6514         # specified WHERE clause and an appropriate LIMIT clause.
6515         . ") AND (".$o->get('where').")"
6516         . ($o->get('bulk-delete-limit') ? " LIMIT $limit" : "");
6517      @bulkdel_slice = @{$asc_stmt->{slice}};
6518   }
6519
6520   if ( $dst ) {
6521      $ins_stmt = $nibbler->generate_ins_stmt(
6522         ins_tbl  => $dst->{info},
6523         sel_cols => \@sel_cols,
6524      );
6525      PTDEBUG && _d("inst stmt: ", Dumper($ins_stmt));
6526      @ins_slice = @{$ins_stmt->{slice}};
6527      if ( $o->get('bulk-insert') ) {
6528         $ins_sql = 'LOAD DATA'
6529                  . ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '')
6530                  . ' LOCAL INFILE ?'
6531                  . ($o->get('replace')    ? ' REPLACE'      : '')
6532                  . ($o->get('ignore')     ? ' IGNORE'       : '')
6533                  . " INTO TABLE $dst->{db_tbl}"
6534                  . ($got_charset ? "CHARACTER SET $got_charset" : "")
6535                  . "("
6536                  . join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} )
6537                  . ")";
6538      }
6539      else {
6540         $ins_sql = ($o->get('replace')             ? 'REPLACE'      : 'INSERT')
6541                  . ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '')
6542                  . ($o->get('delayed-insert')      ? ' DELAYED'      : '')
6543                  . ($o->get('ignore')              ? ' IGNORE'       : '')
6544                  . " INTO $dst->{db_tbl}("
6545                  . join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} )
6546                  . ") VALUES ("
6547                  . join(",", map { "?" } @{$ins_stmt->{cols}} ) . ")";
6548      }
6549   }
6550   else {
6551      $ins_sql = '';
6552   }
6553
6554   if ( PTDEBUG ) {
6555      _d("get first sql:", $first_sql);
6556      _d("get next sql:", $next_sql);
6557      _d("del row sql:", $del_sql);
6558      _d("ins row sql:", $ins_sql);
6559   }
6560
6561   if ( $o->get('dry-run') ) {
6562      if ( !$quiet ) {
6563         print join("\n", grep { $_ } ($archive_file || ''),
6564                  $first_sql, $next_sql,
6565                  ($o->get('no-delete') ? '' : $del_sql), $ins_sql)
6566            , "\n";
6567      }
6568      $src->{dbh}->disconnect();
6569      $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6570      return 0;
6571   }
6572
6573   my $get_first = $dbh->prepare($first_sql);
6574   my $get_next  = $dbh->prepare($next_sql);
6575   my $del_row   = $dbh->prepare($del_sql);
6576   my $ins_row   = $dst->{dbh}->prepare($ins_sql) if $dst; # Different $dbh!
6577
6578   # ########################################################################
6579   # Set MySQL options.
6580   # ########################################################################
6581
6582   if ( $o->get('skip-foreign-key-checks') ) {
6583      $src->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */");
6584      if ( $dst ) {
6585         $dst->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */");
6586      }
6587   }
6588
6589   # ########################################################################
6590   # Set up the plugins
6591   # ########################################################################
6592   foreach my $table ( $dst, $src ) {
6593      next unless $table && $table->{plugin};
6594      trace ('before_begin', sub {
6595         $table->{plugin}->before_begin(
6596            cols    => \@sel_cols,
6597            allcols => $sel_stmt->{cols},
6598         );
6599      });
6600   }
6601
6602   # ########################################################################
6603   # Do the version-check
6604   # ########################################################################
6605   if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
6606      VersionCheck::version_check(
6607         force     => $o->got('version-check'),
6608         instances => [
6609            { dbh => $src->{dbh}, dsn => $src->{dsn} },
6610            ( $dst ? { dbh => $dst->{dbh}, dsn => $dst->{dsn} } : () ),
6611         ],
6612      );
6613   }
6614
6615   # ########################################################################
6616   # Start archiving.
6617   # ########################################################################
6618   my $start   = time();
6619   my $end     = $start + ($o->get('run-time') || 0); # When to exit
6620   my $now     = $start;
6621   my $last_select_time;  # for --sleep-coef
6622   my $retries = $o->get('retries');
6623   printf("%-19s %7s %7s\n", 'TIME', 'ELAPSED', 'COUNT')
6624      if $o->get('progress') && !$quiet;
6625   printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt)
6626      if $o->get('progress') && !$quiet;
6627
6628   $get_sth = $get_first; # Later it may be assigned $get_next
6629   trace('select', sub {
6630      my $select_start = time;
6631      $get_sth->execute;
6632      $last_select_time = time - $select_start;
6633      $statistics{SELECT} += $get_sth->rows;
6634   });
6635   my $row = $get_sth->fetchrow_arrayref();
6636   PTDEBUG && _d("First row: ", Dumper($row), 'rows:', $get_sth->rows);
6637   if ( !$row ) {
6638      $get_sth->finish;
6639      $src->{dbh}->disconnect();
6640      $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
6641      return 0;
6642   }
6643
6644   my $charset  = $got_charset || '';
6645   if ($charset eq 'utf8') {
6646      $charset = ":$charset";
6647   }
6648   elsif ($charset) {
6649      eval { require Encode }
6650            or (PTDEBUG &&
6651               _d("Couldn't load Encode: ", $EVAL_ERROR,
6652                  "Going to try using the charset ",
6653                  "passed in without checking it."));
6654      # No need to punish a user if they did their
6655      # homework and passed in an official charset,
6656      # rather than an alias.
6657      $charset = ":encoding("
6658               . (defined &Encode::resolve_alias
6659                  ? Encode::resolve_alias($charset) || $charset
6660                  : $charset)
6661               . ")";
6662   }
6663
6664   if ( $charset eq ':utf8' && $DBD::mysql::VERSION lt '4'
6665      && ( $archive_file || $o->get('bulk-insert') ) )
6666   {
6667      my $plural = '';
6668      my $files  = $archive_file ? '--file' : '';
6669      if ( $o->get('bulk-insert') ) {
6670         if ($files) {
6671            $plural = 's';
6672            $files .= $files ? ' and ' : '';
6673         }
6674         $files .= '--bulk-insert'
6675      }
6676      warn "Setting binmode :raw instead of :utf8 on $files file$plural "
6677         . "because DBD::mysql 3.0007 has a bug with UTF-8.  "
6678         . "Verify the $files file$plural, as the bug may lead to "
6679         . "data being double-encoded.  Update DBD::mysql to avoid "
6680         . "this warning.";
6681      $charset = ":raw";
6682   }
6683
6684   # Open the file and print the header to it.
6685   if ( $archive_file ) {
6686      if ($o->got('output-format') && $o->get('output-format') ne 'dump' && $o->get('output-format') ne 'csv') {
6687          warn "Invalid output format:". $o->get('format');
6688          warn "Using default 'dump' format";
6689      } elsif ($o->get('output-format') || '' eq 'csv') {
6690              $fields_separated_by = ", ";
6691              $optionally_enclosed_by = '"';
6692      }
6693      my $need_hdr = $o->get('header') && !-f $archive_file;
6694      $archive_fh = IO::File->new($archive_file, ">>$charset")
6695         or die "Cannot open $charset $archive_file: $OS_ERROR\n";
6696      binmode STDOUT, ":utf8";
6697      binmode $archive_fh, ":utf8";
6698      $archive_fh->autoflush(1) unless $o->get('buffer');
6699      if ( $need_hdr ) {
6700         print { $archive_fh } '', escape(\@sel_cols, $fields_separated_by, $optionally_enclosed_by), "\n"
6701            or die "Cannot write to $archive_file: $OS_ERROR\n";
6702      }
6703   }
6704
6705   # Open the bulk insert file, which doesn't get any header info.
6706   my $bulkins_file;
6707   if ( $o->get('bulk-insert') ) {
6708      require File::Temp;
6709      $bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' )
6710         or die "Cannot open temp file: $OS_ERROR\n";
6711      binmode($bulkins_file, $charset)
6712         or die "Cannot set $charset as an encoding for the bulk-insert "
6713              . "file: $OS_ERROR";
6714   }
6715
6716   # This row is the first row fetched from each 'chunk'.
6717   my $first_row = [ @$row ];
6718   my $csv_row;
6719   my $flow_ctl_count = 0;
6720   my $lag_count = 0;
6721   my $bulk_count = 0;
6722
6723   ROW:
6724   while (                                 # Quit if:
6725      $row                                 # There is no data
6726      && $retries >= 0                     # or retries are exceeded
6727      && (!$o->get('run-time') || $now < $end) # or time is exceeded
6728      && !-f $sentinel                     # or the sentinel is set
6729      && $oktorun                          # or instructed to quit
6730      )
6731   {
6732      my $lastrow = $row;
6733
6734      if ( !$src->{plugin}
6735         || trace('is_archivable', sub {
6736            $src->{plugin}->is_archivable(row => $row)
6737         })
6738      ) {
6739
6740         # Do the archiving.  Write to the file first since, like the file,
6741         # MyISAM and other tables cannot be rolled back etc.  If there is a
6742         # problem, hopefully the data has at least made it to the file.
6743         my $escaped_row;
6744         if ( $archive_fh || $bulkins_file ) {
6745            $escaped_row = escape([@{$row}[@sel_slice]], $fields_separated_by, $optionally_enclosed_by);
6746         }
6747         if ( $archive_fh ) {
6748            trace('print_file', sub {
6749               print $archive_fh $escaped_row, "\n"
6750                  or die "Cannot write to $archive_file: $OS_ERROR\n";
6751            });
6752         }
6753
6754         # ###################################################################
6755         # This code is for the row-at-a-time archiving functionality.
6756         # ###################################################################
6757         # INSERT must come first, to be as safe as possible.
6758         if ( $dst && !$bulkins_file ) {
6759            my $ins_sth; # Let plugin change which sth is used for the INSERT.
6760            if ( $dst->{plugin} ) {
6761               trace('before_insert', sub {
6762                  $dst->{plugin}->before_insert(row => $row);
6763               });
6764               trace('custom_sth', sub {
6765                  $ins_sth = $dst->{plugin}->custom_sth(
6766                     row => $row, sql => $ins_sql);
6767               });
6768            }
6769            $ins_sth ||= $ins_row; # Default to the sth decided before.
6770            my $success = do_with_retries($o, 'inserting', sub {
6771               my $ins_cnt = $ins_sth->execute(@{$row}[@ins_slice]);
6772               PTDEBUG && _d('Inserted', $ins_cnt, 'rows');
6773               $statistics{INSERT} += $ins_sth->rows;
6774            });
6775            if ( $success == $OUT_OF_RETRIES ) {
6776               $retries = -1;
6777               last ROW;
6778            }
6779            elsif ( $success == $ROLLED_BACK ) {
6780               --$retries;
6781               next ROW;
6782            }
6783         }
6784
6785         if ( !$bulk_del ) {
6786            # DELETE comes after INSERT for safety.
6787            if ( $src->{plugin} ) {
6788               trace('before_delete', sub {
6789                  $src->{plugin}->before_delete(row => $row);
6790               });
6791            }
6792            if ( !$o->get('no-delete') ) {
6793               my $success = do_with_retries($o, 'deleting', sub {
6794                  $del_row->execute(@{$row}[@del_slice]);
6795                  PTDEBUG && _d('Deleted', $del_row->rows, 'rows');
6796                  $statistics{DELETE} += $del_row->rows;
6797               });
6798               if ( $success == $OUT_OF_RETRIES ) {
6799                  $retries = -1;
6800                  last ROW;
6801               }
6802               elsif ( $success == $ROLLED_BACK ) {
6803                  --$retries;
6804                  next ROW;
6805               }
6806            }
6807         }
6808
6809         # ###################################################################
6810         # This code is for the bulk archiving functionality.
6811         # ###################################################################
6812         if ( $bulkins_file ) {
6813            trace('print_bulkfile', sub {
6814               print $bulkins_file $escaped_row, "\n"
6815                  or die "Cannot write to bulk file: $OS_ERROR\n";
6816            });
6817         }
6818
6819      }  # row is archivable
6820
6821      $now = time();
6822      ++$cnt;
6823      ++$txn_cnt;
6824      $retries = $o->get('retries');
6825
6826      # Possibly flush the file and commit the insert and delete.
6827      commit($o) unless $commit_each;
6828
6829      # Report on progress.
6830      if ( !$quiet && $o->get('progress') && $cnt % $o->get('progress') == 0 ) {
6831         printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt);
6832      }
6833
6834      # Get the next row in this chunk.
6835      # First time through this loop $get_sth is set to $get_first.
6836      # For non-bulk operations this means that rows ($row) are archived
6837      # one-by-one in in the code block above ("row is archivable").  For
6838      # bulk operations, the 2nd to 2nd-to-last rows are ignored and
6839      # only the first row ($first_row) and the last row ($last_row) of
6840      # this chunk are used to do bulk INSERT or DELETE on the range of
6841      # rows between first and last.  After the bulk ops, $first_row and
6842      # $last_row are reset to the next chunk.
6843      if ( $get_sth->{Active} ) { # Fetch until exhausted
6844         $row = $get_sth->fetchrow_arrayref();
6845      }
6846      if ( !$row ) {
6847         PTDEBUG && _d('No more rows in this chunk; doing bulk operations');
6848
6849         # ###################################################################
6850         # This code is for the bulk archiving functionality.
6851         # ###################################################################
6852         if ( $bulkins_file ) {
6853            $bulkins_file->close()
6854               or die "Cannot close bulk insert file: $OS_ERROR\n";
6855            my $ins_sth; # Let plugin change which sth is used for the INSERT.
6856            if ( $dst->{plugin} ) {
6857               trace('before_bulk_insert', sub {
6858                  $dst->{plugin}->before_bulk_insert(
6859                     first_row => $first_row,
6860                     last_row  => $lastrow,
6861                     filename  => $bulkins_file->filename(),
6862                  );
6863               });
6864               trace('custom_sth', sub {
6865                  $ins_sth = $dst->{plugin}->custom_sth_bulk(
6866                     first_row => $first_row,
6867                     last_row  => $lastrow,
6868                     filename  => $bulkins_file->filename(),
6869                     sql       => $ins_sql,
6870                  );
6871               });
6872            }
6873            $ins_sth ||= $ins_row; # Default to the sth decided before.
6874            my $success = do_with_retries($o, 'bulk_inserting', sub {
6875               $ins_sth->execute($bulkins_file->filename());
6876               $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
6877               PTDEBUG && _d('Bulk inserted', $del_row->rows, 'rows');
6878               $statistics{INSERT} += $ins_sth->rows;
6879            });
6880            if ( $success != $ALL_IS_WELL ) {
6881               $retries = -1;
6882               last ROW; # unlike other places, don't do 'next'
6883            }
6884         }
6885
6886         if ( $bulk_del ) {
6887            if ( $src->{plugin} ) {
6888               trace('before_bulk_delete', sub {
6889                  $src->{plugin}->before_bulk_delete(
6890                     first_row => $first_row,
6891                     last_row  => $lastrow,
6892                  );
6893               });
6894            }
6895            if ( !$o->get('no-delete') ) {
6896               my $success = do_with_retries($o, 'bulk_deleting', sub {
6897                  $del_row->execute(
6898                     @{$first_row}[@bulkdel_slice],
6899                     @{$lastrow}[@bulkdel_slice],
6900                  );
6901                  PTDEBUG && _d('Bulk deleted', $del_row->rows, 'rows');
6902                  $statistics{DELETE} += $del_row->rows;
6903               });
6904               if ( $success != $ALL_IS_WELL ) {
6905                  $retries = -1;
6906                  last ROW; # unlike other places, don't do 'next'
6907               }
6908            }
6909         }
6910
6911         # ###################################################################
6912         # This code is for normal operation AND bulk operation.
6913         # ###################################################################
6914         commit($o, 1) if $commit_each;
6915         $get_sth = $get_next;
6916
6917         # Sleep between fetching the next chunk of rows.
6918         if( my $sleep_time = $o->get('sleep') ) {
6919            $sleep_time = $last_select_time * $o->get('sleep-coef')
6920               if $o->get('sleep-coef');
6921            PTDEBUG && _d('Sleeping', $sleep_time);
6922            trace('sleep', sub {
6923               sleep($sleep_time);
6924            });
6925         }
6926
6927         PTDEBUG && _d('Fetching rows in next chunk');
6928         trace('select', sub {
6929            my $select_start = time;
6930            $get_sth->execute(@{$lastrow}[@asc_slice]);
6931            $last_select_time = time - $select_start;
6932            PTDEBUG && _d('Fetched', $get_sth->rows, 'rows');
6933            $statistics{SELECT} += $get_sth->rows;
6934         });
6935
6936         # Reset $first_row to the first row of this new chunk.
6937         @beginning_of_txn = @{$lastrow}[@asc_slice] unless $txn_cnt;
6938         $row              = $get_sth->fetchrow_arrayref();
6939         $first_row        = $row ? [ @$row ] : undef;
6940
6941         if ( $o->get('bulk-insert') ) {
6942            $bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' )
6943               or die "Cannot open temp file: $OS_ERROR\n";
6944            binmode($bulkins_file, $charset)
6945               or die "Cannot set $charset as an encoding for the bulk-insert "
6946                    . "file: $OS_ERROR";
6947         }
6948      }  # no next row (do bulk operations)
6949      else {
6950         # keep alive every 100 rows saved to file
6951         # https://bugs.launchpad.net/percona-toolkit/+bug/1452895
6952         if ( $bulk_count++ % 100 == 0 ) {
6953            $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
6954         }
6955         PTDEBUG && _d('Got another row in this chunk');
6956      }
6957
6958      # Check slave lag and wait if slave is too far behind.
6959      # Do this check every 100 rows
6960      if (@lag_dbh && $lag_count++ % 100 == 0 ) {
6961         foreach my $lag_server (@lag_dbh) {
6962            my $lag_dbh = $lag_server->{'dbh'};
6963            my $id      = $lag_server->{'id'};
6964            if ( $lag_dbh ) {
6965               my $lag = $ms->get_slave_lag($lag_dbh);
6966               while ( !defined $lag || $lag > $o->get('max-lag') ) {
6967                  PTDEBUG && _d("Sleeping: slave lag for server '$id' is", $lag);
6968                  if ($o->got('progress')) {
6969                     _d("Sleeping: slave lag for server '$id' is", $lag);
6970                  }
6971                  sleep($o->get('check-interval'));
6972                  $lag = $ms->get_slave_lag($lag_dbh);
6973                  commit($o, $txnsize || $commit_each);
6974                  $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
6975                  $dst->{dbh}->do("SELECT 'pt-archiver keepalive'") if $dst;
6976               }
6977            }
6978         }
6979      }
6980
6981      # if it's a cluster, check for flow control every 100 rows
6982      if ( $flow_ctl && $flow_ctl_count++ % 100 == 0) {
6983         $flow_ctl->wait();
6984      }
6985
6986   }  # ROW
6987   PTDEBUG && _d('Done fetching rows');
6988
6989   # Transactions might still be open, etc
6990   commit($o, $txnsize || $commit_each);
6991   if ( $archive_file && $archive_fh ) {
6992      close $archive_fh
6993         or die "Cannot close $archive_file: $OS_ERROR\n";
6994   }
6995
6996   if ( !$quiet && $o->get('progress') ) {
6997      printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt);
6998   }
6999
7000   # Tear down the plugins.
7001   foreach my $table ( $dst, $src ) {
7002      next unless $table && $table->{plugin};
7003      trace('after_finish', sub {
7004         $table->{plugin}->after_finish();
7005      });
7006   }
7007
7008   # Run ANALYZE or OPTIMIZE.
7009   if ( $oktorun && ($o->get('analyze') || $o->get('optimize')) ) {
7010      my $action = $o->get('analyze') || $o->get('optimize');
7011      my $maint  = ($o->get('analyze') ? 'ANALYZE' : 'OPTIMIZE')
7012                 . ($o->get('local') ? ' /*!40101 NO_WRITE_TO_BINLOG*/' : '');
7013      if ( $action =~ m/s/i ) {
7014         trace($maint, sub {
7015            $src->{dbh}->do("$maint TABLE $src->{db_tbl}");
7016         });
7017      }
7018      if ( $action =~ m/d/i && $dst ) {
7019         trace($maint, sub {
7020            $dst->{dbh}->do("$maint TABLE $dst->{db_tbl}");
7021         });
7022      }
7023   }
7024
7025   # ########################################################################
7026   # Print statistics
7027   # ########################################################################
7028   if ( $plugin ) {
7029      $plugin->statistics(\%statistics, $stat_start);
7030   }
7031
7032   if ( !$quiet && $o->get('statistics') ) {
7033      my $stat_stop  = gettimeofday();
7034      my $stat_total = $stat_stop - $stat_start;
7035
7036      my $total2 = 0;
7037      my $maxlen = 0;
7038      my %summary;
7039
7040      printf("Started at %s, ended at %s\n", ts($stat_start), ts($stat_stop));
7041      print("Source: ", $dp->as_string($src), "\n");
7042      print("Dest:   ", $dp->as_string($dst), "\n") if $dst;
7043      print(join("\n", map { "$_ " . ($statistics{$_} || 0) }
7044            qw(SELECT INSERT DELETE)), "\n");
7045
7046      foreach my $thing ( grep { m/_(count|time)/ } keys %statistics ) {
7047         my ( $action, $type ) = $thing =~ m/^(.*?)_(count|time)$/;
7048         $summary{$action}->{$type}  = $statistics{$thing};
7049         $summary{$action}->{action} = $action;
7050         $maxlen                     = max($maxlen, length($action));
7051         # Just in case I get only one type of statistic for a given action (in
7052         # case there was a crash or CTRL-C or something).
7053         $summary{$action}->{time}  ||= 0;
7054         $summary{$action}->{count} ||= 0;
7055      }
7056      printf("%-${maxlen}s \%10s %10s %10s\n", qw(Action Count Time Pct));
7057      my $fmt = "%-${maxlen}s \%10d %10.4f %10.2f\n";
7058
7059      foreach my $stat (
7060         reverse sort { $a->{time} <=> $b->{time} } values %summary )
7061      {
7062         my $pct = $stat->{time} / $stat_total * 100;
7063         printf($fmt, @{$stat}{qw(action count time)}, $pct);
7064         $total2 += $stat->{time};
7065      }
7066      printf($fmt, 'other', 0, $stat_total - $total2,
7067         ($stat_total - $total2) / $stat_total * 100);
7068   }
7069
7070   # Optionally print the reason for exiting.  Do this even if --quiet is
7071   # specified.
7072   if ( $o->get('why-quit') ) {
7073      if ( $retries < 0 ) {
7074         print "Exiting because retries exceeded.\n";
7075      }
7076      elsif ( $o->get('run-time') && $now >= $end ) {
7077         print "Exiting because time exceeded.\n";
7078      }
7079      elsif ( -f $sentinel ) {
7080         print "Exiting because sentinel file $sentinel exists.\n";
7081      }
7082      elsif ( $o->get('statistics') ) {
7083         print "Exiting because there are no more rows.\n";
7084      }
7085   }
7086
7087   $get_sth->finish() if $get_sth;
7088   $src->{dbh}->disconnect();
7089   $dst->{dbh}->disconnect() if $dst && $dst->{dbh};
7090
7091   return 0;
7092}
7093
7094# ############################################################################
7095# Subroutines.
7096# ############################################################################
7097
7098# Catches signals so pt-archiver can exit gracefully.
7099sub finish {
7100   my ($signal) = @_;
7101   print STDERR "Exiting on SIG$signal.\n";
7102   $oktorun = 0;
7103}
7104
7105# Accesses globals, but I wanted the code in one place.
7106sub commit {
7107   my ( $o, $force ) = @_;
7108   my $txnsize = $o->get('txn-size');
7109   if ( $force || ($txnsize && $txn_cnt && $cnt % $txnsize == 0) ) {
7110      if ( $o->get('buffer') && $archive_fh ) {
7111         my $archive_file = $o->get('file');
7112         trace('flush', sub {
7113            $archive_fh->flush or die "Cannot flush $archive_file: $OS_ERROR\n";
7114         });
7115      }
7116      if ( $dst ) {
7117         trace('commit', sub {
7118            $dst->{dbh}->commit;
7119         });
7120      }
7121      trace('commit', sub {
7122         $src->{dbh}->commit;
7123      });
7124      $txn_cnt = 0;
7125   }
7126}
7127
7128# Repeatedly retries the code until retries runs out, a really bad error
7129# happens, or it succeeds.  This sub uses lots of global variables; I only wrote
7130# it to factor out some repeated code.
7131sub do_with_retries {
7132   my ( $o, $doing, $code ) = @_;
7133   my $retries = $o->get('retries');
7134   my $txnsize = $o->get('txn-size');
7135   my $success = $OUT_OF_RETRIES;
7136
7137   RETRY:
7138   while ( !$success && $retries >= 0 ) {
7139      eval {
7140         trace($doing, $code);
7141         $success = $ALL_IS_WELL;
7142      };
7143      if ( $EVAL_ERROR ) {
7144         if ( $EVAL_ERROR =~ m/Lock wait timeout exceeded|Deadlock found/ ) {
7145            if (
7146               # More than one row per txn
7147               (
7148                  ($txnsize && $txnsize > 1)
7149                  || ($o->get('commit-each') && $o->get('limit') > 1)
7150               )
7151               # Not first row
7152               && $txn_cnt
7153               # And it's not retry-able
7154               && (!$can_retry || $EVAL_ERROR =~ m/Deadlock/)
7155            ) {
7156               # The txn, which is more than 1 statement, was rolled back.
7157               last RETRY;
7158            }
7159            else {
7160               # Only one statement had trouble, and the rest of the txn was
7161               # not rolled back.  The statement can be retried.
7162               --$retries;
7163            }
7164         }
7165         else {
7166            die $EVAL_ERROR;
7167         }
7168      }
7169   }
7170
7171   if ( $success != $ALL_IS_WELL ) {
7172      # Must throw away everything and start the transaction over.
7173      if ( $retries >= 0 ) {
7174         warn "Deadlock or non-retryable lock wait while $doing; "
7175            . "rolling back $txn_cnt rows.\n";
7176         $success = $ROLLED_BACK;
7177      }
7178      else {
7179         warn "Exhausted retries while $doing; rolling back $txn_cnt rows.\n";
7180         $success = $OUT_OF_RETRIES;
7181      }
7182      $get_sth->finish;
7183      trace('rollback', sub {
7184         $dst->{dbh}->rollback;
7185      });
7186      trace('rollback', sub {
7187         $src->{dbh}->rollback;
7188      });
7189      # I wish: $archive_fh->rollback
7190      trace('select', sub {
7191         $get_sth->execute(@beginning_of_txn);
7192      });
7193      $cnt -= $txn_cnt;
7194      $txn_cnt = 0;
7195   }
7196   return $success;
7197}
7198
7199# Formats a row the same way SELECT INTO OUTFILE does by default.  This is
7200# described in the LOAD DATA INFILE section of the MySQL manual,
7201# http://dev.mysql.com/doc/refman/5.0/en/load-data.html
7202sub escape {
7203   my ($row, $fields_separated_by, $optionally_enclosed_by) = @_;
7204   $fields_separated_by ||= "\t";
7205   $optionally_enclosed_by ||= '';
7206
7207   return join($fields_separated_by, map {
7208      s/([\t\n\\])/\\$1/g if defined $_;  # Escape tabs etc
7209      my $s = defined $_ ? $_ : '\N';             # NULL = \N
7210      # var & ~var will return 0 only for numbers
7211      if ($s !~ /^[0-9,.E]+$/  && $optionally_enclosed_by eq '"') {
7212          $s =~ s/([^\\])"/$1\\"/g;
7213          $s = $optionally_enclosed_by."$s".$optionally_enclosed_by;
7214      }
7215      # $_ =~ s/([^\\])"/$1\\"/g if ($_ !~ /^[0-9,.E]+$/  && $optionally_enclosed_by eq '"');
7216      # $_ = $optionally_enclosed_by && ($_ & ~$_) ? $optionally_enclosed_by."$_".$optionally_enclosed_by : $_;
7217      chomp $s;
7218      $s;
7219   } @$row);
7220
7221}
7222
7223sub ts {
7224   my ( $time ) = @_;
7225   my ( $sec, $min, $hour, $mday, $mon, $year )
7226      = localtime($time);
7227   $mon  += 1;
7228   $year += 1900;
7229   return sprintf("%d-%02d-%02dT%02d:%02d:%02d",
7230      $year, $mon, $mday, $hour, $min, $sec);
7231}
7232
7233sub get_irot {
7234   my ( $dbh ) = @_;
7235   return 1 unless VersionParser->new($dbh) >= '5.0.13';
7236   my $rows = $dbh->selectall_arrayref(
7237      "show variables like 'innodb_rollback_on_timeout'",
7238      { Slice => {} });
7239   return 0 unless $rows;
7240   return @$rows && $rows->[0]->{Value} ne 'OFF';
7241}
7242
7243sub _d {
7244   my ($package, undef, $line) = caller 0;
7245   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
7246        map { defined $_ ? $_ : 'undef' }
7247        @_;
7248   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
7249}
7250
7251# ############################################################################
7252# Run the program.
7253# ############################################################################
7254if ( !caller ) { exit main(@ARGV); }
7255
72561; # Because this is a module as well as a script.
7257
7258# ############################################################################
7259# Documentation.
7260# ############################################################################
7261
7262=pod
7263
7264=head1 NAME
7265
7266pt-archiver - Archive rows from a MySQL table into another table or a file.
7267
7268=head1 SYNOPSIS
7269
7270Usage: pt-archiver [OPTIONS] --source DSN --where WHERE
7271
7272pt-archiver nibbles records from a MySQL table.  The --source and --dest
7273arguments use DSN syntax; if COPY is yes, --dest defaults to the key's value
7274from --source.
7275
7276Examples:
7277
7278Archive all rows from oltp_server to olap_server and to a file:
7279
7280  pt-archiver --source h=oltp_server,D=test,t=tbl --dest h=olap_server \
7281    --file '/var/log/archive/%Y-%m-%d-%D.%t'                           \
7282    --where "1=1" --limit 1000 --commit-each
7283
7284Purge (delete) orphan rows from child table:
7285
7286  pt-archiver --source h=host,D=db,t=child --purge \
7287    --where 'NOT EXISTS(SELECT * FROM parent WHERE col=child.col)'
7288
7289=head1 RISKS
7290
7291Percona Toolkit is mature, proven in the real world, and well tested,
7292but all database tools can pose a risk to the system and the database
7293server.  Before using this tool, please:
7294
7295=over
7296
7297=item * Read the tool's documentation
7298
7299=item * Review the tool's known L<"BUGS">
7300
7301=item * Test the tool on a non-production server
7302
7303=item * Backup your production server and verify the backups
7304
7305=back
7306
7307=head1 DESCRIPTION
7308
7309pt-archiver is the tool I use to archive tables as described in
7310L<http://tinyurl.com/mysql-archiving>.  The goal is a low-impact, forward-only
7311job to nibble old data out of the table without impacting OLTP queries much.
7312You can insert the data into another table, which need not be on the same
7313server.  You can also write it to a file in a format suitable for LOAD DATA
7314INFILE.  Or you can do neither, in which case it's just an incremental DELETE.
7315
7316pt-archiver is extensible via a plugin mechanism.  You can inject your own
7317code to add advanced archiving logic that could be useful for archiving
7318dependent data, applying complex business rules, or building a data warehouse
7319during the archiving process.
7320
7321You need to choose values carefully for some options.  The most important are
7322L<"--limit">, L<"--retries">, and L<"--txn-size">.
7323
7324The strategy is to find the first row(s), then scan some index forward-only to
7325find more rows efficiently.  Each subsequent query should not scan the entire
7326table; it should seek into the index, then scan until it finds more archivable
7327rows.  Specifying the index with the 'i' part of the L<"--source"> argument can
7328be crucial for this; use L<"--dry-run"> to examine the generated queries and be
7329sure to EXPLAIN them to see if they are efficient (most of the time you probably
7330want to scan the PRIMARY key, which is the default).  Even better, examine the
7331difference in the Handler status counters before and after running the query,
7332and make sure it is not scanning the whole table every query.
7333
7334You can disable the seek-then-scan optimizations partially or wholly with
7335L<"--no-ascend"> and L<"--ascend-first">.  Sometimes this may be more efficient
7336for multi-column keys.  Be aware that pt-archiver is built to start at the
7337beginning of the index it chooses and scan it forward-only.  This might result
7338in long table scans if you're trying to nibble from the end of the table by an
7339index other than the one it prefers.  See L<"--source"> and read the
7340documentation on the C<i> part if this applies to you.
7341
7342=head1 Percona XtraDB Cluster
7343
7344pt-archiver works with Percona XtraDB Cluster (PXC) 5.5.28-23.7 and newer,
7345but there are three limitations you should consider before archiving on
7346a cluster:
7347
7348=over
7349
7350=item Error on commit
7351
7352pt-archiver does not check for error when it commits transactions.
7353Commits on PXC can fail, but the tool does not yet check for or retry the
7354transaction when this happens.  If it happens, the tool will die.
7355
7356=item MyISAM tables
7357
7358Archiving MyISAM tables works, but MyISAM support in PXC is still
7359experimental at the time of this release.  There are several known bugs with
7360PXC, MyISAM tables, and C<AUTO_INCREMENT> columns.  Therefore, you must ensure
7361that archiving will not directly or indirectly result in the use of default
7362C<AUTO_INCREMENT> values for a MyISAM table.  For example, this happens with
7363L<"--dest"> if L<"--columns"> is used and the C<AUTO_INCREMENT> column is not
7364included.  The tool does not check for this!
7365
7366=item Non-cluster options
7367
7368Certain options may or may not work.  For example, if a cluster node
7369is not also a slave, then L<"--check-slave-lag"> does not work.  And since PXC
7370tables are usually InnoDB, but InnoDB doesn't support C<INSERT DELAYED>, then
7371L<"--delayed-insert"> does not work.  Other options may also not work, but
7372the tool does not check them, therefore you should test archiving on a test
7373cluster before archiving on your real cluster.
7374
7375=back
7376
7377=head1 OUTPUT
7378
7379If you specify L<"--progress">, the output is a header row, plus status output
7380at intervals.  Each row in the status output lists the current date and time,
7381how many seconds pt-archiver has been running, and how many rows it has
7382archived.
7383
7384If you specify L<"--statistics">, C<pt-archiver> outputs timing and other
7385information to help you identify which part of your archiving process takes the
7386most time.
7387
7388=head1 ERROR-HANDLING
7389
7390pt-archiver tries to catch signals and exit gracefully; for example, if you
7391send it SIGTERM (Ctrl-C on UNIX-ish systems), it will catch the signal, print a
7392message about the signal, and exit fairly normally.  It will not execute
7393L<"--analyze"> or L<"--optimize">, because these may take a long time to finish.
7394It will run all other code normally, including calling after_finish() on any
7395plugins (see L<"EXTENDING">).
7396
7397In other words, a signal, if caught, will break out of the main archiving
7398loop and skip optimize/analyze.
7399
7400=head1 OPTIONS
7401
7402Specify at least one of L<"--dest">, L<"--file">, or L<"--purge">.
7403
7404L<"--ignore"> and L<"--replace"> are mutually exclusive.
7405
7406L<"--txn-size"> and L<"--commit-each"> are mutually exclusive.
7407
7408L<"--low-priority-insert"> and L<"--delayed-insert"> are mutually exclusive.
7409
7410L<"--share-lock"> and L<"--for-update"> are mutually exclusive.
7411
7412L<"--analyze"> and L<"--optimize"> are mutually exclusive.
7413
7414L<"--no-ascend"> and L<"--no-delete"> are mutually exclusive.
7415
7416DSN values in L<"--dest"> default to values from L<"--source"> if COPY is yes.
7417
7418=over
7419
7420=item --analyze
7421
7422type: string
7423
7424Run ANALYZE TABLE afterwards on L<"--source"> and/or L<"--dest">.
7425
7426Runs ANALYZE TABLE after finishing.  The argument is an arbitrary string.  If it
7427contains the letter 's', the source will be analyzed.  If it contains 'd', the
7428destination will be analyzed.  You can specify either or both.  For example, the
7429following will analyze both:
7430
7431  --analyze=ds
7432
7433See L<http://dev.mysql.com/doc/en/analyze-table.html> for details on ANALYZE
7434TABLE.
7435
7436=item --ascend-first
7437
7438Ascend only first column of index.
7439
7440If you do want to use the ascending index optimization (see L<"--no-ascend">),
7441but do not want to incur the overhead of ascending a large multi-column index,
7442you can use this option to tell pt-archiver to ascend only the leftmost column
7443of the index.  This can provide a significant performance boost over not
7444ascending the index at all, while avoiding the cost of ascending the whole
7445index.
7446
7447See L<"EXTENDING"> for a discussion of how this interacts with plugins.
7448
7449=item --ask-pass
7450
7451Prompt for a password when connecting to MySQL.
7452
7453=item --buffer
7454
7455Buffer output to L<"--file"> and flush at commit.
7456
7457Disables autoflushing to L<"--file"> and flushes L<"--file"> to disk only when a
7458transaction commits.  This typically means the file is block-flushed by the
7459operating system, so there may be some implicit flushes to disk between
7460commits as well.  The default is to flush L<"--file"> to disk after every row.
7461
7462The danger is that a crash might cause lost data.
7463
7464The performance increase I have seen from using L<"--buffer"> is around 5 to 15
7465percent.  Your mileage may vary.
7466
7467=item --bulk-delete
7468
7469Delete each chunk with a single statement (implies L<"--commit-each">).
7470
7471Delete each chunk of rows in bulk with a single C<DELETE> statement.  The
7472statement deletes every row between the first and last row of the chunk,
7473inclusive.  It implies L<"--commit-each">, since it would be a bad idea to
7474C<INSERT> rows one at a time and commit them before the bulk C<DELETE>.
7475
7476The normal method is to delete every row by its primary key.  Bulk deletes might
7477be a lot faster.  B<They also might not be faster> if you have a complex
7478C<WHERE> clause.
7479
7480This option completely defers all C<DELETE> processing until the chunk of rows
7481is finished.  If you have a plugin on the source, its C<before_delete> method
7482will not be called.  Instead, its C<before_bulk_delete> method is called later.
7483
7484B<WARNING>: if you have a plugin on the source that sometimes doesn't return
7485true from C<is_archivable()>, you should use this option only if you understand
7486what it does.  If the plugin instructs C<pt-archiver> not to archive a row,
7487it will still be deleted by the bulk delete!
7488
7489=item --[no]bulk-delete-limit
7490
7491default: yes
7492
7493Add L<"--limit"> to L<"--bulk-delete"> statement.
7494
7495This is an advanced option and you should not disable it unless you know what
7496you are doing and why!  By default, L<"--bulk-delete"> appends a L<"--limit">
7497clause to the bulk delete SQL statement.  In certain cases, this clause can be
7498omitted by specifying C<--no-bulk-delete-limit>.  L<"--limit"> must still be
7499specified.
7500
7501=item --bulk-insert
7502
7503Insert each chunk with LOAD DATA INFILE (implies L<"--bulk-delete"> L<"--commit-each">).
7504
7505Insert each chunk of rows with C<LOAD DATA LOCAL INFILE>.  This may be much
7506faster than inserting a row at a time with C<INSERT> statements.  It is
7507implemented by creating a temporary file for each chunk of rows, and writing the
7508rows to this file instead of inserting them.  When the chunk is finished, it
7509uploads the rows.
7510
7511To protect the safety of your data, this option forces bulk deletes to be used.
7512It would be unsafe to delete each row as it is found, before inserting the rows
7513into the destination first.  Forcing bulk deletes guarantees that the deletion
7514waits until the insertion is successful.
7515
7516The L<"--low-priority-insert">, L<"--replace">, and L<"--ignore"> options work
7517with this option, but L<"--delayed-insert"> does not.
7518
7519If C<LOAD DATA LOCAL INFILE> throws an error in the lines of C<The used
7520command is not allowed with this MySQL version>, refer to the documentation
7521for the C<L> DSN option.
7522
7523=item --channel
7524
7525type: string
7526
7527Channel name used when connected to a server using replication channels.
7528Suppose you have two masters, master_a at port 12345, master_b at port 1236 and
7529a slave connected to both masters using channels chan_master_a and chan_master_b.
7530If you want to run pt-archiver to syncronize the slave against master_a, pt-archiver
7531won't be able to determine what's the correct master since SHOW SLAVE STATUS
7532will return 2 rows. In this case, you can use --channel=chan_master_a to specify
7533the channel name to use in the SHOW SLAVE STATUS command.
7534
7535=item --charset
7536
7537short form: -A; type: string
7538
7539Default character set.  If the value is utf8, sets Perl's binmode on
7540STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
7541NAMES UTF8 after connecting to MySQL.  Any other value sets binmode on STDOUT
7542without the utf8 layer, and runs SET NAMES after connecting to MySQL.
7543
7544Note that only charsets as known by MySQL are recognized; So for example,
7545"UTF8" will work, but "UTF-8" will not.
7546
7547See also L<"--[no]check-charset">.
7548
7549=item --[no]check-charset
7550
7551default: yes
7552
7553Ensure connection and table character sets are the same.  Disabling this check
7554may cause text to be erroneously converted from one character set to another
7555(usually from utf8 to latin1) which may cause data loss or mojibake.  Disabling
7556this check may be useful or necessary when character set conversions are
7557intended.
7558
7559=item --[no]check-columns
7560
7561default: yes
7562
7563Ensure L<"--source"> and L<"--dest"> have same columns.
7564
7565Enabled by default; causes pt-archiver to check that the source and destination
7566tables have the same columns.  It does not check column order, data type, etc.
7567It just checks that all columns in the source exist in the destination and
7568vice versa.  If there are any differences, pt-archiver will exit with an
7569error.
7570
7571To disable this check, specify --no-check-columns.
7572
7573=item --check-interval
7574
7575type: time; default: 1s
7576
7577If L<"--check-slave-lag"> is given, this defines how long the tool pauses each
7578 time it discovers that a slave is lagging.
7579 This check is performed every 100 rows.
7580
7581=item --check-slave-lag
7582
7583type: string; repeatable: yes
7584
7585Pause archiving until the specified DSN's slave lag is less than L<"--max-lag">.
7586This option can be specified multiple times for checking more than one slave.
7587
7588=item --columns
7589
7590short form: -c; type: array
7591
7592Comma-separated list of columns to archive.
7593
7594Specify a comma-separated list of columns to fetch, write to the file, and
7595insert into the destination table.  If specified, pt-archiver ignores other
7596columns unless it needs to add them to the C<SELECT> statement for ascending an
7597index or deleting rows.  It fetches and uses these extra columns internally, but
7598does not write them to the file or to the destination table.  It I<does> pass
7599them to plugins.
7600
7601See also L<"--primary-key-only">.
7602
7603=item --commit-each
7604
7605Commit each set of fetched and archived rows (disables L<"--txn-size">).
7606
7607Commits transactions and flushes L<"--file"> after each set of rows has been
7608archived, before fetching the next set of rows, and before sleeping if
7609L<"--sleep"> is specified.  Disables L<"--txn-size">; use L<"--limit"> to
7610control the transaction size with L<"--commit-each">.
7611
7612This option is useful as a shortcut to make L<"--limit"> and L<"--txn-size"> the
7613same value, but more importantly it avoids transactions being held open while
7614searching for more rows.  For example, imagine you are archiving old rows from
7615the beginning of a very large table, with L<"--limit"> 1000 and L<"--txn-size">
76161000.  After some period of finding and archiving 1000 rows at a time,
7617pt-archiver finds the last 999 rows and archives them, then executes the next
7618SELECT to find more rows.  This scans the rest of the table, but never finds any
7619more rows.  It has held open a transaction for a very long time, only to
7620determine it is finished anyway.  You can use L<"--commit-each"> to avoid this.
7621
7622=item --config
7623
7624type: Array
7625
7626Read this comma-separated list of config files; if specified, this must be the
7627first option on the command line.
7628
7629=item --database
7630
7631short form: -D; type: string
7632
7633Connect to this database.
7634
7635=item --delayed-insert
7636
7637Add the DELAYED modifier to INSERT statements.
7638
7639Adds the DELAYED modifier to INSERT or REPLACE statements.  See
7640L<http://dev.mysql.com/doc/en/insert.html> for details.
7641
7642=item --dest
7643
7644type: DSN
7645
7646DSN specifying the table to archive to.
7647
7648This item specifies a table into which pt-archiver will insert rows
7649archived from L<"--source">.  It uses the same key=val argument format as
7650L<"--source">.  Most missing values default to the same values as
7651L<"--source">, so you don't have to repeat options that are the same in
7652L<"--source"> and L<"--dest">.  Use the L<"--help"> option to see which values
7653are copied from L<"--source">.
7654
7655B<WARNING>: Using a default options file (F) DSN option that defines a
7656socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using
7657that socket unless another socket for L<"--dest"> is specified.  This
7658means that pt-archiver may incorrectly connect to L<"--source"> when it
7659connects to L<"--dest">.  For example:
7660
7661  --source F=host1.cnf,D=db,t=tbl --dest h=host2
7662
7663When pt-archiver connects to L<"--dest">, host2, it will connect via the
7664L<"--source">, host1, socket defined in host1.cnf.
7665
7666=item --dry-run
7667
7668Print queries and exit without doing anything.
7669
7670Causes pt-archiver to exit after printing the filename and SQL statements
7671it will use.
7672
7673=item --file
7674
7675type: string
7676
7677File to archive to, with DATE_FORMAT()-like formatting.
7678
7679Filename to write archived rows to.  A subset of MySQL's DATE_FORMAT()
7680formatting codes are allowed in the filename, as follows:
7681
7682   %d    Day of the month, numeric (01..31)
7683   %H    Hour (00..23)
7684   %i    Minutes, numeric (00..59)
7685   %m    Month, numeric (01..12)
7686   %s    Seconds (00..59)
7687   %Y    Year, numeric, four digits
7688
7689You can use the following extra format codes too:
7690
7691   %D    Database name
7692   %t    Table name
7693
7694Example:
7695
7696   --file '/var/log/archive/%Y-%m-%d-%D.%t'
7697
7698The file's contents are in the same format used by SELECT INTO OUTFILE, as
7699documented in the MySQL manual: rows terminated by newlines, columns
7700terminated by tabs, NULL characters are represented by C<\N>, and special
7701characters are escaped by C<\>.  This lets you reload a file with LOAD DATA
7702INFILE's default settings.
7703
7704If you want a column header at the top of the file, see L<"--header">.  The file
7705is auto-flushed by default; see L<"--buffer">.
7706
7707=item --for-update
7708
7709Adds the FOR UPDATE modifier to SELECT statements.
7710
7711For details, see L<http://dev.mysql.com/doc/en/innodb-locking-reads.html>.
7712
7713=item --header
7714
7715Print column header at top of L<"--file">.
7716
7717Writes column names as the first line in the file given by L<"--file">.  If the
7718file exists, does not write headers; this keeps the file loadable with LOAD
7719DATA INFILE in case you append more output to it.
7720
7721=item --help
7722
7723Show help and exit.
7724
7725=item --high-priority-select
7726
7727Adds the HIGH_PRIORITY modifier to SELECT statements.
7728
7729See L<http://dev.mysql.com/doc/en/select.html> for details.
7730
7731=item --host
7732
7733short form: -h; type: string
7734
7735Connect to host.
7736
7737=item --ignore
7738
7739Use IGNORE for INSERT statements.
7740
7741Causes INSERTs into L<"--dest"> to be INSERT IGNORE.
7742
7743=item --limit
7744
7745type: int; default: 1
7746
7747Number of rows to fetch and archive per statement.
7748
7749Limits the number of rows returned by the SELECT statements that retrieve rows
7750to archive.  Default is one row.  It may be more efficient to increase the
7751limit, but be careful if you are archiving sparsely, skipping over many rows;
7752this can potentially cause more contention with other queries, depending on the
7753storage engine, transaction isolation level, and options such as
7754L<"--for-update">.
7755
7756=item --local
7757
7758Do not write OPTIMIZE or ANALYZE queries to binlog.
7759
7760Adds the NO_WRITE_TO_BINLOG modifier to ANALYZE and OPTIMIZE queries.  See
7761L<"--analyze"> for details.
7762
7763=item --low-priority-delete
7764
7765Adds the LOW_PRIORITY modifier to DELETE statements.
7766
7767See L<http://dev.mysql.com/doc/en/delete.html> for details.
7768
7769=item --low-priority-insert
7770
7771Adds the LOW_PRIORITY modifier to INSERT or REPLACE statements.
7772
7773See L<http://dev.mysql.com/doc/en/insert.html> for details.
7774
7775=item --max-flow-ctl
7776
7777type: float
7778
7779Somewhat similar to --max-lag but for PXC clusters.
7780Check average time cluster spent pausing for Flow Control and make tool pause if
7781it goes over the percentage indicated in the option.
7782Default is no Flow Control checking.
7783This option is available for PXC versions 5.6 or higher.
7784
7785=item --max-lag
7786
7787type: time; default: 1s
7788
7789Pause archiving if the slave given by L<"--check-slave-lag"> lags.
7790
7791This option causes pt-archiver to look at the slave every time it's about
7792to fetch another row.  If the slave's lag is greater than the option's value,
7793or if the slave isn't running (so its lag is NULL), pt-table-checksum sleeps
7794for L<"--check-interval"> seconds and then looks at the lag again.  It repeats
7795until the slave is caught up, then proceeds to fetch and archive the row.
7796
7797This option may eliminate the need for L<"--sleep"> or L<"--sleep-coef">.
7798
7799=item --no-ascend
7800
7801Do not use ascending index optimization.
7802
7803The default ascending-index optimization causes C<pt-archiver> to optimize
7804repeated C<SELECT> queries so they seek into the index where the previous query
7805ended, then scan along it, rather than scanning from the beginning of the table
7806every time.  This is enabled by default because it is generally a good strategy
7807for repeated accesses.
7808
7809Large, multiple-column indexes may cause the WHERE clause to be complex enough
7810that this could actually be less efficient.  Consider for example a four-column
7811PRIMARY KEY on (a, b, c, d).  The WHERE clause to start where the last query
7812ended is as follows:
7813
7814   WHERE (a > ?)
7815      OR (a = ? AND b > ?)
7816      OR (a = ? AND b = ? AND c > ?)
7817      OR (a = ? AND b = ? AND c = ? AND d >= ?)
7818
7819Populating the placeholders with values uses memory and CPU, adds network
7820traffic and parsing overhead, and may make the query harder for MySQL to
7821optimize.  A four-column key isn't a big deal, but a ten-column key in which
7822every column allows C<NULL> might be.
7823
7824Ascending the index might not be necessary if you know you are simply removing
7825rows from the beginning of the table in chunks, but not leaving any holes, so
7826starting at the beginning of the table is actually the most efficient thing to
7827do.
7828
7829See also L<"--ascend-first">.  See L<"EXTENDING"> for a discussion of how this
7830interacts with plugins.
7831
7832=item --no-delete
7833
7834Do not delete archived rows.
7835
7836Causes C<pt-archiver> not to delete rows after processing them.  This disallows
7837L<"--no-ascend">, because enabling them both would cause an infinite loop.
7838
7839If there is a plugin on the source DSN, its C<before_delete> method is called
7840anyway, even though C<pt-archiver> will not execute the delete.  See
7841L<"EXTENDING"> for more on plugins.
7842
7843=item --optimize
7844
7845type: string
7846
7847Run OPTIMIZE TABLE afterwards on L<"--source"> and/or L<"--dest">.
7848
7849Runs OPTIMIZE TABLE after finishing.  See L<"--analyze"> for the option syntax
7850and L<http://dev.mysql.com/doc/en/optimize-table.html> for details on OPTIMIZE
7851TABLE.
7852
7853=item --output-format
7854
7855type: string
7856
7857Used with L<"--file"> to specify the output format.
7858
7859Valid formats are:
7860
7861- dump: MySQL dump format using tabs as field separator (default)
7862
7863- csv : Dump rows using ',' as separator and optionally enclosing fields by '"'.
7864        This format is equivalent to FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '"'.
7865
7866=item --password
7867
7868short form: -p; type: string
7869
7870Password to use when connecting.
7871If password contains commas they must be escaped with a backslash: "exam\,ple"
7872
7873=item --pid
7874
7875type: string
7876
7877Create the given PID file.  The tool won't start if the PID file already
7878exists and the PID it contains is different than the current PID.  However,
7879if the PID file exists and the PID it contains is no longer running, the
7880tool will overwrite the PID file with the current PID.  The PID file is
7881removed automatically when the tool exits.
7882
7883=item --plugin
7884
7885type: string
7886
7887Perl module name to use as a generic plugin.
7888
7889Specify the Perl module name of a general-purpose plugin.  It is currently used
7890only for statistics (see L<"--statistics">) and must have C<new()> and a
7891C<statistics()> method.
7892
7893The C<new( src =E<gt> $src, dst =E<gt> $dst, opts =E<gt> $o )> method gets the source
7894and destination DSNs, and their database connections, just like the
7895connection-specific plugins do.  It also gets an OptionParser object (C<$o>) for
7896accessing command-line options (example: C<$o-E<gt>get('purge');>).
7897
7898The C<statistics(\%stats, $time)> method gets a hashref of the statistics
7899collected by the archiving job, and the time the whole job started.
7900
7901=item --port
7902
7903short form: -P; type: int
7904
7905Port number to use for connection.
7906
7907=item --primary-key-only
7908
7909Primary key columns only.
7910
7911A shortcut for specifying L<"--columns"> with the primary key columns.  This is
7912an efficiency if you just want to purge rows; it avoids fetching the entire row,
7913when only the primary key columns are needed for C<DELETE> statements.  See also
7914L<"--purge">.
7915
7916=item --progress
7917
7918type: int
7919
7920Print progress information every X rows.
7921
7922Prints current time, elapsed time, and rows archived every X rows.
7923
7924=item --purge
7925
7926Purge instead of archiving; allows omitting L<"--file"> and L<"--dest">.
7927
7928Allows archiving without a L<"--file"> or L<"--dest"> argument, which is
7929effectively a purge since the rows are just deleted.
7930
7931If you just want to purge rows, consider specifying the table's primary key
7932columns with L<"--primary-key-only">.  This will prevent fetching all columns
7933from the server for no reason.
7934
7935=item --quick-delete
7936
7937Adds the QUICK modifier to DELETE statements.
7938
7939See L<http://dev.mysql.com/doc/en/delete.html> for details.  As stated in the
7940documentation, in some cases it may be faster to use DELETE QUICK followed by
7941OPTIMIZE TABLE.  You can use L<"--optimize"> for this.
7942
7943=item --quiet
7944
7945short form: -q
7946
7947Do not print any output, such as for L<"--statistics">.
7948
7949Suppresses normal output, including the output of L<"--statistics">, but doesn't
7950suppress the output from L<"--why-quit">.
7951
7952=item --replace
7953
7954Causes INSERTs into L<"--dest"> to be written as REPLACE.
7955
7956=item --retries
7957
7958type: int; default: 1
7959
7960Number of retries per timeout or deadlock.
7961
7962Specifies the number of times pt-archiver should retry when there is an
7963InnoDB lock wait timeout or deadlock.  When retries are exhausted,
7964pt-archiver will exit with an error.
7965
7966Consider carefully what you want to happen when you are archiving between a
7967mixture of transactional and non-transactional storage engines.  The INSERT to
7968L<"--dest"> and DELETE from L<"--source"> are on separate connections, so they
7969do not actually participate in the same transaction even if they're on the same
7970server.  However, pt-archiver implements simple distributed transactions in
7971code, so commits and rollbacks should happen as desired across the two
7972connections.
7973
7974At this time I have not written any code to handle errors with transactional
7975storage engines other than InnoDB.  Request that feature if you need it.
7976
7977=item --run-time
7978
7979type: time
7980
7981Time to run before exiting.
7982
7983Optional suffix s=seconds, m=minutes, h=hours, d=days; if no suffix, s is used.
7984
7985=item --[no]safe-auto-increment
7986
7987default: yes
7988
7989Do not archive row with max AUTO_INCREMENT.
7990
7991Adds an extra WHERE clause to prevent pt-archiver from removing the newest
7992row when ascending a single-column AUTO_INCREMENT key.  This guards against
7993re-using AUTO_INCREMENT values if the server restarts, and is enabled by
7994default.
7995
7996The extra WHERE clause contains the maximum value of the auto-increment column
7997as of the beginning of the archive or purge job.  If new rows are inserted while
7998pt-archiver is running, it will not see them.
7999
8000=item --sentinel
8001
8002type: string; default: /tmp/pt-archiver-sentinel
8003
8004Exit if this file exists.
8005
8006The presence of the file specified by L<"--sentinel"> will cause pt-archiver to
8007stop archiving and exit.  The default is /tmp/pt-archiver-sentinel.  You
8008might find this handy to stop cron jobs gracefully if necessary.  See also
8009L<"--stop">.
8010
8011=item --slave-user
8012
8013type: string
8014
8015Sets the user to be used to connect to the slaves.
8016This parameter allows you to have a different user with less privileges on the
8017slaves but that user must exist on all slaves.
8018
8019=item --slave-password
8020
8021type: string
8022
8023Sets the password to be used to connect to the slaves.
8024It can be used with --slave-user and the password for the user must be the same
8025on all slaves.
8026
8027=item --set-vars
8028
8029type: Array
8030
8031Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
8032
8033By default, the tool sets:
8034
8035=for comment ignore-pt-internal-value
8036MAGIC_set_vars
8037
8038   wait_timeout=10000
8039
8040Variables specified on the command line override these defaults.  For
8041example, specifying C<--set-vars wait_timeout=500> overrides the default
8042value of C<10000>.
8043
8044The tool prints a warning and continues if a variable cannot be set.
8045
8046=item --share-lock
8047
8048Adds the LOCK IN SHARE MODE modifier to SELECT statements.
8049
8050See L<http://dev.mysql.com/doc/en/innodb-locking-reads.html>.
8051
8052=item --skip-foreign-key-checks
8053
8054Disables foreign key checks with SET FOREIGN_KEY_CHECKS=0.
8055
8056=item --sleep
8057
8058type: int
8059
8060Sleep time between fetches.
8061
8062Specifies how long to sleep between SELECT statements.  Default is not to
8063sleep at all.  Transactions are NOT committed, and the L<"--file"> file is NOT
8064flushed, before sleeping.  See L<"--txn-size"> to control that.
8065
8066If L<"--commit-each"> is specified, committing and flushing happens before
8067sleeping.
8068
8069=item --sleep-coef
8070
8071type: float
8072
8073Calculate L<"--sleep"> as a multiple of the last SELECT time.
8074
8075If this option is specified, pt-archiver will sleep for the query time of the
8076last SELECT multiplied by the specified coefficient.
8077
8078This is a slightly more sophisticated way to throttle the SELECTs: sleep a
8079varying amount of time between each SELECT, depending on how long the SELECTs
8080are taking.
8081
8082=item --socket
8083
8084short form: -S; type: string
8085
8086Socket file to use for connection.
8087
8088=item --source
8089
8090type: DSN
8091
8092DSN specifying the table to archive from (required).  This argument is a DSN.
8093See L<DSN OPTIONS> for the syntax.  Most options control how pt-archiver
8094connects to MySQL, but there are some extended DSN options in this tool's
8095syntax.  The D, t, and i options select a table to archive:
8096
8097  --source h=my_server,D=my_database,t=my_tbl
8098
8099The a option specifies the database to set as the connection's default with USE.
8100If the b option is true, it disables binary logging with SQL_LOG_BIN.  The m
8101option specifies pluggable actions, which an external Perl module can provide.
8102The only required part is the table; other parts may be read from various
8103places in the environment (such as options files).
8104
8105The 'i' part deserves special mention.  This tells pt-archiver which index
8106it should scan to archive.  This appears in a FORCE INDEX or USE INDEX hint in
8107the SELECT statements used to fetch archivable rows.  If you don't specify
8108anything, pt-archiver will auto-discover a good index, preferring a C<PRIMARY
8109KEY> if one exists.  In my experience this usually works well, so most of the
8110time you can probably just omit the 'i' part.
8111
8112The index is used to optimize repeated accesses to the table; pt-archiver
8113remembers the last row it retrieves from each SELECT statement, and uses it to
8114construct a WHERE clause, using the columns in the specified index, that should
8115allow MySQL to start the next SELECT where the last one ended, rather than
8116potentially scanning from the beginning of the table with each successive
8117SELECT.  If you are using external plugins, please see L<"EXTENDING"> for a
8118discussion of how they interact with ascending indexes.
8119
8120The 'a' and 'b' options allow you to control how statements flow through the
8121binary log.  If you specify the 'b' option, binary logging will be disabled on
8122the specified connection.  If you specify the 'a' option, the connection will
8123C<USE> the specified database, which you can use to prevent slaves from
8124executing the binary log events with C<--replicate-ignore-db> options.  These
8125two options can be used as different methods to achieve the same goal: archive
8126data off the master, but leave it on the slave.  For example, you can run a
8127purge job on the master and prevent it from happening on the slave using your
8128method of choice.
8129
8130B<WARNING>: Using a default options file (F) DSN option that defines a
8131socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using
8132that socket unless another socket for L<"--dest"> is specified.  This
8133means that pt-archiver may incorrectly connect to L<"--source"> when it
8134is meant to connect to L<"--dest">.  For example:
8135
8136  --source F=host1.cnf,D=db,t=tbl --dest h=host2
8137
8138When pt-archiver connects to L<"--dest">, host2, it will connect via the
8139L<"--source">, host1, socket defined in host1.cnf.
8140
8141=item --statistics
8142
8143Collect and print timing statistics.
8144
8145Causes pt-archiver to collect timing statistics about what it does.  These
8146statistics are available to the plugin specified by L<"--plugin">
8147
8148Unless you specify L<"--quiet">, C<pt-archiver> prints the statistics when it
8149exits.  The statistics look like this:
8150
8151 Started at 2008-07-18T07:18:53, ended at 2008-07-18T07:18:53
8152 Source: D=db,t=table
8153 SELECT 4
8154 INSERT 4
8155 DELETE 4
8156 Action         Count       Time        Pct
8157 commit            10     0.1079      88.27
8158 select             5     0.0047       3.87
8159 deleting           4     0.0028       2.29
8160 inserting          4     0.0028       2.28
8161 other              0     0.0040       3.29
8162
8163The first two (or three) lines show times and the source and destination tables.
8164The next three lines show how many rows were fetched, inserted, and deleted.
8165
8166The remaining lines show counts and timing.  The columns are the action, the
8167total number of times that action was timed, the total time it took, and the
8168percent of the program's total runtime.  The rows are sorted in order of
8169descending total time.  The last row is the rest of the time not explicitly
8170attributed to anything.  Actions will vary depending on command-line options.
8171
8172If L<"--why-quit"> is given, its behavior is changed slightly.  This option
8173causes it to print the reason for exiting even when it's just because there are
8174no more rows.
8175
8176This option requires the standard Time::HiRes module, which is part of core Perl
8177on reasonably new Perl releases.
8178
8179=item --stop
8180
8181Stop running instances by creating the sentinel file.
8182
8183Causes pt-archiver to create the sentinel file specified by L<"--sentinel"> and
8184exit.  This should have the effect of stopping all running instances which are
8185watching the same sentinel file.
8186
8187=item --txn-size
8188
8189type: int; default: 1
8190
8191Number of rows per transaction.
8192
8193Specifies the size, in number of rows, of each transaction. Zero disables
8194transactions altogether.  After pt-archiver processes this many rows, it
8195commits both the L<"--source"> and the L<"--dest"> if given, and flushes the
8196file given by L<"--file">.
8197
8198This parameter is critical to performance.  If you are archiving from a live
8199server, which for example is doing heavy OLTP work, you need to choose a good
8200balance between transaction size and commit overhead.  Larger transactions
8201create the possibility of more lock contention and deadlocks, but smaller
8202transactions cause more frequent commit overhead, which can be significant.  To
8203give an idea, on a small test set I worked with while writing pt-archiver, a
8204value of 500 caused archiving to take about 2 seconds per 1000 rows on an
8205otherwise quiet MySQL instance on my desktop machine, archiving to disk and to
8206another table.  Disabling transactions with a value of zero, which turns on
8207autocommit, dropped performance to 38 seconds per thousand rows.
8208
8209If you are not archiving from or to a transactional storage engine, you may
8210want to disable transactions so pt-archiver doesn't try to commit.
8211
8212=item --user
8213
8214short form: -u; type: string
8215
8216User for login if not current user.
8217
8218=item --version
8219
8220Show version and exit.
8221
8222=item --[no]version-check
8223
8224default: yes
8225
8226Check for the latest version of Percona Toolkit, MySQL, and other programs.
8227
8228This is a standard "check for updates automatically" feature, with two
8229additional features.  First, the tool checks its own version and also the
8230versions of the following software: operating system, Percona Monitoring and
8231Management (PMM), MySQL, Perl, MySQL driver for Perl (DBD::mysql), and
8232Percona Toolkit. Second, it checks for and warns about versions with known
8233problems. For example, MySQL 5.5.25 had a critical bug and was re-released
8234as 5.5.25a.
8235
8236A secure connection to Percona's Version Check database server is done to
8237perform these checks. Each request is logged by the server, including software
8238version numbers and unique ID of the checked system. The ID is generated by the
8239Percona Toolkit installation script or when the Version Check database call is
8240done for the first time.
8241
8242Any updates or known problems are printed to STDOUT before the tool's normal
8243output.  This feature should never interfere with the normal operation of the
8244tool.
8245
8246For more information, visit L<https://www.percona.com/doc/percona-toolkit/LATEST/version-check.html>.
8247
8248=item --where
8249
8250type: string
8251
8252WHERE clause to limit which rows to archive (required).
8253
8254Specifies a WHERE clause to limit which rows are archived.  Do not include the
8255word WHERE.  You may need to quote the argument to prevent your shell from
8256interpreting it.  For example:
8257
8258   --where 'ts < current_date - interval 90 day'
8259
8260For safety, L<"--where"> is required.  If you do not require a WHERE clause, use
8261L<"--where"> 1=1.
8262
8263=item --why-quit
8264
8265Print reason for exiting unless rows exhausted.
8266
8267Causes pt-archiver to print a message if it exits for any reason other than
8268running out of rows to archive.  This can be useful if you have a cron job with
8269L<"--run-time"> specified, for example, and you want to be sure pt-archiver is
8270finishing before running out of time.
8271
8272If L<"--statistics"> is given, the behavior is changed slightly.  It will print
8273the reason for exiting even when it's just because there are no more rows.
8274
8275This output prints even if L<"--quiet"> is given.  That's so you can put
8276C<pt-archiver> in a C<cron> job and get an email if there's an abnormal exit.
8277
8278=back
8279
8280=head1 DSN OPTIONS
8281
8282These DSN options are used to create a DSN.  Each option is given like
8283C<option=value>.  The options are case-sensitive, so P and p are not the
8284same option.  There cannot be whitespace before or after the C<=> and
8285if the value contains whitespace it must be quoted.  DSN options are
8286comma-separated.  See the L<percona-toolkit> manpage for full details.
8287
8288=over
8289
8290=item * a
8291
8292copy: no
8293
8294Database to USE when executing queries.
8295
8296=item * A
8297
8298dsn: charset; copy: yes
8299
8300Default character set.
8301
8302=item * b
8303
8304copy: no
8305
8306If true, disable binlog with SQL_LOG_BIN.
8307
8308=item * D
8309
8310dsn: database; copy: yes
8311
8312Database that contains the table.
8313
8314=item * F
8315
8316dsn: mysql_read_default_file; copy: yes
8317
8318Only read default options from the given file
8319
8320=item * h
8321
8322dsn: host; copy: yes
8323
8324Connect to host.
8325
8326=item * i
8327
8328copy: yes
8329
8330Index to use.
8331
8332=item * L
8333
8334copy: yes
8335
8336Explicitly enable LOAD DATA LOCAL INFILE.
8337
8338For some reason, some vendors compile libmysql without the
8339--enable-local-infile option, which disables the statement.  This can
8340lead to weird situations, like the server allowing LOCAL INFILE, but
8341the client throwing exceptions if it's used.
8342
8343However, as long as the server allows LOAD DATA, clients can easily
8344re-enable it; See L<https://dev.mysql.com/doc/refman/5.0/en/load-data-local.html>
8345and L<http://search.cpan.org/~capttofu/DBD-mysql/lib/DBD/mysql.pm>.
8346This option does exactly that.
8347
8348Although we've not found a case where turning this option leads to errors or
8349differing behavior, to be on the safe side, this option is not
8350on by default.
8351
8352=item * m
8353
8354copy: no
8355
8356Plugin module name.
8357
8358=item * p
8359
8360dsn: password; copy: yes
8361
8362Password to use when connecting.
8363If password contains commas they must be escaped with a backslash: "exam\,ple"
8364
8365=item * P
8366
8367dsn: port; copy: yes
8368
8369Port number to use for connection.
8370
8371=item * S
8372
8373dsn: mysql_socket; copy: yes
8374
8375Socket file to use for connection.
8376
8377=item * t
8378
8379copy: yes
8380
8381Table to archive from/to.
8382
8383=item * u
8384
8385dsn: user; copy: yes
8386
8387User for login if not current user.
8388
8389=back
8390
8391=head1 EXTENDING
8392
8393pt-archiver is extensible by plugging in external Perl modules to handle some
8394logic and/or actions.  You can specify a module for both the L<"--source"> and
8395the L<"--dest">, with the 'm' part of the specification.  For example:
8396
8397   --source D=test,t=test1,m=My::Module1 --dest m=My::Module2,t=test2
8398
8399This will cause pt-archiver to load the My::Module1 and My::Module2 packages,
8400create instances of them, and then make calls to them during the archiving
8401process.
8402
8403You can also specify a plugin with L<"--plugin">.
8404
8405The module must provide this interface:
8406
8407=over
8408
8409=item new(dbh => $dbh, db => $db_name, tbl => $tbl_name)
8410
8411The plugin's constructor is passed a reference to the database handle, the
8412database name, and table name.  The plugin is created just after pt-archiver
8413opens the connection, and before it examines the table given in the arguments.
8414This gives the plugin a chance to create and populate temporary tables, or do
8415other setup work.
8416
8417=item before_begin(cols => \@cols, allcols => \@allcols)
8418
8419This method is called just before pt-archiver begins iterating through rows
8420and archiving them, but after it does all other setup work (examining table
8421structures, designing SQL queries, and so on).  This is the only time
8422pt-archiver tells the plugin column names for the rows it will pass the
8423plugin while archiving.
8424
8425The C<cols> argument is the column names the user requested to be archived,
8426either by default or by the L<"--columns"> option.  The C<allcols> argument is
8427the list of column names for every row pt-archiver will fetch from the source
8428table.  It may fetch more columns than the user requested, because it needs some
8429columns for its own use.  When subsequent plugin functions receive a row, it is
8430the full row containing all the extra columns, if any, added to the end.
8431
8432=item is_archivable(row => \@row)
8433
8434This method is called for each row to determine whether it is archivable.  This
8435applies only to L<"--source">.  The argument is the row itself, as an arrayref.
8436If the method returns true, the row will be archived; otherwise it will be
8437skipped.
8438
8439Skipping a row adds complications for non-unique indexes.  Normally
8440pt-archiver uses a WHERE clause designed to target the last processed row as
8441the place to start the scan for the next SELECT statement.  If you have skipped
8442the row by returning false from is_archivable(), pt-archiver could get into
8443an infinite loop because the row still exists.  Therefore, when you specify a
8444plugin for the L<"--source"> argument, pt-archiver will change its WHERE clause
8445slightly.  Instead of starting at "greater than or equal to" the last processed
8446row, it will start "strictly greater than."  This will work fine on unique
8447indexes such as primary keys, but it may skip rows (leave holes) on non-unique
8448indexes or when ascending only the first column of an index.
8449
8450C<pt-archiver> will change the clause in the same way if you specify
8451L<"--no-delete">, because again an infinite loop is possible.
8452
8453If you specify the L<"--bulk-delete"> option and return false from this method,
8454C<pt-archiver> may not do what you want.  The row won't be archived, but it will
8455be deleted, since bulk deletes operate on ranges of rows and don't know which
8456rows the plugin selected to keep.
8457
8458If you specify the L<"--bulk-insert"> option, this method's return value will
8459influence whether the row is written to the temporary file for the bulk insert,
8460so bulk inserts will work as expected.  However, bulk inserts require bulk
8461deletes.
8462
8463=item before_delete(row => \@row)
8464
8465This method is called for each row just before it is deleted.  This applies only
8466to L<"--source">.  This is a good place for you to handle dependencies, such as
8467deleting things that are foreign-keyed to the row you are about to delete.  You
8468could also use this to recursively archive all dependent tables.
8469
8470This plugin method is called even if L<"--no-delete"> is given, but not if
8471L<"--bulk-delete"> is given.
8472
8473=item before_bulk_delete(first_row => \@row, last_row => \@row)
8474
8475This method is called just before a bulk delete is executed.  It is similar to
8476the C<before_delete> method, except its arguments are the first and last row of
8477the range to be deleted.  It is called even if L<"--no-delete"> is given.
8478
8479=item before_insert(row => \@row)
8480
8481This method is called for each row just before it is inserted.  This applies
8482only to L<"--dest">.  You could use this to insert the row into multiple tables,
8483perhaps with an ON DUPLICATE KEY UPDATE clause to build summary tables in a data
8484warehouse.
8485
8486This method is not called if L<"--bulk-insert"> is given.
8487
8488=item before_bulk_insert(first_row => \@row, last_row => \@row, filename => bulk_insert_filename)
8489
8490This method is called just before a bulk insert is executed.  It is similar to
8491the C<before_insert> method, except its arguments are the first and last row of
8492the range to be deleted.
8493
8494=item custom_sth(row => \@row, sql => $sql)
8495
8496This method is called just before inserting the row, but after
8497L<"before_insert()">.  It allows the plugin to specify different C<INSERT>
8498statement if desired.  The return value (if any) should be a DBI statement
8499handle.  The C<sql> parameter is the SQL text used to prepare the default
8500C<INSERT> statement.  This method is not called if you specify
8501L<"--bulk-insert">.
8502
8503If no value is returned, the default C<INSERT> statement handle is used.
8504
8505This method applies only to the plugin specified for L<"--dest">, so if your
8506plugin isn't doing what you expect, check that you've specified it for the
8507destination and not the source.
8508
8509=item custom_sth_bulk(first_row => \@row, last_row => \@row, sql => $sql, filename => $bulk_insert_filename)
8510
8511If you've specified L<"--bulk-insert">, this method is called just before the
8512bulk insert, but after L<"before_bulk_insert()">, and the arguments are
8513different.
8514
8515This method's return value etc is similar to the L<"custom_sth()"> method.
8516
8517=item after_finish()
8518
8519This method is called after pt-archiver exits the archiving loop, commits all
8520database handles, closes L<"--file">, and prints the final statistics, but
8521before pt-archiver runs ANALYZE or OPTIMIZE (see L<"--analyze"> and
8522L<"--optimize">).
8523
8524=back
8525
8526If you specify a plugin for both L<"--source"> and L<"--dest">, pt-archiver
8527constructs, calls before_begin(), and calls after_finish() on the two plugins in
8528the order L<"--source">, L<"--dest">.
8529
8530pt-archiver assumes it controls transactions, and that the plugin will NOT
8531commit or roll back the database handle.  The database handle passed to the
8532plugin's constructor is the same handle pt-archiver uses itself.  Remember
8533that L<"--source"> and L<"--dest"> are separate handles.
8534
8535A sample module might look like this:
8536
8537   package My::Module;
8538
8539   sub new {
8540      my ( $class, %args ) = @_;
8541      return bless(\%args, $class);
8542   }
8543
8544   sub before_begin {
8545      my ( $self, %args ) = @_;
8546      # Save column names for later
8547      $self->{cols} = $args{cols};
8548   }
8549
8550   sub is_archivable {
8551      my ( $self, %args ) = @_;
8552      # Do some advanced logic with $args{row}
8553      return 1;
8554   }
8555
8556   sub before_delete {} # Take no action
8557   sub before_insert {} # Take no action
8558   sub custom_sth    {} # Take no action
8559   sub after_finish  {} # Take no action
8560
8561   1;
8562
8563=head1 ENVIRONMENT
8564
8565The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
8566To enable debugging and capture all output to a file, run the tool like:
8567
8568   PTDEBUG=1 pt-archiver ... > FILE 2>&1
8569
8570Be careful: debugging output is voluminous and can generate several megabytes
8571of output.
8572
8573=head1 SYSTEM REQUIREMENTS
8574
8575You need Perl, DBI, DBD::mysql, and some core packages that ought to be
8576installed in any reasonably new version of Perl.
8577
8578=head1 BUGS
8579
8580For a list of known bugs, see L<http://www.percona.com/bugs/pt-archiver>.
8581
8582Please report bugs at L<https://jira.percona.com/projects/PT>.
8583Include the following information in your bug report:
8584
8585=over
8586
8587=item * Complete command-line used to run the tool
8588
8589=item * Tool L<"--version">
8590
8591=item * MySQL version of all servers involved
8592
8593=item * Output from the tool including STDERR
8594
8595=item * Input files (log/dump/config files, etc.)
8596
8597=back
8598
8599If possible, include debugging output by running the tool with C<PTDEBUG>;
8600see L<"ENVIRONMENT">.
8601
8602=head1 DOWNLOADING
8603
8604Visit L<http://www.percona.com/software/percona-toolkit/> to download the
8605latest release of Percona Toolkit.  Or, get the latest release from the
8606command line:
8607
8608   wget percona.com/get/percona-toolkit.tar.gz
8609
8610   wget percona.com/get/percona-toolkit.rpm
8611
8612   wget percona.com/get/percona-toolkit.deb
8613
8614You can also get individual tools from the latest release:
8615
8616   wget percona.com/get/TOOL
8617
8618Replace C<TOOL> with the name of any tool.
8619
8620=head1 AUTHORS
8621
8622Baron Schwartz
8623
8624=head1 ACKNOWLEDGMENTS
8625
8626Andrew O'Brien
8627
8628=head1 ABOUT PERCONA TOOLKIT
8629
8630This tool is part of Percona Toolkit, a collection of advanced command-line
8631tools for MySQL developed by Percona.  Percona Toolkit was forked from two
8632projects in June, 2011: Maatkit and Aspersa.  Those projects were created by
8633Baron Schwartz and primarily developed by him and Daniel Nichter.  Visit
8634L<http://www.percona.com/software/> to learn about other free, open-source
8635software from Percona.
8636
8637=head1 COPYRIGHT, LICENSE, AND WARRANTY
8638
8639This program is copyright 2011-2018 Percona LLC and/or its affiliates,
86402007-2011 Baron Schwartz.
8641
8642THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
8643WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
8644MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
8645
8646This program is free software; you can redistribute it and/or modify it under
8647the terms of the GNU General Public License as published by the Free Software
8648Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
8649systems, you can issue `man perlgpl' or `man perlartistic' to read these
8650licenses.
8651
8652You should have received a copy of the GNU General Public License along with
8653this program; if not, write to the Free Software Foundation, Inc., 59 Temple
8654Place, Suite 330, Boston, MA  02111-1307  USA.
8655
8656=head1 VERSION
8657
8658pt-archiver 3.3.0
8659
8660=cut
8661