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