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      OptionParser
17   ));
18}
19
20# ###########################################################################
21# OptionParser package
22# This package is a copy without comments from the original.  The original
23# with comments and its test file can be found in the Bazaar repository at,
24#   lib/OptionParser.pm
25#   t/lib/OptionParser.t
26# See https://launchpad.net/percona-toolkit for more information.
27# ###########################################################################
28{
29package OptionParser;
30
31use strict;
32use warnings FATAL => 'all';
33use English qw(-no_match_vars);
34use constant PTDEBUG => $ENV{PTDEBUG} || 0;
35
36use List::Util qw(max);
37use Getopt::Long;
38use Data::Dumper;
39
40my $POD_link_re = '[LC]<"?([^">]+)"?>';
41
42sub new {
43   my ( $class, %args ) = @_;
44   my @required_args = qw();
45   foreach my $arg ( @required_args ) {
46      die "I need a $arg argument" unless $args{$arg};
47   }
48
49   my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
50   $program_name ||= $PROGRAM_NAME;
51   my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
52
53   my %attributes = (
54      'type'       => 1,
55      'short form' => 1,
56      'group'      => 1,
57      'default'    => 1,
58      'cumulative' => 1,
59      'negatable'  => 1,
60      'repeatable' => 1,  # means it can be specified more than once
61   );
62
63   my $self = {
64      head1             => 'OPTIONS',        # These args are used internally
65      skip_rules        => 0,                # to instantiate another Option-
66      item              => '--(.*)',         # Parser obj that parses the
67      attributes        => \%attributes,     # DSN OPTIONS section.  Tools
68      parse_attributes  => \&_parse_attribs, # don't tinker with these args.
69
70      %args,
71
72      strict            => 1,  # disabled by a special rule
73      program_name      => $program_name,
74      opts              => {},
75      got_opts          => 0,
76      short_opts        => {},
77      defaults          => {},
78      groups            => {},
79      allowed_groups    => {},
80      errors            => [],
81      rules             => [],  # desc of rules for --help
82      mutex             => [],  # rule: opts are mutually exclusive
83      atleast1          => [],  # rule: at least one opt is required
84      disables          => {},  # rule: opt disables other opts
85      defaults_to       => {},  # rule: opt defaults to value of other opt
86      DSNParser         => undef,
87      default_files     => [
88         "/etc/percona-toolkit/percona-toolkit.conf",
89         "/etc/percona-toolkit/$program_name.conf",
90         "$home/.percona-toolkit.conf",
91         "$home/.$program_name.conf",
92      ],
93      types             => {
94         string => 's', # standard Getopt type
95         int    => 'i', # standard Getopt type
96         float  => 'f', # standard Getopt type
97         Hash   => 'H', # hash, formed from a comma-separated list
98         hash   => 'h', # hash as above, but only if a value is given
99         Array  => 'A', # array, similar to Hash
100         array  => 'a', # array, similar to hash
101         DSN    => 'd', # DSN
102         size   => 'z', # size with kMG suffix (powers of 2^10)
103         time   => 'm', # time, with an optional suffix of s/h/m/d
104      },
105   };
106
107   return bless $self, $class;
108}
109
110sub get_specs {
111   my ( $self, $file ) = @_;
112   $file ||= $self->{file} || __FILE__;
113   my @specs = $self->_pod_to_specs($file);
114   $self->_parse_specs(@specs);
115
116   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
117   my $contents = do { local $/ = undef; <$fh> };
118   close $fh;
119   if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
120      PTDEBUG && _d('Parsing DSN OPTIONS');
121      my $dsn_attribs = {
122         dsn  => 1,
123         copy => 1,
124      };
125      my $parse_dsn_attribs = sub {
126         my ( $self, $option, $attribs ) = @_;
127         map {
128            my $val = $attribs->{$_};
129            if ( $val ) {
130               $val    = $val eq 'yes' ? 1
131                       : $val eq 'no'  ? 0
132                       :                 $val;
133               $attribs->{$_} = $val;
134            }
135         } keys %$attribs;
136         return {
137            key => $option,
138            %$attribs,
139         };
140      };
141      my $dsn_o = new OptionParser(
142         description       => 'DSN OPTIONS',
143         head1             => 'DSN OPTIONS',
144         dsn               => 0,         # XXX don't infinitely recurse!
145         item              => '\* (.)',  # key opts are a single character
146         skip_rules        => 1,         # no rules before opts
147         attributes        => $dsn_attribs,
148         parse_attributes  => $parse_dsn_attribs,
149      );
150      my @dsn_opts = map {
151         my $opts = {
152            key  => $_->{spec}->{key},
153            dsn  => $_->{spec}->{dsn},
154            copy => $_->{spec}->{copy},
155            desc => $_->{desc},
156         };
157         $opts;
158      } $dsn_o->_pod_to_specs($file);
159      $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
160   }
161
162   if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
163      $self->{version} = $1;
164      PTDEBUG && _d($self->{version});
165   }
166
167   return;
168}
169
170sub DSNParser {
171   my ( $self ) = @_;
172   return $self->{DSNParser};
173};
174
175sub get_defaults_files {
176   my ( $self ) = @_;
177   return @{$self->{default_files}};
178}
179
180sub _pod_to_specs {
181   my ( $self, $file ) = @_;
182   $file ||= $self->{file} || __FILE__;
183   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
184
185   my @specs = ();
186   my @rules = ();
187   my $para;
188
189   local $INPUT_RECORD_SEPARATOR = '';
190   while ( $para = <$fh> ) {
191      next unless $para =~ m/^=head1 $self->{head1}/;
192      last;
193   }
194
195   while ( $para = <$fh> ) {
196      last if $para =~ m/^=over/;
197      next if $self->{skip_rules};
198      chomp $para;
199      $para =~ s/\s+/ /g;
200      $para =~ s/$POD_link_re/$1/go;
201      PTDEBUG && _d('Option rule:', $para);
202      push @rules, $para;
203   }
204
205   die "POD has no $self->{head1} section" unless $para;
206
207   do {
208      if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
209         chomp $para;
210         PTDEBUG && _d($para);
211         my %attribs;
212
213         $para = <$fh>; # read next paragraph, possibly attributes
214
215         if ( $para =~ m/: / ) { # attributes
216            $para =~ s/\s+\Z//g;
217            %attribs = map {
218                  my ( $attrib, $val) = split(/: /, $_);
219                  die "Unrecognized attribute for --$option: $attrib"
220                     unless $self->{attributes}->{$attrib};
221                  ($attrib, $val);
222               } split(/; /, $para);
223            if ( $attribs{'short form'} ) {
224               $attribs{'short form'} =~ s/-//;
225            }
226            $para = <$fh>; # read next paragraph, probably short help desc
227         }
228         else {
229            PTDEBUG && _d('Option has no attributes');
230         }
231
232         $para =~ s/\s+\Z//g;
233         $para =~ s/\s+/ /g;
234         $para =~ s/$POD_link_re/$1/go;
235
236         $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
237         PTDEBUG && _d('Short help:', $para);
238
239         die "No description after option spec $option" if $para =~ m/^=item/;
240
241         if ( my ($base_option) =  $option =~ m/^\[no\](.*)/ ) {
242            $option = $base_option;
243            $attribs{'negatable'} = 1;
244         }
245
246         push @specs, {
247            spec  => $self->{parse_attributes}->($self, $option, \%attribs),
248            desc  => $para
249               . (defined $attribs{default} ? " (default $attribs{default})" : ''),
250            group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
251            attributes => \%attribs
252         };
253      }
254      while ( $para = <$fh> ) {
255         last unless $para;
256         if ( $para =~ m/^=head1/ ) {
257            $para = undef; # Can't 'last' out of a do {} block.
258            last;
259         }
260         last if $para =~ m/^=item /;
261      }
262   } while ( $para );
263
264   die "No valid specs in $self->{head1}" unless @specs;
265
266   close $fh;
267   return @specs, @rules;
268}
269
270sub _parse_specs {
271   my ( $self, @specs ) = @_;
272   my %disables; # special rule that requires deferred checking
273
274   foreach my $opt ( @specs ) {
275      if ( ref $opt ) { # It's an option spec, not a rule.
276         PTDEBUG && _d('Parsing opt spec:',
277            map { ($_, '=>', $opt->{$_}) } keys %$opt);
278
279         my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
280         if ( !$long ) {
281            die "Cannot parse long option from spec $opt->{spec}";
282         }
283         $opt->{long} = $long;
284
285         die "Duplicate long option --$long" if exists $self->{opts}->{$long};
286         $self->{opts}->{$long} = $opt;
287
288         if ( length $long == 1 ) {
289            PTDEBUG && _d('Long opt', $long, 'looks like short opt');
290            $self->{short_opts}->{$long} = $long;
291         }
292
293         if ( $short ) {
294            die "Duplicate short option -$short"
295               if exists $self->{short_opts}->{$short};
296            $self->{short_opts}->{$short} = $long;
297            $opt->{short} = $short;
298         }
299         else {
300            $opt->{short} = undef;
301         }
302
303         $opt->{is_negatable}  = $opt->{spec} =~ m/!/        ? 1 : 0;
304         $opt->{is_cumulative} = $opt->{spec} =~ m/\+/       ? 1 : 0;
305         $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0;
306         $opt->{is_required}   = $opt->{desc} =~ m/required/ ? 1 : 0;
307
308         $opt->{group} ||= 'default';
309         $self->{groups}->{ $opt->{group} }->{$long} = 1;
310
311         $opt->{value} = undef;
312         $opt->{got}   = 0;
313
314         my ( $type ) = $opt->{spec} =~ m/=(.)/;
315         $opt->{type} = $type;
316         PTDEBUG && _d($long, 'type:', $type);
317
318
319         $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
320
321         if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
322            $self->{defaults}->{$long} = defined $def ? $def : 1;
323            PTDEBUG && _d($long, 'default:', $def);
324         }
325
326         if ( $long eq 'config' ) {
327            $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
328         }
329
330         if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
331            $disables{$long} = $dis;
332            PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
333         }
334
335         $self->{opts}->{$long} = $opt;
336      }
337      else { # It's an option rule, not a spec.
338         PTDEBUG && _d('Parsing rule:', $opt);
339         push @{$self->{rules}}, $opt;
340         my @participants = $self->_get_participants($opt);
341         my $rule_ok = 0;
342
343         if ( $opt =~ m/mutually exclusive|one and only one/ ) {
344            $rule_ok = 1;
345            push @{$self->{mutex}}, \@participants;
346            PTDEBUG && _d(@participants, 'are mutually exclusive');
347         }
348         if ( $opt =~ m/at least one|one and only one/ ) {
349            $rule_ok = 1;
350            push @{$self->{atleast1}}, \@participants;
351            PTDEBUG && _d(@participants, 'require at least one');
352         }
353         if ( $opt =~ m/default to/ ) {
354            $rule_ok = 1;
355            $self->{defaults_to}->{$participants[0]} = $participants[1];
356            PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
357         }
358         if ( $opt =~ m/restricted to option groups/ ) {
359            $rule_ok = 1;
360            my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
361            my @groups = split(',', $groups);
362            %{$self->{allowed_groups}->{$participants[0]}} = map {
363               s/\s+//;
364               $_ => 1;
365            } @groups;
366         }
367         if( $opt =~ m/accepts additional command-line arguments/ ) {
368            $rule_ok = 1;
369            $self->{strict} = 0;
370            PTDEBUG && _d("Strict mode disabled by rule");
371         }
372
373         die "Unrecognized option rule: $opt" unless $rule_ok;
374      }
375   }
376
377   foreach my $long ( keys %disables ) {
378      my @participants = $self->_get_participants($disables{$long});
379      $self->{disables}->{$long} = \@participants;
380      PTDEBUG && _d('Option', $long, 'disables', @participants);
381   }
382
383   return;
384}
385
386sub _get_participants {
387   my ( $self, $str ) = @_;
388   my @participants;
389   foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
390      die "Option --$long does not exist while processing rule $str"
391         unless exists $self->{opts}->{$long};
392      push @participants, $long;
393   }
394   PTDEBUG && _d('Participants for', $str, ':', @participants);
395   return @participants;
396}
397
398sub opts {
399   my ( $self ) = @_;
400   my %opts = %{$self->{opts}};
401   return %opts;
402}
403
404sub short_opts {
405   my ( $self ) = @_;
406   my %short_opts = %{$self->{short_opts}};
407   return %short_opts;
408}
409
410sub set_defaults {
411   my ( $self, %defaults ) = @_;
412   $self->{defaults} = {};
413   foreach my $long ( keys %defaults ) {
414      die "Cannot set default for nonexistent option $long"
415         unless exists $self->{opts}->{$long};
416      $self->{defaults}->{$long} = $defaults{$long};
417      PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
418   }
419   return;
420}
421
422sub get_defaults {
423   my ( $self ) = @_;
424   return $self->{defaults};
425}
426
427sub get_groups {
428   my ( $self ) = @_;
429   return $self->{groups};
430}
431
432sub _set_option {
433   my ( $self, $opt, $val ) = @_;
434   my $long = exists $self->{opts}->{$opt}       ? $opt
435            : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
436            : die "Getopt::Long gave a nonexistent option: $opt";
437   $opt = $self->{opts}->{$long};
438   if ( $opt->{is_cumulative} ) {
439      $opt->{value}++;
440   }
441   elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
442      my $next_opt = $1;
443      if (    exists $self->{opts}->{$next_opt}
444           || exists $self->{short_opts}->{$next_opt} ) {
445         $self->save_error("--$long requires a string value");
446         return;
447      }
448      else {
449         if ($opt->{is_repeatable}) {
450            push @{$opt->{value}} , $val;
451         }
452         else {
453            $opt->{value} = $val;
454         }
455      }
456   }
457   else {
458      if ($opt->{is_repeatable}) {
459         push @{$opt->{value}} , $val;
460      }
461      else {
462         $opt->{value} = $val;
463      }
464   }
465   $opt->{got} = 1;
466   PTDEBUG && _d('Got option', $long, '=', $val);
467}
468
469sub get_opts {
470   my ( $self ) = @_;
471
472   foreach my $long ( keys %{$self->{opts}} ) {
473      $self->{opts}->{$long}->{got} = 0;
474      $self->{opts}->{$long}->{value}
475         = exists $self->{defaults}->{$long}       ? $self->{defaults}->{$long}
476         : $self->{opts}->{$long}->{is_cumulative} ? 0
477         : undef;
478   }
479   $self->{got_opts} = 0;
480
481   $self->{errors} = [];
482
483   if ( @ARGV && $ARGV[0] =~/^--config=/ ) {
484      $ARGV[0] = substr($ARGV[0],9);
485      $ARGV[0] =~ s/^'(.*)'$/$1/;
486      $ARGV[0] =~ s/^"(.*)"$/$1/;
487      $self->_set_option('config', shift @ARGV);
488   }
489   if ( @ARGV && $ARGV[0] eq "--config" ) {
490      shift @ARGV;
491      $self->_set_option('config', shift @ARGV);
492   }
493   if ( $self->has('config') ) {
494      my @extra_args;
495      foreach my $filename ( split(',', $self->get('config')) ) {
496         eval {
497            push @extra_args, $self->_read_config_file($filename);
498         };
499         if ( $EVAL_ERROR ) {
500            if ( $self->got('config') ) {
501               die $EVAL_ERROR;
502            }
503            elsif ( PTDEBUG ) {
504               _d($EVAL_ERROR);
505            }
506         }
507      }
508      unshift @ARGV, @extra_args;
509   }
510
511   Getopt::Long::Configure('no_ignore_case', 'bundling');
512   GetOptions(
513      map    { $_->{spec} => sub { $self->_set_option(@_); } }
514      grep   { $_->{long} ne 'config' } # --config is handled specially above.
515      values %{$self->{opts}}
516   ) or $self->save_error('Error parsing options');
517
518   if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
519      if ( $self->{version} ) {
520         print $self->{version}, "\n";
521         exit 0;
522      }
523      else {
524         print "Error parsing version.  See the VERSION section of the tool's documentation.\n";
525         exit 1;
526      }
527   }
528
529   if ( @ARGV && $self->{strict} ) {
530      $self->save_error("Unrecognized command-line options @ARGV");
531   }
532
533   foreach my $mutex ( @{$self->{mutex}} ) {
534      my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
535      if ( @set > 1 ) {
536         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
537                      @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
538                 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
539                 . ' are mutually exclusive.';
540         $self->save_error($err);
541      }
542   }
543
544   foreach my $required ( @{$self->{atleast1}} ) {
545      my @set = grep { $self->{opts}->{$_}->{got} } @$required;
546      if ( @set == 0 ) {
547         my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
548                      @{$required}[ 0 .. scalar(@$required) - 2] )
549                 .' or --'.$self->{opts}->{$required->[-1]}->{long};
550         $self->save_error("Specify at least one of $err");
551      }
552   }
553
554   $self->_check_opts( keys %{$self->{opts}} );
555   $self->{got_opts} = 1;
556   return;
557}
558
559sub _check_opts {
560   my ( $self, @long ) = @_;
561   my $long_last = scalar @long;
562   while ( @long ) {
563      foreach my $i ( 0..$#long ) {
564         my $long = $long[$i];
565         next unless $long;
566         my $opt  = $self->{opts}->{$long};
567         if ( $opt->{got} ) {
568            if ( exists $self->{disables}->{$long} ) {
569               my @disable_opts = @{$self->{disables}->{$long}};
570               map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
571               PTDEBUG && _d('Unset options', @disable_opts,
572                  'because', $long,'disables them');
573            }
574
575            if ( exists $self->{allowed_groups}->{$long} ) {
576
577               my @restricted_groups = grep {
578                  !exists $self->{allowed_groups}->{$long}->{$_}
579               } keys %{$self->{groups}};
580
581               my @restricted_opts;
582               foreach my $restricted_group ( @restricted_groups ) {
583                  RESTRICTED_OPT:
584                  foreach my $restricted_opt (
585                     keys %{$self->{groups}->{$restricted_group}} )
586                  {
587                     next RESTRICTED_OPT if $restricted_opt eq $long;
588                     push @restricted_opts, $restricted_opt
589                        if $self->{opts}->{$restricted_opt}->{got};
590                  }
591               }
592
593               if ( @restricted_opts ) {
594                  my $err;
595                  if ( @restricted_opts == 1 ) {
596                     $err = "--$restricted_opts[0]";
597                  }
598                  else {
599                     $err = join(', ',
600                               map { "--$self->{opts}->{$_}->{long}" }
601                               grep { $_ }
602                               @restricted_opts[0..scalar(@restricted_opts) - 2]
603                            )
604                          . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
605                  }
606                  $self->save_error("--$long is not allowed with $err");
607               }
608            }
609
610         }
611         elsif ( $opt->{is_required} ) {
612            $self->save_error("Required option --$long must be specified");
613         }
614
615         $self->_validate_type($opt);
616         if ( $opt->{parsed} ) {
617            delete $long[$i];
618         }
619         else {
620            PTDEBUG && _d('Temporarily failed to parse', $long);
621         }
622      }
623
624      die "Failed to parse options, possibly due to circular dependencies"
625         if @long == $long_last;
626      $long_last = @long;
627   }
628
629   return;
630}
631
632sub _validate_type {
633   my ( $self, $opt ) = @_;
634   return unless $opt;
635
636   if ( !$opt->{type} ) {
637      $opt->{parsed} = 1;
638      return;
639   }
640
641   my $val = $opt->{value};
642
643   if ( $val && $opt->{type} eq 'm' ) {  # type time
644      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
645      my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
646      if ( !$suffix ) {
647         my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
648         $suffix = $s || 's';
649         PTDEBUG && _d('No suffix given; using', $suffix, 'for',
650            $opt->{long}, '(value:', $val, ')');
651      }
652      if ( $suffix =~ m/[smhd]/ ) {
653         $val = $suffix eq 's' ? $num            # Seconds
654              : $suffix eq 'm' ? $num * 60       # Minutes
655              : $suffix eq 'h' ? $num * 3600     # Hours
656              :                  $num * 86400;   # Days
657         $opt->{value} = ($prefix || '') . $val;
658         PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
659      }
660      else {
661         $self->save_error("Invalid time suffix for --$opt->{long}");
662      }
663   }
664   elsif ( $val && $opt->{type} eq 'd' ) {  # type DSN
665      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
666      my $prev = {};
667      my $from_key = $self->{defaults_to}->{ $opt->{long} };
668      if ( $from_key ) {
669         PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
670         if ( $self->{opts}->{$from_key}->{parsed} ) {
671            $prev = $self->{opts}->{$from_key}->{value};
672         }
673         else {
674            PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
675               $from_key, 'parsed');
676            return;
677         }
678      }
679      my $defaults = $self->{DSNParser}->parse_options($self);
680      if (!$opt->{attributes}->{repeatable}) {
681          $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
682      } else {
683          my $values = [];
684          for my $dsn_string (@$val) {
685              push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults);
686          }
687          $opt->{value} = $values;
688      }
689   }
690   elsif ( $val && $opt->{type} eq 'z' ) {  # type size
691      PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
692      $self->_parse_size($opt, $val);
693   }
694   elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
695      $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
696   }
697   elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
698      $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
699   }
700   else {
701      PTDEBUG && _d('Nothing to validate for option',
702         $opt->{long}, 'type', $opt->{type}, 'value', $val);
703   }
704
705   $opt->{parsed} = 1;
706   return;
707}
708
709sub get {
710   my ( $self, $opt ) = @_;
711   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
712   die "Option $opt does not exist"
713      unless $long && exists $self->{opts}->{$long};
714   return $self->{opts}->{$long}->{value};
715}
716
717sub got {
718   my ( $self, $opt ) = @_;
719   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
720   die "Option $opt does not exist"
721      unless $long && exists $self->{opts}->{$long};
722   return $self->{opts}->{$long}->{got};
723}
724
725sub has {
726   my ( $self, $opt ) = @_;
727   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
728   return defined $long ? exists $self->{opts}->{$long} : 0;
729}
730
731sub set {
732   my ( $self, $opt, $val ) = @_;
733   my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
734   die "Option $opt does not exist"
735      unless $long && exists $self->{opts}->{$long};
736   $self->{opts}->{$long}->{value} = $val;
737   return;
738}
739
740sub save_error {
741   my ( $self, $error ) = @_;
742   push @{$self->{errors}}, $error;
743   return;
744}
745
746sub errors {
747   my ( $self ) = @_;
748   return $self->{errors};
749}
750
751sub usage {
752   my ( $self ) = @_;
753   warn "No usage string is set" unless $self->{usage}; # XXX
754   return "Usage: " . ($self->{usage} || '') . "\n";
755}
756
757sub descr {
758   my ( $self ) = @_;
759   warn "No description string is set" unless $self->{description}; # XXX
760   my $descr  = ($self->{description} || $self->{program_name} || '')
761              . "  For more details, please use the --help option, "
762              . "or try 'perldoc $PROGRAM_NAME' "
763              . "for complete documentation.";
764   $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
765      unless $ENV{DONT_BREAK_LINES};
766   $descr =~ s/ +$//mg;
767   return $descr;
768}
769
770sub usage_or_errors {
771   my ( $self, $file, $return ) = @_;
772   $file ||= $self->{file} || __FILE__;
773
774   if ( !$self->{description} || !$self->{usage} ) {
775      PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
776      my %synop = $self->_parse_synopsis($file);
777      $self->{description} ||= $synop{description};
778      $self->{usage}       ||= $synop{usage};
779      PTDEBUG && _d("Description:", $self->{description},
780         "\nUsage:", $self->{usage});
781   }
782
783   if ( $self->{opts}->{help}->{got} ) {
784      print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
785      exit 0 unless $return;
786   }
787   elsif ( scalar @{$self->{errors}} ) {
788      print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
789      exit 1 unless $return;
790   }
791
792   return;
793}
794
795sub print_errors {
796   my ( $self ) = @_;
797   my $usage = $self->usage() . "\n";
798   if ( (my @errors = @{$self->{errors}}) ) {
799      $usage .= join("\n  * ", 'Errors in command-line arguments:', @errors)
800              . "\n";
801   }
802   return $usage . "\n" . $self->descr();
803}
804
805sub print_usage {
806   my ( $self ) = @_;
807   die "Run get_opts() before print_usage()" unless $self->{got_opts};
808   my @opts = values %{$self->{opts}};
809
810   my $maxl = max(
811      map {
812         length($_->{long})               # option long name
813         + ($_->{is_negatable} ? 4 : 0)   # "[no]" if opt is negatable
814         + ($_->{type} ? 2 : 0)           # "=x" where x is the opt type
815      }
816      @opts);
817
818   my $maxs = max(0,
819      map {
820         length($_)
821         + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
822         + ($self->{opts}->{$_}->{type} ? 2 : 0)
823      }
824      values %{$self->{short_opts}});
825
826   my $lcol = max($maxl, ($maxs + 3));
827   my $rcol = 80 - $lcol - 6;
828   my $rpad = ' ' x ( 80 - $rcol );
829
830   $maxs = max($lcol - 3, $maxs);
831
832   my $usage = $self->descr() . "\n" . $self->usage();
833
834   my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
835   push @groups, 'default';
836
837   foreach my $group ( reverse @groups ) {
838      $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
839      foreach my $opt (
840         sort { $a->{long} cmp $b->{long} }
841         grep { $_->{group} eq $group }
842         @opts )
843      {
844         my $long  = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
845         my $short = $opt->{short};
846         my $desc  = $opt->{desc};
847
848         $long .= $opt->{type} ? "=$opt->{type}" : "";
849
850         if ( $opt->{type} && $opt->{type} eq 'm' ) {
851            my ($s) = $desc =~ m/\(suffix (.)\)/;
852            $s    ||= 's';
853            $desc =~ s/\s+\(suffix .\)//;
854            $desc .= ".  Optional suffix s=seconds, m=minutes, h=hours, "
855                   . "d=days; if no suffix, $s is used.";
856         }
857         $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
858         $desc =~ s/ +$//mg;
859         if ( $short ) {
860            $usage .= sprintf("  --%-${maxs}s -%s  %s\n", $long, $short, $desc);
861         }
862         else {
863            $usage .= sprintf("  --%-${lcol}s  %s\n", $long, $desc);
864         }
865      }
866   }
867
868   $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
869
870   if ( (my @rules = @{$self->{rules}}) ) {
871      $usage .= "\nRules:\n\n";
872      $usage .= join("\n", map { "  $_" } @rules) . "\n";
873   }
874   if ( $self->{DSNParser} ) {
875      $usage .= "\n" . $self->{DSNParser}->usage();
876   }
877   $usage .= "\nOptions and values after processing arguments:\n\n";
878   foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
879      my $val   = $opt->{value};
880      my $type  = $opt->{type} || '';
881      my $bool  = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
882      $val      = $bool              ? ( $val ? 'TRUE' : 'FALSE' )
883                : !defined $val      ? '(No value)'
884                : $type eq 'd'       ? $self->{DSNParser}->as_string($val)
885                : $type =~ m/H|h/    ? join(',', sort keys %$val)
886                : $type =~ m/A|a/    ? join(',', @$val)
887                :                    $val;
888      $usage .= sprintf("  --%-${lcol}s  %s\n", $opt->{long}, $val);
889   }
890   return $usage;
891}
892
893sub prompt_noecho {
894   shift @_ if ref $_[0] eq __PACKAGE__;
895   my ( $prompt ) = @_;
896   local $OUTPUT_AUTOFLUSH = 1;
897   print STDERR $prompt
898      or die "Cannot print: $OS_ERROR";
899   my $response;
900   eval {
901      require Term::ReadKey;
902      Term::ReadKey::ReadMode('noecho');
903      chomp($response = <STDIN>);
904      Term::ReadKey::ReadMode('normal');
905      print "\n"
906         or die "Cannot print: $OS_ERROR";
907   };
908   if ( $EVAL_ERROR ) {
909      die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
910   }
911   return $response;
912}
913
914sub _read_config_file {
915   my ( $self, $filename ) = @_;
916   open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
917   my @args;
918   my $prefix = '--';
919   my $parse  = 1;
920
921   LINE:
922   while ( my $line = <$fh> ) {
923      chomp $line;
924      next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
925      $line =~ s/\s+#.*$//g;
926      $line =~ s/^\s+|\s+$//g;
927      if ( $line eq '--' ) {
928         $prefix = '';
929         $parse  = 0;
930         next LINE;
931      }
932
933      if (  $parse
934            && !$self->has('version-check')
935            && $line =~ /version-check/
936      ) {
937         next LINE;
938      }
939
940      if ( $parse
941         && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
942      ) {
943         push @args, grep { defined $_ } ("$prefix$opt", $arg);
944      }
945      elsif ( $line =~ m/./ ) {
946         push @args, $line;
947      }
948      else {
949         die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
950      }
951   }
952   close $fh;
953   return @args;
954}
955
956sub read_para_after {
957   my ( $self, $file, $regex ) = @_;
958   open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
959   local $INPUT_RECORD_SEPARATOR = '';
960   my $para;
961   while ( $para = <$fh> ) {
962      next unless $para =~ m/^=pod$/m;
963      last;
964   }
965   while ( $para = <$fh> ) {
966      next unless $para =~ m/$regex/;
967      last;
968   }
969   $para = <$fh>;
970   chomp($para);
971   close $fh or die "Can't close $file: $OS_ERROR";
972   return $para;
973}
974
975sub clone {
976   my ( $self ) = @_;
977
978   my %clone = map {
979      my $hashref  = $self->{$_};
980      my $val_copy = {};
981      foreach my $key ( keys %$hashref ) {
982         my $ref = ref $hashref->{$key};
983         $val_copy->{$key} = !$ref           ? $hashref->{$key}
984                           : $ref eq 'HASH'  ? { %{$hashref->{$key}} }
985                           : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
986                           : $hashref->{$key};
987      }
988      $_ => $val_copy;
989   } qw(opts short_opts defaults);
990
991   foreach my $scalar ( qw(got_opts) ) {
992      $clone{$scalar} = $self->{$scalar};
993   }
994
995   return bless \%clone;
996}
997
998sub _parse_size {
999   my ( $self, $opt, $val ) = @_;
1000
1001   if ( lc($val || '') eq 'null' ) {
1002      PTDEBUG && _d('NULL size for', $opt->{long});
1003      $opt->{value} = 'null';
1004      return;
1005   }
1006
1007   my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
1008   my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
1009   if ( defined $num ) {
1010      if ( $factor ) {
1011         $num *= $factor_for{$factor};
1012         PTDEBUG && _d('Setting option', $opt->{y},
1013            'to num', $num, '* factor', $factor);
1014      }
1015      $opt->{value} = ($pre || '') . $num;
1016   }
1017   else {
1018      $self->save_error("Invalid size for --$opt->{long}: $val");
1019   }
1020   return;
1021}
1022
1023sub _parse_attribs {
1024   my ( $self, $option, $attribs ) = @_;
1025   my $types = $self->{types};
1026   return $option
1027      . ($attribs->{'short form'} ? '|' . $attribs->{'short form'}   : '' )
1028      . ($attribs->{'negatable'}  ? '!'                              : '' )
1029      . ($attribs->{'cumulative'} ? '+'                              : '' )
1030      . ($attribs->{'type'}       ? '=' . $types->{$attribs->{type}} : '' );
1031}
1032
1033sub _parse_synopsis {
1034   my ( $self, $file ) = @_;
1035   $file ||= $self->{file} || __FILE__;
1036   PTDEBUG && _d("Parsing SYNOPSIS in", $file);
1037
1038   local $INPUT_RECORD_SEPARATOR = '';  # read paragraphs
1039   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1040   my $para;
1041   1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
1042   die "$file does not contain a SYNOPSIS section" unless $para;
1043   my @synop;
1044   for ( 1..2 ) {  # 1 for the usage, 2 for the description
1045      my $para = <$fh>;
1046      push @synop, $para;
1047   }
1048   close $fh;
1049   PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
1050   my ($usage, $desc) = @synop;
1051   die "The SYNOPSIS section in $file is not formatted properly"
1052      unless $usage && $desc;
1053
1054   $usage =~ s/^\s*Usage:\s+(.+)/$1/;
1055   chomp $usage;
1056
1057   $desc =~ s/\n/ /g;
1058   $desc =~ s/\s{2,}/ /g;
1059   $desc =~ s/\. ([A-Z][a-z])/.  $1/g;
1060   $desc =~ s/\s+$//;
1061
1062   return (
1063      description => $desc,
1064      usage       => $usage,
1065   );
1066};
1067
1068sub set_vars {
1069   my ($self, $file) = @_;
1070   $file ||= $self->{file} || __FILE__;
1071
1072   my %user_vars;
1073   my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
1074   if ( $user_vars ) {
1075      foreach my $var_val ( @$user_vars ) {
1076         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1077         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1078         $user_vars{$var} = {
1079            val     => $val,
1080            default => 0,
1081         };
1082      }
1083   }
1084
1085   my %default_vars;
1086   my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
1087   if ( $default_vars ) {
1088      %default_vars = map {
1089         my $var_val = $_;
1090         my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1091         die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
1092         $var => {
1093            val     => $val,
1094            default => 1,
1095         };
1096      } split("\n", $default_vars);
1097   }
1098
1099   my %vars = (
1100      %default_vars, # first the tool's defaults
1101      %user_vars,    # then the user's which overwrite the defaults
1102   );
1103   PTDEBUG && _d('--set-vars:', Dumper(\%vars));
1104   return \%vars;
1105}
1106
1107sub _d {
1108   my ($package, undef, $line) = caller 0;
1109   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1110        map { defined $_ ? $_ : 'undef' }
1111        @_;
1112   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1113}
1114
1115if ( PTDEBUG ) {
1116   print STDERR '# ', $^X, ' ', $], "\n";
1117   if ( my $uname = `uname -a` ) {
1118      $uname =~ s/\s+/ /g;
1119      print STDERR "# $uname\n";
1120   }
1121   print STDERR '# Arguments: ',
1122      join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
1123}
1124
11251;
1126}
1127# ###########################################################################
1128# End OptionParser package
1129# ###########################################################################
1130
1131# ###########################################################################
1132# This is a combination of modules and programs in one -- a runnable module.
1133# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
1134# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
1135#
1136# Check at the end of this package for the call to main() which actually runs
1137# the program.
1138# ###########################################################################
1139package pt_align;
1140
1141use strict;
1142use warnings FATAL => 'all';
1143
1144use List::Util qw( max );
1145
1146sub main {
1147   local *ARGV; # In the extremely rare case that this is run as a module,
1148                # not resetting ARGV (the filehandle) could cause problems.
1149
1150   @ARGV = @_;  # set global ARGV for this package
1151
1152   my $o = OptionParser->new();
1153   $o->get_specs();
1154   $o->get_opts();
1155   $o->usage_or_errors();
1156
1157   # Read all lines
1158   my @lines;
1159   my %word_count;
1160   while ( <> ) {
1161      my $line = $_;
1162      my @words = $line =~ m/(\S+)/g;
1163      push @lines, \@words;
1164      $word_count{ scalar @words }++;
1165   }
1166
1167   # Find max number of words per line
1168   my @wc = reverse sort { $word_count{$a}<=>$word_count{$b} } keys %word_count;
1169   my $m_words = $wc[0];
1170
1171   # Filter out non-conformists
1172   @lines = grep { scalar @$_ == $m_words } @lines;
1173   die "I need at least 2 lines" unless @lines > 1;
1174
1175   # Find the widths and alignments of each column
1176   my @fmt;
1177   foreach my $i ( 0 .. $m_words-1 ) {
1178      my $m_len = max(map { length($_->[$i]) } @lines);
1179      my $code  = $lines[1]->[$i] =~ m/[^0-9.-]/
1180                ? "%-${m_len}s"
1181                : "%${m_len}s";
1182      push @fmt, $code;
1183   }
1184   my $fmt = join(' ', @fmt) . "\n";
1185
1186   # Print!
1187   foreach my $l ( @lines ) {
1188      printf $fmt, @$l;
1189   }
1190}
1191
1192# ############################################################################
1193# Run the program.
1194# ############################################################################
1195if ( !caller ) { exit main(@ARGV); }
1196
11971; # Because this is a module as well as a script.
1198
1199# ############################################################################
1200# Documentation
1201# ############################################################################
1202=pod
1203
1204=head1 NAME
1205
1206pt-align - Align output from other tools to columns.
1207
1208=head1 SYNOPSIS
1209
1210Usage: pt-align [FILES]
1211
1212pt-align aligns output from other tools to columns.  If no FILES are specified,
1213STDIN is read.
1214
1215If a tool prints the following output,
1216
1217   DATABASE TABLE   ROWS
1218   foo      bar      100
1219   long_db_name table  1
1220   another  long_name 500
1221
1222then pt-align reprints the output as,
1223
1224   DATABASE     TABLE     ROWS
1225   foo          bar        100
1226   long_db_name table        1
1227   another      long_name  500
1228
1229=head1 RISKS
1230
1231Percona Toolkit is mature, proven in the real world, and well tested,
1232but all database tools can pose a risk to the system and the database
1233server.  Before using this tool, please:
1234
1235=over
1236
1237=item * Read the tool's documentation
1238
1239=item * Review the tool's known L<"BUGS">
1240
1241=item * Test the tool on a non-production server
1242
1243=item * Backup your production server and verify the backups
1244
1245=back
1246
1247=head1 DESCRIPTION
1248
1249pt-align reads lines and splits them into words.  It counts how many
1250words each line has, and if there is one number that predominates, it assumes
1251this is the number of words in each line.  Then it discards all lines that
1252don't have that many words, and looks at the 2nd line that does.  It assumes
1253this is the first non-header line.  Based on whether each word looks numeric
1254or not, it decides on column alignment.  Finally, it goes through and decides
1255how wide each column should be, and then prints them out.
1256
1257This is useful for things like aligning the output of vmstat or iostat so it
1258is easier to read.
1259
1260=head1 OPTIONS
1261
1262This tool accepts additional command-line arguments.  Refer to the
1263L<"SYNOPSIS"> and usage information for details.
1264
1265=over
1266
1267=item --help
1268
1269Show help and exit.
1270
1271=item --version
1272
1273Show version and exit.
1274
1275=back
1276
1277=head1 ENVIRONMENT
1278
1279This tool does not use any environment variables.
1280
1281=head1 SYSTEM REQUIREMENTS
1282
1283You need Perl, and some core packages that ought to be installed in any
1284reasonably new version of Perl.
1285
1286=head1 BUGS
1287
1288For a list of known bugs, see L<http://www.percona.com/bugs/pt-align>.
1289
1290Please report bugs at L<https://jira.percona.com/projects/PT>.
1291Include the following information in your bug report:
1292
1293=over
1294
1295=item * Complete command-line used to run the tool
1296
1297=item * Tool L<"--version">
1298
1299=item * MySQL version of all servers involved
1300
1301=item * Output from the tool including STDERR
1302
1303=item * Input files (log/dump/config files, etc.)
1304
1305=back
1306
1307If possible, include debugging output by running the tool with C<PTDEBUG>;
1308see L<"ENVIRONMENT">.
1309
1310=head1 DOWNLOADING
1311
1312Visit L<http://www.percona.com/software/percona-toolkit/> to download the
1313latest release of Percona Toolkit.  Or, get the latest release from the
1314command line:
1315
1316   wget percona.com/get/percona-toolkit.tar.gz
1317
1318   wget percona.com/get/percona-toolkit.rpm
1319
1320   wget percona.com/get/percona-toolkit.deb
1321
1322You can also get individual tools from the latest release:
1323
1324   wget percona.com/get/TOOL
1325
1326Replace C<TOOL> with the name of any tool.
1327
1328=head1 AUTHORS
1329
1330Baron Schwartz, Brian Fraser, and Daniel Nichter
1331
1332=head1 ABOUT PERCONA TOOLKIT
1333
1334This tool is part of Percona Toolkit, a collection of advanced command-line
1335tools for MySQL developed by Percona.  Percona Toolkit was forked from two
1336projects in June, 2011: Maatkit and Aspersa.  Those projects were created by
1337Baron Schwartz and primarily developed by him and Daniel Nichter.  Visit
1338L<http://www.percona.com/software/> to learn about other free, open-source
1339software from Percona.
1340
1341=head1 COPYRIGHT, LICENSE, AND WARRANTY
1342
1343This program is copyright 2011-2018 Percona LLC and/or its affiliates,
13442010-2011 Baron Schwartz.
1345
1346THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
1347WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
1348MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
1349
1350This program is free software; you can redistribute it and/or modify it under
1351the terms of the GNU General Public License as published by the Free Software
1352Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
1353systems, you can issue `man perlgpl' or `man perlartistic' to read these
1354licenses.
1355
1356You should have received a copy of the GNU General Public License along with
1357this program; if not, write to the Free Software Foundation, Inc., 59 Temple
1358Place, Suite 330, Boston, MA  02111-1307  USA.
1359
1360=head1 VERSION
1361
1362pt-align 3.3.0
1363
1364=cut
1365