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      OptionParser
18      Quoter
19      DSNParser
20      Cxn
21      Daemon
22      Transformers
23      HTTP::Micro
24      VersionCheck
25      Runtime
26   ));
27}
28
29# ###########################################################################
30# Percona::Toolkit package
31# This package is a copy without comments from the original.  The original
32# with comments and its test file can be found in the Bazaar repository at,
33#   lib/Percona/Toolkit.pm
34#   t/lib/Percona/Toolkit.t
35# See https://launchpad.net/percona-toolkit for more information.
36# ###########################################################################
37{
38package Percona::Toolkit;
39
40our $VERSION = '3.3.0';
41
42use strict;
43use warnings FATAL => 'all';
44use English qw(-no_match_vars);
45use constant PTDEBUG => $ENV{PTDEBUG} || 0;
46
47use Carp qw(carp cluck);
48use Data::Dumper qw();
49
50require Exporter;
51our @ISA         = qw(Exporter);
52our @EXPORT_OK   = qw(
53   have_required_args
54   Dumper
55   _d
56);
57
58sub have_required_args {
59   my ($args, @required_args) = @_;
60   my $have_required_args = 1;
61   foreach my $arg ( @required_args ) {
62      if ( !defined $args->{$arg} ) {
63         $have_required_args = 0;
64         carp "Argument $arg is not defined";
65      }
66   }
67   cluck unless $have_required_args;  # print backtrace
68   return $have_required_args;
69}
70
71sub Dumper {
72   local $Data::Dumper::Indent    = 1;
73   local $Data::Dumper::Sortkeys  = 1;
74   local $Data::Dumper::Quotekeys = 0;
75   Data::Dumper::Dumper(@_);
76}
77
78sub _d {
79   my ($package, undef, $line) = caller 0;
80   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
81        map { defined $_ ? $_ : 'undef' }
82        @_;
83   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
84}
85
861;
87}
88# ###########################################################################
89# End Percona::Toolkit package
90# ###########################################################################
91
92# ###########################################################################
93# OptionParser package
94# This package is a copy without comments from the original.  The original
95# with comments and its test file can be found in the Bazaar repository at,
96#   lib/OptionParser.pm
97#   t/lib/OptionParser.t
98# See https://launchpad.net/percona-toolkit for more information.
99# ###########################################################################
100{
101package OptionParser;
102
103use strict;
104use warnings FATAL => 'all';
105use English qw(-no_match_vars);
106use constant PTDEBUG => $ENV{PTDEBUG} || 0;
107
108use List::Util qw(max);
109use Getopt::Long;
110use Data::Dumper;
111
112my $POD_link_re = '[LC]<"?([^">]+)"?>';
113
114sub new {
115   my ( $class, %args ) = @_;
116   my @required_args = qw();
117   foreach my $arg ( @required_args ) {
118      die "I need a $arg argument" unless $args{$arg};
119   }
120
121   my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
122   $program_name ||= $PROGRAM_NAME;
123   my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
124
125   my %attributes = (
126      'type'       => 1,
127      'short form' => 1,
128      'group'      => 1,
129      'default'    => 1,
130      'cumulative' => 1,
131      'negatable'  => 1,
132      'repeatable' => 1,  # means it can be specified more than once
133   );
134
135   my $self = {
136      head1             => 'OPTIONS',        # These args are used internally
137      skip_rules        => 0,                # to instantiate another Option-
138      item              => '--(.*)',         # Parser obj that parses the
139      attributes        => \%attributes,     # DSN OPTIONS section.  Tools
140      parse_attributes  => \&_parse_attribs, # don't tinker with these args.
141
142      %args,
143
144      strict            => 1,  # disabled by a special rule
145      program_name      => $program_name,
146      opts              => {},
147      got_opts          => 0,
148      short_opts        => {},
149      defaults          => {},
150      groups            => {},
151      allowed_groups    => {},
152      errors            => [],
153      rules             => [],  # desc of rules for --help
154      mutex             => [],  # rule: opts are mutually exclusive
155      atleast1          => [],  # rule: at least one opt is required
156      disables          => {},  # rule: opt disables other opts
157      defaults_to       => {},  # rule: opt defaults to value of other opt
158      DSNParser         => undef,
159      default_files     => [
160         "/etc/percona-toolkit/percona-toolkit.conf",
161         "/etc/percona-toolkit/$program_name.conf",
162         "$home/.percona-toolkit.conf",
163         "$home/.$program_name.conf",
164      ],
165      types             => {
166         string => 's', # standard Getopt type
167         int    => 'i', # standard Getopt type
168         float  => 'f', # standard Getopt type
169         Hash   => 'H', # hash, formed from a comma-separated list
170         hash   => 'h', # hash as above, but only if a value is given
171         Array  => 'A', # array, similar to Hash
172         array  => 'a', # array, similar to hash
173         DSN    => 'd', # DSN
174         size   => 'z', # size with kMG suffix (powers of 2^10)
175         time   => 'm', # time, with an optional suffix of s/h/m/d
176      },
177   };
178
179   return bless $self, $class;
180}
181
182sub get_specs {
183   my ( $self, $file ) = @_;
184   $file ||= $self->{file} || __FILE__;
185   my @specs = $self->_pod_to_specs($file);
186   $self->_parse_specs(@specs);
187
188   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
189   my $contents = do { local $/ = undef; <$fh> };
190   close $fh;
191   if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
192      PTDEBUG && _d('Parsing DSN OPTIONS');
193      my $dsn_attribs = {
194         dsn  => 1,
195         copy => 1,
196      };
197      my $parse_dsn_attribs = sub {
198         my ( $self, $option, $attribs ) = @_;
199         map {
200            my $val = $attribs->{$_};
201            if ( $val ) {
202               $val    = $val eq 'yes' ? 1
203                       : $val eq 'no'  ? 0
204                       :                 $val;
205               $attribs->{$_} = $val;
206            }
207         } keys %$attribs;
208         return {
209            key => $option,
210            %$attribs,
211         };
212      };
213      my $dsn_o = new OptionParser(
214         description       => 'DSN OPTIONS',
215         head1             => 'DSN OPTIONS',
216         dsn               => 0,         # XXX don't infinitely recurse!
217         item              => '\* (.)',  # key opts are a single character
218         skip_rules        => 1,         # no rules before opts
219         attributes        => $dsn_attribs,
220         parse_attributes  => $parse_dsn_attribs,
221      );
222      my @dsn_opts = map {
223         my $opts = {
224            key  => $_->{spec}->{key},
225            dsn  => $_->{spec}->{dsn},
226            copy => $_->{spec}->{copy},
227            desc => $_->{desc},
228         };
229         $opts;
230      } $dsn_o->_pod_to_specs($file);
231      $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
232   }
233
234   if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
235      $self->{version} = $1;
236      PTDEBUG && _d($self->{version});
237   }
238
239   return;
240}
241
242sub DSNParser {
243   my ( $self ) = @_;
244   return $self->{DSNParser};
245};
246
247sub get_defaults_files {
248   my ( $self ) = @_;
249   return @{$self->{default_files}};
250}
251
252sub _pod_to_specs {
253   my ( $self, $file ) = @_;
254   $file ||= $self->{file} || __FILE__;
255   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
256
257   my @specs = ();
258   my @rules = ();
259   my $para;
260
261   local $INPUT_RECORD_SEPARATOR = '';
262   while ( $para = <$fh> ) {
263      next unless $para =~ m/^=head1 $self->{head1}/;
264      last;
265   }
266
267   while ( $para = <$fh> ) {
268      last if $para =~ m/^=over/;
269      next if $self->{skip_rules};
270      chomp $para;
271      $para =~ s/\s+/ /g;
272      $para =~ s/$POD_link_re/$1/go;
273      PTDEBUG && _d('Option rule:', $para);
274      push @rules, $para;
275   }
276
277   die "POD has no $self->{head1} section" unless $para;
278
279   do {
280      if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
281         chomp $para;
282         PTDEBUG && _d($para);
283         my %attribs;
284
285         $para = <$fh>; # read next paragraph, possibly attributes
286
287         if ( $para =~ m/: / ) { # attributes
288            $para =~ s/\s+\Z//g;
289            %attribs = map {
290                  my ( $attrib, $val) = split(/: /, $_);
291                  die "Unrecognized attribute for --$option: $attrib"
292                     unless $self->{attributes}->{$attrib};
293                  ($attrib, $val);
294               } split(/; /, $para);
295            if ( $attribs{'short form'} ) {
296               $attribs{'short form'} =~ s/-//;
297            }
298            $para = <$fh>; # read next paragraph, probably short help desc
299         }
300         else {
301            PTDEBUG && _d('Option has no attributes');
302         }
303
304         $para =~ s/\s+\Z//g;
305         $para =~ s/\s+/ /g;
306         $para =~ s/$POD_link_re/$1/go;
307
308         $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
309         PTDEBUG && _d('Short help:', $para);
310
311         die "No description after option spec $option" if $para =~ m/^=item/;
312
313         if ( my ($base_option) =  $option =~ m/^\[no\](.*)/ ) {
314            $option = $base_option;
315            $attribs{'negatable'} = 1;
316         }
317
318         push @specs, {
319            spec  => $self->{parse_attributes}->($self, $option, \%attribs),
320            desc  => $para
321               . (defined $attribs{default} ? " (default $attribs{default})" : ''),
322            group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
323            attributes => \%attribs
324         };
325      }
326      while ( $para = <$fh> ) {
327         last unless $para;
328         if ( $para =~ m/^=head1/ ) {
329            $para = undef; # Can't 'last' out of a do {} block.
330            last;
331         }
332         last if $para =~ m/^=item /;
333      }
334   } while ( $para );
335
336   die "No valid specs in $self->{head1}" unless @specs;
337
338   close $fh;
339   return @specs, @rules;
340}
341
342sub _parse_specs {
343   my ( $self, @specs ) = @_;
344   my %disables; # special rule that requires deferred checking
345
346   foreach my $opt ( @specs ) {
347      if ( ref $opt ) { # It's an option spec, not a rule.
348         PTDEBUG && _d('Parsing opt spec:',
349            map { ($_, '=>', $opt->{$_}) } keys %$opt);
350
351         my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
352         if ( !$long ) {
353            die "Cannot parse long option from spec $opt->{spec}";
354         }
355         $opt->{long} = $long;
356
357         die "Duplicate long option --$long" if exists $self->{opts}->{$long};
358         $self->{opts}->{$long} = $opt;
359
360         if ( length $long == 1 ) {
361            PTDEBUG && _d('Long opt', $long, 'looks like short opt');
362            $self->{short_opts}->{$long} = $long;
363         }
364
365         if ( $short ) {
366            die "Duplicate short option -$short"
367               if exists $self->{short_opts}->{$short};
368            $self->{short_opts}->{$short} = $long;
369            $opt->{short} = $short;
370         }
371         else {
372            $opt->{short} = undef;
373         }
374
375         $opt->{is_negatable}  = $opt->{spec} =~ m/!/        ? 1 : 0;
376         $opt->{is_cumulative} = $opt->{spec} =~ m/\+/       ? 1 : 0;
377         $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0;
378         $opt->{is_required}   = $opt->{desc} =~ m/required/ ? 1 : 0;
379
380         $opt->{group} ||= 'default';
381         $self->{groups}->{ $opt->{group} }->{$long} = 1;
382
383         $opt->{value} = undef;
384         $opt->{got}   = 0;
385
386         my ( $type ) = $opt->{spec} =~ m/=(.)/;
387         $opt->{type} = $type;
388         PTDEBUG && _d($long, 'type:', $type);
389
390
391         $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
392
393         if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
394            $self->{defaults}->{$long} = defined $def ? $def : 1;
395            PTDEBUG && _d($long, 'default:', $def);
396         }
397
398         if ( $long eq 'config' ) {
399            $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
400         }
401
402         if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
403            $disables{$long} = $dis;
404            PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
405         }
406
407         $self->{opts}->{$long} = $opt;
408      }
409      else { # It's an option rule, not a spec.
410         PTDEBUG && _d('Parsing rule:', $opt);
411         push @{$self->{rules}}, $opt;
412         my @participants = $self->_get_participants($opt);
413         my $rule_ok = 0;
414
415         if ( $opt =~ m/mutually exclusive|one and only one/ ) {
416            $rule_ok = 1;
417            push @{$self->{mutex}}, \@participants;
418            PTDEBUG && _d(@participants, 'are mutually exclusive');
419         }
420         if ( $opt =~ m/at least one|one and only one/ ) {
421            $rule_ok = 1;
422            push @{$self->{atleast1}}, \@participants;
423            PTDEBUG && _d(@participants, 'require at least one');
424         }
425         if ( $opt =~ m/default to/ ) {
426            $rule_ok = 1;
427            $self->{defaults_to}->{$participants[0]} = $participants[1];
428            PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
429         }
430         if ( $opt =~ m/restricted to option groups/ ) {
431            $rule_ok = 1;
432            my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
433            my @groups = split(',', $groups);
434            %{$self->{allowed_groups}->{$participants[0]}} = map {
435               s/\s+//;
436               $_ => 1;
437            } @groups;
438         }
439         if( $opt =~ m/accepts additional command-line arguments/ ) {
440            $rule_ok = 1;
441            $self->{strict} = 0;
442            PTDEBUG && _d("Strict mode disabled by rule");
443         }
444
445         die "Unrecognized option rule: $opt" unless $rule_ok;
446      }
447   }
448
449   foreach my $long ( keys %disables ) {
450      my @participants = $self->_get_participants($disables{$long});
451      $self->{disables}->{$long} = \@participants;
452      PTDEBUG && _d('Option', $long, 'disables', @participants);
453   }
454
455   return;
456}
457
458sub _get_participants {
459   my ( $self, $str ) = @_;
460   my @participants;
461   foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
462      die "Option --$long does not exist while processing rule $str"
463         unless exists $self->{opts}->{$long};
464      push @participants, $long;
465   }
466   PTDEBUG && _d('Participants for', $str, ':', @participants);
467   return @participants;
468}
469
470sub opts {
471   my ( $self ) = @_;
472   my %opts = %{$self->{opts}};
473   return %opts;
474}
475
476sub short_opts {
477   my ( $self ) = @_;
478   my %short_opts = %{$self->{short_opts}};
479   return %short_opts;
480}
481
482sub set_defaults {
483   my ( $self, %defaults ) = @_;
484   $self->{defaults} = {};
485   foreach my $long ( keys %defaults ) {
486      die "Cannot set default for nonexistent option $long"
487         unless exists $self->{opts}->{$long};
488      $self->{defaults}->{$long} = $defaults{$long};
489      PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
490   }
491   return;
492}
493
494sub get_defaults {
495   my ( $self ) = @_;
496   return $self->{defaults};
497}
498
499sub get_groups {
500   my ( $self ) = @_;
501   return $self->{groups};
502}
503
504sub _set_option {
505   my ( $self, $opt, $val ) = @_;
506   my $long = exists $self->{opts}->{$opt}       ? $opt
507            : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
508            : die "Getopt::Long gave a nonexistent option: $opt";
509   $opt = $self->{opts}->{$long};
510   if ( $opt->{is_cumulative} ) {
511      $opt->{value}++;
512   }
513   elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
514      my $next_opt = $1;
515      if (    exists $self->{opts}->{$next_opt}
516           || exists $self->{short_opts}->{$next_opt} ) {
517         $self->save_error("--$long requires a string value");
518         return;
519      }
520      else {
521         if ($opt->{is_repeatable}) {
522            push @{$opt->{value}} , $val;
523         }
524         else {
525            $opt->{value} = $val;
526         }
527      }
528   }
529   else {
530      if ($opt->{is_repeatable}) {
531         push @{$opt->{value}} , $val;
532      }
533      else {
534         $opt->{value} = $val;
535      }
536   }
537   $opt->{got} = 1;
538   PTDEBUG && _d('Got option', $long, '=', $val);
539}
540
541sub get_opts {
542   my ( $self ) = @_;
543
544   foreach my $long ( keys %{$self->{opts}} ) {
545      $self->{opts}->{$long}->{got} = 0;
546      $self->{opts}->{$long}->{value}
547         = exists $self->{defaults}->{$long}       ? $self->{defaults}->{$long}
548         : $self->{opts}->{$long}->{is_cumulative} ? 0
549         : undef;
550   }
551   $self->{got_opts} = 0;
552
553   $self->{errors} = [];
554
555   if ( @ARGV && $ARGV[0] =~/^--config=/ ) {
556      $ARGV[0] = substr($ARGV[0],9);
557      $ARGV[0] =~ s/^'(.*)'$/$1/;
558      $ARGV[0] =~ s/^"(.*)"$/$1/;
559      $self->_set_option('config', shift @ARGV);
560   }
561   if ( @ARGV && $ARGV[0] eq "--config" ) {
562      shift @ARGV;
563      $self->_set_option('config', shift @ARGV);
564   }
565   if ( $self->has('config') ) {
566      my @extra_args;
567      foreach my $filename ( split(',', $self->get('config')) ) {
568         eval {
569            push @extra_args, $self->_read_config_file($filename);
570         };
571         if ( $EVAL_ERROR ) {
572            if ( $self->got('config') ) {
573               die $EVAL_ERROR;
574            }
575            elsif ( PTDEBUG ) {
576               _d($EVAL_ERROR);
577            }
578         }
579      }
580      unshift @ARGV, @extra_args;
581   }
582
583   Getopt::Long::Configure('no_ignore_case', 'bundling');
584   GetOptions(
585      map    { $_->{spec} => sub { $self->_set_option(@_); } }
586      grep   { $_->{long} ne 'config' } # --config is handled specially above.
587      values %{$self->{opts}}
588   ) or $self->save_error('Error parsing options');
589
590   if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
591      if ( $self->{version} ) {
592         print $self->{version}, "\n";
593         exit 0;
594      }
595      else {
596         print "Error parsing version.  See the VERSION section of the tool's documentation.\n";
597         exit 1;
598      }
599   }
600
601   if ( @ARGV && $self->{strict} ) {
602      $self->save_error("Unrecognized command-line options @ARGV");
603   }
604
605   foreach my $mutex ( @{$self->{mutex}} ) {
606      my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
607      if ( @set > 1 ) {
608         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
609                      @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
610                 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
611                 . ' are mutually exclusive.';
612         $self->save_error($err);
613      }
614   }
615
616   foreach my $required ( @{$self->{atleast1}} ) {
617      my @set = grep { $self->{opts}->{$_}->{got} } @$required;
618      if ( @set == 0 ) {
619         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
620                      @{$required}[ 0 .. scalar(@$required) - 2] )
621                 .' or --'.$self->{opts}->{$required->[-1]}->{long};
622         $self->save_error("Specify at least one of $err");
623      }
624   }
625
626   $self->_check_opts( keys %{$self->{opts}} );
627   $self->{got_opts} = 1;
628   return;
629}
630
631sub _check_opts {
632   my ( $self, @long ) = @_;
633   my $long_last = scalar @long;
634   while ( @long ) {
635      foreach my $i ( 0..$#long ) {
636         my $long = $long[$i];
637         next unless $long;
638         my $opt  = $self->{opts}->{$long};
639         if ( $opt->{got} ) {
640            if ( exists $self->{disables}->{$long} ) {
641               my @disable_opts = @{$self->{disables}->{$long}};
642               map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
643               PTDEBUG && _d('Unset options', @disable_opts,
644                  'because', $long,'disables them');
645            }
646
647            if ( exists $self->{allowed_groups}->{$long} ) {
648
649               my @restricted_groups = grep {
650                  !exists $self->{allowed_groups}->{$long}->{$_}
651               } keys %{$self->{groups}};
652
653               my @restricted_opts;
654               foreach my $restricted_group ( @restricted_groups ) {
655                  RESTRICTED_OPT:
656                  foreach my $restricted_opt (
657                     keys %{$self->{groups}->{$restricted_group}} )
658                  {
659                     next RESTRICTED_OPT if $restricted_opt eq $long;
660                     push @restricted_opts, $restricted_opt
661                        if $self->{opts}->{$restricted_opt}->{got};
662                  }
663               }
664
665               if ( @restricted_opts ) {
666                  my $err;
667                  if ( @restricted_opts == 1 ) {
668                     $err = "--$restricted_opts[0]";
669                  }
670                  else {
671                     $err = join(', ',
672                               map { "--$self->{opts}->{$_}->{long}" }
673                               grep { $_ }
674                               @restricted_opts[0..scalar(@restricted_opts) - 2]
675                            )
676                          . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
677                  }
678                  $self->save_error("--$long is not allowed with $err");
679               }
680            }
681
682         }
683         elsif ( $opt->{is_required} ) {
684            $self->save_error("Required option --$long must be specified");
685         }
686
687         $self->_validate_type($opt);
688         if ( $opt->{parsed} ) {
689            delete $long[$i];
690         }
691         else {
692            PTDEBUG && _d('Temporarily failed to parse', $long);
693         }
694      }
695
696      die "Failed to parse options, possibly due to circular dependencies"
697         if @long == $long_last;
698      $long_last = @long;
699   }
700
701   return;
702}
703
704sub _validate_type {
705   my ( $self, $opt ) = @_;
706   return unless $opt;
707
708   if ( !$opt->{type} ) {
709      $opt->{parsed} = 1;
710      return;
711   }
712
713   my $val = $opt->{value};
714
715   if ( $val && $opt->{type} eq 'm' ) {  # type time
716      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
717      my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
718      if ( !$suffix ) {
719         my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
720         $suffix = $s || 's';
721         PTDEBUG && _d('No suffix given; using', $suffix, 'for',
722            $opt->{long}, '(value:', $val, ')');
723      }
724      if ( $suffix =~ m/[smhd]/ ) {
725         $val = $suffix eq 's' ? $num            # Seconds
726              : $suffix eq 'm' ? $num * 60       # Minutes
727              : $suffix eq 'h' ? $num * 3600     # Hours
728              :                  $num * 86400;   # Days
729         $opt->{value} = ($prefix || '') . $val;
730         PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
731      }
732      else {
733         $self->save_error("Invalid time suffix for --$opt->{long}");
734      }
735   }
736   elsif ( $val && $opt->{type} eq 'd' ) {  # type DSN
737      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
738      my $prev = {};
739      my $from_key = $self->{defaults_to}->{ $opt->{long} };
740      if ( $from_key ) {
741         PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
742         if ( $self->{opts}->{$from_key}->{parsed} ) {
743            $prev = $self->{opts}->{$from_key}->{value};
744         }
745         else {
746            PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
747               $from_key, 'parsed');
748            return;
749         }
750      }
751      my $defaults = $self->{DSNParser}->parse_options($self);
752      if (!$opt->{attributes}->{repeatable}) {
753          $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
754      } else {
755          my $values = [];
756          for my $dsn_string (@$val) {
757              push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults);
758          }
759          $opt->{value} = $values;
760      }
761   }
762   elsif ( $val && $opt->{type} eq 'z' ) {  # type size
763      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
764      $self->_parse_size($opt, $val);
765   }
766   elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
767      $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
768   }
769   elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
770      $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
771   }
772   else {
773      PTDEBUG && _d('Nothing to validate for option',
774         $opt->{long}, 'type', $opt->{type}, 'value', $val);
775   }
776
777   $opt->{parsed} = 1;
778   return;
779}
780
781sub get {
782   my ( $self, $opt ) = @_;
783   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
784   die "Option $opt does not exist"
785      unless $long && exists $self->{opts}->{$long};
786   return $self->{opts}->{$long}->{value};
787}
788
789sub got {
790   my ( $self, $opt ) = @_;
791   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
792   die "Option $opt does not exist"
793      unless $long && exists $self->{opts}->{$long};
794   return $self->{opts}->{$long}->{got};
795}
796
797sub has {
798   my ( $self, $opt ) = @_;
799   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
800   return defined $long ? exists $self->{opts}->{$long} : 0;
801}
802
803sub set {
804   my ( $self, $opt, $val ) = @_;
805   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
806   die "Option $opt does not exist"
807      unless $long && exists $self->{opts}->{$long};
808   $self->{opts}->{$long}->{value} = $val;
809   return;
810}
811
812sub save_error {
813   my ( $self, $error ) = @_;
814   push @{$self->{errors}}, $error;
815   return;
816}
817
818sub errors {
819   my ( $self ) = @_;
820   return $self->{errors};
821}
822
823sub usage {
824   my ( $self ) = @_;
825   warn "No usage string is set" unless $self->{usage}; # XXX
826   return "Usage: " . ($self->{usage} || '') . "\n";
827}
828
829sub descr {
830   my ( $self ) = @_;
831   warn "No description string is set" unless $self->{description}; # XXX
832   my $descr  = ($self->{description} || $self->{program_name} || '')
833              . "  For more details, please use the --help option, "
834              . "or try 'perldoc $PROGRAM_NAME' "
835              . "for complete documentation.";
836   $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
837      unless $ENV{DONT_BREAK_LINES};
838   $descr =~ s/ +$//mg;
839   return $descr;
840}
841
842sub usage_or_errors {
843   my ( $self, $file, $return ) = @_;
844   $file ||= $self->{file} || __FILE__;
845
846   if ( !$self->{description} || !$self->{usage} ) {
847      PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
848      my %synop = $self->_parse_synopsis($file);
849      $self->{description} ||= $synop{description};
850      $self->{usage}       ||= $synop{usage};
851      PTDEBUG && _d("Description:", $self->{description},
852         "\nUsage:", $self->{usage});
853   }
854
855   if ( $self->{opts}->{help}->{got} ) {
856      print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
857      exit 0 unless $return;
858   }
859   elsif ( scalar @{$self->{errors}} ) {
860      print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
861      exit 1 unless $return;
862   }
863
864   return;
865}
866
867sub print_errors {
868   my ( $self ) = @_;
869   my $usage = $self->usage() . "\n";
870   if ( (my @errors = @{$self->{errors}}) ) {
871      $usage .= join("\n  * ", 'Errors in command-line arguments:', @errors)
872              . "\n";
873   }
874   return $usage . "\n" . $self->descr();
875}
876
877sub print_usage {
878   my ( $self ) = @_;
879   die "Run get_opts() before print_usage()" unless $self->{got_opts};
880   my @opts = values %{$self->{opts}};
881
882   my $maxl = max(
883      map {
884         length($_->{long})               # option long name
885         + ($_->{is_negatable} ? 4 : 0)   # "[no]" if opt is negatable
886         + ($_->{type} ? 2 : 0)           # "=x" where x is the opt type
887      }
888      @opts);
889
890   my $maxs = max(0,
891      map {
892         length($_)
893         + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
894         + ($self->{opts}->{$_}->{type} ? 2 : 0)
895      }
896      values %{$self->{short_opts}});
897
898   my $lcol = max($maxl, ($maxs + 3));
899   my $rcol = 80 - $lcol - 6;
900   my $rpad = ' ' x ( 80 - $rcol );
901
902   $maxs = max($lcol - 3, $maxs);
903
904   my $usage = $self->descr() . "\n" . $self->usage();
905
906   my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
907   push @groups, 'default';
908
909   foreach my $group ( reverse @groups ) {
910      $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
911      foreach my $opt (
912         sort { $a->{long} cmp $b->{long} }
913         grep { $_->{group} eq $group }
914         @opts )
915      {
916         my $long  = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
917         my $short = $opt->{short};
918         my $desc  = $opt->{desc};
919
920         $long .= $opt->{type} ? "=$opt->{type}" : "";
921
922         if ( $opt->{type} && $opt->{type} eq 'm' ) {
923            my ($s) = $desc =~ m/\(suffix (.)\)/;
924            $s    ||= 's';
925            $desc =~ s/\s+\(suffix .\)//;
926            $desc .= ".  Optional suffix s=seconds, m=minutes, h=hours, "
927                   . "d=days; if no suffix, $s is used.";
928         }
929         $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
930         $desc =~ s/ +$//mg;
931         if ( $short ) {
932            $usage .= sprintf("  --%-${maxs}s -%s  %s\n", $long, $short, $desc);
933         }
934         else {
935            $usage .= sprintf("  --%-${lcol}s  %s\n", $long, $desc);
936         }
937      }
938   }
939
940   $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
941
942   if ( (my @rules = @{$self->{rules}}) ) {
943      $usage .= "\nRules:\n\n";
944      $usage .= join("\n", map { "  $_" } @rules) . "\n";
945   }
946   if ( $self->{DSNParser} ) {
947      $usage .= "\n" . $self->{DSNParser}->usage();
948   }
949   $usage .= "\nOptions and values after processing arguments:\n\n";
950   foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
951      my $val   = $opt->{value};
952      my $type  = $opt->{type} || '';
953      my $bool  = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
954      $val      = $bool              ? ( $val ? 'TRUE' : 'FALSE' )
955                : !defined $val      ? '(No value)'
956                : $type eq 'd'       ? $self->{DSNParser}->as_string($val)
957                : $type =~ m/H|h/    ? join(',', sort keys %$val)
958                : $type =~ m/A|a/    ? join(',', @$val)
959                :                    $val;
960      $usage .= sprintf("  --%-${lcol}s  %s\n", $opt->{long}, $val);
961   }
962   return $usage;
963}
964
965sub prompt_noecho {
966   shift @_ if ref $_[0] eq __PACKAGE__;
967   my ( $prompt ) = @_;
968   local $OUTPUT_AUTOFLUSH = 1;
969   print STDERR $prompt
970      or die "Cannot print: $OS_ERROR";
971   my $response;
972   eval {
973      require Term::ReadKey;
974      Term::ReadKey::ReadMode('noecho');
975      chomp($response = <STDIN>);
976      Term::ReadKey::ReadMode('normal');
977      print "\n"
978         or die "Cannot print: $OS_ERROR";
979   };
980   if ( $EVAL_ERROR ) {
981      die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
982   }
983   return $response;
984}
985
986sub _read_config_file {
987   my ( $self, $filename ) = @_;
988   open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
989   my @args;
990   my $prefix = '--';
991   my $parse  = 1;
992
993   LINE:
994   while ( my $line = <$fh> ) {
995      chomp $line;
996      next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
997      $line =~ s/\s+#.*$//g;
998      $line =~ s/^\s+|\s+$//g;
999      if ( $line eq '--' ) {
1000         $prefix = '';
1001         $parse  = 0;
1002         next LINE;
1003      }
1004
1005      if (  $parse
1006            && !$self->has('version-check')
1007            && $line =~ /version-check/
1008      ) {
1009         next LINE;
1010      }
1011
1012      if ( $parse
1013         && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
1014      ) {
1015         push @args, grep { defined $_ } ("$prefix$opt", $arg);
1016      }
1017      elsif ( $line =~ m/./ ) {
1018         push @args, $line;
1019      }
1020      else {
1021         die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
1022      }
1023   }
1024   close $fh;
1025   return @args;
1026}
1027
1028sub read_para_after {
1029   my ( $self, $file, $regex ) = @_;
1030   open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
1031   local $INPUT_RECORD_SEPARATOR = '';
1032   my $para;
1033   while ( $para = <$fh> ) {
1034      next unless $para =~ m/^=pod$/m;
1035      last;
1036   }
1037   while ( $para = <$fh> ) {
1038      next unless $para =~ m/$regex/;
1039      last;
1040   }
1041   $para = <$fh>;
1042   chomp($para);
1043   close $fh or die "Can't close $file: $OS_ERROR";
1044   return $para;
1045}
1046
1047sub clone {
1048   my ( $self ) = @_;
1049
1050   my %clone = map {
1051      my $hashref  = $self->{$_};
1052      my $val_copy = {};
1053      foreach my $key ( keys %$hashref ) {
1054         my $ref = ref $hashref->{$key};
1055         $val_copy->{$key} = !$ref           ? $hashref->{$key}
1056                           : $ref eq 'HASH'  ? { %{$hashref->{$key}} }
1057                           : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
1058                           : $hashref->{$key};
1059      }
1060      $_ => $val_copy;
1061   } qw(opts short_opts defaults);
1062
1063   foreach my $scalar ( qw(got_opts) ) {
1064      $clone{$scalar} = $self->{$scalar};
1065   }
1066
1067   return bless \%clone;
1068}
1069
1070sub _parse_size {
1071   my ( $self, $opt, $val ) = @_;
1072
1073   if ( lc($val || '') eq 'null' ) {
1074      PTDEBUG && _d('NULL size for', $opt->{long});
1075      $opt->{value} = 'null';
1076      return;
1077   }
1078
1079   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
1080   my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
1081   if ( defined $num ) {
1082      if ( $factor ) {
1083         $num *= $factor_for{$factor};
1084         PTDEBUG && _d('Setting option', $opt->{y},
1085            'to num', $num, '* factor', $factor);
1086      }
1087      $opt->{value} = ($pre || '') . $num;
1088   }
1089   else {
1090      $self->save_error("Invalid size for --$opt->{long}: $val");
1091   }
1092   return;
1093}
1094
1095sub _parse_attribs {
1096   my ( $self, $option, $attribs ) = @_;
1097   my $types = $self->{types};
1098   return $option
1099      . ($attribs->{'short form'} ? '|' . $attribs->{'short form'}   : '' )
1100      . ($attribs->{'negatable'}  ? '!'                              : '' )
1101      . ($attribs->{'cumulative'} ? '+'                              : '' )
1102      . ($attribs->{'type'}       ? '=' . $types->{$attribs->{type}} : '' );
1103}
1104
1105sub _parse_synopsis {
1106   my ( $self, $file ) = @_;
1107   $file ||= $self->{file} || __FILE__;
1108   PTDEBUG && _d("Parsing SYNOPSIS in", $file);
1109
1110   local $INPUT_RECORD_SEPARATOR = '';  # read paragraphs
1111   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1112   my $para;
1113   1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
1114   die "$file does not contain a SYNOPSIS section" unless $para;
1115   my @synop;
1116   for ( 1..2 ) {  # 1 for the usage, 2 for the description
1117      my $para = <$fh>;
1118      push @synop, $para;
1119   }
1120   close $fh;
1121   PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
1122   my ($usage, $desc) = @synop;
1123   die "The SYNOPSIS section in $file is not formatted properly"
1124      unless $usage && $desc;
1125
1126   $usage =~ s/^\s*Usage:\s+(.+)/$1/;
1127   chomp $usage;
1128
1129   $desc =~ s/\n/ /g;
1130   $desc =~ s/\s{2,}/ /g;
1131   $desc =~ s/\. ([A-Z][a-z])/.  $1/g;
1132   $desc =~ s/\s+$//;
1133
1134   return (
1135      description => $desc,
1136      usage       => $usage,
1137   );
1138};
1139
1140sub set_vars {
1141   my ($self, $file) = @_;
1142   $file ||= $self->{file} || __FILE__;
1143
1144   my %user_vars;
1145   my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
1146   if ( $user_vars ) {
1147      foreach my $var_val ( @$user_vars ) {
1148         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1149         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1150         $user_vars{$var} = {
1151            val     => $val,
1152            default => 0,
1153         };
1154      }
1155   }
1156
1157   my %default_vars;
1158   my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
1159   if ( $default_vars ) {
1160      %default_vars = map {
1161         my $var_val = $_;
1162         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1163         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1164         $var => {
1165            val     => $val,
1166            default => 1,
1167         };
1168      } split("\n", $default_vars);
1169   }
1170
1171   my %vars = (
1172      %default_vars, # first the tool's defaults
1173      %user_vars,    # then the user's which overwrite the defaults
1174   );
1175   PTDEBUG && _d('--set-vars:', Dumper(\%vars));
1176   return \%vars;
1177}
1178
1179sub _d {
1180   my ($package, undef, $line) = caller 0;
1181   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1182        map { defined $_ ? $_ : 'undef' }
1183        @_;
1184   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1185}
1186
1187if ( PTDEBUG ) {
1188   print STDERR '# ', $^X, ' ', $], "\n";
1189   if ( my $uname = `uname -a` ) {
1190      $uname =~ s/\s+/ /g;
1191      print STDERR "# $uname\n";
1192   }
1193   print STDERR '# Arguments: ',
1194      join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
1195}
1196
11971;
1198}
1199# ###########################################################################
1200# End OptionParser package
1201# ###########################################################################
1202
1203# ###########################################################################
1204# Quoter package
1205# This package is a copy without comments from the original.  The original
1206# with comments and its test file can be found in the Bazaar repository at,
1207#   lib/Quoter.pm
1208#   t/lib/Quoter.t
1209# See https://launchpad.net/percona-toolkit for more information.
1210# ###########################################################################
1211{
1212package Quoter;
1213
1214use strict;
1215use warnings FATAL => 'all';
1216use English qw(-no_match_vars);
1217use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1218
1219use Data::Dumper;
1220$Data::Dumper::Indent    = 1;
1221$Data::Dumper::Sortkeys  = 1;
1222$Data::Dumper::Quotekeys = 0;
1223
1224sub new {
1225   my ( $class, %args ) = @_;
1226   return bless {}, $class;
1227}
1228
1229sub quote {
1230   my ( $self, @vals ) = @_;
1231   foreach my $val ( @vals ) {
1232      $val =~ s/`/``/g;
1233   }
1234   return join('.', map { '`' . $_ . '`' } @vals);
1235}
1236
1237sub quote_val {
1238   my ( $self, $val, %args ) = @_;
1239
1240   return 'NULL' unless defined $val;          # undef = NULL
1241   return "''" if $val eq '';                  # blank string = ''
1242   return $val if $val =~ m/^0x[0-9a-fA-F]+$/  # quote hex data
1243                  && !$args{is_char};          # unless is_char is true
1244
1245   $val =~ s/(['\\])/\\$1/g;
1246   return "'$val'";
1247}
1248
1249sub split_unquote {
1250   my ( $self, $db_tbl, $default_db ) = @_;
1251   my ( $db, $tbl ) = split(/[.]/, $db_tbl);
1252   if ( !$tbl ) {
1253      $tbl = $db;
1254      $db  = $default_db;
1255   }
1256   for ($db, $tbl) {
1257      next unless $_;
1258      s/\A`//;
1259      s/`\z//;
1260      s/``/`/g;
1261   }
1262
1263   return ($db, $tbl);
1264}
1265
1266sub literal_like {
1267   my ( $self, $like ) = @_;
1268   return unless $like;
1269   $like =~ s/([%_])/\\$1/g;
1270   return "'$like'";
1271}
1272
1273sub join_quote {
1274   my ( $self, $default_db, $db_tbl ) = @_;
1275   return unless $db_tbl;
1276   my ($db, $tbl) = split(/[.]/, $db_tbl);
1277   if ( !$tbl ) {
1278      $tbl = $db;
1279      $db  = $default_db;
1280   }
1281   $db  = "`$db`"  if $db  && $db  !~ m/^`/;
1282   $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
1283   return $db ? "$db.$tbl" : $tbl;
1284}
1285
1286sub serialize_list {
1287   my ( $self, @args ) = @_;
1288   PTDEBUG && _d('Serializing', Dumper(\@args));
1289   return unless @args;
1290
1291   my @parts;
1292   foreach my $arg  ( @args ) {
1293      if ( defined $arg ) {
1294         $arg =~ s/,/\\,/g;      # escape commas
1295         $arg =~ s/\\N/\\\\N/g;  # escape literal \N
1296         push @parts, $arg;
1297      }
1298      else {
1299         push @parts, '\N';
1300      }
1301   }
1302
1303   my $string = join(',', @parts);
1304   PTDEBUG && _d('Serialized: <', $string, '>');
1305   return $string;
1306}
1307
1308sub deserialize_list {
1309   my ( $self, $string ) = @_;
1310   PTDEBUG && _d('Deserializing <', $string, '>');
1311   die "Cannot deserialize an undefined string" unless defined $string;
1312
1313   my @parts;
1314   foreach my $arg ( split(/(?<!\\),/, $string) ) {
1315      if ( $arg eq '\N' ) {
1316         $arg = undef;
1317      }
1318      else {
1319         $arg =~ s/\\,/,/g;
1320         $arg =~ s/\\\\N/\\N/g;
1321      }
1322      push @parts, $arg;
1323   }
1324
1325   if ( !@parts ) {
1326      my $n_empty_strings = $string =~ tr/,//;
1327      $n_empty_strings++;
1328      PTDEBUG && _d($n_empty_strings, 'empty strings');
1329      map { push @parts, '' } 1..$n_empty_strings;
1330   }
1331   elsif ( $string =~ m/(?<!\\),$/ ) {
1332      PTDEBUG && _d('Last value is an empty string');
1333      push @parts, '';
1334   }
1335
1336   PTDEBUG && _d('Deserialized', Dumper(\@parts));
1337   return @parts;
1338}
1339
1340sub _d {
1341   my ($package, undef, $line) = caller 0;
1342   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1343        map { defined $_ ? $_ : 'undef' }
1344        @_;
1345   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1346}
1347
13481;
1349}
1350# ###########################################################################
1351# End Quoter package
1352# ###########################################################################
1353
1354# ###########################################################################
1355# DSNParser package
1356# This package is a copy without comments from the original.  The original
1357# with comments and its test file can be found in the Bazaar repository at,
1358#   lib/DSNParser.pm
1359#   t/lib/DSNParser.t
1360# See https://launchpad.net/percona-toolkit for more information.
1361# ###########################################################################
1362{
1363package DSNParser;
1364
1365use strict;
1366use warnings FATAL => 'all';
1367use English qw(-no_match_vars);
1368use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1369
1370use Data::Dumper;
1371$Data::Dumper::Indent    = 0;
1372$Data::Dumper::Quotekeys = 0;
1373
1374my $dsn_sep = qr/(?<!\\),/;
1375
1376eval {
1377   require DBI;
1378};
1379my $have_dbi = $EVAL_ERROR ? 0 : 1;
1380
1381sub new {
1382   my ( $class, %args ) = @_;
1383   foreach my $arg ( qw(opts) ) {
1384      die "I need a $arg argument" unless $args{$arg};
1385   }
1386   my $self = {
1387      opts => {}  # h, P, u, etc.  Should come from DSN OPTIONS section in POD.
1388   };
1389   foreach my $opt ( @{$args{opts}} ) {
1390      if ( !$opt->{key} || !$opt->{desc} ) {
1391         die "Invalid DSN option: ", Dumper($opt);
1392      }
1393      PTDEBUG && _d('DSN option:',
1394         join(', ',
1395            map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
1396               keys %$opt
1397         )
1398      );
1399      $self->{opts}->{$opt->{key}} = {
1400         dsn  => $opt->{dsn},
1401         desc => $opt->{desc},
1402         copy => $opt->{copy} || 0,
1403      };
1404   }
1405   return bless $self, $class;
1406}
1407
1408sub prop {
1409   my ( $self, $prop, $value ) = @_;
1410   if ( @_ > 2 ) {
1411      PTDEBUG && _d('Setting', $prop, 'property');
1412      $self->{$prop} = $value;
1413   }
1414   return $self->{$prop};
1415}
1416
1417sub parse {
1418   my ( $self, $dsn, $prev, $defaults ) = @_;
1419   if ( !$dsn ) {
1420      PTDEBUG && _d('No DSN to parse');
1421      return;
1422   }
1423   PTDEBUG && _d('Parsing', $dsn);
1424   $prev     ||= {};
1425   $defaults ||= {};
1426   my %given_props;
1427   my %final_props;
1428   my $opts = $self->{opts};
1429
1430   foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
1431      $dsn_part =~ s/\\,/,/g;
1432      if ( my ($prop_key, $prop_val) = $dsn_part =~  m/^(.)=(.*)$/ ) {
1433         $given_props{$prop_key} = $prop_val;
1434      }
1435      else {
1436         PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
1437         $given_props{h} = $dsn_part;
1438      }
1439   }
1440
1441   foreach my $key ( keys %$opts ) {
1442      PTDEBUG && _d('Finding value for', $key);
1443      $final_props{$key} = $given_props{$key};
1444      if ( !defined $final_props{$key}
1445           && defined $prev->{$key} && $opts->{$key}->{copy} )
1446      {
1447         $final_props{$key} = $prev->{$key};
1448         PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
1449      }
1450      if ( !defined $final_props{$key} ) {
1451         $final_props{$key} = $defaults->{$key};
1452         PTDEBUG && _d('Copying value for', $key, 'from defaults');
1453      }
1454   }
1455
1456   foreach my $key ( keys %given_props ) {
1457      die "Unknown DSN option '$key' in '$dsn'.  For more details, "
1458            . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
1459            . "for complete documentation."
1460         unless exists $opts->{$key};
1461   }
1462   if ( (my $required = $self->prop('required')) ) {
1463      foreach my $key ( keys %$required ) {
1464         die "Missing required DSN option '$key' in '$dsn'.  For more details, "
1465               . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
1466               . "for complete documentation."
1467            unless $final_props{$key};
1468      }
1469   }
1470
1471   return \%final_props;
1472}
1473
1474sub parse_options {
1475   my ( $self, $o ) = @_;
1476   die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
1477   my $dsn_string
1478      = join(',',
1479          map  { "$_=".$o->get($_); }
1480          grep { $o->has($_) && $o->get($_) }
1481          keys %{$self->{opts}}
1482        );
1483   PTDEBUG && _d('DSN string made from options:', $dsn_string);
1484   return $self->parse($dsn_string);
1485}
1486
1487sub as_string {
1488   my ( $self, $dsn, $props ) = @_;
1489   return $dsn unless ref $dsn;
1490   my @keys = $props ? @$props : sort keys %$dsn;
1491   return join(',',
1492      map  { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
1493      grep {
1494         exists $self->{opts}->{$_}
1495         && exists $dsn->{$_}
1496         && defined $dsn->{$_}
1497      } @keys);
1498}
1499
1500sub usage {
1501   my ( $self ) = @_;
1502   my $usage
1503      = "DSN syntax is key=value[,key=value...]  Allowable DSN keys:\n\n"
1504      . "  KEY  COPY  MEANING\n"
1505      . "  ===  ====  =============================================\n";
1506   my %opts = %{$self->{opts}};
1507   foreach my $key ( sort keys %opts ) {
1508      $usage .= "  $key    "
1509             .  ($opts{$key}->{copy} ? 'yes   ' : 'no    ')
1510             .  ($opts{$key}->{desc} || '[No description]')
1511             . "\n";
1512   }
1513   $usage .= "\n  If the DSN is a bareword, the word is treated as the 'h' key.\n";
1514   return $usage;
1515}
1516
1517sub get_cxn_params {
1518   my ( $self, $info ) = @_;
1519   my $dsn;
1520   my %opts = %{$self->{opts}};
1521   my $driver = $self->prop('dbidriver') || '';
1522   if ( $driver eq 'Pg' ) {
1523      $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
1524         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
1525                     grep { defined $info->{$_} }
1526                     qw(h P));
1527   }
1528   else {
1529      $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
1530         . join(';', map  { "$opts{$_}->{dsn}=$info->{$_}" }
1531                     grep { defined $info->{$_} }
1532                     qw(F h P S A))
1533         . ';mysql_read_default_group=client'
1534         . ($info->{L} ? ';mysql_local_infile=1' : '');
1535   }
1536   PTDEBUG && _d($dsn);
1537   return ($dsn, $info->{u}, $info->{p});
1538}
1539
1540sub fill_in_dsn {
1541   my ( $self, $dbh, $dsn ) = @_;
1542   my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
1543   my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
1544   $user =~ s/@.*//;
1545   $dsn->{h} ||= $vars->{hostname}->{Value};
1546   $dsn->{S} ||= $vars->{'socket'}->{Value};
1547   $dsn->{P} ||= $vars->{port}->{Value};
1548   $dsn->{u} ||= $user;
1549   $dsn->{D} ||= $db;
1550}
1551
1552sub get_dbh {
1553   my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
1554   $opts ||= {};
1555   my $defaults = {
1556      AutoCommit         => 0,
1557      RaiseError         => 1,
1558      PrintError         => 0,
1559      ShowErrorStatement => 1,
1560      mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
1561   };
1562   @{$defaults}{ keys %$opts } = values %$opts;
1563   if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
1564      $defaults->{mysql_local_infile} = 1;
1565   }
1566
1567   if ( $opts->{mysql_use_result} ) {
1568      $defaults->{mysql_use_result} = 1;
1569   }
1570
1571   if ( !$have_dbi ) {
1572      die "Cannot connect to MySQL because the Perl DBI module is not "
1573         . "installed or not found.  Run 'perl -MDBI' to see the directories "
1574         . "that Perl searches for DBI.  If DBI is not installed, try:\n"
1575         . "  Debian/Ubuntu  apt-get install libdbi-perl\n"
1576         . "  RHEL/CentOS    yum install perl-DBI\n"
1577         . "  OpenSolaris    pkg install pkg:/SUNWpmdbi\n";
1578
1579   }
1580
1581   my $dbh;
1582   my $tries = 2;
1583   while ( !$dbh && $tries-- ) {
1584      PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
1585         join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
1586
1587      $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
1588
1589      if ( !$dbh && $EVAL_ERROR ) {
1590         if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
1591            die "Cannot connect to MySQL because the Perl DBD::mysql module is "
1592               . "not installed or not found.  Run 'perl -MDBD::mysql' to see "
1593               . "the directories that Perl searches for DBD::mysql.  If "
1594               . "DBD::mysql is not installed, try:\n"
1595               . "  Debian/Ubuntu  apt-get install libdbd-mysql-perl\n"
1596               . "  RHEL/CentOS    yum install perl-DBD-MySQL\n"
1597               . "  OpenSolaris    pgk install pkg:/SUNWapu13dbd-mysql\n";
1598         }
1599         elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
1600            PTDEBUG && _d('Going to try again without utf8 support');
1601            delete $defaults->{mysql_enable_utf8};
1602         }
1603         if ( !$tries ) {
1604            die $EVAL_ERROR;
1605         }
1606      }
1607   }
1608
1609   if ( $cxn_string =~ m/mysql/i ) {
1610      my $sql;
1611
1612      if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
1613         $sql = qq{/*!40101 SET NAMES "$charset"*/};
1614         PTDEBUG && _d($dbh, $sql);
1615         eval { $dbh->do($sql) };
1616         if ( $EVAL_ERROR ) {
1617            die "Error setting NAMES to $charset: $EVAL_ERROR";
1618         }
1619         PTDEBUG && _d('Enabling charset for STDOUT');
1620         if ( $charset eq 'utf8' ) {
1621            binmode(STDOUT, ':utf8')
1622               or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
1623         }
1624         else {
1625            binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
1626         }
1627      }
1628
1629      if ( my $vars = $self->prop('set-vars') ) {
1630         $self->set_vars($dbh, $vars);
1631      }
1632
1633      $sql = 'SELECT @@SQL_MODE';
1634      PTDEBUG && _d($dbh, $sql);
1635      my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
1636      if ( $EVAL_ERROR ) {
1637         die "Error getting the current SQL_MODE: $EVAL_ERROR";
1638      }
1639
1640      $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
1641            . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
1642            . ($sql_mode ? ",$sql_mode" : '')
1643            . '\'*/';
1644      PTDEBUG && _d($dbh, $sql);
1645      eval { $dbh->do($sql) };
1646      if ( $EVAL_ERROR ) {
1647         die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
1648           . ($sql_mode ? " and $sql_mode" : '')
1649           . ": $EVAL_ERROR";
1650      }
1651   }
1652   my ($mysql_version) = eval { $dbh->selectrow_array('SELECT VERSION()') };
1653   if ($EVAL_ERROR) {
1654       die "Cannot get MySQL version: $EVAL_ERROR";
1655   }
1656
1657   my (undef, $character_set_server) = eval { $dbh->selectrow_array("SHOW VARIABLES LIKE 'character_set_server'") };
1658   if ($EVAL_ERROR) {
1659       die "Cannot get MySQL var character_set_server: $EVAL_ERROR";
1660   }
1661
1662   if ($mysql_version =~ m/^(\d+)\.(\d)\.(\d+).*/) {
1663       if ($1 >= 8 && $character_set_server =~ m/^utf8/) {
1664           $dbh->{mysql_enable_utf8} = 1;
1665           my $msg = "MySQL version $mysql_version >= 8 and character_set_server = $character_set_server\n".
1666                     "Setting: SET NAMES $character_set_server";
1667           PTDEBUG && _d($msg);
1668           eval { $dbh->do("SET NAMES 'utf8mb4'") };
1669           if ($EVAL_ERROR) {
1670               die "Cannot SET NAMES $character_set_server: $EVAL_ERROR";
1671           }
1672       }
1673   }
1674
1675   PTDEBUG && _d('DBH info: ',
1676      $dbh,
1677      Dumper($dbh->selectrow_hashref(
1678         'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
1679      'Connection info:',      $dbh->{mysql_hostinfo},
1680      'Character set info:',   Dumper($dbh->selectall_arrayref(
1681                     "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
1682      '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
1683      '$DBI::VERSION:',        $DBI::VERSION,
1684   );
1685
1686   return $dbh;
1687}
1688
1689sub get_hostname {
1690   my ( $self, $dbh ) = @_;
1691   if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
1692      return $host;
1693   }
1694   my ( $hostname, $one ) = $dbh->selectrow_array(
1695      'SELECT /*!50038 @@hostname, */ 1');
1696   return $hostname;
1697}
1698
1699sub disconnect {
1700   my ( $self, $dbh ) = @_;
1701   PTDEBUG && $self->print_active_handles($dbh);
1702   $dbh->disconnect;
1703}
1704
1705sub print_active_handles {
1706   my ( $self, $thing, $level ) = @_;
1707   $level ||= 0;
1708   printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
1709      $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
1710      or die "Cannot print: $OS_ERROR";
1711   foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
1712      $self->print_active_handles( $handle, $level + 1 );
1713   }
1714}
1715
1716sub copy {
1717   my ( $self, $dsn_1, $dsn_2, %args ) = @_;
1718   die 'I need a dsn_1 argument' unless $dsn_1;
1719   die 'I need a dsn_2 argument' unless $dsn_2;
1720   my %new_dsn = map {
1721      my $key = $_;
1722      my $val;
1723      if ( $args{overwrite} ) {
1724         $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
1725      }
1726      else {
1727         $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
1728      }
1729      $key => $val;
1730   } keys %{$self->{opts}};
1731   return \%new_dsn;
1732}
1733
1734sub set_vars {
1735   my ($self, $dbh, $vars) = @_;
1736
1737   return unless $vars;
1738
1739   foreach my $var ( sort keys %$vars ) {
1740      my $val = $vars->{$var}->{val};
1741
1742      (my $quoted_var = $var) =~ s/_/\\_/;
1743      my ($var_exists, $current_val);
1744      eval {
1745         ($var_exists, $current_val) = $dbh->selectrow_array(
1746            "SHOW VARIABLES LIKE '$quoted_var'");
1747      };
1748      my $e = $EVAL_ERROR;
1749      if ( $e ) {
1750         PTDEBUG && _d($e);
1751      }
1752
1753      if ( $vars->{$var}->{default} && !$var_exists ) {
1754         PTDEBUG && _d('Not setting default var', $var,
1755            'because it does not exist');
1756         next;
1757      }
1758
1759      if ( $current_val && $current_val eq $val ) {
1760         PTDEBUG && _d('Not setting var', $var, 'because its value',
1761            'is already', $val);
1762         next;
1763      }
1764
1765      my $sql = "SET SESSION $var=$val";
1766      PTDEBUG && _d($dbh, $sql);
1767      eval { $dbh->do($sql) };
1768      if ( my $set_error = $EVAL_ERROR ) {
1769         chomp($set_error);
1770         $set_error =~ s/ at \S+ line \d+//;
1771         my $msg = "Error setting $var: $set_error";
1772         if ( $current_val ) {
1773            $msg .= "  The current value for $var is $current_val.  "
1774                  . "If the variable is read only (not dynamic), specify "
1775                  . "--set-vars $var=$current_val to avoid this warning, "
1776                  . "else manually set the variable and restart MySQL.";
1777         }
1778         warn $msg . "\n\n";
1779      }
1780   }
1781
1782   return;
1783}
1784
1785sub _d {
1786   my ($package, undef, $line) = caller 0;
1787   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1788        map { defined $_ ? $_ : 'undef' }
1789        @_;
1790   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1791}
1792
17931;
1794}
1795# ###########################################################################
1796# End DSNParser package
1797# ###########################################################################
1798
1799# ###########################################################################
1800# Cxn package
1801# This package is a copy without comments from the original.  The original
1802# with comments and its test file can be found in the Bazaar repository at,
1803#   lib/Cxn.pm
1804#   t/lib/Cxn.t
1805# See https://launchpad.net/percona-toolkit for more information.
1806# ###########################################################################
1807{
1808package Cxn;
1809
1810use strict;
1811use warnings FATAL => 'all';
1812use English qw(-no_match_vars);
1813use Scalar::Util qw(blessed);
1814use constant {
1815   PTDEBUG => $ENV{PTDEBUG} || 0,
1816   PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
1817};
1818
1819sub new {
1820   my ( $class, %args ) = @_;
1821   my @required_args = qw(DSNParser OptionParser);
1822   foreach my $arg ( @required_args ) {
1823      die "I need a $arg argument" unless $args{$arg};
1824   };
1825   my ($dp, $o) = @args{@required_args};
1826
1827   my $dsn_defaults = $dp->parse_options($o);
1828   my $prev_dsn     = $args{prev_dsn};
1829   my $dsn          = $args{dsn};
1830   if ( !$dsn ) {
1831      $args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
1832
1833      $dsn = $dp->parse(
1834         $args{dsn_string}, $prev_dsn, $dsn_defaults);
1835   }
1836   elsif ( $prev_dsn ) {
1837      $dsn = $dp->copy($prev_dsn, $dsn);
1838   }
1839
1840   my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
1841               || $dp->as_string($dsn, [qw(F)])
1842               || '';
1843
1844   my $self = {
1845      dsn             => $dsn,
1846      dbh             => $args{dbh},
1847      dsn_name        => $dsn_name,
1848      hostname        => '',
1849      set             => $args{set},
1850      NAME_lc         => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
1851      dbh_set         => 0,
1852      ask_pass        => $o->get('ask-pass'),
1853      DSNParser       => $dp,
1854      is_cluster_node => undef,
1855      parent          => $args{parent},
1856   };
1857
1858   return bless $self, $class;
1859}
1860
1861sub connect {
1862   my ( $self, %opts ) = @_;
1863   my $dsn = $opts{dsn} || $self->{dsn};
1864   my $dp  = $self->{DSNParser};
1865
1866   my $dbh = $self->{dbh};
1867   if ( !$dbh || !$dbh->ping() ) {
1868      if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
1869         $dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
1870         $self->{asked_for_pass} = 1;
1871      }
1872      $dbh = $dp->get_dbh(
1873         $dp->get_cxn_params($dsn),
1874         {
1875            AutoCommit => 1,
1876            %opts,
1877         },
1878      );
1879   }
1880
1881   $dbh = $self->set_dbh($dbh);
1882   if ( $opts{dsn} ) {
1883      $self->{dsn}      = $dsn;
1884      $self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
1885                       || $dp->as_string($dsn, [qw(F)])
1886                       || '';
1887
1888   }
1889   PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
1890   return $dbh;
1891}
1892
1893sub set_dbh {
1894   my ($self, $dbh) = @_;
1895
1896   if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
1897      PTDEBUG && _d($dbh, 'Already set dbh');
1898      return $dbh;
1899   }
1900
1901   PTDEBUG && _d($dbh, 'Setting dbh');
1902
1903   $dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
1904
1905   my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
1906   PTDEBUG && _d($dbh, $sql);
1907   my ($server_id, $hostname) = $dbh->selectrow_array($sql);
1908   PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
1909   if ( $hostname ) {
1910      $self->{hostname} = $hostname;
1911   }
1912
1913   if ( $self->{parent} ) {
1914      PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
1915      $dbh->{InactiveDestroy} = 1;
1916   }
1917
1918   if ( my $set = $self->{set}) {
1919      $set->($dbh);
1920   }
1921
1922   $self->{dbh}     = $dbh;
1923   $self->{dbh_set} = 1;
1924   return $dbh;
1925}
1926
1927sub lost_connection {
1928   my ($self, $e) = @_;
1929   return 0 unless $e;
1930   return $e =~ m/MySQL server has gone away/
1931       || $e =~ m/Lost connection to MySQL server/
1932       || $e =~ m/Server shutdown in progress/;
1933}
1934
1935sub dbh {
1936   my ($self) = @_;
1937   return $self->{dbh};
1938}
1939
1940sub dsn {
1941   my ($self) = @_;
1942   return $self->{dsn};
1943}
1944
1945sub name {
1946   my ($self) = @_;
1947   return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
1948   return $self->{hostname} || $self->{dsn_name} || 'unknown host';
1949}
1950
1951sub description {
1952   my ($self) = @_;
1953   return sprintf("%s -> %s:%s", $self->name(), $self->{dsn}->{h}, $self->{dsn}->{P} || 'socket');
1954}
1955
1956sub get_id {
1957   my ($self, $cxn) = @_;
1958
1959   $cxn ||= $self;
1960
1961   my $unique_id;
1962   if ($cxn->is_cluster_node()) {  # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
1963      my $sql  = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
1964      my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
1965      PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
1966      $unique_id = $wsrep_local_index."|";
1967      foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
1968         my $sql = "SHOW VARIABLES LIKE '$val'";
1969         PTDEBUG && _d($cxn->name, $sql);
1970         my (undef, $val) = $cxn->dbh->selectrow_array($sql);
1971         $unique_id .= "|$val";
1972      }
1973   } else {
1974      my $sql  = 'SELECT @@SERVER_ID';
1975      PTDEBUG && _d($sql);
1976      $unique_id = $cxn->dbh->selectrow_array($sql);
1977   }
1978   PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
1979   return $unique_id;
1980}
1981
1982
1983sub is_cluster_node {
1984   my ($self, $cxn) = @_;
1985
1986   $cxn ||= $self;
1987
1988   my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
1989
1990   my $dbh;
1991   if ($cxn->isa('DBI::db')) {
1992      $dbh = $cxn;
1993      PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn!
1994   }
1995   else {
1996      $dbh = $cxn->dbh();
1997      PTDEBUG && _d($cxn->name, $sql);
1998   }
1999
2000   my $row = $dbh->selectrow_arrayref($sql);
2001   return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
2002
2003}
2004
2005sub remove_duplicate_cxns {
2006   my ($self, %args) = @_;
2007   my @cxns     = @{$args{cxns}};
2008   my $seen_ids = $args{seen_ids} || {};
2009   PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
2010   my @trimmed_cxns;
2011
2012   for my $cxn ( @cxns ) {
2013
2014      my $id = $cxn->get_id();
2015      PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
2016
2017      if ( ! $seen_ids->{$id}++ ) {
2018         push @trimmed_cxns, $cxn
2019      }
2020      else {
2021         PTDEBUG && _d("Removing ", $cxn->name,
2022                       ", ID ", $id, ", because we've already seen it");
2023      }
2024   }
2025
2026   return \@trimmed_cxns;
2027}
2028
2029sub DESTROY {
2030   my ($self) = @_;
2031
2032   PTDEBUG && _d('Destroying cxn');
2033
2034   if ( $self->{parent} ) {
2035      PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
2036   }
2037   elsif ( $self->{dbh}
2038           && blessed($self->{dbh})
2039           && $self->{dbh}->can("disconnect") )
2040   {
2041      PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
2042         $self->{dsn_name});
2043      $self->{dbh}->disconnect();
2044   }
2045
2046   return;
2047}
2048
2049sub _d {
2050   my ($package, undef, $line) = caller 0;
2051   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2052        map { defined $_ ? $_ : 'undef' }
2053        @_;
2054   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2055}
2056
20571;
2058}
2059# ###########################################################################
2060# End Cxn package
2061# ###########################################################################
2062
2063# ###########################################################################
2064# Daemon package
2065# This package is a copy without comments from the original.  The original
2066# with comments and its test file can be found in the Bazaar repository at,
2067#   lib/Daemon.pm
2068#   t/lib/Daemon.t
2069# See https://launchpad.net/percona-toolkit for more information.
2070# ###########################################################################
2071{
2072package Daemon;
2073
2074use strict;
2075use warnings FATAL => 'all';
2076use English qw(-no_match_vars);
2077use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2078
2079use POSIX qw(setsid);
2080
2081sub new {
2082   my ( $class, %args ) = @_;
2083   foreach my $arg ( qw(o) ) {
2084      die "I need a $arg argument" unless $args{$arg};
2085   }
2086   my $o = $args{o};
2087   my $self = {
2088      o        => $o,
2089      log_file => $o->has('log') ? $o->get('log') : undef,
2090      PID_file => $o->has('pid') ? $o->get('pid') : undef,
2091   };
2092
2093   check_PID_file(undef, $self->{PID_file});
2094
2095   PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
2096   return bless $self, $class;
2097}
2098
2099sub daemonize {
2100   my ( $self ) = @_;
2101
2102   PTDEBUG && _d('About to fork and daemonize');
2103   defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
2104   if ( $pid ) {
2105      PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
2106      exit;
2107   }
2108
2109   PTDEBUG && _d('Daemonizing child PID', $PID);
2110   $self->{PID_owner} = $PID;
2111   $self->{child}     = 1;
2112
2113   POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
2114   chdir '/'       or die "Cannot chdir to /: $OS_ERROR";
2115
2116   $self->_make_PID_file();
2117
2118   $OUTPUT_AUTOFLUSH = 1;
2119
2120   PTDEBUG && _d('Redirecting STDIN to /dev/null');
2121   close STDIN;
2122   open  STDIN, '/dev/null'
2123      or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
2124
2125   if ( $self->{log_file} ) {
2126      PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
2127      close STDOUT;
2128      open  STDOUT, '>>', $self->{log_file}
2129         or die "Cannot open log file $self->{log_file}: $OS_ERROR";
2130
2131      close STDERR;
2132      open  STDERR, ">&STDOUT"
2133         or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
2134   }
2135   else {
2136      if ( -t STDOUT ) {
2137         PTDEBUG && _d('No log file and STDOUT is a terminal;',
2138            'redirecting to /dev/null');
2139         close STDOUT;
2140         open  STDOUT, '>', '/dev/null'
2141            or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
2142      }
2143      if ( -t STDERR ) {
2144         PTDEBUG && _d('No log file and STDERR is a terminal;',
2145            'redirecting to /dev/null');
2146         close STDERR;
2147         open  STDERR, '>', '/dev/null'
2148            or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
2149      }
2150   }
2151
2152   return;
2153}
2154
2155sub check_PID_file {
2156   my ( $self, $file ) = @_;
2157   my $PID_file = $self ? $self->{PID_file} : $file;
2158   PTDEBUG && _d('Checking PID file', $PID_file);
2159   if ( $PID_file && -f $PID_file ) {
2160      my $pid;
2161      eval {
2162         chomp($pid = (slurp_file($PID_file) || ''));
2163      };
2164      if ( $EVAL_ERROR ) {
2165         die "The PID file $PID_file already exists but it cannot be read: "
2166            . $EVAL_ERROR;
2167      }
2168      PTDEBUG && _d('PID file exists; it contains PID', $pid);
2169      if ( $pid ) {
2170         my $pid_is_alive = kill 0, $pid;
2171         if ( $pid_is_alive ) {
2172            die "The PID file $PID_file already exists "
2173               . " and the PID that it contains, $pid, is running";
2174         }
2175         else {
2176            warn "Overwriting PID file $PID_file because the PID that it "
2177               . "contains, $pid, is not running";
2178         }
2179      }
2180      else {
2181         die "The PID file $PID_file already exists but it does not "
2182            . "contain a PID";
2183      }
2184   }
2185   else {
2186      PTDEBUG && _d('No PID file');
2187   }
2188   return;
2189}
2190
2191sub make_PID_file {
2192   my ( $self ) = @_;
2193   if ( exists $self->{child} ) {
2194      die "Do not call Daemon::make_PID_file() for daemonized scripts";
2195   }
2196   $self->_make_PID_file();
2197   $self->{PID_owner} = $PID;
2198   return;
2199}
2200
2201sub _make_PID_file {
2202   my ( $self ) = @_;
2203
2204   my $PID_file = $self->{PID_file};
2205   if ( !$PID_file ) {
2206      PTDEBUG && _d('No PID file to create');
2207      return;
2208   }
2209
2210   $self->check_PID_file();
2211
2212   open my $PID_FH, '>', $PID_file
2213      or die "Cannot open PID file $PID_file: $OS_ERROR";
2214   print $PID_FH $PID
2215      or die "Cannot print to PID file $PID_file: $OS_ERROR";
2216   close $PID_FH
2217      or die "Cannot close PID file $PID_file: $OS_ERROR";
2218
2219   PTDEBUG && _d('Created PID file:', $self->{PID_file});
2220   return;
2221}
2222
2223sub _remove_PID_file {
2224   my ( $self ) = @_;
2225   if ( $self->{PID_file} && -f $self->{PID_file} ) {
2226      unlink $self->{PID_file}
2227         or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
2228      PTDEBUG && _d('Removed PID file');
2229   }
2230   else {
2231      PTDEBUG && _d('No PID to remove');
2232   }
2233   return;
2234}
2235
2236sub DESTROY {
2237   my ( $self ) = @_;
2238
2239   $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
2240
2241   return;
2242}
2243
2244sub slurp_file {
2245   my ($file) = @_;
2246   return unless $file;
2247   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2248   return do { local $/; <$fh> };
2249}
2250
2251sub _d {
2252   my ($package, undef, $line) = caller 0;
2253   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2254        map { defined $_ ? $_ : 'undef' }
2255        @_;
2256   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2257}
2258
22591;
2260}
2261# ###########################################################################
2262# End Daemon package
2263# ###########################################################################
2264
2265# ###########################################################################
2266# Transformers package
2267# This package is a copy without comments from the original.  The original
2268# with comments and its test file can be found in the Bazaar repository at,
2269#   lib/Transformers.pm
2270#   t/lib/Transformers.t
2271# See https://launchpad.net/percona-toolkit for more information.
2272# ###########################################################################
2273{
2274package Transformers;
2275
2276use strict;
2277use warnings FATAL => 'all';
2278use English qw(-no_match_vars);
2279use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2280
2281use Time::Local qw(timegm timelocal);
2282use Digest::MD5 qw(md5_hex);
2283use B qw();
2284
2285BEGIN {
2286   require Exporter;
2287   our @ISA         = qw(Exporter);
2288   our %EXPORT_TAGS = ();
2289   our @EXPORT      = ();
2290   our @EXPORT_OK   = qw(
2291      micro_t
2292      percentage_of
2293      secs_to_time
2294      time_to_secs
2295      shorten
2296      ts
2297      parse_timestamp
2298      unix_timestamp
2299      any_unix_timestamp
2300      make_checksum
2301      crc32
2302      encode_json
2303   );
2304}
2305
2306our $mysql_ts  = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
2307our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
2308our $n_ts      = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
2309
2310sub micro_t {
2311   my ( $t, %args ) = @_;
2312   my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0;  # precision for ms vals
2313   my $p_s  = defined $args{p_s}  ? $args{p_s}  : 0;  # precision for s vals
2314   my $f;
2315
2316   $t = 0 if $t < 0;
2317
2318   $t = sprintf('%.17f', $t) if $t =~ /e/;
2319
2320   $t =~ s/\.(\d{1,6})\d*/\.$1/;
2321
2322   if ($t > 0 && $t <= 0.000999) {
2323      $f = ($t * 1000000) . 'us';
2324   }
2325   elsif ($t >= 0.001000 && $t <= 0.999999) {
2326      $f = sprintf("%.${p_ms}f", $t * 1000);
2327      $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
2328   }
2329   elsif ($t >= 1) {
2330      $f = sprintf("%.${p_s}f", $t);
2331      $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
2332   }
2333   else {
2334      $f = 0;  # $t should = 0 at this point
2335   }
2336
2337   return $f;
2338}
2339
2340sub percentage_of {
2341   my ( $is, $of, %args ) = @_;
2342   my $p   = $args{p} || 0; # float precision
2343   my $fmt = $p ? "%.${p}f" : "%d";
2344   return sprintf $fmt, ($is * 100) / ($of ||= 1);
2345}
2346
2347sub secs_to_time {
2348   my ( $secs, $fmt ) = @_;
2349   $secs ||= 0;
2350   return '00:00' unless $secs;
2351
2352   $fmt ||= $secs >= 86_400 ? 'd'
2353          : $secs >= 3_600  ? 'h'
2354          :                   'm';
2355
2356   return
2357      $fmt eq 'd' ? sprintf(
2358         "%d+%02d:%02d:%02d",
2359         int($secs / 86_400),
2360         int(($secs % 86_400) / 3_600),
2361         int(($secs % 3_600) / 60),
2362         $secs % 60)
2363      : $fmt eq 'h' ? sprintf(
2364         "%02d:%02d:%02d",
2365         int(($secs % 86_400) / 3_600),
2366         int(($secs % 3_600) / 60),
2367         $secs % 60)
2368      : sprintf(
2369         "%02d:%02d",
2370         int(($secs % 3_600) / 60),
2371         $secs % 60);
2372}
2373
2374sub time_to_secs {
2375   my ( $val, $default_suffix ) = @_;
2376   die "I need a val argument" unless defined $val;
2377   my $t = 0;
2378   my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
2379   $suffix = $suffix || $default_suffix || 's';
2380   if ( $suffix =~ m/[smhd]/ ) {
2381      $t = $suffix eq 's' ? $num * 1        # Seconds
2382         : $suffix eq 'm' ? $num * 60       # Minutes
2383         : $suffix eq 'h' ? $num * 3600     # Hours
2384         :                  $num * 86400;   # Days
2385
2386      $t *= -1 if $prefix && $prefix eq '-';
2387   }
2388   else {
2389      die "Invalid suffix for $val: $suffix";
2390   }
2391   return $t;
2392}
2393
2394sub shorten {
2395   my ( $num, %args ) = @_;
2396   my $p = defined $args{p} ? $args{p} : 2;     # float precision
2397   my $d = defined $args{d} ? $args{d} : 1_024; # divisor
2398   my $n = 0;
2399   my @units = ('', qw(k M G T P E Z Y));
2400   while ( $num >= $d && $n < @units - 1 ) {
2401      $num /= $d;
2402      ++$n;
2403   }
2404   return sprintf(
2405      $num =~ m/\./ || $n
2406         ? '%1$.'.$p.'f%2$s'
2407         : '%1$d',
2408      $num, $units[$n]);
2409}
2410
2411sub ts {
2412   my ( $time, $gmt ) = @_;
2413   my ( $sec, $min, $hour, $mday, $mon, $year )
2414      = $gmt ? gmtime($time) : localtime($time);
2415   $mon  += 1;
2416   $year += 1900;
2417   my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
2418      $year, $mon, $mday, $hour, $min, $sec);
2419   if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
2420      $us = sprintf("%.6f", $us);
2421      $us =~ s/^0\././;
2422      $val .= $us;
2423   }
2424   return $val;
2425}
2426
2427sub parse_timestamp {
2428   my ( $val ) = @_;
2429   if ( my($y, $m, $d, $h, $i, $s, $f)
2430         = $val =~ m/^$mysql_ts$/ )
2431   {
2432      return sprintf "%d-%02d-%02d %02d:%02d:"
2433                     . (defined $f ? '%09.6f' : '%02d'),
2434                     $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
2435   }
2436   elsif ( $val =~ m/^$proper_ts$/ ) {
2437      return $val;
2438   }
2439   return $val;
2440}
2441
2442sub unix_timestamp {
2443   my ( $val, $gmt ) = @_;
2444   if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
2445      $val = $gmt
2446         ? timegm($s, $i, $h, $d, $m - 1, $y)
2447         : timelocal($s, $i, $h, $d, $m - 1, $y);
2448      if ( defined $us ) {
2449         $us = sprintf('%.6f', $us);
2450         $us =~ s/^0\././;
2451         $val .= $us;
2452      }
2453   }
2454   return $val;
2455}
2456
2457sub any_unix_timestamp {
2458   my ( $val, $callback ) = @_;
2459
2460   if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
2461      $n = $suffix eq 's' ? $n            # Seconds
2462         : $suffix eq 'm' ? $n * 60       # Minutes
2463         : $suffix eq 'h' ? $n * 3600     # Hours
2464         : $suffix eq 'd' ? $n * 86400    # Days
2465         :                  $n;           # default: Seconds
2466      PTDEBUG && _d('ts is now - N[shmd]:', $n);
2467      return time - $n;
2468   }
2469   elsif ( $val =~ m/^\d{9,}/ ) {
2470      PTDEBUG && _d('ts is already a unix timestamp');
2471      return $val;
2472   }
2473   elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
2474      PTDEBUG && _d('ts is MySQL slow log timestamp');
2475      $val .= ' 00:00:00' unless $hms;
2476      return unix_timestamp(parse_timestamp($val));
2477   }
2478   elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
2479      PTDEBUG && _d('ts is properly formatted timestamp');
2480      $val .= ' 00:00:00' unless $hms;
2481      return unix_timestamp($val);
2482   }
2483   else {
2484      PTDEBUG && _d('ts is MySQL expression');
2485      return $callback->($val) if $callback && ref $callback eq 'CODE';
2486   }
2487
2488   PTDEBUG && _d('Unknown ts type:', $val);
2489   return;
2490}
2491
2492sub make_checksum {
2493   my ( $val ) = @_;
2494   my $checksum = uc substr(md5_hex($val), -16);
2495   PTDEBUG && _d($checksum, 'checksum for', $val);
2496   return $checksum;
2497}
2498
2499sub crc32 {
2500   my ( $string ) = @_;
2501   return unless $string;
2502   my $poly = 0xEDB88320;
2503   my $crc  = 0xFFFFFFFF;
2504   foreach my $char ( split(//, $string) ) {
2505      my $comp = ($crc ^ ord($char)) & 0xFF;
2506      for ( 1 .. 8 ) {
2507         $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
2508      }
2509      $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
2510   }
2511   return $crc ^ 0xFFFFFFFF;
2512}
2513
2514my $got_json = eval { require JSON };
2515sub encode_json {
2516   return JSON::encode_json(@_) if $got_json;
2517   my ( $data ) = @_;
2518   return (object_to_json($data) || '');
2519}
2520
2521
2522sub object_to_json {
2523   my ($obj) = @_;
2524   my $type  = ref($obj);
2525
2526   if($type eq 'HASH'){
2527      return hash_to_json($obj);
2528   }
2529   elsif($type eq 'ARRAY'){
2530      return array_to_json($obj);
2531   }
2532   else {
2533      return value_to_json($obj);
2534   }
2535}
2536
2537sub hash_to_json {
2538   my ($obj) = @_;
2539   my @res;
2540   for my $k ( sort { $a cmp $b } keys %$obj ) {
2541      push @res, string_to_json( $k )
2542         .  ":"
2543         . ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
2544   }
2545   return '{' . ( @res ? join( ",", @res ) : '' )  . '}';
2546}
2547
2548sub array_to_json {
2549   my ($obj) = @_;
2550   my @res;
2551
2552   for my $v (@$obj) {
2553      push @res, object_to_json($v) || value_to_json($v);
2554   }
2555
2556   return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
2557}
2558
2559sub value_to_json {
2560   my ($value) = @_;
2561
2562   return 'null' if(!defined $value);
2563
2564   my $b_obj = B::svref_2object(\$value);  # for round trip problem
2565   my $flags = $b_obj->FLAGS;
2566   return $value # as is
2567      if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
2568
2569   my $type = ref($value);
2570
2571   if( !$type ) {
2572      return string_to_json($value);
2573   }
2574   else {
2575      return 'null';
2576   }
2577
2578}
2579
2580my %esc = (
2581   "\n" => '\n',
2582   "\r" => '\r',
2583   "\t" => '\t',
2584   "\f" => '\f',
2585   "\b" => '\b',
2586   "\"" => '\"',
2587   "\\" => '\\\\',
2588   "\'" => '\\\'',
2589);
2590
2591sub string_to_json {
2592   my ($arg) = @_;
2593
2594   $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
2595   $arg =~ s/\//\\\//g;
2596   $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
2597
2598   utf8::upgrade($arg);
2599   utf8::encode($arg);
2600
2601   return '"' . $arg . '"';
2602}
2603
2604sub _d {
2605   my ($package, undef, $line) = caller 0;
2606   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2607        map { defined $_ ? $_ : 'undef' }
2608        @_;
2609   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2610}
2611
26121;
2613}
2614# ###########################################################################
2615# End Transformers package
2616# ###########################################################################
2617
2618# ###########################################################################
2619# HTTP::Micro package
2620# This package is a copy without comments from the original.  The original
2621# with comments and its test file can be found in the Bazaar repository at,
2622#   lib/HTTP/Micro.pm
2623#   t/lib/HTTP/Micro.t
2624# See https://launchpad.net/percona-toolkit for more information.
2625# ###########################################################################
2626{
2627package HTTP::Micro;
2628
2629our $VERSION = '0.01';
2630
2631use strict;
2632use warnings FATAL => 'all';
2633use English qw(-no_match_vars);
2634use Carp ();
2635
2636my @attributes;
2637BEGIN {
2638    @attributes = qw(agent timeout);
2639    no strict 'refs';
2640    for my $accessor ( @attributes ) {
2641        *{$accessor} = sub {
2642            @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
2643        };
2644    }
2645}
2646
2647sub new {
2648    my($class, %args) = @_;
2649    (my $agent = $class) =~ s{::}{-}g;
2650    my $self = {
2651        agent        => $agent . "/" . ($class->VERSION || 0),
2652        timeout      => 60,
2653    };
2654    for my $key ( @attributes ) {
2655        $self->{$key} = $args{$key} if exists $args{$key}
2656    }
2657    return bless $self, $class;
2658}
2659
2660my %DefaultPort = (
2661    http => 80,
2662    https => 443,
2663);
2664
2665sub request {
2666    my ($self, $method, $url, $args) = @_;
2667    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
2668      or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
2669    $args ||= {}; # we keep some state in this during _request
2670
2671    my $response;
2672    for ( 0 .. 1 ) {
2673        $response = eval { $self->_request($method, $url, $args) };
2674        last unless $@ && $method eq 'GET'
2675            && $@ =~ m{^(?:Socket closed|Unexpected end)};
2676    }
2677
2678    if (my $e = "$@") {
2679        $response = {
2680            success => q{},
2681            status  => 599,
2682            reason  => 'Internal Exception',
2683            content => $e,
2684            headers => {
2685                'content-type'   => 'text/plain',
2686                'content-length' => length $e,
2687            }
2688        };
2689    }
2690    return $response;
2691}
2692
2693sub _request {
2694    my ($self, $method, $url, $args) = @_;
2695
2696    my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
2697
2698    my $request = {
2699        method    => $method,
2700        scheme    => $scheme,
2701        host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
2702        uri       => $path_query,
2703        headers   => {},
2704    };
2705
2706    my $handle  = HTTP::Micro::Handle->new(timeout => $self->{timeout});
2707
2708    $handle->connect($scheme, $host, $port);
2709
2710    $self->_prepare_headers_and_cb($request, $args);
2711    $handle->write_request_header(@{$request}{qw/method uri headers/});
2712    $handle->write_content_body($request) if $request->{content};
2713
2714    my $response;
2715    do { $response = $handle->read_response_header }
2716        until (substr($response->{status},0,1) ne '1');
2717
2718    if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
2719        $response->{content} = '';
2720        $handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
2721    }
2722
2723    $handle->close;
2724    $response->{success} = substr($response->{status},0,1) eq '2';
2725    return $response;
2726}
2727
2728sub _prepare_headers_and_cb {
2729    my ($self, $request, $args) = @_;
2730
2731    for ($args->{headers}) {
2732        next unless defined;
2733        while (my ($k, $v) = each %$_) {
2734            $request->{headers}{lc $k} = $v;
2735        }
2736    }
2737    $request->{headers}{'host'}         = $request->{host_port};
2738    $request->{headers}{'connection'}   = "close";
2739    $request->{headers}{'user-agent'} ||= $self->{agent};
2740
2741    if (defined $args->{content}) {
2742        $request->{headers}{'content-type'} ||= "application/octet-stream";
2743        utf8::downgrade($args->{content}, 1)
2744            or Carp::croak(q/Wide character in request message body/);
2745        $request->{headers}{'content-length'} = length $args->{content};
2746        $request->{content} = $args->{content};
2747    }
2748    return;
2749}
2750
2751sub _split_url {
2752    my $url = pop;
2753
2754    my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
2755      or Carp::croak(qq/Cannot parse URL: '$url'/);
2756
2757    $scheme     = lc $scheme;
2758    $path_query = "/$path_query" unless $path_query =~ m<\A/>;
2759
2760    my $host = (length($authority)) ? lc $authority : 'localhost';
2761       $host =~ s/\A[^@]*@//;   # userinfo
2762    my $port = do {
2763       $host =~ s/:([0-9]*)\z// && length $1
2764         ? $1
2765         : $DefaultPort{$scheme}
2766    };
2767
2768    return ($scheme, $host, $port, $path_query);
2769}
2770
2771} # HTTP::Micro
2772
2773{
2774   package HTTP::Micro::Handle;
2775
2776   use strict;
2777   use warnings FATAL => 'all';
2778   use English qw(-no_match_vars);
2779
2780   use Carp       qw(croak);
2781   use Errno      qw(EINTR EPIPE);
2782   use IO::Socket qw(SOCK_STREAM);
2783
2784   sub BUFSIZE () { 32768 }
2785
2786   my $Printable = sub {
2787       local $_ = shift;
2788       s/\r/\\r/g;
2789       s/\n/\\n/g;
2790       s/\t/\\t/g;
2791       s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
2792       $_;
2793   };
2794
2795   sub new {
2796       my ($class, %args) = @_;
2797       return bless {
2798           rbuf          => '',
2799           timeout       => 60,
2800           max_line_size => 16384,
2801           %args
2802       }, $class;
2803   }
2804
2805   my $ssl_verify_args = {
2806       check_cn         => "when_only",
2807       wildcards_in_alt => "anywhere",
2808       wildcards_in_cn  => "anywhere"
2809   };
2810
2811   sub connect {
2812       @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
2813       my ($self, $scheme, $host, $port) = @_;
2814
2815       if ( $scheme eq 'https' ) {
2816           eval "require IO::Socket::SSL"
2817               unless exists $INC{'IO/Socket/SSL.pm'};
2818           croak(qq/IO::Socket::SSL must be installed for https support\n/)
2819               unless $INC{'IO/Socket/SSL.pm'};
2820       }
2821       elsif ( $scheme ne 'http' ) {
2822         croak(qq/Unsupported URL scheme '$scheme'\n/);
2823       }
2824
2825       $self->{fh} = IO::Socket::INET->new(
2826           PeerHost  => $host,
2827           PeerPort  => $port,
2828           Proto     => 'tcp',
2829           Type      => SOCK_STREAM,
2830           Timeout   => $self->{timeout}
2831       ) or croak(qq/Could not connect to '$host:$port': $@/);
2832
2833       binmode($self->{fh})
2834         or croak(qq/Could not binmode() socket: '$!'/);
2835
2836       if ( $scheme eq 'https') {
2837           IO::Socket::SSL->start_SSL($self->{fh});
2838           ref($self->{fh}) eq 'IO::Socket::SSL'
2839               or die(qq/SSL connection failed for $host\n/);
2840           if ( $self->{fh}->can("verify_hostname") ) {
2841               $self->{fh}->verify_hostname( $host, $ssl_verify_args )
2842                  or die(qq/SSL certificate not valid for $host\n/);
2843           }
2844           else {
2845            my $fh = $self->{fh};
2846            _verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
2847                  or die(qq/SSL certificate not valid for $host\n/);
2848            }
2849       }
2850
2851       $self->{host} = $host;
2852       $self->{port} = $port;
2853
2854       return $self;
2855   }
2856
2857   sub close {
2858       @_ == 1 || croak(q/Usage: $handle->close()/);
2859       my ($self) = @_;
2860       CORE::close($self->{fh})
2861         or croak(qq/Could not close socket: '$!'/);
2862   }
2863
2864   sub write {
2865       @_ == 2 || croak(q/Usage: $handle->write(buf)/);
2866       my ($self, $buf) = @_;
2867
2868       my $len = length $buf;
2869       my $off = 0;
2870
2871       local $SIG{PIPE} = 'IGNORE';
2872
2873       while () {
2874           $self->can_write
2875             or croak(q/Timed out while waiting for socket to become ready for writing/);
2876           my $r = syswrite($self->{fh}, $buf, $len, $off);
2877           if (defined $r) {
2878               $len -= $r;
2879               $off += $r;
2880               last unless $len > 0;
2881           }
2882           elsif ($! == EPIPE) {
2883               croak(qq/Socket closed by remote server: $!/);
2884           }
2885           elsif ($! != EINTR) {
2886               croak(qq/Could not write to socket: '$!'/);
2887           }
2888       }
2889       return $off;
2890   }
2891
2892   sub read {
2893       @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
2894       my ($self, $len) = @_;
2895
2896       my $buf  = '';
2897       my $got = length $self->{rbuf};
2898
2899       if ($got) {
2900           my $take = ($got < $len) ? $got : $len;
2901           $buf  = substr($self->{rbuf}, 0, $take, '');
2902           $len -= $take;
2903       }
2904
2905       while ($len > 0) {
2906           $self->can_read
2907             or croak(q/Timed out while waiting for socket to become ready for reading/);
2908           my $r = sysread($self->{fh}, $buf, $len, length $buf);
2909           if (defined $r) {
2910               last unless $r;
2911               $len -= $r;
2912           }
2913           elsif ($! != EINTR) {
2914               croak(qq/Could not read from socket: '$!'/);
2915           }
2916       }
2917       if ($len) {
2918           croak(q/Unexpected end of stream/);
2919       }
2920       return $buf;
2921   }
2922
2923   sub readline {
2924       @_ == 1 || croak(q/Usage: $handle->readline()/);
2925       my ($self) = @_;
2926
2927       while () {
2928           if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
2929               return $1;
2930           }
2931           $self->can_read
2932             or croak(q/Timed out while waiting for socket to become ready for reading/);
2933           my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
2934           if (defined $r) {
2935               last unless $r;
2936           }
2937           elsif ($! != EINTR) {
2938               croak(qq/Could not read from socket: '$!'/);
2939           }
2940       }
2941       croak(q/Unexpected end of stream while looking for line/);
2942   }
2943
2944   sub read_header_lines {
2945       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
2946       my ($self, $headers) = @_;
2947       $headers ||= {};
2948       my $lines   = 0;
2949       my $val;
2950
2951       while () {
2952            my $line = $self->readline;
2953
2954            if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
2955                my ($field_name) = lc $1;
2956                $val = \($headers->{$field_name} = $2);
2957            }
2958            elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
2959                $val
2960                  or croak(q/Unexpected header continuation line/);
2961                next unless length $1;
2962                $$val .= ' ' if length $$val;
2963                $$val .= $1;
2964            }
2965            elsif ($line =~ /\A \x0D?\x0A \z/x) {
2966               last;
2967            }
2968            else {
2969               croak(q/Malformed header line: / . $Printable->($line));
2970            }
2971       }
2972       return $headers;
2973   }
2974
2975   sub write_header_lines {
2976       (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
2977       my($self, $headers) = @_;
2978
2979       my $buf = '';
2980       while (my ($k, $v) = each %$headers) {
2981           my $field_name = lc $k;
2982            $field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
2983               or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
2984            $field_name =~ s/\b(\w)/\u$1/g;
2985            $buf .= "$field_name: $v\x0D\x0A";
2986       }
2987       $buf .= "\x0D\x0A";
2988       return $self->write($buf);
2989   }
2990
2991   sub read_content_body {
2992       @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
2993       my ($self, $cb, $response, $len) = @_;
2994       $len ||= $response->{headers}{'content-length'};
2995
2996       croak("No content-length in the returned response, and this "
2997           . "UA doesn't implement chunking") unless defined $len;
2998
2999       while ($len > 0) {
3000           my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
3001           $cb->($self->read($read), $response);
3002           $len -= $read;
3003       }
3004
3005       return;
3006   }
3007
3008   sub write_content_body {
3009       @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
3010       my ($self, $request) = @_;
3011       my ($len, $content_length) = (0, $request->{headers}{'content-length'});
3012
3013       $len += $self->write($request->{content});
3014
3015       $len == $content_length
3016         or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
3017
3018       return $len;
3019   }
3020
3021   sub read_response_header {
3022       @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
3023       my ($self) = @_;
3024
3025       my $line = $self->readline;
3026
3027       $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
3028         or croak(q/Malformed Status-Line: / . $Printable->($line));
3029
3030       my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
3031
3032       return {
3033           status   => $status,
3034           reason   => $reason,
3035           headers  => $self->read_header_lines,
3036           protocol => $protocol,
3037       };
3038   }
3039
3040   sub write_request_header {
3041       @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
3042       my ($self, $method, $request_uri, $headers) = @_;
3043
3044       return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
3045            + $self->write_header_lines($headers);
3046   }
3047
3048   sub _do_timeout {
3049       my ($self, $type, $timeout) = @_;
3050       $timeout = $self->{timeout}
3051           unless defined $timeout && $timeout >= 0;
3052
3053       my $fd = fileno $self->{fh};
3054       defined $fd && $fd >= 0
3055         or croak(q/select(2): 'Bad file descriptor'/);
3056
3057       my $initial = time;
3058       my $pending = $timeout;
3059       my $nfound;
3060
3061       vec(my $fdset = '', $fd, 1) = 1;
3062
3063       while () {
3064           $nfound = ($type eq 'read')
3065               ? select($fdset, undef, undef, $pending)
3066               : select(undef, $fdset, undef, $pending) ;
3067           if ($nfound == -1) {
3068               $! == EINTR
3069                 or croak(qq/select(2): '$!'/);
3070               redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
3071               $nfound = 0;
3072           }
3073           last;
3074       }
3075       $! = 0;
3076       return $nfound;
3077   }
3078
3079   sub can_read {
3080       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
3081       my $self = shift;
3082       return $self->_do_timeout('read', @_)
3083   }
3084
3085   sub can_write {
3086       @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
3087       my $self = shift;
3088       return $self->_do_timeout('write', @_)
3089   }
3090}  # HTTP::Micro::Handle
3091
3092my $prog = <<'EOP';
3093BEGIN {
3094   if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
3095      *CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
3096   }
3097   else {
3098      constant->import( CAN_IPV6 => '' );
3099   }
3100   my %const = (
3101      NID_CommonName => 13,
3102      GEN_DNS => 2,
3103      GEN_IPADD => 7,
3104   );
3105   while ( my ($name,$value) = each %const ) {
3106      no strict 'refs';
3107      *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
3108   }
3109}
3110{
3111   use Carp qw(croak);
3112   my %dispatcher = (
3113      issuer =>  sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
3114      subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
3115   );
3116   if ( $Net::SSLeay::VERSION >= 1.30 ) {
3117      $dispatcher{commonName} = sub {
3118         my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
3119            Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
3120         $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
3121         $cn;
3122      }
3123   } else {
3124      $dispatcher{commonName} = sub {
3125         croak "you need at least Net::SSLeay version 1.30 for getting commonName"
3126      }
3127   }
3128
3129   if ( $Net::SSLeay::VERSION >= 1.33 ) {
3130      $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
3131   } else {
3132      $dispatcher{subjectAltNames} = sub {
3133         return;
3134      };
3135   }
3136
3137   $dispatcher{authority} = $dispatcher{issuer};
3138   $dispatcher{owner}     = $dispatcher{subject};
3139   $dispatcher{cn}        = $dispatcher{commonName};
3140
3141   sub _peer_certificate {
3142      my ($self, $field) = @_;
3143      my $ssl = $self->_get_ssl_object or return;
3144
3145      my $cert = ${*$self}{_SSL_certificate}
3146         ||= Net::SSLeay::get_peer_certificate($ssl)
3147         or return $self->error("Could not retrieve peer certificate");
3148
3149      if ($field) {
3150         my $sub = $dispatcher{$field} or croak
3151            "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
3152            "\nMaybe you need to upgrade your Net::SSLeay";
3153         return $sub->($cert);
3154      } else {
3155         return $cert
3156      }
3157   }
3158
3159
3160   my %scheme = (
3161      ldap => {
3162         wildcards_in_cn    => 0,
3163         wildcards_in_alt => 'leftmost',
3164         check_cn         => 'always',
3165      },
3166      http => {
3167         wildcards_in_cn    => 'anywhere',
3168         wildcards_in_alt => 'anywhere',
3169         check_cn         => 'when_only',
3170      },
3171      smtp => {
3172         wildcards_in_cn    => 0,
3173         wildcards_in_alt => 0,
3174         check_cn         => 'always'
3175      },
3176      none => {}, # do not check
3177   );
3178
3179   $scheme{www}  = $scheme{http}; # alias
3180   $scheme{xmpp} = $scheme{http}; # rfc 3920
3181   $scheme{pop3} = $scheme{ldap}; # rfc 2595
3182   $scheme{imap} = $scheme{ldap}; # rfc 2595
3183   $scheme{acap} = $scheme{ldap}; # rfc 2595
3184   $scheme{nntp} = $scheme{ldap}; # rfc 4642
3185   $scheme{ftp}  = $scheme{http}; # rfc 4217
3186
3187
3188   sub _verify_hostname_of_cert {
3189      my $identity = shift;
3190      my $cert = shift;
3191      my $scheme = shift || 'none';
3192      if ( ! ref($scheme) ) {
3193         $scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
3194      }
3195
3196      return 1 if ! %$scheme; # 'none'
3197
3198      my $commonName = $dispatcher{cn}->($cert);
3199      my @altNames   = $dispatcher{subjectAltNames}->($cert);
3200
3201      if ( my $sub = $scheme->{callback} ) {
3202         return $sub->($identity,$commonName,@altNames);
3203      }
3204
3205
3206      my $ipn;
3207      if ( CAN_IPV6 and $identity =~m{:} ) {
3208         $ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
3209            or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
3210      } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
3211         $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
3212      } else {
3213         if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
3214            $identity =~m{\0} and croak("name '$identity' has \\0 byte");
3215            $identity = IO::Socket::SSL::idn_to_ascii($identity) or
3216               croak "Warning: Given name '$identity' could not be converted to IDNA!";
3217         }
3218      }
3219
3220      my $check_name = sub {
3221         my ($name,$identity,$wtyp) = @_;
3222         $wtyp ||= '';
3223         my $pattern;
3224         if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
3225            $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
3226         } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
3227            $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
3228         } else {
3229            $pattern = qr{^\Q$name\E$}i;
3230         }
3231         return $identity =~ $pattern;
3232      };
3233
3234      my $alt_dnsNames = 0;
3235      while (@altNames) {
3236         my ($type, $name) = splice (@altNames, 0, 2);
3237         if ( $ipn and $type == GEN_IPADD ) {
3238            return 1 if $ipn eq $name;
3239
3240         } elsif ( ! $ipn and $type == GEN_DNS ) {
3241            $name =~s/\s+$//; $name =~s/^\s+//;
3242            $alt_dnsNames++;
3243            $check_name->($name,$identity,$scheme->{wildcards_in_alt})
3244               and return 1;
3245         }
3246      }
3247
3248      if ( ! $ipn and (
3249         $scheme->{check_cn} eq 'always' or
3250         $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
3251         $check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
3252            and return 1;
3253      }
3254
3255      return 0; # no match
3256   }
3257}
3258EOP
3259
3260eval { require IO::Socket::SSL };
3261if ( $INC{"IO/Socket/SSL.pm"} ) {
3262   eval $prog;
3263   die $@ if $@;
3264}
3265
32661;
3267# ###########################################################################
3268# End HTTP::Micro package
3269# ###########################################################################
3270
3271# ###########################################################################
3272# VersionCheck package
3273# This package is a copy without comments from the original.  The original
3274# with comments and its test file can be found in the Bazaar repository at,
3275#   lib/VersionCheck.pm
3276#   t/lib/VersionCheck.t
3277# See https://launchpad.net/percona-toolkit for more information.
3278# ###########################################################################
3279{
3280package VersionCheck;
3281
3282
3283use strict;
3284use warnings FATAL => 'all';
3285use English qw(-no_match_vars);
3286
3287use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3288
3289use Data::Dumper;
3290local $Data::Dumper::Indent    = 1;
3291local $Data::Dumper::Sortkeys  = 1;
3292local $Data::Dumper::Quotekeys = 0;
3293
3294use Digest::MD5 qw(md5_hex);
3295use Sys::Hostname qw(hostname);
3296use File::Basename qw();
3297use File::Spec;
3298use FindBin qw();
3299
3300eval {
3301   require Percona::Toolkit;
3302   require HTTP::Micro;
3303};
3304
3305my $home    = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
3306my @vc_dirs = (
3307   '/etc/percona',
3308   '/etc/percona-toolkit',
3309   '/tmp',
3310   "$home",
3311);
3312
3313{
3314   my $file    = 'percona-version-check';
3315
3316   sub version_check_file {
3317      foreach my $dir ( @vc_dirs ) {
3318         if ( -d $dir && -w $dir ) {
3319            PTDEBUG && _d('Version check file', $file, 'in', $dir);
3320            return $dir . '/' . $file;
3321         }
3322      }
3323      PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
3324      return $file;  # in the CWD
3325   }
3326}
3327
3328sub version_check_time_limit {
3329   return 60 * 60 * 24;  # one day
3330}
3331
3332
3333sub version_check {
3334   my (%args) = @_;
3335
3336   my $instances = $args{instances} || [];
3337   my $instances_to_check;
3338
3339   PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
3340   if ( !$args{force} ) {
3341      if ( $FindBin::Bin
3342           && (-d "$FindBin::Bin/../.bzr"    ||
3343               -d "$FindBin::Bin/../../.bzr" ||
3344               -d "$FindBin::Bin/../.git"    ||
3345               -d "$FindBin::Bin/../../.git"
3346              )
3347         ) {
3348         PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
3349         return;
3350      }
3351   }
3352
3353   eval {
3354      foreach my $instance ( @$instances ) {
3355         my ($name, $id) = get_instance_id($instance);
3356         $instance->{name} = $name;
3357         $instance->{id}   = $id;
3358      }
3359
3360      push @$instances, { name => 'system', id => 0 };
3361
3362      $instances_to_check = get_instances_to_check(
3363         instances => $instances,
3364         vc_file   => $args{vc_file},  # testing
3365         now       => $args{now},      # testing
3366      );
3367      PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
3368      return unless @$instances_to_check;
3369
3370      my $protocol = 'https';
3371      eval { require IO::Socket::SSL; };
3372      if ( $EVAL_ERROR ) {
3373         PTDEBUG && _d($EVAL_ERROR);
3374         PTDEBUG && _d("SSL not available, won't run version_check");
3375         return;
3376      }
3377      PTDEBUG && _d('Using', $protocol);
3378
3379      my $advice = pingback(
3380         instances => $instances_to_check,
3381         protocol  => $protocol,
3382         url       => $args{url}                       # testing
3383                   || $ENV{PERCONA_VERSION_CHECK_URL}  # testing
3384                   || "$protocol://v.percona.com",
3385      );
3386      if ( $advice ) {
3387         PTDEBUG && _d('Advice:', Dumper($advice));
3388         if ( scalar @$advice > 1) {
3389            print "\n# " . scalar @$advice . " software updates are "
3390               . "available:\n";
3391         }
3392         else {
3393            print "\n# A software update is available:\n";
3394         }
3395         print join("\n", map { "#   * $_" } @$advice), "\n\n";
3396      }
3397   };
3398   if ( $EVAL_ERROR ) {
3399      PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
3400   }
3401
3402   if ( @$instances_to_check ) {
3403      eval {
3404         update_check_times(
3405            instances => $instances_to_check,
3406            vc_file   => $args{vc_file},  # testing
3407            now       => $args{now},      # testing
3408         );
3409      };
3410      if ( $EVAL_ERROR ) {
3411         PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
3412      }
3413   }
3414
3415   if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
3416      warn "Exiting because the PTDEBUG_VERSION_CHECK "
3417         . "environment variable is defined.\n";
3418      exit 255;
3419   }
3420
3421   return;
3422}
3423
3424sub get_instances_to_check {
3425   my (%args) = @_;
3426
3427   my $instances = $args{instances};
3428   my $now       = $args{now}     || int(time);
3429   my $vc_file   = $args{vc_file} || version_check_file();
3430
3431   if ( !-f $vc_file ) {
3432      PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
3433         'version checking all instances');
3434      return $instances;
3435   }
3436
3437   open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
3438   chomp(my $file_contents = do { local $/ = undef; <$fh> });
3439   PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
3440   close $fh;
3441   my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
3442
3443   my $check_time_limit = version_check_time_limit();
3444   my @instances_to_check;
3445   foreach my $instance ( @$instances ) {
3446      my $last_check_time = $last_check_time_for{ $instance->{id} };
3447      PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
3448         $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
3449         'hours until next check',
3450         sprintf '%.2f',
3451            ($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
3452      if ( !defined $last_check_time
3453           || ($now - $last_check_time) >= $check_time_limit ) {
3454         PTDEBUG && _d('Time to check', Dumper($instance));
3455         push @instances_to_check, $instance;
3456      }
3457   }
3458
3459   return \@instances_to_check;
3460}
3461
3462sub update_check_times {
3463   my (%args) = @_;
3464
3465   my $instances = $args{instances};
3466   my $now       = $args{now}     || int(time);
3467   my $vc_file   = $args{vc_file} || version_check_file();
3468   PTDEBUG && _d('Updating last check time:', $now);
3469
3470   my %all_instances = map {
3471      $_->{id} => { name => $_->{name}, ts => $now }
3472   } @$instances;
3473
3474   if ( -f $vc_file ) {
3475      open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
3476      my $contents = do { local $/ = undef; <$fh> };
3477      close $fh;
3478
3479      foreach my $line ( split("\n", ($contents || '')) ) {
3480         my ($id, $ts) = split(',', $line);
3481         if ( !exists $all_instances{$id} ) {
3482            $all_instances{$id} = { ts => $ts };  # original ts, not updated
3483         }
3484      }
3485   }
3486
3487   open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
3488   foreach my $id ( sort keys %all_instances ) {
3489      PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
3490      print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
3491   }
3492   close $fh;
3493
3494   return;
3495}
3496
3497sub get_instance_id {
3498   my ($instance) = @_;
3499
3500   my $dbh = $instance->{dbh};
3501   my $dsn = $instance->{dsn};
3502
3503   my $sql = q{SELECT CONCAT(@@hostname, @@port)};
3504   PTDEBUG && _d($sql);
3505   my ($name) = eval { $dbh->selectrow_array($sql) };
3506   if ( $EVAL_ERROR ) {
3507      PTDEBUG && _d($EVAL_ERROR);
3508      $sql = q{SELECT @@hostname};
3509      PTDEBUG && _d($sql);
3510      ($name) = eval { $dbh->selectrow_array($sql) };
3511      if ( $EVAL_ERROR ) {
3512         PTDEBUG && _d($EVAL_ERROR);
3513         $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
3514      }
3515      else {
3516         $sql = q{SHOW VARIABLES LIKE 'port'};
3517         PTDEBUG && _d($sql);
3518         my (undef, $port) = eval { $dbh->selectrow_array($sql) };
3519         PTDEBUG && _d('port:', $port);
3520         $name .= $port || '';
3521      }
3522   }
3523   my $id = md5_hex($name);
3524
3525   PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
3526
3527   return $name, $id;
3528}
3529
3530
3531sub get_uuid {
3532    my $uuid_file = '/.percona-toolkit.uuid';
3533    foreach my $dir (@vc_dirs) {
3534        my $filename = $dir.$uuid_file;
3535        my $uuid=_read_uuid($filename);
3536        return $uuid if $uuid;
3537    }
3538
3539    my $filename = $ENV{"HOME"} . $uuid_file;
3540    my $uuid = _generate_uuid();
3541
3542    open(my $fh, '>', $filename) or die "Could not open file '$filename' $!";
3543    print $fh $uuid;
3544    close $fh;
3545
3546    return $uuid;
3547}
3548
3549sub _generate_uuid {
3550    return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7;
3551}
3552
3553sub _read_uuid {
3554    my $filename = shift;
3555    my $fh;
3556
3557    eval {
3558        open($fh, '<:encoding(UTF-8)', $filename);
3559    };
3560    return if ($EVAL_ERROR);
3561
3562    my $uuid;
3563    eval { $uuid = <$fh>; };
3564    return if ($EVAL_ERROR);
3565
3566    chomp $uuid;
3567    return $uuid;
3568}
3569
3570
3571sub pingback {
3572   my (%args) = @_;
3573   my @required_args = qw(url instances);
3574   foreach my $arg ( @required_args ) {
3575      die "I need a $arg arugment" unless $args{$arg};
3576   }
3577   my $url       = $args{url};
3578   my $instances = $args{instances};
3579
3580   my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
3581
3582   my $response = $ua->request('GET', $url);
3583   PTDEBUG && _d('Server response:', Dumper($response));
3584   die "No response from GET $url"
3585      if !$response;
3586   die("GET on $url returned HTTP status $response->{status}; expected 200\n",
3587       ($response->{content} || '')) if $response->{status} != 200;
3588   die("GET on $url did not return any programs to check")
3589      if !$response->{content};
3590
3591   my $items = parse_server_response(
3592      response => $response->{content}
3593   );
3594   die "Failed to parse server requested programs: $response->{content}"
3595      if !scalar keys %$items;
3596
3597   my $versions = get_versions(
3598      items     => $items,
3599      instances => $instances,
3600   );
3601   die "Failed to get any program versions; should have at least gotten Perl"
3602      if !scalar keys %$versions;
3603
3604   my $client_content = encode_client_response(
3605      items      => $items,
3606      versions   => $versions,
3607      general_id => get_uuid(),
3608   );
3609
3610   my $client_response = {
3611      headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
3612      content => $client_content,
3613   };
3614   PTDEBUG && _d('Client response:', Dumper($client_response));
3615
3616   $response = $ua->request('POST', $url, $client_response);
3617   PTDEBUG && _d('Server suggestions:', Dumper($response));
3618   die "No response from POST $url $client_response"
3619      if !$response;
3620   die "POST $url returned HTTP status $response->{status}; expected 200"
3621      if $response->{status} != 200;
3622
3623   return unless $response->{content};
3624
3625   $items = parse_server_response(
3626      response   => $response->{content},
3627      split_vars => 0,
3628   );
3629   die "Failed to parse server suggestions: $response->{content}"
3630      if !scalar keys %$items;
3631   my @suggestions = map { $_->{vars} }
3632                     sort { $a->{item} cmp $b->{item} }
3633                     values %$items;
3634
3635   return \@suggestions;
3636}
3637
3638sub encode_client_response {
3639   my (%args) = @_;
3640   my @required_args = qw(items versions general_id);
3641   foreach my $arg ( @required_args ) {
3642      die "I need a $arg arugment" unless $args{$arg};
3643   }
3644   my ($items, $versions, $general_id) = @args{@required_args};
3645
3646   my @lines;
3647   foreach my $item ( sort keys %$items ) {
3648      next unless exists $versions->{$item};
3649      if ( ref($versions->{$item}) eq 'HASH' ) {
3650         my $mysql_versions = $versions->{$item};
3651         for my $id ( sort keys %$mysql_versions ) {
3652            push @lines, join(';', $id, $item, $mysql_versions->{$id});
3653         }
3654      }
3655      else {
3656         push @lines, join(';', $general_id, $item, $versions->{$item});
3657      }
3658   }
3659
3660   my $client_response = join("\n", @lines) . "\n";
3661   return $client_response;
3662}
3663
3664sub parse_server_response {
3665   my (%args) = @_;
3666   my @required_args = qw(response);
3667   foreach my $arg ( @required_args ) {
3668      die "I need a $arg arugment" unless $args{$arg};
3669   }
3670   my ($response) = @args{@required_args};
3671
3672   my %items = map {
3673      my ($item, $type, $vars) = split(";", $_);
3674      if ( !defined $args{split_vars} || $args{split_vars} ) {
3675         $vars = [ split(",", ($vars || '')) ];
3676      }
3677      $item => {
3678         item => $item,
3679         type => $type,
3680         vars => $vars,
3681      };
3682   } split("\n", $response);
3683
3684   PTDEBUG && _d('Items:', Dumper(\%items));
3685
3686   return \%items;
3687}
3688
3689my %sub_for_type = (
3690   os_version          => \&get_os_version,
3691   perl_version        => \&get_perl_version,
3692   perl_module_version => \&get_perl_module_version,
3693   mysql_variable      => \&get_mysql_variable,
3694);
3695
3696sub valid_item {
3697   my ($item) = @_;
3698   return unless $item;
3699   if ( !exists $sub_for_type{ $item->{type} } ) {
3700      PTDEBUG && _d('Invalid type:', $item->{type});
3701      return 0;
3702   }
3703   return 1;
3704}
3705
3706sub get_versions {
3707   my (%args) = @_;
3708   my @required_args = qw(items);
3709   foreach my $arg ( @required_args ) {
3710      die "I need a $arg arugment" unless $args{$arg};
3711   }
3712   my ($items) = @args{@required_args};
3713
3714   my %versions;
3715   foreach my $item ( values %$items ) {
3716      next unless valid_item($item);
3717      eval {
3718         my $version = $sub_for_type{ $item->{type} }->(
3719            item      => $item,
3720            instances => $args{instances},
3721         );
3722         if ( $version ) {
3723            chomp $version unless ref($version);
3724            $versions{$item->{item}} = $version;
3725         }
3726      };
3727      if ( $EVAL_ERROR ) {
3728         PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
3729      }
3730   }
3731
3732   return \%versions;
3733}
3734
3735
3736sub get_os_version {
3737   if ( $OSNAME eq 'MSWin32' ) {
3738      require Win32;
3739      return Win32::GetOSDisplayName();
3740   }
3741
3742  chomp(my $platform = `uname -s`);
3743  PTDEBUG && _d('platform:', $platform);
3744  return $OSNAME unless $platform;
3745
3746   chomp(my $lsb_release
3747            = `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
3748   PTDEBUG && _d('lsb_release:', $lsb_release);
3749
3750   my $release = "";
3751
3752   if ( $platform eq 'Linux' ) {
3753      if ( -f "/etc/fedora-release" ) {
3754         $release = `cat /etc/fedora-release`;
3755      }
3756      elsif ( -f "/etc/redhat-release" ) {
3757         $release = `cat /etc/redhat-release`;
3758      }
3759      elsif ( -f "/etc/system-release" ) {
3760         $release = `cat /etc/system-release`;
3761      }
3762      elsif ( $lsb_release ) {
3763         $release = `$lsb_release -ds`;
3764      }
3765      elsif ( -f "/etc/lsb-release" ) {
3766         $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
3767         $release =~ s/^\w+="([^"]+)".+/$1/;
3768      }
3769      elsif ( -f "/etc/debian_version" ) {
3770         chomp(my $rel = `cat /etc/debian_version`);
3771         $release = "Debian $rel";
3772         if ( -f "/etc/apt/sources.list" ) {
3773             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}'`);
3774             $release .= " ($code_name)" if $code_name;
3775         }
3776      }
3777      elsif ( -f "/etc/os-release" ) { # openSUSE
3778         chomp($release = `grep PRETTY_NAME /etc/os-release`);
3779         $release =~ s/^PRETTY_NAME="(.+)"$/$1/;
3780      }
3781      elsif ( `ls /etc/*release 2>/dev/null` ) {
3782         if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
3783            $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
3784         }
3785         else {
3786            $release = `cat /etc/*release | head -n1`;
3787         }
3788      }
3789   }
3790   elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
3791      my $rel = `uname -r`;
3792      $release = "$platform $rel";
3793   }
3794   elsif ( $platform eq "SunOS" ) {
3795      my $rel = `head -n1 /etc/release` || `uname -r`;
3796      $release = "$platform $rel";
3797   }
3798
3799   if ( !$release ) {
3800      PTDEBUG && _d('Failed to get the release, using platform');
3801      $release = $platform;
3802   }
3803   chomp($release);
3804
3805   $release =~ s/^"|"$//g;
3806
3807   PTDEBUG && _d('OS version =', $release);
3808   return $release;
3809}
3810
3811sub get_perl_version {
3812   my (%args) = @_;
3813   my $item = $args{item};
3814   return unless $item;
3815
3816   my $version = sprintf '%vd', $PERL_VERSION;
3817   PTDEBUG && _d('Perl version', $version);
3818   return $version;
3819}
3820
3821sub get_perl_module_version {
3822   my (%args) = @_;
3823   my $item = $args{item};
3824   return unless $item;
3825
3826   my $var     = '$' . $item->{item} . '::VERSION';
3827   my $version = eval "use $item->{item}; $var;";
3828   PTDEBUG && _d('Perl version for', $var, '=', $version);
3829   return $version;
3830}
3831
3832sub get_mysql_variable {
3833   return get_from_mysql(
3834      show => 'VARIABLES',
3835      @_,
3836   );
3837}
3838
3839sub get_from_mysql {
3840   my (%args) = @_;
3841   my $show      = $args{show};
3842   my $item      = $args{item};
3843   my $instances = $args{instances};
3844   return unless $show && $item;
3845
3846   if ( !$instances || !@$instances ) {
3847      PTDEBUG && _d('Cannot check', $item,
3848         'because there are no MySQL instances');
3849      return;
3850   }
3851
3852   if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
3853      @{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
3854   }
3855
3856
3857   my @versions;
3858   my %version_for;
3859   foreach my $instance ( @$instances ) {
3860      next unless $instance->{id};  # special system instance has id=0
3861      my $dbh = $instance->{dbh};
3862      local $dbh->{FetchHashKeyName} = 'NAME_lc';
3863      my $sql = qq/SHOW $show/;
3864      PTDEBUG && _d($sql);
3865      my $rows = $dbh->selectall_hashref($sql, 'variable_name');
3866
3867      my @versions;
3868      foreach my $var ( @{$item->{vars}} ) {
3869         $var = lc($var);
3870         my $version = $rows->{$var}->{value};
3871         PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
3872            'on', $instance->{name});
3873         push @versions, $version;
3874      }
3875      $version_for{ $instance->{id} } = join(' ', @versions);
3876   }
3877
3878   return \%version_for;
3879}
3880
3881sub _d {
3882   my ($package, undef, $line) = caller 0;
3883   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3884        map { defined $_ ? $_ : 'undef' }
3885        @_;
3886   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3887}
3888
38891;
3890}
3891# ###########################################################################
3892# End VersionCheck package
3893# ###########################################################################
3894
3895# ###########################################################################
3896# Runtime package
3897# This package is a copy without comments from the original.  The original
3898# with comments and its test file can be found in the Bazaar repository at,
3899#   lib/Runtime.pm
3900#   t/lib/Runtime.t
3901# See https://launchpad.net/percona-toolkit for more information.
3902# ###########################################################################
3903{
3904package Runtime;
3905
3906use strict;
3907use warnings FATAL => 'all';
3908use English qw(-no_match_vars);
3909use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3910
3911sub new {
3912   my ( $class, %args ) = @_;
3913   my @required_args = qw(now);
3914   foreach my $arg ( @required_args ) {
3915      die "I need a $arg argument" unless exists $args{$arg};
3916   }
3917
3918   my $run_time = $args{run_time};
3919   if ( defined $run_time ) {
3920      die "run_time must be > 0" if $run_time <= 0;
3921   }
3922
3923   my $now = $args{now};
3924   die "now must be a callback" unless ref $now eq 'CODE';
3925
3926   my $self = {
3927      run_time   => $run_time,
3928      now        => $now,
3929      start_time => undef,
3930      end_time   => undef,
3931      time_left  => undef,
3932      stop       => 0,
3933   };
3934
3935   return bless $self, $class;
3936}
3937
3938sub time_left {
3939   my ( $self, %args ) = @_;
3940
3941   if ( $self->{stop} ) {
3942      PTDEBUG && _d("No time left because stop was called");
3943      return 0;
3944   }
3945
3946   my $now = $self->{now}->(%args);
3947   PTDEBUG && _d("Current time:", $now);
3948
3949   if ( !defined $self->{start_time} ) {
3950      $self->{start_time} = $now;
3951   }
3952
3953   return unless defined $now;
3954
3955   my $run_time = $self->{run_time};
3956   return unless defined $run_time;
3957
3958   if ( !$self->{end_time} ) {
3959      $self->{end_time} = $now + $run_time;
3960      PTDEBUG && _d("End time:", $self->{end_time});
3961   }
3962
3963   $self->{time_left} = $self->{end_time} - $now;
3964   PTDEBUG && _d("Time left:", $self->{time_left});
3965   return $self->{time_left};
3966}
3967
3968sub have_time {
3969   my ( $self, %args ) = @_;
3970   my $time_left = $self->time_left(%args);
3971   return 1 if !defined $time_left;  # run forever
3972   return $time_left <= 0 ? 0 : 1;   # <=0s means run time has elapsed
3973}
3974
3975sub time_elapsed {
3976   my ( $self, %args ) = @_;
3977
3978   my $start_time = $self->{start_time};
3979   return 0 unless $start_time;
3980
3981   my $now = $self->{now}->(%args);
3982   PTDEBUG && _d("Current time:", $now);
3983
3984   my $time_elapsed = $now - $start_time;
3985   PTDEBUG && _d("Time elapsed:", $time_elapsed);
3986   if ( $time_elapsed < 0 ) {
3987      warn "Current time $now is earlier than start time $start_time";
3988   }
3989   return $time_elapsed;
3990}
3991
3992sub reset {
3993   my ( $self ) = @_;
3994   $self->{start_time} = undef;
3995   $self->{end_time}   = undef;
3996   $self->{time_left}  = undef;
3997   $self->{stop}       = 0;
3998   PTDEBUG && _d("Reset run time");
3999   return;
4000}
4001
4002sub stop {
4003   my ( $self ) = @_;
4004   $self->{stop} = 1;
4005   return;
4006}
4007
4008sub start {
4009   my ( $self ) = @_;
4010   $self->{stop} = 0;
4011   return;
4012}
4013
4014sub _d {
4015   my ($package, undef, $line) = caller 0;
4016   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4017        map { defined $_ ? $_ : 'undef' }
4018        @_;
4019   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4020}
4021
40221;
4023}
4024# ###########################################################################
4025# End Runtime package
4026# ###########################################################################
4027
4028# ###########################################################################
4029# This is a combination of modules and programs in one -- a runnable module.
4030# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
4031# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
4032#
4033# Check at the end of this package for the call to main() which actually runs
4034# the program.
4035# ###########################################################################
4036package pt_fk_error_logger;
4037
4038use strict;
4039use warnings FATAL => 'all';
4040use English qw(-no_match_vars);
4041
4042use sigtrap 'handler', \&sig_int, 'normal-signals';
4043
4044use Percona::Toolkit;
4045use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4046
4047Transformers->import(qw(parse_timestamp));
4048
4049my $oktorun     = 1;
4050my $exit_status = 0;
4051
4052sub main {
4053   local @ARGV  = @_;  # set global ARGV for this package
4054   $oktorun     = 1;
4055   $exit_status = 0;
4056
4057   # ########################################################################
4058   # Get configuration information.
4059   # ########################################################################
4060   my $o = new OptionParser();
4061   $o->get_specs();
4062   $o->get_opts();
4063
4064   my $dp = $o->DSNParser();
4065   $dp->prop('set-vars', $o->set_vars());
4066
4067   my $src;
4068   if ( my $src_dsn_string = shift @ARGV ) {
4069      $src = Cxn->new(
4070         dsn_string   => $src_dsn_string,
4071         parent       => $o->get('daemonize'),
4072         DSNParser    => $dp,
4073         OptionParser => $o,
4074      );
4075   }
4076
4077   my $dst;
4078   if ( my $dst_dsn = $o->get('dest') ) {
4079      $dst = Cxn->new(
4080         dsn          => $dst_dsn,
4081         prev_dsn     => ($src ? $src->dsn : undef),
4082         parent       => $o->get('daemonize'),
4083         DSNParser    => $dp,
4084         OptionParser => $o,
4085      );
4086   }
4087
4088   if ( !$o->get('help') ) {
4089      if ( !$src ) {
4090         $o->save_error('No DSN was specified.');
4091      }
4092      if ( $dst && !$dst->dsn->{D} ) {
4093         $o->save_error("--dest requires a 'D' (database) part.");
4094      }
4095      if ( $dst && !$dst->dsn->{t} ) {
4096         $o->save_error("--dest requires a 't' (table) part.");
4097      }
4098   }
4099
4100   $o->usage_or_errors();
4101
4102   # ########################################################################
4103   # Connect to MySQL.
4104   # ########################################################################
4105   my $q = Quoter->new();
4106
4107   $src->connect();
4108
4109   my $ins_sth;
4110   if ( $dst ) {
4111      $dst->connect();
4112      my $db_tbl =  $q->join_quote($dst->dsn->{D}, $dst->dsn->{t});
4113      my $sql    = "INSERT IGNORE INTO $db_tbl VALUES (?, ?)";
4114      PTDEBUG && _d('--dest INSERT SQL:', $sql);
4115      $ins_sth   = $dst->dbh->prepare($sql);
4116   }
4117
4118   # ########################################################################
4119   # Daemonize only after (potentially) asking for passwords for --ask-pass.
4120   # ########################################################################
4121   my $daemon;
4122   if ( $o->get('daemonize') ) {
4123      $daemon = new Daemon(o=>$o);
4124      $daemon->daemonize();
4125      PTDEBUG && _d('I am a daemon now');
4126   }
4127   elsif ( $o->get('pid') ) {
4128      # We're not daemoninzing, it just handles PID stuff.
4129      $daemon = new Daemon(o=>$o);
4130      $daemon->make_PID_file();
4131   }
4132
4133   # If we daemonized, the parent has already exited and we're the child.
4134   # We shared a copy of every Cxn with the parent, and the parent's copies
4135   # were destroyed but the dbhs were not disconnected because the parent
4136   # attrib was true.  Now, as the child, set it false so the dbhs will be
4137   # disconnected when our Cxn copies are destroyed.  If we didn't daemonize,
4138   # then we're not really a parent (since we have no children), so set it
4139   # false to auto-disconnect the dbhs when our Cxns are destroyed.
4140   $src->{parent} = 0;
4141   $dst->{parent} = 0 if $dst;
4142
4143   # ########################################################################
4144   # Do the version-check
4145   # ########################################################################
4146   if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
4147      VersionCheck::version_check(
4148         force     => $o->got('version-check'),
4149         instances => [
4150            { dbh => $src->dbh, dsn => $src->dsn },
4151            ($dst ? { dbh => $dst->dbh, dsn => $dst->dsn } : ())
4152         ],
4153      );
4154   }
4155
4156   # ########################################################################
4157   # Start finding and logging foreign key errors.
4158   # ########################################################################
4159   my $run_time = Runtime->new(
4160      run_time => $o->get('run-time'),
4161      now      => sub { return time },
4162   );
4163
4164   my $interval = $o->get('interval');
4165   my $iters    = $o->get('iterations');
4166   PTDEBUG && _d('iterations:', $iters, 'interval:', $interval);
4167
4168   ITERATION:
4169   while (
4170      $oktorun
4171      && $run_time->have_time()
4172      && (!defined $iters || $iters--)
4173   ) {
4174      my ($ts, $fk_error);
4175      eval {
4176         my $sql = "SHOW /*!40100 ENGINE*/ INNODB STATUS "
4177                 . "/* pt-fk-error-logger */";
4178         PTDEBUG && _d($sql);
4179         my $text = $src->dbh->selectrow_hashref($sql)->{status};
4180         ($ts, $fk_error) = get_fk_error($text);
4181      };
4182      if ( my $e = $EVAL_ERROR ) {
4183         PTDEBUG && _d('Error getting InnoDB status:', $e);
4184         if ( $src->lost_connection($e) ) {
4185            eval { $src->connect() };
4186            if ( $EVAL_ERROR ) {
4187               warn "Lost connection to MySQL.  Will try to reconnect "
4188                  . "in the next iteration.\n";
4189            }
4190            else {
4191               PTDEBUG && _d('Reconnected to MySQL');
4192               redo ITERATION;
4193            }
4194         }
4195         else {
4196            warn "Error parsing SHOW ENGINE INNODB STATUS: $EVAL_ERROR";
4197            $exit_status |= 1;
4198         }
4199      }
4200      else {
4201         if ( $ts && $fk_error ) {
4202            # Save and/or print the foreign key error.
4203            if ( $ins_sth ) {
4204               my $fk_ts = parse_timestamp($ts);
4205               PTDEBUG && _d('Saving fk error', $ts, $fk_error);
4206               eval {
4207                  $ins_sth->execute($fk_ts, $fk_error);
4208               };
4209               if ( $EVAL_ERROR ) {
4210                  warn $EVAL_ERROR;
4211                  PTDEBUG && _d($EVAL_ERROR);
4212               }
4213            }
4214
4215            if ( !$o->get('quiet') ) {
4216               print "$ts $fk_error\n\n";
4217            }
4218         }
4219      }
4220
4221      # Sleep if there's an --iteration left.
4222      if ( !defined $iters || $iters ) {
4223         PTDEBUG && _d('Sleeping', $interval, 'seconds');
4224         sleep $interval;
4225      }
4226   }
4227
4228   PTDEBUG && _d('Done running, exiting', $exit_status);
4229   return $exit_status;
4230}
4231
4232# ############################################################################
4233# Subroutines
4234# ############################################################################
4235
4236sub get_fk_error {
4237   my ( $text ) = @_;
4238   PTDEBUG && _d($text);
4239
4240   # Quick check if text even has a foreign key error.
4241   if ( $text !~ m/LATEST FOREIGN KEY ERROR/ ) {
4242      PTDEBUG && _d('No fk error');
4243      return;
4244   }
4245
4246   # InnoDB timestamp
4247   my $idb_ts = qr/((?:\d{6}|\d{4}-\d\d-\d\d) .\d:\d\d:\d\d)/;
4248
4249   my ($ts, $fke) = $text =~ m/LATEST FOREIGN KEY ERROR.+?$idb_ts\s*(.+?)---/ms;
4250   chomp $fke if $fke;
4251
4252   PTDEBUG && _d('Latest fk error:', $ts, $fke);
4253   return $ts, $fke;
4254}
4255
4256sub sig_int {
4257   my ( $signal ) = @_;
4258   $oktorun = 0;
4259   print STDERR "# Caught SIG$signal.  Use 'kill -ABRT $PID' if "
4260      . "the tool does not exit normally in a few seconds.\n";
4261}
4262
4263sub _d {
4264   my ($package, undef, $line) = caller 0;
4265   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4266        map { defined $_ ? $_ : 'undef' }
4267        @_;
4268   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4269}
4270
4271# ############################################################################
4272# Run the program.
4273# ############################################################################
4274if ( !caller ) { exit main(@ARGV); }
4275
42761; # Because this is a module as well as a script.
4277
4278# ############################################################################
4279# Documentation
4280# ############################################################################
4281=pod
4282
4283=head1 NAME
4284
4285pt-fk-error-logger - Log MySQL foreign key errors.
4286
4287=head1 SYNOPSIS
4288
4289Usage: pt-fk-error-logger [OPTIONS] [DSN]
4290
4291pt-fk-error-logger logs information about foreign key errors on the given
4292DSN.  Information is printed to C<STDOUT>, and it can also be saved to a
4293table by specifying L<"--dest">.  The tool runs for forever unless
4294L<"--run-time"> or L<"--iterations"> is specified.
4295
4296Print foreign key errors on host1:
4297
4298   pt-fk-error-logger h=host1
4299
4300Print foreign key errors on host1 once then exit:
4301
4302   pt-fk-error-logger h=host1 --iterations 1
4303
4304Save foreign key errors on host1 to percona_schema.fke on host2:
4305
4306  pt-fk-error-logger h=host1 --dest h=host2,D=percona_schema,t=fke
4307
4308=head1 RISKS
4309
4310Percona Toolkit is mature, proven in the real world, and well tested,
4311but all database tools can pose a risk to the system and the database
4312server.  Before using this tool, please:
4313
4314=over
4315
4316=item * Read the tool's documentation
4317
4318=item * Review the tool's known L<"BUGS">
4319
4320=item * Test the tool on a non-production server
4321
4322=item * Backup your production server and verify the backups
4323
4324=back
4325
4326=head1 DESCRIPTION
4327
4328pt-fk-error-logger prints or saves the foreign key errors text from
4329C<SHOW INNODB STATUS>.  The errors are not parsed or interpreted in any
4330way.  Foreign key errors are uniquely identified by their timestamp.
4331Only new (more recent) errors are printed or saved.
4332
4333By default the tool runs forever, checking every L<"--interval"> seconds
4334for new foreign key errors.  Specify L<"--run-time"> and/or L<"--iterations">
4335to limit how long the tool runs.
4336
4337=head1 OUTPUT
4338
4339The foreign key error text from C<SHOW ENGINE INNODB STATUS> is printed
4340to C<STDOUT>, unless L<"--quiet"> is specified.  Errors and warnings
4341are printed to C<STDERR>.
4342
4343=head1 OPTIONS
4344
4345This tool accepts additional command-line arguments.  Refer to the
4346L<"SYNOPSIS"> and usage information for details.
4347
4348=over
4349
4350=item --ask-pass
4351
4352Prompt for a password when connecting to MySQL.
4353
4354=item --charset
4355
4356short form: -A; type: string
4357
4358Default character set.  If the value is utf8, sets Perl's binmode on
4359STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
4360NAMES UTF8 after connecting to MySQL.  Any other value sets binmode on STDOUT
4361without the utf8 layer, and runs SET NAMES after connecting to MySQL.
4362
4363=item --config
4364
4365type: Array
4366
4367Read this comma-separated list of config files; if specified, this must be the
4368first option on the command line.
4369
4370=item --daemonize
4371
4372Fork to the background and detach from the shell.  POSIX operating systems only.
4373
4374=item --database
4375
4376short form: -D; type: string
4377
4378Connect to this database.
4379
4380=item --defaults-file
4381
4382short form: -F; type: string
4383
4384Only read mysql options from the given file.  You must give an absolute
4385pathname.
4386
4387=item --dest
4388
4389type: DSN
4390
4391Save foreign key errors in this table.  The DSN must specify a database (D)
4392and table (t).
4393
4394Missing DSN values are inherited from the DSN being monitored, so you
4395can omit most values if you're saving foreign key errors on the same
4396host.
4397
4398The following table is suggested:
4399
4400 CREATE TABLE foreign_key_errors (
4401   ts datetime NOT NULL,
4402   error text NOT NULL,
4403   PRIMARY KEY (ts)
4404 )
4405
4406The only information saved is the timestamp and the foreign key error text.
4407
4408=item --help
4409
4410Show help and exit.
4411
4412=item --host
4413
4414short form: -h; type: string
4415
4416Connect to host.
4417
4418=item --interval
4419
4420type: time; default: 30
4421
4422How often to check for foreign key errors.
4423
4424=item --iterations
4425
4426type: int
4427
4428How many times to check for foreign key errors.  By default, this option
4429is undefined which means an infinite number of iterations.  The tool always
4430exits for L<"--run-time">, regardless of the value specified for this option.
4431For example, the tool will exit after 1 minute with
4432C<--run-time 1m --iterations 4 --interval 30> because 4 iterations at 30
4433second intervals would take 2 minutes, longer than the 1 mintue run-time.
4434
4435=item --log
4436
4437type: string
4438
4439Print all output to this file when daemonized.
4440
4441=item --password
4442
4443short form: -p; type: string
4444
4445Password to use when connecting.
4446If password contains commas they must be escaped with a backslash: "exam\,ple"
4447
4448=item --pid
4449
4450type: string
4451
4452Create the given PID file.  The tool won't start if the PID file already
4453exists and the PID it contains is different than the current PID.  However,
4454if the PID file exists and the PID it contains is no longer running, the
4455tool will overwrite the PID file with the current PID.  The PID file is
4456removed automatically when the tool exits.
4457
4458=item --port
4459
4460short form: -P; type: int
4461
4462Port number to use for connection.
4463
4464=item --quiet
4465
4466Do not print foreign key errors; only print errors and warnings to C<STDERR>.
4467
4468=item --run-time
4469
4470type: time
4471
4472How long to run before exiting.  By default, the tool runs forever.
4473
4474=item --set-vars
4475
4476type: Array
4477
4478Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
4479
4480By default, the tool sets:
4481
4482=for comment ignore-pt-internal-value
4483MAGIC_set_vars
4484
4485   wait_timeout=10000
4486
4487Variables specified on the command line override these defaults.  For
4488example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
4489
4490The tool prints a warning and continues if a variable cannot be set.
4491
4492=item --socket
4493
4494short form: -S; type: string
4495
4496Socket file to use for connection.
4497
4498=item --user
4499
4500short form: -u; type: string
4501
4502User for login if not current user.
4503
4504=item --version
4505
4506Show version and exit.
4507
4508=item --[no]version-check
4509
4510default: yes
4511
4512Check for the latest version of Percona Toolkit, MySQL, and other programs.
4513
4514This is a standard "check for updates automatically" feature, with two
4515additional features.  First, the tool checks its own version and also the
4516versions of the following software: operating system, Percona Monitoring and
4517Management (PMM), MySQL, Perl, MySQL driver for Perl (DBD::mysql), and
4518Percona Toolkit. Second, it checks for and warns about versions with known
4519problems. For example, MySQL 5.5.25 had a critical bug and was re-released
4520as 5.5.25a.
4521
4522A secure connection to Percona’s Version Check database server is done to
4523perform these checks. Each request is logged by the server, including software
4524version numbers and unique ID of the checked system. The ID is generated by the
4525Percona Toolkit installation script or when the Version Check database call is
4526done for the first time.
4527
4528Any updates or known problems are printed to STDOUT before the tool's normal
4529output.  This feature should never interfere with the normal operation of the
4530tool.
4531
4532For more information, visit L<https://www.percona.com/doc/percona-toolkit/LATEST/version-check.html>.
4533
4534=back
4535
4536=head1 DSN OPTIONS
4537
4538These DSN options are used to create a DSN.  Each option is given like
4539C<option=value>.  The options are case-sensitive, so P and p are not the
4540same option.  There cannot be whitespace before or after the C<=> and
4541if the value contains whitespace it must be quoted.  DSN options are
4542comma-separated.  See the L<percona-toolkit> manpage for full details.
4543
4544=over
4545
4546=item * A
4547
4548dsn: charset; copy: yes
4549
4550Default character set.
4551
4552=item * D
4553
4554dsn: database; copy: yes
4555
4556Default database.
4557
4558=item * F
4559
4560dsn: mysql_read_default_file; copy: yes
4561
4562Only read default options from the given file
4563
4564=item * h
4565
4566dsn: host; copy: yes
4567
4568Connect to host.
4569
4570=item * p
4571
4572dsn: password; copy: yes
4573
4574Password to use when connecting.
4575If password contains commas they must be escaped with a backslash: "exam\,ple"
4576
4577=item * P
4578
4579dsn: port; copy: yes
4580
4581Port number to use for connection.
4582
4583=item * S
4584
4585dsn: mysql_socket; copy: yes
4586
4587Socket file to use for connection.
4588
4589=item * t
4590
4591Table in which to store foreign key errors.
4592
4593=item * u
4594
4595dsn: user; copy: yes
4596
4597User for login if not current user.
4598
4599=back
4600
4601=head1 ENVIRONMENT
4602
4603The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
4604To enable debugging and capture all output to a file, run the tool like:
4605
4606   PTDEBUG=1 pt-fk-error-logger ... > FILE 2>&1
4607
4608Be careful: debugging output is voluminous and can generate several megabytes
4609of output.
4610
4611=head1 SYSTEM REQUIREMENTS
4612
4613You need Perl, DBI, DBD::mysql, and some core packages that ought to be
4614installed in any reasonably new version of Perl.
4615
4616=head1 BUGS
4617
4618For a list of known bugs, see L<http://www.percona.com/bugs/pt-fk-error-logger>.
4619
4620Please report bugs at L<https://jira.percona.com/projects/PT>.
4621Include the following information in your bug report:
4622
4623=over
4624
4625=item * Complete command-line used to run the tool
4626
4627=item * Tool L<"--version">
4628
4629=item * MySQL version of all servers involved
4630
4631=item * Output from the tool including STDERR
4632
4633=item * Input files (log/dump/config files, etc.)
4634
4635=back
4636
4637If possible, include debugging output by running the tool with C<PTDEBUG>;
4638see L<"ENVIRONMENT">.
4639
4640=head1 DOWNLOADING
4641
4642Visit L<http://www.percona.com/software/percona-toolkit/> to download the
4643latest release of Percona Toolkit.  Or, get the latest release from the
4644command line:
4645
4646   wget percona.com/get/percona-toolkit.tar.gz
4647
4648   wget percona.com/get/percona-toolkit.rpm
4649
4650   wget percona.com/get/percona-toolkit.deb
4651
4652You can also get individual tools from the latest release:
4653
4654   wget percona.com/get/TOOL
4655
4656Replace C<TOOL> with the name of any tool.
4657
4658=head1 AUTHORS
4659
4660Daniel Nichter
4661
4662=head1 ABOUT PERCONA TOOLKIT
4663
4664This tool is part of Percona Toolkit, a collection of advanced command-line
4665tools for MySQL developed by Percona.  Percona Toolkit was forked from two
4666projects in June, 2011: Maatkit and Aspersa.  Those projects were created by
4667Baron Schwartz and primarily developed by him and Daniel Nichter.  Visit
4668L<http://www.percona.com/software/> to learn about other free, open-source
4669software from Percona.
4670
4671=head1 COPYRIGHT, LICENSE, AND WARRANTY
4672
4673This program is copyright 2011-2018 Percona LLC and/or its affiliates.
4674
4675THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
4676WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
4677MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
4678
4679This program is free software; you can redistribute it and/or modify it under
4680the terms of the GNU General Public License as published by the Free Software
4681Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
4682systems, you can issue `man perlgpl' or `man perlartistic' to read these
4683licenses.
4684
4685You should have received a copy of the GNU General Public License along with
4686this program; if not, write to the Free Software Foundation, Inc., 59 Temple
4687Place, Suite 330, Boston, MA  02111-1307  USA.
4688
4689=head1 VERSION
4690
4691pt-fk-error-logger 3.3.0
4692
4693=cut
4694