diff --git a/bin/pt-eustack-resolver b/bin/pt-eustack-resolver index 8975bae6..ab50b92b 100755 --- a/bin/pt-eustack-resolver +++ b/bin/pt-eustack-resolver @@ -5,9 +5,1352 @@ # notices and disclaimers. use strict; +#use warnings FATAL => 'all'; + +# This tool is "fat-packed": most of its dependent modules are embedded +# in this file. Setting %INC to this file for each module makes Perl aware +# of this so it will not try to load the module from @INC. See the tool's +# documentation for a full list of dependencies. +BEGIN { + $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw( + Percona::Toolkit + VersionCompare + OptionParser + )); +} + +# ########################################################################### +# Percona::Toolkit package +# This package is a copy without comments from the original. The original +# with comments and its test file can be found in the GitHub repository at, +# lib/Percona/Toolkit.pm +# t/lib/Percona/Toolkit.t +# See https://github.com/percona/percona-toolkit for more information. +# ########################################################################### +{ +package Percona::Toolkit; + +our $VERSION = '3.7.1'; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use constant PTDEBUG => $ENV{PTDEBUG} || 0; + +use Carp qw(carp cluck); +use Data::Dumper qw(); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + have_required_args + Dumper + _d +); + +sub have_required_args { + my ($args, @required_args) = @_; + my $have_required_args = 1; + foreach my $arg ( @required_args ) { + if ( !defined $args->{$arg} ) { + $have_required_args = 0; + carp "Argument $arg is not defined"; + } + } + cluck unless $have_required_args; # print backtrace + return $have_required_args; +} + +sub Dumper { + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; + Data::Dumper::Dumper(@_); +} + +sub _d { + my ($package, undef, $line) = caller 0; + @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } + map { defined $_ ? $_ : 'undef' } + @_; + print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; +} + +1; +} +# ########################################################################### +# End Percona::Toolkit package +# ########################################################################### +# + +# ########################################################################### +# VersionCompare package +# This package is a copy without comments from the original. The original +# with comments and its test file can be found in the GitHub repository at, +# lib/VersionCompare.pm +# t/lib/VersionCompare.t +# See https://github.com/percona/percona-toolkit for more information. +# ########################################################################### +{ +package VersionCompare; + +use strict; +use English qw(-no_match_vars); +use constant PTDEBUG => $ENV{PTDEBUG} || 0; + +sub cmp { + my ($v1, $v2) = @_; + + $v1 =~ s/[^\d\.]//; + $v2 =~ s/[^\d\.]//; + + my @a = ( $v1 =~ /(\d+)\.?/g ); + my @b = ( $v2 =~ /(\d+)\.?/g ); + foreach my $n1 (@a) { + $n1 += 0; #convert to number + if (!@b) { + return 1; + } + my $n2 = shift @b; + $n2 += 0; # convert to number + if ($n1 == $n2) { + next; + } + else { + return $n1 <=> $n2; + } + } + return @b ? -1 : 0; +} + + +1; +} +# ########################################################################### +# End VersionCompare package +# ########################################################################### + +# ########################################################################### +# OptionParser package +# This package is a copy without comments from the original. The original +# with comments and its test file can be found in the GitHub repository at, +# lib/OptionParser.pm +# t/lib/OptionParser.t +# See https://github.com/percona/percona-toolkit for more information. +# ########################################################################### +{ +package OptionParser; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use constant PTDEBUG => $ENV{PTDEBUG} || 0; + +use List::Util qw(max); +use Getopt::Long; use Data::Dumper; -my $mmap; +my $POD_link_re = '[LC]<"?([^">]+)"?>'; + +sub new { + my ( $class, %args ) = @_; + my @required_args = qw(); + foreach my $arg ( @required_args ) { + die "I need a $arg argument" unless $args{$arg}; + } + + my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/; + $program_name ||= $PROGRAM_NAME; + my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; + + my %attributes = ( + 'type' => 1, + 'short form' => 1, + 'group' => 1, + 'default' => 1, + 'cumulative' => 1, + 'negatable' => 1, + 'repeatable' => 1, # means it can be specified more than once + ); + + my $self = { + head1 => 'OPTIONS', # These args are used internally + skip_rules => 0, # to instantiate another Option- + item => '--(.*)', # Parser obj that parses the + attributes => \%attributes, # DSN OPTIONS section. Tools + parse_attributes => \&_parse_attribs, # don't tinker with these args. + + %args, + + strict => 1, # disabled by a special rule + program_name => $program_name, + opts => {}, + got_opts => 0, + short_opts => {}, + defaults => {}, + groups => {}, + allowed_groups => {}, + errors => [], + rules => [], # desc of rules for --help + mutex => [], # rule: opts are mutually exclusive + atleast1 => [], # rule: at least one opt is required + disables => {}, # rule: opt disables other opts + defaults_to => {}, # rule: opt defaults to value of other opt + DSNParser => undef, + default_files => [ + "/etc/percona-toolkit/percona-toolkit.conf", + "/etc/percona-toolkit/$program_name.conf", + "$home/.percona-toolkit.conf", + "$home/.$program_name.conf", + ], + types => { + string => 's', # standard Getopt type + int => 'i', # standard Getopt type + float => 'f', # standard Getopt type + Hash => 'H', # hash, formed from a comma-separated list + hash => 'h', # hash as above, but only if a value is given + Array => 'A', # array, similar to Hash + array => 'a', # array, similar to hash + DSN => 'd', # DSN + size => 'z', # size with kMG suffix (powers of 2^10) + time => 'm', # time, with an optional suffix of s/h/m/d + }, + }; + + return bless $self, $class; +} + +sub get_specs { + my ( $self, $file ) = @_; + $file ||= $self->{file} || __FILE__; + my @specs = $self->_pod_to_specs($file); + $self->_parse_specs(@specs); + + open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; + my $contents = do { local $/ = undef; <$fh> }; + close $fh; + if ( $contents =~ m/^=head1 DSN OPTIONS/m ) { + PTDEBUG && _d('Parsing DSN OPTIONS'); + my $dsn_attribs = { + dsn => 1, + copy => 1, + }; + my $parse_dsn_attribs = sub { + my ( $self, $option, $attribs ) = @_; + map { + my $val = $attribs->{$_}; + if ( $val ) { + $val = $val eq 'yes' ? 1 + : $val eq 'no' ? 0 + : $val; + $attribs->{$_} = $val; + } + } keys %$attribs; + return { + key => $option, + %$attribs, + }; + }; + my $dsn_o = new OptionParser( + description => 'DSN OPTIONS', + head1 => 'DSN OPTIONS', + dsn => 0, # XXX don't infinitely recurse! + item => '\* (.)', # key opts are a single character + skip_rules => 1, # no rules before opts + attributes => $dsn_attribs, + parse_attributes => $parse_dsn_attribs, + ); + my @dsn_opts = map { + my $opts = { + key => $_->{spec}->{key}, + dsn => $_->{spec}->{dsn}, + copy => $_->{spec}->{copy}, + desc => $_->{desc}, + }; + $opts; + } $dsn_o->_pod_to_specs($file); + $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts); + } + + if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) { + $self->{version} = $1; + PTDEBUG && _d($self->{version}); + } + + return; +} + +sub DSNParser { + my ( $self ) = @_; + return $self->{DSNParser}; +}; + +sub get_defaults_files { + my ( $self ) = @_; + return @{$self->{default_files}}; +} + +sub _pod_to_specs { + my ( $self, $file ) = @_; + $file ||= $self->{file} || __FILE__; + open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR"; + + my @specs = (); + my @rules = (); + my $para; + + local $INPUT_RECORD_SEPARATOR = ''; + while ( $para = <$fh> ) { + next unless $para =~ m/^=head1 $self->{head1}/; + last; + } + + while ( $para = <$fh> ) { + last if $para =~ m/^=over/; + next if $self->{skip_rules}; + chomp $para; + $para =~ s/\s+/ /g; + $para =~ s/$POD_link_re/$1/go; + PTDEBUG && _d('Option rule:', $para); + push @rules, $para; + } + + die "POD has no $self->{head1} section" unless $para; + + do { + if ( my ($option) = $para =~ m/^=item $self->{item}/ ) { + chomp $para; + PTDEBUG && _d($para); + my %attribs; + + $para = <$fh>; # read next paragraph, possibly attributes + + if ( $para =~ m/: / ) { # attributes + $para =~ s/\s+\Z//g; + %attribs = map { + my ( $attrib, $val) = split(/: /, $_); + die "Unrecognized attribute for --$option: $attrib" + unless $self->{attributes}->{$attrib}; + ($attrib, $val); + } split(/; /, $para); + if ( $attribs{'short form'} ) { + $attribs{'short form'} =~ s/-//; + } + $para = <$fh>; # read next paragraph, probably short help desc + } + else { + PTDEBUG && _d('Option has no attributes'); + } + + $para =~ s/\s+\Z//g; + $para =~ s/\s+/ /g; + $para =~ s/$POD_link_re/$1/go; + + $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s; + PTDEBUG && _d('Short help:', $para); + + die "No description after option spec $option" if $para =~ m/^=item/; + + if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) { + $option = $base_option; + $attribs{'negatable'} = 1; + } + + push @specs, { + spec => $self->{parse_attributes}->($self, $option, \%attribs), + desc => $para + . (defined $attribs{default} ? " (default $attribs{default})" : ''), + group => ($attribs{'group'} ? $attribs{'group'} : 'default'), + attributes => \%attribs + }; + } + while ( $para = <$fh> ) { + last unless $para; + if ( $para =~ m/^=head1/ ) { + $para = undef; # Can't 'last' out of a do {} block. + last; + } + last if $para =~ m/^=item /; + } + } while ( $para ); + + die "No valid specs in $self->{head1}" unless @specs; + + close $fh; + return @specs, @rules; +} + +sub _parse_specs { + my ( $self, @specs ) = @_; + my %disables; # special rule that requires deferred checking + + foreach my $opt ( @specs ) { + if ( ref $opt ) { # It's an option spec, not a rule. + PTDEBUG && _d('Parsing opt spec:', + map { ($_, '=>', $opt->{$_}) } keys %$opt); + + my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/; + if ( !$long ) { + die "Cannot parse long option from spec $opt->{spec}"; + } + $opt->{long} = $long; + + die "Duplicate long option --$long" if exists $self->{opts}->{$long}; + $self->{opts}->{$long} = $opt; + + if ( length $long == 1 ) { + PTDEBUG && _d('Long opt', $long, 'looks like short opt'); + $self->{short_opts}->{$long} = $long; + } + + if ( $short ) { + die "Duplicate short option -$short" + if exists $self->{short_opts}->{$short}; + $self->{short_opts}->{$short} = $long; + $opt->{short} = $short; + } + else { + $opt->{short} = undef; + } + + $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0; + $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0; + $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0; + $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0; + + $opt->{group} ||= 'default'; + $self->{groups}->{ $opt->{group} }->{$long} = 1; + + $opt->{value} = undef; + $opt->{got} = 0; + + my ( $type ) = $opt->{spec} =~ m/=(.)/; + $opt->{type} = $type; + PTDEBUG && _d($long, 'type:', $type); + + + $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ ); + + if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) { + $def = defined $def ? $def : 1; + $def = $def eq 'yes' ? 1 : $def eq 'no' ? 0 : $def; + $self->{defaults}->{$long} = $def; + PTDEBUG && _d($long, 'default:', $def); + } + + if ( $long eq 'config' ) { + $self->{defaults}->{$long} = join(',', $self->get_defaults_files()); + } + + if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) { + $disables{$long} = $dis; + PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis); + } + + $self->{opts}->{$long} = $opt; + } + else { # It's an option rule, not a spec. + PTDEBUG && _d('Parsing rule:', $opt); + push @{$self->{rules}}, $opt; + my @participants = $self->_get_participants($opt); + my $rule_ok = 0; + + if ( $opt =~ m/mutually exclusive|one and only one/ ) { + $rule_ok = 1; + push @{$self->{mutex}}, \@participants; + PTDEBUG && _d(@participants, 'are mutually exclusive'); + } + if ( $opt =~ m/at least one|one and only one/ ) { + $rule_ok = 1; + push @{$self->{atleast1}}, \@participants; + PTDEBUG && _d(@participants, 'require at least one'); + } + if ( $opt =~ m/default to/ ) { + $rule_ok = 1; + $self->{defaults_to}->{$participants[0]} = $participants[1]; + PTDEBUG && _d($participants[0], 'defaults to', $participants[1]); + } + if ( $opt =~ m/restricted to option groups/ ) { + $rule_ok = 1; + my ($groups) = $opt =~ m/groups ([\w\s\,]+)/; + my @groups = split(',', $groups); + %{$self->{allowed_groups}->{$participants[0]}} = map { + s/\s+//; + $_ => 1; + } @groups; + } + if( $opt =~ m/accepts additional command-line arguments/ ) { + $rule_ok = 1; + $self->{strict} = 0; + PTDEBUG && _d("Strict mode disabled by rule"); + } + + die "Unrecognized option rule: $opt" unless $rule_ok; + } + } + + foreach my $long ( keys %disables ) { + my @participants = $self->_get_participants($disables{$long}); + $self->{disables}->{$long} = \@participants; + PTDEBUG && _d('Option', $long, 'disables', @participants); + } + + return; +} + +sub _get_participants { + my ( $self, $str ) = @_; + my @participants; + foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) { + die "Option --$long does not exist while processing rule $str" + unless exists $self->{opts}->{$long}; + push @participants, $long; + } + PTDEBUG && _d('Participants for', $str, ':', @participants); + return @participants; +} + +sub opts { + my ( $self ) = @_; + my %opts = %{$self->{opts}}; + return %opts; +} + +sub short_opts { + my ( $self ) = @_; + my %short_opts = %{$self->{short_opts}}; + return %short_opts; +} + +sub set_defaults { + my ( $self, %defaults ) = @_; + $self->{defaults} = {}; + foreach my $long ( keys %defaults ) { + die "Cannot set default for nonexistent option $long" + unless exists $self->{opts}->{$long}; + $self->{defaults}->{$long} = $defaults{$long}; + PTDEBUG && _d('Default val for', $long, ':', $defaults{$long}); + } + return; +} + +sub get_defaults { + my ( $self ) = @_; + return $self->{defaults}; +} + +sub get_groups { + my ( $self ) = @_; + return $self->{groups}; +} + +sub _set_option { + my ( $self, $opt, $val ) = @_; + my $long = exists $self->{opts}->{$opt} ? $opt + : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt} + : die "Getopt::Long gave a nonexistent option: $opt"; + $opt = $self->{opts}->{$long}; + if ( $opt->{is_cumulative} ) { + $opt->{value}++; + } + elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) { + my $next_opt = $1; + if ( exists $self->{opts}->{$next_opt} + || exists $self->{short_opts}->{$next_opt} ) { + $self->save_error("--$long requires a string value"); + return; + } + else { + if ($opt->{is_repeatable}) { + push @{$opt->{value}} , $val; + } + else { + $opt->{value} = $val; + } + } + } + else { + if ($opt->{is_repeatable}) { + push @{$opt->{value}} , $val; + } + else { + $opt->{value} = $val; + } + } + $opt->{got} = 1; + PTDEBUG && _d('Got option', $long, '=', $val); +} + +sub get_opts { + my ( $self ) = @_; + + foreach my $long ( keys %{$self->{opts}} ) { + $self->{opts}->{$long}->{got} = 0; + $self->{opts}->{$long}->{value} + = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long} + : $self->{opts}->{$long}->{is_cumulative} ? 0 + : undef; + } + $self->{got_opts} = 0; + + $self->{errors} = []; + + if ( @ARGV && $ARGV[0] =~/^--config=/ ) { + $ARGV[0] = substr($ARGV[0],9); + $ARGV[0] =~ s/^'(.*)'$/$1/; + $ARGV[0] =~ s/^"(.*)"$/$1/; + $self->_set_option('config', shift @ARGV); + } + if ( @ARGV && $ARGV[0] eq "--config" ) { + shift @ARGV; + $self->_set_option('config', shift @ARGV); + } + if ( $self->has('config') ) { + my @extra_args; + foreach my $filename ( split(',', $self->get('config')) ) { + eval { + push @extra_args, $self->_read_config_file($filename); + }; + if ( $EVAL_ERROR ) { + if ( $self->got('config') ) { + die $EVAL_ERROR; + } + elsif ( PTDEBUG ) { + _d($EVAL_ERROR); + } + } + } + unshift @ARGV, @extra_args; + } + + Getopt::Long::Configure('no_ignore_case', 'bundling'); + GetOptions( + map { $_->{spec} => sub { $self->_set_option(@_); } } + grep { $_->{long} ne 'config' } # --config is handled specially above. + values %{$self->{opts}} + ) or $self->save_error('Error parsing options'); + + if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) { + if ( $self->{version} ) { + print $self->{version}, "\n"; + exit 0; + } + else { + print "Error parsing version. See the VERSION section of the tool's documentation.\n"; + exit 1; + } + } + + if ( exists $self->{opts}->{'buffer-stdout'} && $self->{opts}->{'buffer-stdout'}->{got} ) { + STDOUT->autoflush(1 - $self->{opts}->{'buffer-stdout'}->{value}); + } + + if ( @ARGV && $self->{strict} ) { + $self->save_error("Unrecognized command-line options @ARGV"); + } + + foreach my $mutex ( @{$self->{mutex}} ) { + my @set = grep { $self->{opts}->{$_}->{got} } @$mutex; + if ( @set > 1 ) { + my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } + @{$mutex}[ 0 .. scalar(@$mutex) - 2] ) + . ' and --'.$self->{opts}->{$mutex->[-1]}->{long} + . ' are mutually exclusive.'; + $self->save_error($err); + } + } + + foreach my $required ( @{$self->{atleast1}} ) { + my @set = grep { $self->{opts}->{$_}->{got} } @$required; + if ( @set == 0 ) { + my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } + @{$required}[ 0 .. scalar(@$required) - 2] ) + .' or --'.$self->{opts}->{$required->[-1]}->{long}; + $self->save_error("Specify at least one of $err"); + } + } + + $self->_check_opts( keys %{$self->{opts}} ); + $self->{got_opts} = 1; + return; +} + +sub _check_opts { + my ( $self, @long ) = @_; + my $long_last = scalar @long; + while ( @long ) { + foreach my $i ( 0..$#long ) { + my $long = $long[$i]; + next unless $long; + my $opt = $self->{opts}->{$long}; + if ( $opt->{got} ) { + if ( exists $self->{disables}->{$long} ) { + my @disable_opts = @{$self->{disables}->{$long}}; + map { $self->{opts}->{$_}->{value} = undef; } @disable_opts; + PTDEBUG && _d('Unset options', @disable_opts, + 'because', $long,'disables them'); + } + + if ( exists $self->{allowed_groups}->{$long} ) { + + my @restricted_groups = grep { + !exists $self->{allowed_groups}->{$long}->{$_} + } keys %{$self->{groups}}; + + my @restricted_opts; + foreach my $restricted_group ( @restricted_groups ) { + RESTRICTED_OPT: + foreach my $restricted_opt ( + keys %{$self->{groups}->{$restricted_group}} ) + { + next RESTRICTED_OPT if $restricted_opt eq $long; + push @restricted_opts, $restricted_opt + if $self->{opts}->{$restricted_opt}->{got}; + } + } + + if ( @restricted_opts ) { + my $err; + if ( @restricted_opts == 1 ) { + $err = "--$restricted_opts[0]"; + } + else { + $err = join(', ', + map { "--$self->{opts}->{$_}->{long}" } + grep { $_ } + @restricted_opts[0..scalar(@restricted_opts) - 2] + ) + . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long}; + } + $self->save_error("--$long is not allowed with $err"); + } + } + + } + elsif ( $opt->{is_required} ) { + $self->save_error("Required option --$long must be specified"); + } + + $self->_validate_type($opt); + if ( $opt->{parsed} ) { + delete $long[$i]; + } + else { + PTDEBUG && _d('Temporarily failed to parse', $long); + } + } + + die "Failed to parse options, possibly due to circular dependencies" + if @long == $long_last; + $long_last = @long; + } + + return; +} + +sub _validate_type { + my ( $self, $opt ) = @_; + return unless $opt; + + if ( !$opt->{type} ) { + $opt->{parsed} = 1; + return; + } + + my $val = $opt->{value}; + + if ( $val && $opt->{type} eq 'm' ) { # type time + PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value'); + my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; + if ( !$suffix ) { + my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/; + $suffix = $s || 's'; + PTDEBUG && _d('No suffix given; using', $suffix, 'for', + $opt->{long}, '(value:', $val, ')'); + } + if ( $suffix =~ m/[smhd]/ ) { + $val = $suffix eq 's' ? $num # Seconds + : $suffix eq 'm' ? $num * 60 # Minutes + : $suffix eq 'h' ? $num * 3600 # Hours + : $num * 86400; # Days + $opt->{value} = ($prefix || '') . $val; + PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val); + } + else { + $self->save_error("Invalid time suffix for --$opt->{long}"); + } + } + elsif ( $val && $opt->{type} eq 'd' ) { # type DSN + PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN'); + my $prev = {}; + my $from_key = $self->{defaults_to}->{ $opt->{long} }; + if ( $from_key ) { + PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN'); + if ( $self->{opts}->{$from_key}->{parsed} ) { + $prev = $self->{opts}->{$from_key}->{value}; + } + else { + PTDEBUG && _d('Cannot parse', $opt->{long}, 'until', + $from_key, 'parsed'); + return; + } + } + my $defaults = $self->{DSNParser}->parse_options($self); + if (!$opt->{attributes}->{repeatable}) { + $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); + } else { + my $values = []; + for my $dsn_string (@$val) { + push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults); + } + $opt->{value} = $values; + } + } + elsif ( $val && $opt->{type} eq 'z' ) { # type size + PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value'); + $self->_parse_size($opt, $val); + } + elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) { + $opt->{value} = { map { $_ => 1 } split(/(?{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) { + $opt->{value} = [ split(/(?{long}, 'type', $opt->{type}, 'value', $val); + } + + $opt->{parsed} = 1; + return; +} + +sub get { + my ( $self, $opt ) = @_; + my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); + die "Option $opt does not exist" + unless $long && exists $self->{opts}->{$long}; + return $self->{opts}->{$long}->{value}; +} + +sub got { + my ( $self, $opt ) = @_; + my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); + die "Option $opt does not exist" + unless $long && exists $self->{opts}->{$long}; + return $self->{opts}->{$long}->{got}; +} + +sub has { + my ( $self, $opt ) = @_; + my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); + return defined $long ? exists $self->{opts}->{$long} : 0; +} + +sub set { + my ( $self, $opt, $val ) = @_; + my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); + die "Option $opt does not exist" + unless $long && exists $self->{opts}->{$long}; + $self->{opts}->{$long}->{value} = $val; + return; +} + +sub save_error { + my ( $self, $error ) = @_; + push @{$self->{errors}}, $error; + return; +} + +sub errors { + my ( $self ) = @_; + return $self->{errors}; +} + +sub usage { + my ( $self ) = @_; + warn "No usage string is set" unless $self->{usage}; # XXX + return "Usage: " . ($self->{usage} || '') . "\n"; +} + +sub descr { + my ( $self ) = @_; + warn "No description string is set" unless $self->{description}; # XXX + my $descr = ($self->{description} || $self->{program_name} || '') + . " For more details, please use the --help option, " + . "or try 'perldoc $PROGRAM_NAME' " + . "for complete documentation."; + $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g) + unless $ENV{DONT_BREAK_LINES}; + $descr =~ s/ +$//mg; + return $descr; +} + +sub usage_or_errors { + my ( $self, $file, $return ) = @_; + $file ||= $self->{file} || __FILE__; + + if ( !$self->{description} || !$self->{usage} ) { + PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file); + my %synop = $self->_parse_synopsis($file); + $self->{description} ||= $synop{description}; + $self->{usage} ||= $synop{usage}; + PTDEBUG && _d("Description:", $self->{description}, + "\nUsage:", $self->{usage}); + } + + if ( $self->{opts}->{help}->{got} ) { + print $self->print_usage() or die "Cannot print usage: $OS_ERROR"; + exit 0 unless $return; + } + elsif ( scalar @{$self->{errors}} ) { + print $self->print_errors() or die "Cannot print errors: $OS_ERROR"; + exit 1 unless $return; + } + + return; +} + +sub print_errors { + my ( $self ) = @_; + my $usage = $self->usage() . "\n"; + if ( (my @errors = @{$self->{errors}}) ) { + $usage .= join("\n * ", 'Errors in command-line arguments:', @errors) + . "\n"; + } + return $usage . "\n" . $self->descr(); +} + +sub print_usage { + my ( $self ) = @_; + die "Run get_opts() before print_usage()" unless $self->{got_opts}; + my @opts = values %{$self->{opts}}; + + my $maxl = max( + map { + length($_->{long}) # option long name + + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable + + ($_->{type} ? 2 : 0) # "=x" where x is the opt type + } + @opts); + + my $maxs = max(0, + map { + length($_) + + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) + + ($self->{opts}->{$_}->{type} ? 2 : 0) + } + values %{$self->{short_opts}}); + + my $lcol = max($maxl, ($maxs + 3)); + my $rcol = 80 - $lcol - 6; + my $rpad = ' ' x ( 80 - $rcol ); + + $maxs = max($lcol - 3, $maxs); + + my $usage = $self->descr() . "\n" . $self->usage(); + + my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}}; + push @groups, 'default'; + + foreach my $group ( reverse @groups ) { + $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n"; + foreach my $opt ( + sort { $a->{long} cmp $b->{long} } + grep { $_->{group} eq $group } + @opts ) + { + my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long}; + my $short = $opt->{short}; + my $desc = $opt->{desc}; + + $long .= $opt->{type} ? "=$opt->{type}" : ""; + + if ( $opt->{type} && $opt->{type} eq 'm' ) { + my ($s) = $desc =~ m/\(suffix (.)\)/; + $s ||= 's'; + $desc =~ s/\s+\(suffix .\)//; + $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, " + . "d=days; if no suffix, $s is used."; + } + $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g); + $desc =~ s/ +$//mg; + if ( $short ) { + $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc); + } + else { + $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc); + } + } + } + + $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n"; + + if ( (my @rules = @{$self->{rules}}) ) { + $usage .= "\nRules:\n\n"; + $usage .= join("\n", map { " $_" } @rules) . "\n"; + } + if ( $self->{DSNParser} ) { + $usage .= "\n" . $self->{DSNParser}->usage(); + } + $usage .= "\nOptions and values after processing arguments:\n\n"; + foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) { + my $val = $opt->{value}; + my $type = $opt->{type} || ''; + my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/; + $val = $bool ? ( $val ? 'TRUE' : 'FALSE' ) + : !defined $val ? '(No value)' + : $type eq 'd' ? $self->{DSNParser}->as_string($val) + : $type =~ m/H|h/ ? join(',', sort keys %$val) + : $type =~ m/A|a/ ? join(',', @$val) + : $val; + $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val); + } + return $usage; +} + +sub prompt_noecho { + shift @_ if ref $_[0] eq __PACKAGE__; + my ( $prompt ) = @_; + local $OUTPUT_AUTOFLUSH = 1; + print STDERR $prompt + or die "Cannot print: $OS_ERROR"; + my $response; + eval { + require Term::ReadKey; + Term::ReadKey::ReadMode('noecho'); + chomp($response = ); + Term::ReadKey::ReadMode('normal'); + print "\n" + or die "Cannot print: $OS_ERROR"; + }; + if ( $EVAL_ERROR ) { + die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR"; + } + return $response; +} + +sub _read_config_file { + my ( $self, $filename ) = @_; + open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n"; + my @args; + my $prefix = '--'; + my $parse = 1; + + LINE: + while ( my $line = <$fh> ) { + chomp $line; + next LINE if $line =~ m/^\s*(?:\#|\;|$)/; + $line =~ s/\s+#.*$//g; + $line =~ s/^\s+|\s+$//g; + if ( $line eq '--' ) { + $prefix = ''; + $parse = 0; + next LINE; + } + + if ( $parse + && !$self->has('version-check') + && $line =~ /version-check/ + ) { + next LINE; + } + + if ( $parse + && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/) + ) { + push @args, grep { defined $_ } ("$prefix$opt", $arg); + } + elsif ( $line =~ m/./ ) { + push @args, $line; + } + else { + die "Syntax error in file $filename at line $INPUT_LINE_NUMBER"; + } + } + close $fh; + return @args; +} + +sub read_para_after { + my ( $self, $file, $regex ) = @_; + open my $fh, "<", $file or die "Can't open $file: $OS_ERROR"; + local $INPUT_RECORD_SEPARATOR = ''; + my $para; + while ( $para = <$fh> ) { + next unless $para =~ m/^=pod$/m; + last; + } + while ( $para = <$fh> ) { + next unless $para =~ m/$regex/; + last; + } + $para = <$fh>; + chomp($para); + close $fh or die "Can't close $file: $OS_ERROR"; + return $para; +} + +sub clone { + my ( $self ) = @_; + + my %clone = map { + my $hashref = $self->{$_}; + my $val_copy = {}; + foreach my $key ( keys %$hashref ) { + my $ref = ref $hashref->{$key}; + $val_copy->{$key} = !$ref ? $hashref->{$key} + : $ref eq 'HASH' ? { %{$hashref->{$key}} } + : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ] + : $hashref->{$key}; + } + $_ => $val_copy; + } qw(opts short_opts defaults); + + foreach my $scalar ( qw(got_opts) ) { + $clone{$scalar} = $self->{$scalar}; + } + + return bless \%clone; +} + +sub _parse_size { + my ( $self, $opt, $val ) = @_; + + if ( lc($val || '') eq 'null' ) { + PTDEBUG && _d('NULL size for', $opt->{long}); + $opt->{value} = 'null'; + return; + } + + my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824); + my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/; + if ( defined $num ) { + if ( $factor ) { + $num *= $factor_for{$factor}; + PTDEBUG && _d('Setting option', $opt->{y}, + 'to num', $num, '* factor', $factor); + } + $opt->{value} = ($pre || '') . $num; + } + else { + $self->save_error("Invalid size for --$opt->{long}: $val"); + } + return; +} + +sub _parse_attribs { + my ( $self, $option, $attribs ) = @_; + my $types = $self->{types}; + return $option + . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' ) + . ($attribs->{'negatable'} ? '!' : '' ) + . ($attribs->{'cumulative'} ? '+' : '' ) + . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' ); +} + +sub _parse_synopsis { + my ( $self, $file ) = @_; + $file ||= $self->{file} || __FILE__; + PTDEBUG && _d("Parsing SYNOPSIS in", $file); + + local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs + open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; + my $para; + 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/; + die "$file does not contain a SYNOPSIS section" unless $para; + my @synop; + for ( 1..2 ) { # 1 for the usage, 2 for the description + my $para = <$fh>; + push @synop, $para; + } + close $fh; + PTDEBUG && _d("Raw SYNOPSIS text:", @synop); + my ($usage, $desc) = @synop; + die "The SYNOPSIS section in $file is not formatted properly" + unless $usage && $desc; + + $usage =~ s/^\s*Usage:\s+(.+)/$1/; + chomp $usage; + + $desc =~ s/\n/ /g; + $desc =~ s/\s{2,}/ /g; + $desc =~ s/\. ([A-Z][a-z])/. $1/g; + $desc =~ s/\s+$//; + + return ( + description => $desc, + usage => $usage, + ); +}; + +sub set_vars { + my ($self, $file) = @_; + $file ||= $self->{file} || __FILE__; + + my %user_vars; + my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef; + if ( $user_vars ) { + foreach my $var_val ( @$user_vars ) { + my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; + die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; + $user_vars{$var} = { + val => $val, + default => 0, + }; + } + } + + my %default_vars; + my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/); + if ( $default_vars ) { + %default_vars = map { + my $var_val = $_; + my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; + die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; + $var => { + val => $val, + default => 1, + }; + } split("\n", $default_vars); + } + + my %vars = ( + %default_vars, # first the tool's defaults + %user_vars, # then the user's which overwrite the defaults + ); + PTDEBUG && _d('--set-vars:', Dumper(\%vars)); + return \%vars; +} + +sub _d { + my ($package, undef, $line) = caller 0; + @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } + map { defined $_ ? $_ : 'undef' } + @_; + print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; +} + +if ( PTDEBUG ) { + print STDERR '# ', $^X, ' ', $], "\n"; + if ( my $uname = `uname -a` ) { + $uname =~ s/\s+/ /g; + print STDERR "# $uname\n"; + } + print STDERR '# Arguments: ', + join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; +} + +1; +} +# ########################################################################### +# End OptionParser package +# ########################################################################### + + +# ########################################################################### +# This is a combination of modules and programs in one -- a runnable module. +# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last +# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition. +# +# Check at the end of this package for the call to main() which actually runs +# the program. +# ########################################################################### +package pt_eu_stack_resolver; + +use strict; +#use warnings FATAL => 'all'; + +use Percona::Toolkit; +use constant PTDEBUG => $ENV{PTDEBUG} || 0; + +use Data::Dumper; +use VersionCompare; +$Data::Dumper::Indent = 1; +$Data::Dumper::Sortkeys = 1; +$Data::Dumper::Quotekeys = 0; + +my $exit_status; + +sub main { + local @ARGV = @_; + + # Reset global vars else tests will fail. + $exit_status = 0; + + my $o = new OptionParser(); + $o->get_specs(); + $o->get_opts(); + + my $pid = shift @ARGV; + if ( !$pid ) { + $o->save_error('A PID must be specified'); + } + + $o->usage_or_errors(); + + my $mmap = load_mapping($pid); + + open (my $STACK_TRACE, "eu-stack -q -p $pid 2>/dev/null|") or die "open(): $!"; + my @lines= <$STACK_TRACE>; + close($STACK_TRACE); + + my $frame_no= 0; + my %addr=(); + my %sf=(); + my $lwp; + + for my $line (@lines) { + if ($line =~ /^TID ([0-9]+):/) + { + $frame_no= 0; + $lwp=$1; + } + elsif ($line =~ /^#[0-9]+?\s*0x([a-f0-9]+)/) + { + push @{$sf{$lwp}},$1; + $addr{$1}=[get_image(hex($1), $mmap),""]; + } else { + #print $line; + } + } + + my %inverse; + push @{ $inverse{ $addr{$_}->[0] } }, $_ for keys %addr; + + foreach my $bin (keys %inverse) + { + my $addrs=join(" ",@{$inverse{$bin}}); + my @resolved=(); + + @resolved=(`eu-addr2line --pretty-print -s -C -f -p $pid $addrs`); + + my $idx=0; + foreach $a (@{$inverse{$bin}}) + { + $addr{$a}->[1]=$resolved[$idx]; + $addr{$a}->[1]=~ s/\n//; + $addr{$a}->[1]=~ s/at \?\?:0/from $addr{$a}->[0]/; + $idx++; + } + } + + foreach $lwp (sort {$a<=>$b} keys %sf) + { + my $idx=0; + print "Thread $lwp (LWP $lwp):\n"; + foreach $frame_no (@{$sf{$lwp}}) + { + print join(" ","#".$idx, "0x".$frame_no,"in", $addr{$frame_no}->[1]),"\n"; + $idx++; + } + print "\n"; + } +} + +# ############################################################################ +# Subroutines. +# ############################################################################ sub load_mapping { my ($pid)= @_; @@ -28,13 +1371,11 @@ sub load_mapping { } close $FH; sort { $a->{S} <=> $b->{S} } @$arr; - $mmap= $arr; + return $arr; } -my $syms= { }; - sub get_image { - my ($addr)= @_; + my ($addr, $mmap)= @_; # Ensure addr is defined die "Address is undefined" unless defined $addr; @@ -52,72 +1393,16 @@ sub get_image { return ""; } -die "Usage: $0 " unless @ARGV == 1; +# ############################################################################ +# Run the program. +# ############################################################################ +if ( !caller ) { exit main(@ARGV); } -my $pid= $ARGV[0]; -load_mapping($pid); +1; # Because this is a module as well as a script. -open (my $STACK_TRACE, "eu-stack -q -p $pid 2>/dev/null|") or die "open(): $!"; -my @lines= <$STACK_TRACE>; -close($STACK_TRACE); - -my $frame_no= 0; -my %addr=(); -my %sf=(); -my $lwp; - -for my $line (@lines) { - if ($line =~ /^TID ([0-9]+):/) - { - $frame_no= 0; - $lwp=$1; - } - elsif ($line =~ /^#[0-9]+?\s*0x([a-f0-9]+)/) - { - push @{$sf{$lwp}},$1; - $addr{$1}=[get_image(hex($1)),""]; - } else { - #print $line; - } -} - -my %inverse; -push @{ $inverse{ $addr{$_}->[0] } }, $_ for keys %addr; - -foreach my $bin (keys %inverse) -{ - my $addrs=join(" ",@{$inverse{$bin}}); - my @resolved=(); - - @resolved=(`eu-addr2line --pretty-print -s -C -f -p $pid $addrs`); - - my $idx=0; - foreach $a (@{$inverse{$bin}}) - { - $addr{$a}->[1]=$resolved[$idx]; - $addr{$a}->[1]=~ s/\n//; - $addr{$a}->[1]=~ s/at \?\?:0/from $addr{$a}->[0]/; - $idx++; - } -} - -foreach $lwp (sort {$a<=>$b} keys %sf) -{ - my $idx=0; - print "Thread $lwp (LWP $lwp):\n"; - foreach $frame_no (@{$sf{$lwp}}) - { - print join(" ","#".$idx, "0x".$frame_no,"in", $addr{$frame_no}->[1]),"\n"; - $idx++; - } - print "\n"; -} - - # ############################################################################ # Documentation # ############################################################################ - =pod =head1 NAME @@ -127,7 +1412,7 @@ and resolve symbols. =head1 SYNOPSIS -Usage: pt-eustack-resolver +Usage: pt-eustack-resolver PID pt-eustack-resolver collects stack traces for the process with specified C. @@ -163,6 +1448,22 @@ than gdb and have smaller overhead on the diagnosed process. Stack for each thread, formatted similarly to C output. +=head1 OPTIONS + +This tool accepts additional command-line arguments. Refer to the +L<"SYNOPSIS"> and usage information for details. + +=over + +=item --help + +Show help and exit. + +=item --version + +Show version and exit. + + =head1 ATTENTION Using might expose passwords. When debug is enabled, all command line