diff --git a/MANIFEST b/MANIFEST index 2b25d4d7..d5478ff6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -18,7 +18,6 @@ bin/pt-heartbeat bin/pt-index-usage bin/pt-ioprofile bin/pt-kill -bin/pt-log-player bin/pt-mext bin/pt-mysql-summary bin/pt-online-schema-change @@ -35,8 +34,6 @@ bin/pt-summary bin/pt-table-checksum bin/pt-table-sync bin/pt-table-usage -bin/pt-tcp-model -bin/pt-trend bin/pt-upgrade bin/pt-variable-advisor bin/pt-visual-explain diff --git a/bin/pt-log-player b/bin/pt-log-player deleted file mode 100755 index 0debb6af..00000000 --- a/bin/pt-log-player +++ /dev/null @@ -1,3667 +0,0 @@ -#!/usr/bin/env perl - -# This program is part of Percona Toolkit: http://www.percona.com/software/ -# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal -# 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( - OptionParser - SlowLogParser - BinaryLogParser - GeneralLogParser - LogSplitter - DSNParser - Daemon - )); -} - -# ########################################################################### -# 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 Bazaar repository at, -# lib/OptionParser.pm -# t/lib/OptionParser.t -# See https://launchpad.net/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; - -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, - ); - - 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'), - }; - } - 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_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(?: ([^)]+))?/) ) { - $self->{defaults}->{$long} = defined $def ? $def : 1; - 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}++; - } - 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] 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"; - } - else { - print "Error parsing version. See the VERSION section of the tool's documentation.\n"; - } - exit 1; - } - - 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); - $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); - } - 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 $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 - && (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 _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 '# ', $^X, ' ', $], "\n"; - if ( my $uname = `uname -a` ) { - $uname =~ s/\s+/ /g; - print "# $uname\n"; - } - print '# Arguments: ', - join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; -} - -1; -} -# ########################################################################### -# End OptionParser package -# ########################################################################### - -# ########################################################################### -# SlowLogParser package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/SlowLogParser.pm -# t/lib/SlowLogParser.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package SlowLogParser; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -sub new { - my ( $class ) = @_; - my $self = { - pending => [], - }; - return bless $self, $class; -} - -my $slow_log_ts_line = qr/^# Time: ([0-9: ]{15})/; -my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]/; -my $slow_log_hd_line = qr{ - ^(?: - T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix - | - [/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary) - | - Time\s+Id\s+Command - ).*\n - }xm; - -sub parse_event { - my ( $self, %args ) = @_; - my @required_args = qw(next_event tell); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my ($next_event, $tell) = @args{@required_args}; - - my $pending = $self->{pending}; - local $INPUT_RECORD_SEPARATOR = ";\n#"; - my $trimlen = length($INPUT_RECORD_SEPARATOR); - my $pos_in_log = $tell->(); - my $stmt; - - EVENT: - while ( - defined($stmt = shift @$pending) - or defined($stmt = $next_event->()) - ) { - my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log); - $pos_in_log = $tell->(); - - if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log - my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt); - if ( @chunks > 1 ) { - PTDEBUG && _d("Found multiple chunks"); - $stmt = shift @chunks; - unshift @$pending, @chunks; - } - } - - $stmt = '#' . $stmt unless $stmt =~ m/\A#/; - $stmt =~ s/;\n#?\Z//; - - - my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed); - my $pos = 0; - my $len = length($stmt); - my $found_arg = 0; - LINE: - while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match. - $pos = pos($stmt); # Be careful not to mess this up! - my $line = $1; # Necessary for /g and pos() to work. - PTDEBUG && _d($line); - - if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) { - - if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) { - PTDEBUG && _d("Got ts", $time); - push @properties, 'ts', $time; - ++$got_ts; - if ( !$got_uh - && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o ) - ) { - PTDEBUG && _d("Got user, host, ip", $user, $host, $ip); - push @properties, 'user', $user, 'host', $host, 'ip', $ip; - ++$got_uh; - } - } - - elsif ( !$got_uh - && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o ) - ) { - PTDEBUG && _d("Got user, host, ip", $user, $host, $ip); - push @properties, 'user', $user, 'host', $host, 'ip', $ip; - ++$got_uh; - } - - elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) { - PTDEBUG && _d("Got admin command"); - $line =~ s/^#\s+//; # string leading "# ". - push @properties, 'cmd', 'Admin', 'arg', $line; - push @properties, 'bytes', length($properties[-1]); - ++$found_arg; - ++$got_ac; - } - - elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap! - PTDEBUG && _d("Got some line with properties"); - - if ( $line =~ m/Schema:\s+\w+: / ) { - PTDEBUG && _d('Removing empty Schema attrib'); - $line =~ s/Schema:\s+//; - PTDEBUG && _d($line); - } - - my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g; - push @properties, @temp; - } - - elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) { - PTDEBUG && _d("Got a default database:", $db); - push @properties, 'db', $db; - ++$got_db; - } - - elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) { - PTDEBUG && _d("Got some setting:", $setting); - push @properties, split(/,|\s*=\s*/, $setting); - ++$got_set; - } - - if ( !$found_arg && $pos == $len ) { - PTDEBUG && _d("Did not find arg, looking for special cases"); - local $INPUT_RECORD_SEPARATOR = ";\n"; - if ( defined(my $l = $next_event->()) ) { - chomp $l; - $l =~ s/^\s+//; - PTDEBUG && _d("Found admin statement", $l); - push @properties, 'cmd', 'Admin', 'arg', $l; - push @properties, 'bytes', length($properties[-1]); - $found_arg++; - } - else { - PTDEBUG && _d("I can't figure out what to do with this line"); - next EVENT; - } - } - } - else { - PTDEBUG && _d("Got the query/arg line"); - my $arg = substr($stmt, $pos - length($line)); - push @properties, 'arg', $arg, 'bytes', length($arg); - if ( $args{misc} && $args{misc}->{embed} - && ( my ($e) = $arg =~ m/($args{misc}->{embed})/) - ) { - push @properties, $e =~ m/$args{misc}->{capture}/g; - } - last LINE; - } - } - - PTDEBUG && _d('Properties of event:', Dumper(\@properties)); - my $event = { @properties }; - if ( $args{stats} ) { - $args{stats}->{events_read}++; - $args{stats}->{events_parsed}++; - } - return $event; - } # EVENT - - @$pending = (); - $args{oktorun}->(0) if $args{oktorun}; - return; -} - -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 SlowLogParser package -# ########################################################################### - -# ########################################################################### -# BinaryLogParser package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/BinaryLogParser.pm -# t/lib/BinaryLogParser.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package BinaryLogParser; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -my $binlog_line_1 = qr/at (\d+)$/m; -my $binlog_line_2 = qr/^#(\d{6}\s+\d{1,2}:\d\d:\d\d)\s+server\s+id\s+(\d+)\s+end_log_pos\s+(\d+)\s+(\S+)\s*([^\n]*)$/m; -my $binlog_line_2_rest = qr/thread_id=(\d+)\s+exec_time=(\d+)\s+error_code=(\d+)/m; - -sub new { - my ( $class, %args ) = @_; - my $self = { - delim => undef, - delim_len => 0, - }; - return bless $self, $class; -} - - -sub parse_event { - my ( $self, %args ) = @_; - my @required_args = qw(next_event tell); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my ($next_event, $tell) = @args{@required_args}; - - local $INPUT_RECORD_SEPARATOR = ";\n#"; - my $pos_in_log = $tell->(); - my $stmt; - my ($delim, $delim_len) = ($self->{delim}, $self->{delim_len}); - - EVENT: - while ( defined($stmt = $next_event->()) ) { - my @properties = ('pos_in_log', $pos_in_log); - my ($ts, $sid, $end, $type, $rest); - $pos_in_log = $tell->(); - $stmt =~ s/;\n#?\Z//; - - my ( $got_offset, $got_hdr ); - my $pos = 0; - my $len = length($stmt); - my $found_arg = 0; - LINE: - while ( $stmt =~ m/^(.*)$/mg ) { # /g requires scalar match. - $pos = pos($stmt); # Be careful not to mess this up! - my $line = $1; # Necessary for /g and pos() to work. - $line =~ s/$delim// if $delim; - PTDEBUG && _d($line); - - if ( $line =~ m/^\/\*.+\*\/;/ ) { - PTDEBUG && _d('Comment line'); - next LINE; - } - - if ( $line =~ m/^DELIMITER/m ) { - my ( $del ) = $line =~ m/^DELIMITER (\S*)$/m; - if ( $del ) { - $self->{delim_len} = $delim_len = length $del; - $self->{delim} = $delim = quotemeta $del; - PTDEBUG && _d('delimiter:', $delim); - } - else { - PTDEBUG && _d('Delimiter reset to ;'); - $self->{delim} = $delim = undef; - $self->{delim_len} = $delim_len = 0; - } - next LINE; - } - - next LINE if $line =~ m/End of log file/; - - if ( !$got_offset && (my ( $offset ) = $line =~ m/$binlog_line_1/m) ) { - PTDEBUG && _d('Got the at offset line'); - push @properties, 'offset', $offset; - $got_offset++; - } - - elsif ( !$got_hdr && $line =~ m/^#(\d{6}\s+\d{1,2}:\d\d:\d\d)/ ) { - ($ts, $sid, $end, $type, $rest) = $line =~ m/$binlog_line_2/m; - PTDEBUG && _d('Got the header line; type:', $type, 'rest:', $rest); - push @properties, 'cmd', 'Query', 'ts', $ts, 'server_id', $sid, - 'end_log_pos', $end; - $got_hdr++; - } - - elsif ( $line =~ m/^(?:#|use |SET)/i ) { - - if ( my ( $db ) = $line =~ m/^use ([^;]+)/ ) { - PTDEBUG && _d("Got a default database:", $db); - push @properties, 'db', $db; - } - - elsif ( my ($setting) = $line =~ m/^SET\s+([^;]*)/ ) { - PTDEBUG && _d("Got some setting:", $setting); - push @properties, map { s/\s+//; lc } split(/,|\s*=\s*/, $setting); - } - - } - else { - PTDEBUG && _d("Got the query/arg line at pos", $pos); - $found_arg++; - if ( $got_offset && $got_hdr ) { - if ( $type eq 'Xid' ) { - my ($xid) = $rest =~ m/(\d+)/; - push @properties, 'Xid', $xid; - } - elsif ( $type eq 'Query' ) { - my ($i, $t, $c) = $rest =~ m/$binlog_line_2_rest/m; - push @properties, 'Thread_id', $i, 'Query_time', $t, - 'error_code', $c; - } - elsif ( $type eq 'Start:' ) { - PTDEBUG && _d("Binlog start"); - } - else { - PTDEBUG && _d('Unknown event type:', $type); - next EVENT; - } - } - else { - PTDEBUG && _d("It's not a query/arg, it's just some SQL fluff"); - push @properties, 'cmd', 'Query', 'ts', undef; - } - - my $delim_len = ($pos == length($stmt) ? $delim_len : 0); - my $arg = substr($stmt, $pos - length($line) - $delim_len); - - $arg =~ s/$delim// if $delim; # Remove the delimiter. - - if ( $arg =~ m/^DELIMITER/m ) { - my ( $del ) = $arg =~ m/^DELIMITER (\S*)$/m; - if ( $del ) { - $self->{delim_len} = $delim_len = length $del; - $self->{delim} = $delim = quotemeta $del; - PTDEBUG && _d('delimiter:', $delim); - } - else { - PTDEBUG && _d('Delimiter reset to ;'); - $del = ';'; - $self->{delim} = $delim = undef; - $self->{delim_len} = $delim_len = 0; - } - - $arg =~ s/^DELIMITER.*$//m; # Remove DELIMITER from arg. - } - - $arg =~ s/;$//gm; # Ensure ending ; are gone. - $arg =~ s/\s+$//; # Remove trailing spaces and newlines. - - push @properties, 'arg', $arg, 'bytes', length($arg); - last LINE; - } - } # LINE - - if ( $found_arg ) { - PTDEBUG && _d('Properties of event:', Dumper(\@properties)); - my $event = { @properties }; - if ( $args{stats} ) { - $args{stats}->{events_read}++; - $args{stats}->{events_parsed}++; - } - return $event; - } - else { - PTDEBUG && _d('Event had no arg'); - } - } # EVENT - - $args{oktorun}->(0) if $args{oktorun}; - return; -} - -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 BinaryLogParser package -# ########################################################################### - -# ########################################################################### -# GeneralLogParser package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/GeneralLogParser.pm -# t/lib/GeneralLogParser.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package GeneralLogParser; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -sub new { - my ( $class ) = @_; - my $self = { - pending => [], - db_for => {}, - }; - return bless $self, $class; -} - -my $genlog_line_1= qr{ - \A - (?:(\d{6}\s+\d{1,2}:\d\d:\d\d))? # Timestamp - \s+ - (?:\s*(\d+)) # Thread ID - \s - (\w+) # Command - \s+ - (.*) # Argument - \Z -}xs; - -sub parse_event { - my ( $self, %args ) = @_; - my @required_args = qw(next_event tell); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my ($next_event, $tell) = @args{@required_args}; - - my $pending = $self->{pending}; - my $db_for = $self->{db_for}; - my $line; - my $pos_in_log = $tell->(); - LINE: - while ( - defined($line = shift @$pending) - or defined($line = $next_event->()) - ) { - PTDEBUG && _d($line); - my ($ts, $thread_id, $cmd, $arg) = $line =~ m/$genlog_line_1/; - if ( !($thread_id && $cmd) ) { - PTDEBUG && _d('Not start of general log event'); - next; - } - my @properties = ('pos_in_log', $pos_in_log, 'ts', $ts, - 'Thread_id', $thread_id); - - $pos_in_log = $tell->(); - - @$pending = (); - if ( $cmd eq 'Query' ) { - my $done = 0; - do { - $line = $next_event->(); - if ( $line ) { - my (undef, $next_thread_id, $next_cmd) - = $line =~ m/$genlog_line_1/; - if ( $next_thread_id && $next_cmd ) { - PTDEBUG && _d('Event done'); - $done = 1; - push @$pending, $line; - } - else { - PTDEBUG && _d('More arg:', $line); - $arg .= $line; - } - } - else { - PTDEBUG && _d('No more lines'); - $done = 1; - } - } until ( $done ); - - chomp $arg; - push @properties, 'cmd', 'Query', 'arg', $arg; - push @properties, 'bytes', length($properties[-1]); - push @properties, 'db', $db_for->{$thread_id} if $db_for->{$thread_id}; - } - else { - push @properties, 'cmd', 'Admin'; - - if ( $cmd eq 'Connect' ) { - if ( $arg =~ m/^Access denied/ ) { - $cmd = $arg; - } - else { - my ($user, undef, $db) = $arg =~ /(\S+)/g; - my $host; - ($user, $host) = split(/@/, $user); - PTDEBUG && _d('Connect', $user, '@', $host, 'on', $db); - - push @properties, 'user', $user if $user; - push @properties, 'host', $host if $host; - push @properties, 'db', $db if $db; - $db_for->{$thread_id} = $db; - } - } - elsif ( $cmd eq 'Init' ) { - $cmd = 'Init DB'; - $arg =~ s/^DB\s+//; - my ($db) = $arg =~ /(\S+)/; - PTDEBUG && _d('Init DB:', $db); - push @properties, 'db', $db if $db; - $db_for->{$thread_id} = $db; - } - - push @properties, 'arg', "administrator command: $cmd"; - push @properties, 'bytes', length($properties[-1]); - } - - push @properties, 'Query_time', 0; - - PTDEBUG && _d('Properties of event:', Dumper(\@properties)); - my $event = { @properties }; - if ( $args{stats} ) { - $args{stats}->{events_read}++; - $args{stats}->{events_parsed}++; - } - return $event; - } # LINE - - @{$self->{pending}} = (); - $args{oktorun}->(0) if $args{oktorun}; - return; -} - -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 GeneralLogParser package -# ########################################################################### - -# ########################################################################### -# LogSplitter package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/LogSplitter.pm -# t/lib/LogSplitter.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package LogSplitter; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -my $oktorun = 1; - -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(attribute base_dir parser session_files) ) { - die "I need a $arg argument" unless $args{$arg}; - } - - $args{base_dir} .= '/' if substr($args{base_dir}, -1, 1) ne '/'; - - if ( $args{split_random} ) { - PTDEBUG && _d('Split random'); - $args{attribute} = '_sessionno'; # set round-robin 1..session_files - } - - my $self = { - base_file_name => 'session', - max_dirs => 1_000, - max_files_per_dir => 5_000, - max_sessions => 5_000_000, # max_dirs * max_files_per_dir - merge_sessions => 1, - session_files => 64, - quiet => 0, - verbose => 0, - max_open_files => 1_000, - close_lru_files => 100, - %args, - n_dirs_total => 0, # total number of dirs created - n_files_total => 0, # total number of session files created - n_files_this_dir => -1, # number of session files in current dir - session_fhs => [], # filehandles for each session - n_open_fhs => 0, # current number of open session filehandles - n_events_total => 0, # total number of events in log - n_events_saved => 0, # total number of events saved - n_sessions_skipped => 0, # total number of sessions skipped - n_sessions_saved => 0, # number of sessions saved - sessions => {}, # sessions data store - created_dirs => [], - }; - - PTDEBUG && _d('new LogSplitter final args:', Dumper($self)); - return bless $self, $class; -} - -sub split { - my ( $self, @logs ) = @_; - $oktorun = 1; # True as long as we haven't created too many - - my $callbacks = $self->{callbacks}; - - my $next_sessionno; - if ( $self->{split_random} ) { - $next_sessionno = make_rr_iter(1, $self->{session_files}); - } - - if ( @logs == 0 ) { - PTDEBUG && _d('Implicitly reading STDIN because no logs were given'); - push @logs, '-'; - } - - my $lp = $self->{parser}; - LOG: - foreach my $log ( @logs ) { - last unless $oktorun; - next unless defined $log; - - if ( !-f $log && $log ne '-' ) { - warn "Skipping $log because it is not a file"; - next LOG; - } - my $fh; - if ( $log eq '-' ) { - $fh = *STDIN; - } - else { - if ( !open $fh, "<", $log ) { - warn "Cannot open $log: $OS_ERROR\n"; - next LOG; - } - } - - PTDEBUG && _d('Splitting', $log); - my $event = {}; - my $more_events = 1; - my $more_events_sub = sub { $more_events = $_[0]; }; - EVENT: - while ( $oktorun ) { - $event = $lp->parse_event( - next_event => sub { return <$fh>; }, - tell => sub { return tell $fh; }, - oktorun => $more_events_sub, - ); - if ( $event ) { - $self->{n_events_total}++; - if ( $self->{split_random} ) { - $event->{_sessionno} = $next_sessionno->(); - } - if ( $callbacks ) { - foreach my $callback ( @$callbacks ) { - $event = $callback->($event); - last unless $event; - } - } - $self->_save_event($event) if $event; - } - if ( !$more_events ) { - PTDEBUG && _d('Done parsing', $log); - close $fh; - next LOG; - } - last LOG unless $oktorun; - } - } - - while ( my $fh = pop @{ $self->{session_fhs} } ) { - close $fh->{fh}; - } - $self->{n_open_fhs} = 0; - - $self->_merge_session_files() if $self->{merge_sessions}; - $self->print_split_summary() unless $self->{quiet}; - - return; -} - -sub _save_event { - my ( $self, $event ) = @_; - my ($session, $session_id) = $self->_get_session_ds($event); - return unless $session; - - if ( !defined $session->{fh} ) { - $self->{n_sessions_saved}++; - PTDEBUG && _d('New session:', $session_id, ',', - $self->{n_sessions_saved}, 'of', $self->{max_sessions}); - - my $session_file = $self->_get_next_session_file(); - if ( !$session_file ) { - $oktorun = 0; - PTDEBUG && _d('Not oktorun because no _get_next_session_file'); - return; - } - - if ( $self->{n_open_fhs} >= $self->{max_open_files} ) { - $self->_close_lru_session() - } - - open my $fh, '>', $session_file - or die "Cannot open session file $session_file: $OS_ERROR"; - $session->{fh} = $fh; - $self->{n_open_fhs}++; - - $session->{active} = 1; - $session->{session_file} = $session_file; - - push @{$self->{session_fhs}}, { fh => $fh, session_id => $session_id }; - - PTDEBUG && _d('Created', $session_file, 'for session', - $self->{attribute}, '=', $session_id); - - print $fh "-- START SESSION $session_id\n\n"; - } - elsif ( !$session->{active} ) { - - if ( $self->{n_open_fhs} >= $self->{max_open_files} ) { - $self->_close_lru_session(); - } - - open $session->{fh}, '>>', $session->{session_file} - or die "Cannot reopen session file " - . "$session->{session_file}: $OS_ERROR"; - - $session->{active} = 1; - $self->{n_open_fhs}++; - - PTDEBUG && _d('Reopend', $session->{session_file}, 'for session', - $self->{attribute}, '=', $session_id); - } - else { - PTDEBUG && _d('Event belongs to active session', $session_id); - } - - my $session_fh = $session->{fh}; - - my $db = $event->{db} || $event->{Schema}; - if ( $db && ( !defined $session->{db} || $session->{db} ne $db ) ) { - print $session_fh "use $db\n\n"; - $session->{db} = $db; - } - - print $session_fh $self->flatten($event->{arg}), "\n\n"; - $self->{n_events_saved}++; - - return; -} - -sub _get_session_ds { - my ( $self, $event ) = @_; - - my $attrib = $self->{attribute}; - if ( !$event->{ $attrib } ) { - PTDEBUG && _d('No attribute', $attrib, 'in event:', Dumper($event)); - return; - } - - return unless $event->{arg}; - - return if ($event->{cmd} || '') eq 'Admin'; - - my $session; - my $session_id = $event->{ $attrib }; - - if ( $self->{n_sessions_saved} < $self->{max_sessions} ) { - $session = $self->{sessions}->{ $session_id } ||= {}; - } - elsif ( exists $self->{sessions}->{ $session_id } ) { - $session = $self->{sessions}->{ $session_id }; - } - else { - $self->{n_sessions_skipped} += 1; - PTDEBUG && _d('Skipping new session', $session_id, - 'because max_sessions is reached'); - } - - return $session, $session_id; -} - -sub _close_lru_session { - my ( $self ) = @_; - my $session_fhs = $self->{session_fhs}; - my $lru_n = $self->{n_sessions_saved} - $self->{max_open_files} - 1; - my $close_to_n = $lru_n + $self->{close_lru_files} - 1; - - PTDEBUG && _d('Closing session fhs', $lru_n, '..', $close_to_n, - '(',$self->{n_sessions}, 'sessions', $self->{n_open_fhs}, 'open fhs)'); - - foreach my $session ( @$session_fhs[ $lru_n..$close_to_n ] ) { - close $session->{fh}; - $self->{n_open_fhs}--; - $self->{sessions}->{ $session->{session_id} }->{active} = 0; - } - - return; -} - -sub _get_next_session_file { - my ( $self, $n ) = @_; - return if $self->{n_dirs_total} >= $self->{max_dirs}; - - if ( ($self->{n_files_this_dir} >= $self->{max_files_per_dir}) - || $self->{n_files_this_dir} < 0 ) { - $self->{n_dirs_total}++; - $self->{n_files_this_dir} = 0; - my $new_dir = "$self->{base_dir}$self->{n_dirs_total}"; - if ( !-d $new_dir ) { - my $retval = system("mkdir $new_dir"); - if ( ($retval >> 8) != 0 ) { - die "Cannot create new directory $new_dir: $OS_ERROR"; - } - PTDEBUG && _d('Created new base_dir', $new_dir); - push @{$self->{created_dirs}}, $new_dir; - } - elsif ( PTDEBUG ) { - _d($new_dir, 'already exists'); - } - } - else { - PTDEBUG && _d('No dir created; n_files_this_dir:', - $self->{n_files_this_dir}, 'n_files_total:', - $self->{n_files_total}); - } - - $self->{n_files_total}++; - $self->{n_files_this_dir}++; - my $dir_n = $self->{n_dirs_total} . '/'; - my $session_n = sprintf '%d', $n || $self->{n_sessions_saved}; - my $session_file = $self->{base_dir} - . $dir_n - . $self->{base_file_name}."-$session_n.txt"; - PTDEBUG && _d('Next session file', $session_file); - return $session_file; -} - -sub flatten { - my ( $self, $query ) = @_; - return unless $query; - $query =~ s!/\*.*?\*/! !g; - $query =~ s/^\s+//; - $query =~ s/\s{2,}/ /g; - return $query; -} - -sub _merge_session_files { - my ( $self ) = @_; - - print "Merging session files...\n" unless $self->{quiet}; - - my @multi_session_files; - for my $i ( 1..$self->{session_files} ) { - push @multi_session_files, $self->{base_dir} ."sessions-$i.txt"; - } - - my @single_session_files = map { - $_->{session_file}; - } values %{$self->{sessions}}; - - my $i = make_rr_iter(0, $#multi_session_files); # round-robin iterator - foreach my $single_session_file ( @single_session_files ) { - my $multi_session_file = $multi_session_files[ $i->() ]; - my $cmd; - if ( $self->{split_random} ) { - $cmd = "mv $single_session_file $multi_session_file"; - } - else { - $cmd = "cat $single_session_file >> $multi_session_file"; - } - eval { `$cmd`; }; - if ( $EVAL_ERROR ) { - warn "Failed to `$cmd`: $OS_ERROR"; - } - } - - foreach my $created_dir ( @{$self->{created_dirs}} ) { - my $cmd = "rm -rf $created_dir"; - eval { `$cmd`; }; - if ( $EVAL_ERROR ) { - warn "Failed to `$cmd`: $OS_ERROR"; - } - } - - return; -} - -sub make_rr_iter { - my ( $start, $end ) = @_; - my $current = $start; - return sub { - $current = $start if $current > $end ; - $current++; # For next iteration. - return $current - 1; - }; -} - -sub print_split_summary { - my ( $self ) = @_; - print "Split summary:\n"; - my $fmt = "%-20s %-10s\n"; - printf $fmt, 'Total sessions', - $self->{n_sessions_saved} + $self->{n_sessions_skipped}; - printf $fmt, 'Sessions saved', - $self->{n_sessions_saved}; - printf $fmt, 'Total events', $self->{n_events_total}; - printf $fmt, 'Events saved', $self->{n_events_saved}; - return; -} - -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 LogSplitter package -# ########################################################################### - -# ########################################################################### -# DSNParser package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/DSNParser.pm -# t/lib/DSNParser.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package DSNParser; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 0; -$Data::Dumper::Quotekeys = 0; - -my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD. - }; - foreach my $opt ( @{$args{opts}} ) { - if ( !$opt->{key} || !$opt->{desc} ) { - die "Invalid DSN option: ", Dumper($opt); - } - PTDEBUG && _d('DSN option:', - join(', ', - map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') } - keys %$opt - ) - ); - $self->{opts}->{$opt->{key}} = { - dsn => $opt->{dsn}, - desc => $opt->{desc}, - copy => $opt->{copy} || 0, - }; - } - return bless $self, $class; -} - -sub prop { - my ( $self, $prop, $value ) = @_; - if ( @_ > 2 ) { - PTDEBUG && _d('Setting', $prop, 'property'); - $self->{$prop} = $value; - } - return $self->{$prop}; -} - -sub parse { - my ( $self, $dsn, $prev, $defaults ) = @_; - if ( !$dsn ) { - PTDEBUG && _d('No DSN to parse'); - return; - } - PTDEBUG && _d('Parsing', $dsn); - $prev ||= {}; - $defaults ||= {}; - my %given_props; - my %final_props; - my $opts = $self->{opts}; - - foreach my $dsn_part ( split($dsn_sep, $dsn) ) { - $dsn_part =~ s/\\,/,/g; - if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) { - $given_props{$prop_key} = $prop_val; - } - else { - PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part); - $given_props{h} = $dsn_part; - } - } - - foreach my $key ( keys %$opts ) { - PTDEBUG && _d('Finding value for', $key); - $final_props{$key} = $given_props{$key}; - if ( !defined $final_props{$key} - && defined $prev->{$key} && $opts->{$key}->{copy} ) - { - $final_props{$key} = $prev->{$key}; - PTDEBUG && _d('Copying value for', $key, 'from previous DSN'); - } - if ( !defined $final_props{$key} ) { - $final_props{$key} = $defaults->{$key}; - PTDEBUG && _d('Copying value for', $key, 'from defaults'); - } - } - - foreach my $key ( keys %given_props ) { - die "Unknown DSN option '$key' in '$dsn'. For more details, " - . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " - . "for complete documentation." - unless exists $opts->{$key}; - } - if ( (my $required = $self->prop('required')) ) { - foreach my $key ( keys %$required ) { - die "Missing required DSN option '$key' in '$dsn'. For more details, " - . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " - . "for complete documentation." - unless $final_props{$key}; - } - } - - return \%final_props; -} - -sub parse_options { - my ( $self, $o ) = @_; - die 'I need an OptionParser object' unless ref $o eq 'OptionParser'; - my $dsn_string - = join(',', - map { "$_=".$o->get($_); } - grep { $o->has($_) && $o->get($_) } - keys %{$self->{opts}} - ); - PTDEBUG && _d('DSN string made from options:', $dsn_string); - return $self->parse($dsn_string); -} - -sub as_string { - my ( $self, $dsn, $props ) = @_; - return $dsn unless ref $dsn; - my @keys = $props ? @$props : sort keys %$dsn; - return join(',', - map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) } - grep { - exists $self->{opts}->{$_} - && exists $dsn->{$_} - && defined $dsn->{$_} - } @keys); -} - -sub usage { - my ( $self ) = @_; - my $usage - = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n" - . " KEY COPY MEANING\n" - . " === ==== =============================================\n"; - my %opts = %{$self->{opts}}; - foreach my $key ( sort keys %opts ) { - $usage .= " $key " - . ($opts{$key}->{copy} ? 'yes ' : 'no ') - . ($opts{$key}->{desc} || '[No description]') - . "\n"; - } - $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n"; - return $usage; -} - -sub get_cxn_params { - my ( $self, $info ) = @_; - my $dsn; - my %opts = %{$self->{opts}}; - my $driver = $self->prop('dbidriver') || ''; - if ( $driver eq 'Pg' ) { - $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';' - . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } - grep { defined $info->{$_} } - qw(h P)); - } - else { - $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';' - . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } - grep { defined $info->{$_} } - qw(F h P S A)) - . ';mysql_read_default_group=client' - . ($info->{L} ? ';mysql_local_infile=1' : ''); - } - PTDEBUG && _d($dsn); - return ($dsn, $info->{u}, $info->{p}); -} - -sub fill_in_dsn { - my ( $self, $dbh, $dsn ) = @_; - my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name'); - my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()'); - $user =~ s/@.*//; - $dsn->{h} ||= $vars->{hostname}->{Value}; - $dsn->{S} ||= $vars->{'socket'}->{Value}; - $dsn->{P} ||= $vars->{port}->{Value}; - $dsn->{u} ||= $user; - $dsn->{D} ||= $db; -} - -sub get_dbh { - my ( $self, $cxn_string, $user, $pass, $opts ) = @_; - $opts ||= {}; - my $defaults = { - AutoCommit => 0, - RaiseError => 1, - PrintError => 0, - ShowErrorStatement => 1, - mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0), - }; - @{$defaults}{ keys %$opts } = values %$opts; - if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension - $defaults->{mysql_local_infile} = 1; - } - - if ( $opts->{mysql_use_result} ) { - $defaults->{mysql_use_result} = 1; - } - - if ( !$have_dbi ) { - die "Cannot connect to MySQL because the Perl DBI module is not " - . "installed or not found. Run 'perl -MDBI' to see the directories " - . "that Perl searches for DBI. If DBI is not installed, try:\n" - . " Debian/Ubuntu apt-get install libdbi-perl\n" - . " RHEL/CentOS yum install perl-DBI\n" - . " OpenSolaris pkg install pkg:/SUNWpmdbi\n"; - - } - - my $dbh; - my $tries = 2; - while ( !$dbh && $tries-- ) { - PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, - join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults )); - - $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) }; - - if ( !$dbh && $EVAL_ERROR ) { - if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) { - die "Cannot connect to MySQL because the Perl DBD::mysql module is " - . "not installed or not found. Run 'perl -MDBD::mysql' to see " - . "the directories that Perl searches for DBD::mysql. If " - . "DBD::mysql is not installed, try:\n" - . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n" - . " RHEL/CentOS yum install perl-DBD-MySQL\n" - . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n"; - } - elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) { - PTDEBUG && _d('Going to try again without utf8 support'); - delete $defaults->{mysql_enable_utf8}; - } - if ( !$tries ) { - die $EVAL_ERROR; - } - } - } - - if ( $cxn_string =~ m/mysql/i ) { - my $sql; - - $sql = 'SELECT @@SQL_MODE'; - PTDEBUG && _d($dbh, $sql); - my ($sql_mode) = eval { $dbh->selectrow_array($sql) }; - if ( $EVAL_ERROR ) { - die "Error getting the current SQL_MODE: $EVAL_ERROR"; - } - - if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) { - $sql = qq{/*!40101 SET NAMES "$charset"*/}; - PTDEBUG && _d($dbh, ':', $sql); - eval { $dbh->do($sql) }; - if ( $EVAL_ERROR ) { - die "Error setting NAMES to $charset: $EVAL_ERROR"; - } - PTDEBUG && _d('Enabling charset for STDOUT'); - if ( $charset eq 'utf8' ) { - binmode(STDOUT, ':utf8') - or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR"; - } - else { - binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR"; - } - } - - if ( my $var = $self->prop('set-vars') ) { - $sql = "SET $var"; - PTDEBUG && _d($dbh, ':', $sql); - eval { $dbh->do($sql) }; - if ( $EVAL_ERROR ) { - die "Error setting $var: $EVAL_ERROR"; - } - } - - $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1' - . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO' - . ($sql_mode ? ",$sql_mode" : '') - . '\'*/'; - PTDEBUG && _d($dbh, $sql); - eval { $dbh->do($sql) }; - if ( $EVAL_ERROR ) { - die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE" - . ($sql_mode ? " and $sql_mode" : '') - . ": $EVAL_ERROR"; - } - } - - PTDEBUG && _d('DBH info: ', - $dbh, - Dumper($dbh->selectrow_hashref( - 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')), - 'Connection info:', $dbh->{mysql_hostinfo}, - 'Character set info:', Dumper($dbh->selectall_arrayref( - "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})), - '$DBD::mysql::VERSION:', $DBD::mysql::VERSION, - '$DBI::VERSION:', $DBI::VERSION, - ); - - return $dbh; -} - -sub get_hostname { - my ( $self, $dbh ) = @_; - if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) { - return $host; - } - my ( $hostname, $one ) = $dbh->selectrow_array( - 'SELECT /*!50038 @@hostname, */ 1'); - return $hostname; -} - -sub disconnect { - my ( $self, $dbh ) = @_; - PTDEBUG && $self->print_active_handles($dbh); - $dbh->disconnect; -} - -sub print_active_handles { - my ( $self, $thing, $level ) = @_; - $level ||= 0; - printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level, - $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : '')) - or die "Cannot print: $OS_ERROR"; - foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) { - $self->print_active_handles( $handle, $level + 1 ); - } -} - -sub copy { - my ( $self, $dsn_1, $dsn_2, %args ) = @_; - die 'I need a dsn_1 argument' unless $dsn_1; - die 'I need a dsn_2 argument' unless $dsn_2; - my %new_dsn = map { - my $key = $_; - my $val; - if ( $args{overwrite} ) { - $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key}; - } - else { - $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key}; - } - $key => $val; - } keys %{$self->{opts}}; - return \%new_dsn; -} - -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 DSNParser package -# ########################################################################### - -# ########################################################################### -# Daemon package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Daemon.pm -# t/lib/Daemon.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Daemon; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use POSIX qw(setsid); - -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(o) ) { - die "I need a $arg argument" unless $args{$arg}; - } - my $o = $args{o}; - my $self = { - o => $o, - log_file => $o->has('log') ? $o->get('log') : undef, - PID_file => $o->has('pid') ? $o->get('pid') : undef, - }; - - check_PID_file(undef, $self->{PID_file}); - - PTDEBUG && _d('Daemonized child will log to', $self->{log_file}); - return bless $self, $class; -} - -sub daemonize { - my ( $self ) = @_; - - PTDEBUG && _d('About to fork and daemonize'); - defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR"; - if ( $pid ) { - PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid); - exit; - } - - PTDEBUG && _d('Daemonizing child PID', $PID); - $self->{PID_owner} = $PID; - $self->{child} = 1; - - POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; - chdir '/' or die "Cannot chdir to /: $OS_ERROR"; - - $self->_make_PID_file(); - - $OUTPUT_AUTOFLUSH = 1; - - PTDEBUG && _d('Redirecting STDIN to /dev/null'); - close STDIN; - open STDIN, '/dev/null' - or die "Cannot reopen STDIN to /dev/null: $OS_ERROR"; - - if ( $self->{log_file} ) { - PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file}); - close STDOUT; - open STDOUT, '>>', $self->{log_file} - or die "Cannot open log file $self->{log_file}: $OS_ERROR"; - - close STDERR; - open STDERR, ">&STDOUT" - or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; - } - else { - if ( -t STDOUT ) { - PTDEBUG && _d('No log file and STDOUT is a terminal;', - 'redirecting to /dev/null'); - close STDOUT; - open STDOUT, '>', '/dev/null' - or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR"; - } - if ( -t STDERR ) { - PTDEBUG && _d('No log file and STDERR is a terminal;', - 'redirecting to /dev/null'); - close STDERR; - open STDERR, '>', '/dev/null' - or die "Cannot reopen STDERR to /dev/null: $OS_ERROR"; - } - } - - return; -} - -sub check_PID_file { - my ( $self, $file ) = @_; - my $PID_file = $self ? $self->{PID_file} : $file; - PTDEBUG && _d('Checking PID file', $PID_file); - if ( $PID_file && -f $PID_file ) { - my $pid; - eval { - chomp($pid = (slurp_file($PID_file) || '')); - }; - if ( $EVAL_ERROR ) { - die "The PID file $PID_file already exists but it cannot be read: " - . $EVAL_ERROR; - } - PTDEBUG && _d('PID file exists; it contains PID', $pid); - if ( $pid ) { - my $pid_is_alive = kill 0, $pid; - if ( $pid_is_alive ) { - die "The PID file $PID_file already exists " - . " and the PID that it contains, $pid, is running"; - } - else { - warn "Overwriting PID file $PID_file because the PID that it " - . "contains, $pid, is not running"; - } - } - else { - die "The PID file $PID_file already exists but it does not " - . "contain a PID"; - } - } - else { - PTDEBUG && _d('No PID file'); - } - return; -} - -sub make_PID_file { - my ( $self ) = @_; - if ( exists $self->{child} ) { - die "Do not call Daemon::make_PID_file() for daemonized scripts"; - } - $self->_make_PID_file(); - $self->{PID_owner} = $PID; - return; -} - -sub _make_PID_file { - my ( $self ) = @_; - - my $PID_file = $self->{PID_file}; - if ( !$PID_file ) { - PTDEBUG && _d('No PID file to create'); - return; - } - - $self->check_PID_file(); - - open my $PID_FH, '>', $PID_file - or die "Cannot open PID file $PID_file: $OS_ERROR"; - print $PID_FH $PID - or die "Cannot print to PID file $PID_file: $OS_ERROR"; - close $PID_FH - or die "Cannot close PID file $PID_file: $OS_ERROR"; - - PTDEBUG && _d('Created PID file:', $self->{PID_file}); - return; -} - -sub _remove_PID_file { - my ( $self ) = @_; - if ( $self->{PID_file} && -f $self->{PID_file} ) { - unlink $self->{PID_file} - or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR"; - PTDEBUG && _d('Removed PID file'); - } - else { - PTDEBUG && _d('No PID to remove'); - } - return; -} - -sub DESTROY { - my ( $self ) = @_; - - $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID; - - return; -} - -sub slurp_file { - my ($file) = @_; - return unless $file; - open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; - return do { local $/; <$fh> }; -} - -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 Daemon 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_log_player; - -use POSIX; -use Time::HiRes qw(time usleep); -use File::Basename qw(dirname); -use File::Find; -use File::Spec; -use List::Util qw(max); -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -use English qw(-no_match_vars); - -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -# These are global so the --play threads can access them. -my $o; -my $dp; - -sub main { - @ARGV = @_; # set global ARGV for this package - - # ######################################################################### - # Get configuration information. - # ######################################################################### - $o = new OptionParser(); - $o->get_specs(); - $o->get_opts(); - - $dp = $o->DSNParser(); - $dp->prop('set-vars', $o->get('set-vars')); - - # LogSplitter will override the split attribute if split_random is true. - # Set --split to some arbitrary value so we don't have to check for both - # and --play will not be invoked. - $o->set('split', 'random') if $o->get('split-random'); - - # If not --split then the remaining arg should be a DSN for --play. - my $dsn; - if ( !$o->get('split') && !$o->get('print') && !$o->get('dry-run') ) { - my $dsn_defaults = $dp->parse_options($o); - $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults) : $dsn_defaults; - if ( !$dsn ) { - $o->save_error('Missing or invalid host'); - } - } - - if ( !-d $o->get('base-dir') ) { - $o->save_error('Invalid --base-dir: ' - . $o->get('base-dir') . ' is not a directory'); - } - - $o->set('threads', max(2, get_number_of_cpus())) - unless $o->got('threads'); - - $o->set('verbose', 0) if $o->get('quiet'); - - $o->usage_or_errors(); - - # ######################################################################## - # If --pid, check it first since we'll die if it already exits. - # ######################################################################## - my $daemon; - if ( $o->get('pid') ) { - # We're not daemoninzing, it just handles PID stuff. Keep $daemon - # in the the scope of main() because when it's destroyed it automatically - # removes the PID file. - $daemon = new Daemon(o=>$o); - $daemon->make_PID_file(); - } - - # ######################################################################### - # Split the logs into session files and exit. - # ######################################################################### - my $split = $o->get('split'); - my $base_dir = $o->get('base-dir'); - if ( $split ) { - die "$base_dir is not a directory" if !-d $base_dir; - - # It's sad because I wrote this script but I still frequently forget - # to specify the split attribute (Thread_id, etc.). So the log file - # is taken to be the split attrib and then LogSplitter tries to read - # from STDIN. This is my self-reminder. - warn "The --split attribute $split does not appear valid" - if $split !~ m/^[\w]+$/; - - $ARGV[0] = '-' if scalar @ARGV == 0; # causes LogSplitter to read STDIN - - my @callbacks; - if ( $o->get('filter') ) { - my $filter = $o->get('filter'); - if ( -f $filter && -r $filter ) { - PTDEBUG && _d('Reading file', $filter, 'for --filter code'); - open my $fh, "<", $filter or die "Cannot open $filter: $OS_ERROR"; - $filter = do { local $/ = undef; <$fh> }; - close $fh; - } - else { - $filter = "( $filter )"; # issue 565 - } - my $code = "sub { PTDEBUG && _d('callback: filter'); my(\$event) = shift; $filter && return \$event; };"; - PTDEBUG && _d('--filter code:', $code); - my $sub = eval $code - or die "Error compiling --filter code: $code\n$EVAL_ERROR"; - push @callbacks, $sub; - } - - my $parser = $o->get('type') eq 'slowlog' ? new SlowLogParser() - : $o->get('type') eq 'binlog' ? new BinaryLogParser() - : $o->get('type') eq 'genlog' ? new GeneralLogParser() - : die("Unknown type " . $o->get('type')); - my $ls = new LogSplitter( - attribute => $split, - split_random => $o->get('split-random'), - base_dir => $base_dir, - base_file_name => $o->get('base-file-name'), - max_sessions => $o->get('max-sessions'), - session_files => $o->get('session-files'), - quiet => $o->get('quiet'), - verbose => $o->get('verbose'), - parser => $parser, - callbacks => \@callbacks, - ); - $ls->split(@ARGV); - - return 0; - } - - # ######################################################################### - # Make list of session files to play. If playing a whole, the log is - # treated as one big session file. - # ######################################################################### - my @session_files; - foreach my $session_file ( split ',', $o->get('play') ) { - # The session "file" might actually be a dir, in which case we - # read ALL files in that dir. - if ( -d $session_file ) { - PTDEBUG && _d('Reading all session log files in', $session_file); - opendir my $dir, $session_file - or die "Cannot open directory $session_file: $OS_ERROR"; - push @session_files, - map { "$session_file/$_" } # 3. Save full dir/file - grep { -f "$session_file/$_" } # 2. If it's a file - readdir $dir; # 1. Each file in dir - closedir $dir; - } - else { - if ( !-f $session_file ) { - warn "$session_file is not a file"; - } - else { - push @session_files, $session_file; - } - } - } - - PTDEBUG && _d('Session files:', @session_files); - - if ( @session_files == 0 ) { - warn 'No valid session files'; - return 0; - } - - my $n_session_files = scalar @session_files; - print "Found $n_session_files session files.\n" unless $o->get('quiet'); - - if ( $o->get('threads') > $n_session_files ) { - warn "--threads is greater than the number of session files. " - . "Only $n_session_files concurrent process will be ran"; - $o->set('threads', $n_session_files); - } - my $threads = $o->get('threads'); - - my @child_tasks; - my $childno = LogSplitter::make_rr_iter(0, $threads-1); - while ( defined (my $session_file = pop @session_files) ) { - push @{$child_tasks[$childno->()]}, $session_file; - } - - # Shouldn't happen... - warn "There are unassigned session files" if @session_files > 0; - - if ( $o->get('dry-run') || $o->get('verbose') ) { - for my $i ( 0..($threads-1) ) { - print "Process $i plays $_\n" for @{$child_tasks[$i]}; - } - # Shouldn't happen... - print "Unassigned session files: " . join(', ', @session_files), "\n" - if @session_files; - return 0 if $o->get('dry-run'); - } - - # ######################################################################### - # Connect parent to MySQL. - # ######################################################################### - my $parent_dbh; - if ( !$o->get('print') ) { - if ( $o->get('ask-pass') ) { - $o->set('password', OptionParser::prompt_noecho("Enter password: ")); - } - $parent_dbh = get_cxn($dsn); - $parent_dbh->{InactiveDestroy} = 1; # Don't die on fork(). - } - - # ######################################################################### - # Assign sessions to child processes. - # ######################################################################### - my %children; - my %exited_children; - # This signal handler will do nothing but wake up the sleeping parent process - # and record the exit status and time of the child that exited (as a side - # effect of not discarding the signal). - # -- Presently, however, we do not use this information. - $SIG{CHLD} = sub { - my $pid; - while (($pid = waitpid(-1, POSIX::WNOHANG)) > 0) { - # Must right-shift to get the actual exit status of the child. - $exited_children{$pid}->{exit_status} = $CHILD_ERROR >> 8; - $exited_children{$pid}->{exit_time} = time; - } - }; - - # Fork the child processes. - print "Running processes...\n" unless $o->get('quiet'); - for my $childno ( 0..($threads-1) ) { - my $child_tasks = $child_tasks[$childno]; - - my $pid = fork(); - die "Cannot fork process $childno: $OS_ERROR" unless defined $pid; - if ( $pid ) { # I'm the parent. - $children{$pid} = $childno + 1; - } - else { # I'm the child. - $SIG{CHLD} = 'DEFAULT'; # See bug #1886444 - PTDEBUG && _d('Child PID', $PID, 'started'); - play_session($dsn, ($childno + 1), $child_tasks); - PTDEBUG && _d('Child PID', $PID, 'finished'); - return 0; - } - } - print "All processes are running; waiting for them to finish...\n" - unless $o->get('quiet'); - - # Wait for and reap the child processes. - do { - # Possibly wait for child. - my $reaped = 0; - foreach my $pid ( keys %exited_children ) { - $reaped = 1; - print "Process ", $children{$pid}, " finished with exit status ", - $exited_children{$pid}->{exit_status}, ".\n" - unless $o->get('quiet'); - PTDEBUG && _d('Reaped child PID', $pid); - delete $children{$pid}; - delete $exited_children{$pid}; - } - - if ( keys %children && !$reaped ) { - # Don't busy-wait. But don't wait forever either, as a child may exit - # and signal while we're not sleeping, so if we sleep forever we may - # not get the signal. - PTDEBUG && _d('Sleeping to wait for children'); - sleep 1; - } - PTDEBUG && _d(scalar keys %children, 'children are still working'); - - } while ( keys %children ); - - print "All processes have finished.\n" unless $o->get('quiet'); - return 0; -} - -# ############################################################################# -# Subroutines. -# ############################################################################# -sub play_session { - my ( $dsn, $childno, $session_files ) = @_; - - my $query_time; - my $slowlog_fmt = "# Thread_id: %s Query_time: %.6f Schema: %s\n%s;\n"; - my $only_select = $o->get('only-select'); - my $warnings = $o->get('warnings'); - my $print = $o->get('print'); - my $results = $o->get('results'); - my $dbh = get_cxn($dsn) unless $print; - - # Each thread writes to its own file because contention will not allow - # them all to write correctly to STDOUT at once. - my $base_dir = $o->get('base-dir'); - my $output_file = $o->get('base-dir') - . '/' - . $o->get('base-file-name') . "-results-$PID.txt"; - my $output_fh; - if ( $results || $print ) { - open $output_fh, '>', $output_file - or die "Cannot open $output_file for writing: $OS_ERROR"; - PTDEBUG && _d('Proc', $childno, 'writing to', $output_file); - } - else { - PTDEBUG && _d('Proc', $childno, 'not writing results'); - } - - local $INPUT_RECORD_SEPARATOR = ''; - - ITERATION: - for my $iteration_n ( 1..$o->get('iterations') ) { - PTDEBUG && _d('Proc', $childno, 'starting iteration', $iteration_n); - - SESSION_FILE: - foreach my $session_file ( @$session_files ) { - my $session_fh; - my $session_n; - if ( !open $session_fh, '<', $session_file ) { - warn "Cannot open session file $session_file: $OS_ERROR"; - next SESSION_FILE; - } - - my $db; - QUERY: - while ( my $query = <$session_fh> ) { - if ( $print ) { - print $output_fh $query; - next QUERY; - } - - if ( $query =~ m/^-- START SESSION (\S+)/ ) { - $session_n = $1; - next QUERY; - } - - if ( $only_select ) { - # Remove leading /* comments */ (issue 903) - $query =~ s!^/\*.*?\*/\s*!!; - if ( $query !~ m/^(?:SELECT|USE) /i ) { - PTDEBUG && _d('Skipping query for --only-select:', $query); - next QUERY; - } - } - - if ( $query =~ m/^use (\S+)/ ) { - $db = $1; - eval { $dbh->do($query); }; - if ( $EVAL_ERROR && $warnings ) { - warn_error($childno, $session_n, $query,$dbh->errstr()); - } - next QUERY; - } - - $query_time = time; - eval { $dbh->do($query); }; - if ( $EVAL_ERROR && $warnings ) { - warn_error($childno, $session_n, $query, $dbh->errstr()); - next QUERY; - } - - if ( $results ) { - chomp $query; - printf $output_fh $slowlog_fmt, - "$childno$session_n", - time - $query_time, - ($db || ''), - $query; - } - } # QUERY - - PTDEBUG && _d('No more sessions in', $session_file); - close $session_fh; - } # SESSION_FILE - } # ITERATION - - close $output_fh if $output_fh; - if ($dbh) { - $dbh->commit() unless $dbh->{AutoCommit}; - $dbh->disconnect(); - } - return; -} - -sub get_delay { - my ( $delay ) = @_; - return 0 if !defined $delay || scalar @$delay == 0; - my $t = 0; - - my ( $from, $to ) = @$delay[0..1]; - if ( defined $to ) { - $t = rand($to) + $from; - } - else { - $t = $from; - } - - # Return time is expressed in microseconds because this value - # is used with usleep() which takes a microsecond time value. - return $t *= 1_000_000; -} - -sub get_cxn { - my ( $dsn ) = @_; - return $dp->get_dbh( $dp->get_cxn_params($dsn) ); -} - -sub warn_error { - my ( $childno, $session_n, $query, $warning ) = @_; - $childno = -1 unless defined $childno; - $session_n = -1 unless defined $session_n; - $query ||= ""; - $warning ||= ""; - warn "Query '$query' in proc $childno session $session_n caused an error: " - . "$warning\n"; - return; -} - -# Returns the number of CPUs. If no sys info is given, then it's gotten -# from /proc/cpuinfo, sysctl or whatever method will work. If sys info -# is given, then we try to parse the number of CPUs from it. Passing in -# $sys_info makes this code easy to test. -sub get_number_of_cpus { - my ( $sys_info ) = @_; - my $n_cpus; - - # Try to read the number of CPUs in /proc/cpuinfo. - # This only works on GNU/Linux. - my $cpuinfo; - if ( $sys_info || (open $cpuinfo, "<", "/proc/cpuinfo") ) { - local $INPUT_RECORD_SEPARATOR = undef; - my $contents = $sys_info || <$cpuinfo>; - PTDEBUG && _d('sys info:', $contents); - close $cpuinfo if $cpuinfo; - $n_cpus = scalar( map { $_ } $contents =~ m/(processor)/g ); - PTDEBUG && _d('Got', $n_cpus, 'cpus from /proc/cpuinfo'); - return $n_cpus if $n_cpus; - } - - # Alternatives to /proc/cpuinfo: - - # FreeBSD and Mac OS X - if ( $sys_info || ($OSNAME =~ m/freebsd/i) || ($OSNAME =~ m/darwin/i) ) { - my $contents = $sys_info || `sysctl hw.ncpu`; - PTDEBUG && _d('sys info:', $contents); - ($n_cpus) = $contents =~ m/(\d)/ if $contents; - PTDEBUG && _d('Got', $n_cpus, 'cpus from sysctl hw.ncpu'); - return $n_cpus if $n_cpus; - } - - # Windows - $n_cpus ||= $ENV{NUMBER_OF_PROCESSORS}; - - return $n_cpus || 1; # There has to be at least 1 CPU. -} - -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"; -} - -# ############################################################################ -# Run the program. -# ############################################################################ -if ( !caller ) { exit main(@ARGV); } - -1; # Because this is a module as well as a script. - -# ############################################################################ -# Documentation. -# ############################################################################ - -=pod - -=head1 NAME - -pt-log-player - Replay MySQL query logs. - -=head1 SYNOPSIS - -This tool is deprecated and will be removed in Percona Toolkit 2.2. - -Usage: pt-log-player [OPTION...] [DSN] - -pt-log-player splits and plays slow log files. - -Split slow.log on Thread_id into 16 session files, save in ./sessions: - - pt-log-player --split Thread_id --session-files 16 --base-dir ./sessions slow.log - -Play all those sessions on host1, save results in ./results: - - pt-log-player --play ./sessions --base-dir ./results h=host1 - -Use L to summarize the results: - - pt-query-digest ./results/* - -=head1 RISKS - -The following section is included to inform users about the potential risks, -whether known or unknown, of using this tool. The two main categories of risks -are those created by the nature of the tool (e.g. read-only tools vs. read-write -tools) and those created by bugs. - -This tool is meant to load a server as much as possible, for stress-testing -purposes. It is not designed to be used on production servers. - -At the time of this release there is a bug which causes pt-log-player to -exceed max open files during L<"--split">. - -As of version 2.1.8, this tool no longer works with auto values on zero -because it sets a SQL mode with C. Therefore, -playing INSERT or UPDATE statements that use zero instead of C -will not work. - -The authoritative source for updated information is always the online issue -tracking system. Issues that affect this tool will be marked as such. You can -see a list of such issues at the following URL: -L. - -See also L<"BUGS"> for more information on filing bugs and getting help. - -=head1 DESCRIPTION - -pt-log-player does two things: it splits MySQL query logs into session files -and it plays (executes) queries in session files on a MySQL server. Only -session files can be played; slow logs cannot be played directly without -being split. - -A session is a group of queries from the slow log that all share a common -attribute, usually Thread_id. The common attribute is specified with -L<"--split">. Multiple sessions are saved into a single session file. -See L<"--session-files">, L<"--max-sessions">, L<"--base-file-name"> and -L<"--base-dir">. These session files are played with L<"--play">. - -pt-log-player will L<"--play"> session files in parallel using N number of -L<"--threads">. (They're not technically threads, but we call them that -anyway.) Each thread will play all the sessions in its given session files. -The sessions are played as fast as possible (there are no delays) because the -goal is to stress-test and load-test the server. So be careful using this -script on a production server! - -Each L<"--play"> thread writes its results to a separate file. These result -files are in slow log format so they can be aggregated and summarized with -L. See L<"OUTPUT">. - -=head1 OUTPUT - -Both L<"--split"> and L<"--play"> have two outputs: status messages printed to -STDOUT to let you know what the script is doing, and session or result files -written to separate files saved in L<"--base-dir">. You can suppress all -output to STDOUT for each with L<"--quiet">, or increase output with -L<"--verbose">. - -The session files written by L<"--split"> are simple text files containing -queries grouped into sessions. For example: - - -- START SESSION 10 - - use foo - - SELECT col FROM foo_tbl - -The format of these session files is important: each query must be a single -line separated by a single blank line. And the "-- START SESSION" comment -tells pt-log-player where individual sessions begin and end so that L<"--play"> -can correctly fake Thread_id in its result files. - -The result files written by L<"--play"> are in slow log format with a minimal -header: the only attributes printed are Thread_id, Query_time and Schema. - -=head1 OPTIONS - -Specify at least one of L<"--play">, L<"--split"> or L<"--split-random">. - -L<"--play"> and L<"--split"> are mutually exclusive. - -This tool accepts additional command-line arguments. Refer to the -L<"SYNOPSIS"> and usage information for details. - -=over - -=item --ask-pass - -group: Play - -Prompt for a password when connecting to MySQL. - -=item --base-dir - -type: string; default: ./ - -Base directory for L<"--split"> session files and L<"--play"> result file. - -=item --base-file-name - -type: string; default: session - -Base file name for L<"--split"> session files and L<"--play"> result file. - -Each L<"--split"> session file will be saved as -N.txt, where -N is a four digit, zero-padded session ID. For example: session-0003.txt. - -Each L<"--play"> result file will be saved as -results-PID.txt, -where PID is the process ID of the executing thread. - -All files are saved in L<"--base-dir">. - -=item --charset - -short form: -A; type: string; group: Play - -Default character set. If the value is utf8, sets Perl's binmode on STDOUT to -utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET NAMES UTF8 -after connecting to MySQL. Any other value sets binmode on STDOUT without the -utf8 layer, and runs SET NAMES after connecting to MySQL. - -=item --config - -type: Array - -Read this comma-separated list of config files; if specified, this must be the -first option on the command line. - -=item --defaults-file - -short form: -F; type: string - -Only read mysql options from the given file. - -=item --dry-run - -Print which processes play which session files then exit. - -=item --filter - -type: string; group: Split - -Discard L<"--split"> events for which this Perl code doesn't return true. - -This option only works with L<"--split">. - -This option allows you to inject Perl code into the tool to affect how the -tool runs. Usually your code should examine C<$event> to decided whether -or not to allow the event. C<$event> is a hashref of attributes and values of -the event being filtered. Or, your code could add new attribute-value pairs -to C<$event> for use by other options that accept event attributes as their -value. You can find an explanation of the structure of C<$event> at -L. - -There are two ways to supply your code: on the command line or in a file. -If you supply your code on the command line, it is injected into the following -subroutine where C<$filter> is your code: - - sub { - PTDEBUG && _d('callback: filter'); - my( $event ) = shift; - ( $filter ) && return $event; - } - -Therefore you must ensure two things: first, that you correctly escape any -special characters that need to be escaped on the command line for your -shell, and two, that your code is syntactically valid when injected into -the subroutine above. - -Here's an example filter supplied on the command line that discards -events that are not SELECT statements: - - --filter '$event->{arg} =~ m/^select/i' - -The second way to supply your code is in a file. If your code is too complex -to be expressed on the command line that results in valid syntax in the -subroutine above, then you need to put the code in a file and give the file -name as the value to L<"--filter">. The file should not contain a shebang -(C<#!/usr/bin/perl>) line. The entire contents of the file is injected into -the following subroutine: - - sub { - PTDEBUG && _d('callback: filter'); - my( $event ) = shift; - $filter && return $event; - } - -That subroutine is almost identical to the one above except your code is -not wrapped in parentheses. This allows you to write multi-line code like: - - my $event_ok; - if (...) { - $event_ok = 1; - } - else { - $event_ok = 0; - } - $event_ok - -Notice that the last line is not syntactically valid by itself, but it -becomes syntactically valid when injected into the subroutine because it -becomes: - - $event_ok && return $event; - -If your code doesn't compile, the tool will die with an error. Even if your -code compiles, it may crash to tool during runtime if, for example, it tries -a pattern match an undefined value. No safeguards of any kind are provided so -code carefully! - -=item --help - -Show help and exit. - -=item --host - -short form: -h; type: string; group: Play - -Connect to host. - -=item --iterations - -type: int; default: 1; group: Play - -How many times each thread should play all its session files. - -=item --max-sessions - -type: int; default: 5000000; group: Split - -Maximum number of sessions to L<"--split">. - -By default, C tries to split every session from the log file. -For huge logs, however, this can result in millions of sessions. This -option causes only the first N number of sessions to be saved. All sessions -after this number are ignored, but sessions split before this number will -continue to have their queries split even if those queries appear near the end -of the log and after this number has been reached. - -=item --only-select - -group: Play - -Play only SELECT and USE queries; ignore all others. - -=item --password - -short form: -p; type: string; group: Play - -Password to use when connecting. - -=item --pid - -type: string - -Create the given PID file. The file contains the process ID of the script. -The PID file is removed when the script exits. Before starting, the script -checks if the PID file already exists. If it does not, then the script creates -and writes its own PID to it. If it does, then the script checks the following: -if the file contains a PID and a process is running with that PID, then -the script dies; or, if there is no process running with that PID, then the -script overwrites the file with its own PID and starts; else, if the file -contains no PID, then the script dies. - -=item --play - -type: string; group: Play - -Play (execute) session files created by L<"--split">. - -The argument to play must be a comma-separated list of session files -created by L<"--split"> or a directory. If the argument is a directory, -ALL files in that directory will be played. - -=item --port - -short form: -P; type: int; group: Play - -Port number to use for connection. - -=item --print - -group: Play - -Print queries instead of playing them; requires L<"--play">. - -You must also specify L<"--play"> with L<"--print">. Although the queries -will not be executed, L<"--play"> is required to specify which session files to -read. - -=item --quiet - -short form: -q - -Do not print anything; disables L<"--verbose">. - -=item --[no]results - -default: yes - -Print L<"--play"> results to files in L<"--base-dir">. - -=item --session-files - -type: int; default: 8; group: Split - -Number of session files to create with L<"--split">. - -The number of session files should either be equal to the number of -L<"--threads"> you intend to L<"--play"> or be an even multiple of -L<"--threads">. This number is important for maximum performance because it: - - * allows each thread to have roughly the same amount of sessions to play - * avoids having to open/close many session files - * avoids disk IO overhead by doing large sequential reads - -You may want to increase this number beyond L<"--threads"> if each session -file becomes too large. For example, splitting a 20G log into 8 sessions -files may yield roughly eight 2G session files. - -See also L<"--max-sessions">. - -=item --set-vars - -type: string; group: Play; default: wait_timeout=10000 - -Set these MySQL variables. Immediately after connecting to MySQL, this string -will be appended to SET and executed. - -=item --socket - -short form: -S; type: string; group: Play - -Socket file to use for connection. - -=item --split - -type: string; group: Split - -Split log by given attribute to create session files. - -Valid attributes are any which appear in the log: Thread_id, Schema, -etc. - -=item --split-random - -group: Split - -Split log without an attribute, write queries round-robin to session files. - -This option, if specified, overrides L<"--split"> and causes the log to be -split query-by-query, writing each query to the next session file in round-robin -style. If you don't care about "sessions" and just want to split a lot into -N many session files and the relation or order of the queries does not matter, -then use this option. - -=item --threads - -type: int; default: 2; group: Play - -Number of threads used to play sessions concurrently. - -Specifies the number of parallel processes to run. The default is 2. On -GNU/Linux machines, the default is the number of times 'processor' appears in -F. On Windows, the default is read from the environment. -In any case, the default is at least 2, even when there's only a single -processor. - -See also L<"--session-files">. - -=item --type - -type: string; group: Split - -The type of log to L<"--split"> (default slowlog). The permitted types are - -=over - -=item binlog - -Split the output of running C against a binary log file. -Currently, splitting binary logs does not always work well depending -on what the binary logs contain. Be sure to check the session files -after splitting to ensure proper L<"OUTPUT">. - -If the binary log contains row-based replication data, you need to run -C with options C<--base64-output=decode-rows --verbose>, -else invalid statements will be written to the session files. - -=item genlog - -Split a general log file. - -=item slowlog - -Split a log file in any variation of MySQL slow-log format. - -=back - -=item --user - -short form: -u; type: string; group: Play - -User for login if not current user. - -=item --verbose - -short form: -v; cumulative: yes; default: 0 - -Increase verbosity; can be specified multiple times. - -This option is disabled by L<"--quiet">. - -=item --version - -Show version and exit. - -=item --[no]warnings - -default: no; group: Play - -Print warnings about SQL errors such as invalid queries to STDERR. - -=back - -=head1 DSN OPTIONS - -These DSN options are used to create a DSN. Each option is given like -C. The options are case-sensitive, so P and p are not the -same option. There cannot be whitespace before or after the C<=> and -if the value contains whitespace it must be quoted. DSN options are -comma-separated. See the L manpage for full details. - -=over - -=item * A - -dsn: charset; copy: yes - -Default character set. - -=item * D - -dsn: database; copy: yes - -Default database. - -=item * F - -dsn: mysql_read_default_file; copy: yes - -Only read default options from the given file - -=item * h - -dsn: host; copy: yes - -Connect to host. - -=item * p - -dsn: password; copy: yes - -Password to use when connecting. - -=item * P - -dsn: port; copy: yes - -Port number to use for connection. - -=item * S - -dsn: mysql_socket; copy: yes - -Socket file to use for connection. - -=item * u - -dsn: user; copy: yes - -User for login if not current user. - -=back - -=head1 ENVIRONMENT - -The environment variable C enables verbose debugging output to STDERR. -To enable debugging and capture all output to a file, run the tool like: - - PTDEBUG=1 pt-log-player ... > FILE 2>&1 - -Be careful: debugging output is voluminous and can generate several megabytes -of output. - -=head1 SYSTEM REQUIREMENTS - -You need Perl, DBI, DBD::mysql, and some core packages that ought to be -installed in any reasonably new version of Perl. - -=head1 BUGS - -For a list of known bugs, see L. - -Please report bugs at L. -Include the following information in your bug report: - -=over - -=item * Complete command-line used to run the tool - -=item * Tool L<"--version"> - -=item * MySQL version of all servers involved - -=item * Output from the tool including STDERR - -=item * Input files (log/dump/config files, etc.) - -=back - -If possible, include debugging output by running the tool with C; -see L<"ENVIRONMENT">. - -=head1 DOWNLOADING - -Visit L to download the -latest release of Percona Toolkit. Or, get the latest release from the -command line: - - wget percona.com/get/percona-toolkit.tar.gz - - wget percona.com/get/percona-toolkit.rpm - - wget percona.com/get/percona-toolkit.deb - -You can also get individual tools from the latest release: - - wget percona.com/get/TOOL - -Replace C with the name of any tool. - -=head1 AUTHORS - -Daniel Nichter - -=head1 ABOUT PERCONA TOOLKIT - -This tool is part of Percona Toolkit, a collection of advanced command-line -tools developed by Percona for MySQL support and consulting. Percona Toolkit -was forked from two projects in June, 2011: Maatkit and Aspersa. Those -projects were created by Baron Schwartz and developed primarily by him and -Daniel Nichter, both of whom are employed by Percona. Visit -L for more software developed by Percona. - -=head1 COPYRIGHT, LICENSE, AND WARRANTY - -This program is copyright 2008-2012 Percona Inc. -Feedback and improvements are welcome. - -THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -This program is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 2; OR the Perl Artistic License. On UNIX and similar -systems, you can issue `man perlgpl' or `man perlartistic' to read these -licenses. - -You should have received a copy of the GNU General Public License along with -this program; if not, write to the Free Software Foundation, Inc., 59 Temple -Place, Suite 330, Boston, MA 02111-1307 USA. - -=head1 VERSION - -pt-log-player 2.1.7 - -=cut diff --git a/bin/pt-tcp-model b/bin/pt-tcp-model deleted file mode 100755 index 4991e170..00000000 --- a/bin/pt-tcp-model +++ /dev/null @@ -1,2534 +0,0 @@ -#!/usr/bin/env perl - -# This program is part of Percona Toolkit: http://www.percona.com/software/ -# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal -# 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( - OptionParser - Transformers - Progress - FileIterator - SimpleTCPDumpParser - TCPRequestAggregator - )); -} - -# ########################################################################### -# 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 Bazaar repository at, -# lib/OptionParser.pm -# t/lib/OptionParser.t -# See https://launchpad.net/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; - -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, - ); - - 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'), - }; - } - 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_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(?: ([^)]+))?/) ) { - $self->{defaults}->{$long} = defined $def ? $def : 1; - 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}++; - } - 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] 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"; - } - else { - print "Error parsing version. See the VERSION section of the tool's documentation.\n"; - } - exit 1; - } - - 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); - $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); - } - 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 $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 - && (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 _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 '# ', $^X, ' ', $], "\n"; - if ( my $uname = `uname -a` ) { - $uname =~ s/\s+/ /g; - print "# $uname\n"; - } - print '# Arguments: ', - join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; -} - -1; -} -# ########################################################################### -# End OptionParser package -# ########################################################################### - -# ########################################################################### -# Transformers package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Transformers.pm -# t/lib/Transformers.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Transformers; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Time::Local qw(timegm timelocal); -use Digest::MD5 qw(md5_hex); -use B qw(); - -require Exporter; -our @ISA = qw(Exporter); -our %EXPORT_TAGS = (); -our @EXPORT = (); -our @EXPORT_OK = qw( - micro_t - percentage_of - secs_to_time - time_to_secs - shorten - ts - parse_timestamp - unix_timestamp - any_unix_timestamp - make_checksum - crc32 - encode_json -); - -our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/; -our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/; -our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks - -sub micro_t { - my ( $t, %args ) = @_; - my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals - my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals - my $f; - - $t = 0 if $t < 0; - - $t = sprintf('%.17f', $t) if $t =~ /e/; - - $t =~ s/\.(\d{1,6})\d*/\.$1/; - - if ($t > 0 && $t <= 0.000999) { - $f = ($t * 1000000) . 'us'; - } - elsif ($t >= 0.001000 && $t <= 0.999999) { - $f = sprintf("%.${p_ms}f", $t * 1000); - $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros - } - elsif ($t >= 1) { - $f = sprintf("%.${p_s}f", $t); - $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros - } - else { - $f = 0; # $t should = 0 at this point - } - - return $f; -} - -sub percentage_of { - my ( $is, $of, %args ) = @_; - my $p = $args{p} || 0; # float precision - my $fmt = $p ? "%.${p}f" : "%d"; - return sprintf $fmt, ($is * 100) / ($of ||= 1); -} - -sub secs_to_time { - my ( $secs, $fmt ) = @_; - $secs ||= 0; - return '00:00' unless $secs; - - $fmt ||= $secs >= 86_400 ? 'd' - : $secs >= 3_600 ? 'h' - : 'm'; - - return - $fmt eq 'd' ? sprintf( - "%d+%02d:%02d:%02d", - int($secs / 86_400), - int(($secs % 86_400) / 3_600), - int(($secs % 3_600) / 60), - $secs % 60) - : $fmt eq 'h' ? sprintf( - "%02d:%02d:%02d", - int(($secs % 86_400) / 3_600), - int(($secs % 3_600) / 60), - $secs % 60) - : sprintf( - "%02d:%02d", - int(($secs % 3_600) / 60), - $secs % 60); -} - -sub time_to_secs { - my ( $val, $default_suffix ) = @_; - die "I need a val argument" unless defined $val; - my $t = 0; - my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; - $suffix = $suffix || $default_suffix || 's'; - if ( $suffix =~ m/[smhd]/ ) { - $t = $suffix eq 's' ? $num * 1 # Seconds - : $suffix eq 'm' ? $num * 60 # Minutes - : $suffix eq 'h' ? $num * 3600 # Hours - : $num * 86400; # Days - - $t *= -1 if $prefix && $prefix eq '-'; - } - else { - die "Invalid suffix for $val: $suffix"; - } - return $t; -} - -sub shorten { - my ( $num, %args ) = @_; - my $p = defined $args{p} ? $args{p} : 2; # float precision - my $d = defined $args{d} ? $args{d} : 1_024; # divisor - my $n = 0; - my @units = ('', qw(k M G T P E Z Y)); - while ( $num >= $d && $n < @units - 1 ) { - $num /= $d; - ++$n; - } - return sprintf( - $num =~ m/\./ || $n - ? "%.${p}f%s" - : '%d', - $num, $units[$n]); -} - -sub ts { - my ( $time, $gmt ) = @_; - my ( $sec, $min, $hour, $mday, $mon, $year ) - = $gmt ? gmtime($time) : localtime($time); - $mon += 1; - $year += 1900; - my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d", - $year, $mon, $mday, $hour, $min, $sec); - if ( my ($us) = $time =~ m/(\.\d+)$/ ) { - $us = sprintf("%.6f", $us); - $us =~ s/^0\././; - $val .= $us; - } - return $val; -} - -sub parse_timestamp { - my ( $val ) = @_; - if ( my($y, $m, $d, $h, $i, $s, $f) - = $val =~ m/^$mysql_ts$/ ) - { - return sprintf "%d-%02d-%02d %02d:%02d:" - . (defined $f ? '%09.6f' : '%02d'), - $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s); - } - return $val; -} - -sub unix_timestamp { - my ( $val, $gmt ) = @_; - if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) { - $val = $gmt - ? timegm($s, $i, $h, $d, $m - 1, $y) - : timelocal($s, $i, $h, $d, $m - 1, $y); - if ( defined $us ) { - $us = sprintf('%.6f', $us); - $us =~ s/^0\././; - $val .= $us; - } - } - return $val; -} - -sub any_unix_timestamp { - my ( $val, $callback ) = @_; - - if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) { - $n = $suffix eq 's' ? $n # Seconds - : $suffix eq 'm' ? $n * 60 # Minutes - : $suffix eq 'h' ? $n * 3600 # Hours - : $suffix eq 'd' ? $n * 86400 # Days - : $n; # default: Seconds - PTDEBUG && _d('ts is now - N[shmd]:', $n); - return time - $n; - } - elsif ( $val =~ m/^\d{9,}/ ) { - PTDEBUG && _d('ts is already a unix timestamp'); - return $val; - } - elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) { - PTDEBUG && _d('ts is MySQL slow log timestamp'); - $val .= ' 00:00:00' unless $hms; - return unix_timestamp(parse_timestamp($val)); - } - elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) { - PTDEBUG && _d('ts is properly formatted timestamp'); - $val .= ' 00:00:00' unless $hms; - return unix_timestamp($val); - } - else { - PTDEBUG && _d('ts is MySQL expression'); - return $callback->($val) if $callback && ref $callback eq 'CODE'; - } - - PTDEBUG && _d('Unknown ts type:', $val); - return; -} - -sub make_checksum { - my ( $val ) = @_; - my $checksum = uc substr(md5_hex($val), -16); - PTDEBUG && _d($checksum, 'checksum for', $val); - return $checksum; -} - -sub crc32 { - my ( $string ) = @_; - return unless $string; - my $poly = 0xEDB88320; - my $crc = 0xFFFFFFFF; - foreach my $char ( split(//, $string) ) { - my $comp = ($crc ^ ord($char)) & 0xFF; - for ( 1 .. 8 ) { - $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1; - } - $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp; - } - return $crc ^ 0xFFFFFFFF; -} - -my $got_json = eval { require JSON }; -sub encode_json { - return JSON::encode_json(@_) if $got_json; - my ( $data ) = @_; - return (object_to_json($data) || ''); -} - - -sub object_to_json { - my ($obj) = @_; - my $type = ref($obj); - - if($type eq 'HASH'){ - return hash_to_json($obj); - } - elsif($type eq 'ARRAY'){ - return array_to_json($obj); - } - else { - return value_to_json($obj); - } -} - -sub hash_to_json { - my ($obj) = @_; - my @res; - for my $k ( sort { $a cmp $b } keys %$obj ) { - push @res, string_to_json( $k ) - . ":" - . ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) ); - } - return '{' . ( @res ? join( ",", @res ) : '' ) . '}'; -} - -sub array_to_json { - my ($obj) = @_; - my @res; - - for my $v (@$obj) { - push @res, object_to_json($v) || value_to_json($v); - } - - return '[' . ( @res ? join( ",", @res ) : '' ) . ']'; -} - -sub value_to_json { - my ($value) = @_; - - return 'null' if(!defined $value); - - my $b_obj = B::svref_2object(\$value); # for round trip problem - my $flags = $b_obj->FLAGS; - return $value # as is - if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? - - my $type = ref($value); - - if( !$type ) { - return string_to_json($value); - } - else { - return 'null'; - } - -} - -my %esc = ( - "\n" => '\n', - "\r" => '\r', - "\t" => '\t', - "\f" => '\f', - "\b" => '\b', - "\"" => '\"', - "\\" => '\\\\', - "\'" => '\\\'', -); - -sub string_to_json { - my ($arg) = @_; - - $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; - $arg =~ s/\//\\\//g; - $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; - - utf8::upgrade($arg); - utf8::encode($arg); - - return '"' . $arg . '"'; -} - -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 Transformers package -# ########################################################################### - -# ########################################################################### -# Progress package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Progress.pm -# t/lib/Progress.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Progress; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -sub new { - my ( $class, %args ) = @_; - foreach my $arg (qw(jobsize)) { - die "I need a $arg argument" unless defined $args{$arg}; - } - if ( (!$args{report} || !$args{interval}) ) { - if ( $args{spec} && @{$args{spec}} == 2 ) { - @args{qw(report interval)} = @{$args{spec}}; - } - else { - die "I need either report and interval arguments, or a spec"; - } - } - - my $name = $args{name} || "Progress"; - $args{start} ||= time(); - my $self; - $self = { - last_reported => $args{start}, - fraction => 0, # How complete the job is - callback => sub { - my ($fraction, $elapsed, $remaining, $eta) = @_; - printf STDERR "$name: %3d%% %s remain\n", - $fraction * 100, - Transformers::secs_to_time($remaining), - Transformers::ts($eta); - }, - %args, - }; - return bless $self, $class; -} - -sub validate_spec { - shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress:: - my ( $spec ) = @_; - if ( @$spec != 2 ) { - die "spec array requires a two-part argument\n"; - } - if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) { - die "spec array's first element must be one of " - . "percentage,time,iterations\n"; - } - if ( $spec->[1] !~ m/^\d+$/ ) { - die "spec array's second element must be an integer\n"; - } -} - -sub set_callback { - my ( $self, $callback ) = @_; - $self->{callback} = $callback; -} - -sub start { - my ( $self, $start ) = @_; - $self->{start} = $self->{last_reported} = $start || time(); - $self->{first_report} = 0; -} - -sub update { - my ( $self, $callback, %args ) = @_; - my $jobsize = $self->{jobsize}; - my $now ||= $args{now} || time; - - $self->{iterations}++; # How many updates have happened; - - if ( !$self->{first_report} && $args{first_report} ) { - $args{first_report}->(); - $self->{first_report} = 1; - } - - if ( $self->{report} eq 'time' - && $self->{interval} > $now - $self->{last_reported} - ) { - return; - } - elsif ( $self->{report} eq 'iterations' - && ($self->{iterations} - 1) % $self->{interval} > 0 - ) { - return; - } - $self->{last_reported} = $now; - - my $completed = $callback->(); - $self->{updates}++; # How many times we have run the update callback - - return if $completed > $jobsize; - - my $fraction = $completed > 0 ? $completed / $jobsize : 0; - - if ( $self->{report} eq 'percentage' - && $self->fraction_modulo($self->{fraction}) - >= $self->fraction_modulo($fraction) - ) { - $self->{fraction} = $fraction; - return; - } - $self->{fraction} = $fraction; - - my $elapsed = $now - $self->{start}; - my $remaining = 0; - my $eta = $now; - if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) { - my $rate = $completed / $elapsed; - if ( $rate > 0 ) { - $remaining = ($jobsize - $completed) / $rate; - $eta = $now + int($remaining); - } - } - $self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed); -} - -sub fraction_modulo { - my ( $self, $num ) = @_; - $num *= 100; # Convert from fraction to percentage - return sprintf('%d', - sprintf('%d', $num / $self->{interval}) * $self->{interval}); -} - -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 Progress package -# ########################################################################### - -# ########################################################################### -# FileIterator package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/FileIterator.pm -# t/lib/FileIterator.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package FileIterator; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -sub new { - my ( $class, %args ) = @_; - my $self = { - %args, - }; - return bless $self, $class; -} - -sub get_file_itr { - my ( $self, @filenames ) = @_; - - my @final_filenames; - FILENAME: - foreach my $fn ( @filenames ) { - if ( !defined $fn ) { - warn "Skipping undefined filename"; - next FILENAME; - } - if ( $fn ne '-' ) { - if ( !-e $fn || !-r $fn ) { - warn "$fn does not exist or is not readable"; - next FILENAME; - } - } - push @final_filenames, $fn; - } - - if ( !@filenames ) { - push @final_filenames, '-'; - PTDEBUG && _d('Auto-adding "-" to the list of filenames'); - } - - PTDEBUG && _d('Final filenames:', @final_filenames); - return sub { - while ( @final_filenames ) { - my $fn = shift @final_filenames; - PTDEBUG && _d('Filename:', $fn); - if ( $fn eq '-' ) { # Magical STDIN filename. - return (*STDIN, undef, undef); - } - open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR"; - if ( $fh ) { - return ( $fh, $fn, -s $fn ); - } - } - return (); # Avoids $f being set to 0 in list context. - }; -} - -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 FileIterator package -# ########################################################################### - -# ########################################################################### -# SimpleTCPDumpParser package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/SimpleTCPDumpParser.pm -# t/lib/SimpleTCPDumpParser.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package SimpleTCPDumpParser; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Time::Local qw(timelocal); -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -sub new { - my ( $class, %args ) = @_; - my ($ip, $port) = split(/:/, $args{watch}); - my $self = { - sessions => {}, - requests => 0, - port => $port || 3306, - }; - return bless $self, $class; -} - -sub parse_event { - my ( $self, %args ) = @_; - my @required_args = qw(next_event tell); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my ($next_event, $tell) = @args{@required_args}; - - my $sessions = $self->{sessions}; - my $pos_in_log = $tell->(); - my $line; - - EVENT: - while ( defined($line = $next_event->()) ) { - my ( $ts, $us, $src, $dst ) - = $line =~ m/([0-9-]{10} [0-9:]{8})(\.\d{6}) IP (\S+) > (\S+):/; - next unless $ts; - my $unix_timestamp = make_ts($ts) . $us; - - if ( $dst =~ m/\.$self->{port}$/o ) { - my $event; - if ( exists $sessions->{$src} && $sessions->{$src}->{status} eq 'R' ) { - $event = $self->make_event($src); - } - if ( exists $sessions->{$src} ) { - $sessions->{$src}->{ts} = $unix_timestamp; - } - else { - $sessions->{$src} ||= { - pos_in_log => $pos_in_log, - ts => $unix_timestamp, - ts0 => $unix_timestamp, - id => $self->{requests}++, - status => 'Q', - }; - } - return $event if $event; - } - - elsif (defined (my $event = $sessions->{$dst}) ) { - $event->{status} = 'R', - $event->{end} ||= $unix_timestamp; - $event->{end1} = $unix_timestamp; - } - $pos_in_log = $tell->(); - } # EVENT - - foreach my $src ( keys %$sessions ) { - my $event = $self->make_event($src); - return $event if $event; - } - - $args{oktorun}->(0) if $args{oktorun}; - return; -} - -sub make_event { - my ( $self, $src ) = @_; - my $event = $self->{sessions}->{$src}; - delete $self->{sessions}->{$src}; - if ( $event->{status} eq 'R' ) { - my ( $src_host, $src_port ) = $src =~ m/^(.*)\.(\d+)$/; - $event->{host} = $src_host; - $event->{port} = $src_port; - $event->{arg} = undef; - delete $event->{status}; - PTDEBUG && _d('Properties of event:', Dumper($event)); - return $event; - } - return undef; -} - -{ - my ($last, $result); - sub make_ts { - my ($arg) = @_; - if ( !$last || $last ne $arg ) { - my ($year, $mon, $mday, $hour, $min, $sec) = split(/\D/, $arg); - $result = timelocal($sec, $min, $hour, $mday, $mon - 1, $year); - $last = $arg; - } - return $result; - } -} - -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 SimpleTCPDumpParser package -# ########################################################################### - -# ########################################################################### -# TCPRequestAggregator package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/TCPRequestAggregator.pm -# t/lib/TCPRequestAggregator.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package TCPRequestAggregator; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use List::Util qw(sum); -use Data::Dumper; - -sub new { - my ( $class, %args ) = @_; - my @required_args = qw(interval quantile); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my $self = { - buffer => [], - last_weighted_time => 0, - last_busy_time => 0, - last_completions => 0, - current_ts => 0, - %args, - }; - return bless $self, $class; -} - -sub parse_event { - my ( $self, %args ) = @_; - my @required_args = qw(next_event tell); - foreach my $arg ( @required_args ) { - die "I need a $arg argument" unless $args{$arg}; - } - my ($next_event, $tell) = @args{@required_args}; - - my $pos_in_log = $tell->(); - my $buffer = $self->{buffer}; - $self->{last_pos_in_log} ||= $pos_in_log; - - EVENT: - while ( 1 ) { - PTDEBUG && _d("Beginning a loop at pos", $pos_in_log); - my ( $id, $start, $elapsed ); - - my ($timestamp, $direction); - if ( $self->{pending} ) { - ( $id, $start, $elapsed ) = @{$self->{pending}}; - PTDEBUG && _d("Pulled from pending", @{$self->{pending}}); - } - elsif ( defined(my $line = $next_event->()) ) { - my ($end, $host_port); - ( $id, $start, $end, $elapsed, $host_port ) = $line =~ m/(\S+)/g; - @$buffer = sort { $a <=> $b } ( @$buffer, $end ); - PTDEBUG && _d("Read from the file", $id, $start, $end, $elapsed, $host_port); - PTDEBUG && _d("Buffer is now", @$buffer); - } - if ( $start ) { # Test that we got a line; $id can be 0. - if ( @$buffer && $buffer->[0] < $start ) { - $direction = 'C'; # Completion - $timestamp = shift @$buffer; - $self->{pending} = [ $id, $start, $elapsed ]; - $id = $start = $elapsed = undef; - PTDEBUG && _d("Completion: using buffered end value", $timestamp); - PTDEBUG && _d("Saving line to pending", @{$self->{pending}}); - } - else { - $direction = 'A'; # Arrival - $timestamp = $start; - $self->{pending} = undef; - PTDEBUG && _d("Deleting pending line"); - PTDEBUG && _d("Arrival: using the line"); - } - } - elsif ( @$buffer ) { - $direction = 'C'; - $timestamp = shift @$buffer; - PTDEBUG && _d("No more lines, reading from buffer", $timestamp); - } - else { # We hit EOF. - PTDEBUG && _d("No more lines, no more buffered end times"); - if ( $self->{in_prg} ) { - die "Error: no more lines, but in_prg = $self->{in_prg}"; - } - if ( defined $self->{t_start} - && defined $self->{current_ts} - && $self->{t_start} < $self->{current_ts} ) - { - PTDEBUG && _d("Returning event based on what's been seen"); - return $self->make_event($self->{t_start}, $self->{current_ts}); - } - else { - PTDEBUG && _d("No further events to make"); - return; - } - } - - my $t_start = int($timestamp / $self->{interval}) * $self->{interval}; - $self->{t_start} ||= $timestamp; # Not $t_start; that'd skew 1st interval. - PTDEBUG && _d("Timestamp", $timestamp, "interval start time", $t_start); - - if ( $t_start > $self->{t_start} ) { - PTDEBUG && _d("Timestamp doesn't belong to this interval"); - if ( $self->{in_prg} ) { - PTDEBUG && _d("Computing from", $self->{current_ts}, "to", $t_start); - $self->{busy_time} += $t_start - $self->{current_ts}; - $self->{weighted_time} += ($t_start - $self->{current_ts}) * $self->{in_prg}; - } - - if ( @$buffer && $buffer->[0] < $t_start ) { - die "Error: completions for interval remain unprocessed"; - } - - my $event = $self->make_event($self->{t_start}, $t_start); - $self->{last_pos_in_log} = $pos_in_log; - if ( $start ) { - $self->{pending} = [ $id, $start, $elapsed ]; - } - else { - unshift @$buffer, $timestamp; - } - return $event; - } - - else { - if ( $self->{in_prg} ) { - PTDEBUG && _d("Computing from", $self->{current_ts}, "to", $timestamp); - $self->{busy_time} += $timestamp - $self->{current_ts}; - $self->{weighted_time} += ($timestamp - $self->{current_ts}) * $self->{in_prg}; - } - $self->{current_ts} = $timestamp; - if ( $direction eq 'A' ) { - PTDEBUG && _d("Direction A", $timestamp); - ++$self->{in_prg}; - if ( defined $elapsed ) { - push @{$self->{response_times}}, $elapsed; - } - } - else { - PTDEBUG && _d("Direction C", $timestamp); - --$self->{in_prg}; - ++$self->{completions}; - } - } - - $pos_in_log = $tell->(); - } # EVENT - - $args{oktorun}->(0) if $args{oktorun}; - return; -} - -sub make_event { - my ( $self, $t_start, $t_end ) = @_; - - my $quantile_cutoff = sprintf( "%.0f", # Round to nearest int - scalar( @{ $self->{response_times} } ) * $self->{quantile} ); - my @times = sort { $a <=> $b } @{ $self->{response_times} }; - my $arrivals = scalar(@times); - my $sum_times = sum( @times ); - my $mean_times = ($sum_times || 0) / ($arrivals || 1); - my $var_times = 0; - if ( @times ) { - $var_times = sum( map { ($_ - $mean_times) **2 } @times ) / $arrivals; - } - - my $e_ts - = int( $self->{current_ts} / $self->{interval} ) * $self->{interval}; - my $e_concurrency = sprintf( "%.6f", - ( $self->{weighted_time} - $self->{last_weighted_time} ) - / ( $t_end - $t_start ) ); - my $e_arrivals = $arrivals; - my $e_throughput = sprintf( "%.6f", $e_arrivals / ( $t_end - $t_start ) ); - my $e_completions - = ( $self->{completions} - $self->{last_completions} ); - my $e_busy_time - = sprintf( "%.6f", $self->{busy_time} - $self->{last_busy_time} ); - my $e_weighted_time = sprintf( "%.6f", - $self->{weighted_time} - $self->{last_weighted_time} ); - my $e_sum_time = sprintf("%.6f", $sum_times || 0); - my $e_variance_mean = sprintf("%.6f", $var_times / ($mean_times || 1)); - my $e_quantile_time = sprintf("%.6f", $times[ $quantile_cutoff - 1 ] || 0); - - my $event = { - ts => $e_ts, - concurrency => $e_concurrency, - throughput => $e_throughput, - arrivals => $e_arrivals, - completions => $e_completions, - busy_time => $e_busy_time, - weighted_time => $e_weighted_time, - sum_time => $e_sum_time, - variance_mean => $e_variance_mean, - quantile_time => $e_quantile_time, - pos_in_log => $self->{last_pos_in_log}, - obs_time => sprintf("%.6f", $t_end - $t_start), - }; - - $self->{t_start} = $t_end; # Not current_timestamp! - $self->{current_ts} = $t_end; # Next iteration will begin at boundary - $self->{last_weighted_time} = $self->{weighted_time}; - $self->{last_busy_time} = $self->{busy_time}; - $self->{last_completions} = $self->{completions}; - $self->{response_times} = []; - - PTDEBUG && _d("Event is", Dumper($event)); - return $event; -} - -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 TCPRequestAggregator 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_tcp_model; - -use English qw(-no_match_vars); -use Time::Local qw(timelocal); -use Time::HiRes qw(time usleep); -use List::Util qw(max); -use POSIX qw(signal_h); -use Data::Dumper; -$Data::Dumper::Indent = 1; -$OUTPUT_AUTOFLUSH = 1; - -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use sigtrap 'handler', \&sig_int, 'normal-signals'; - -# Global variables. Only really essential variables should be here. -my $oktorun = 1; - -sub main { - @ARGV = @_; # set global ARGV for this package - $oktorun = 1; # reset between tests else pipeline won't run - - # ########################################################################## - # Get configuration information. - # ########################################################################## - my $o = new OptionParser(); - $o->get_specs(); - $o->get_opts(); - if ( !$o->get('help') ) { - if ( $o->get('progress') ) { - eval { Progress->validate_spec($o->get('progress')) }; - if ( $EVAL_ERROR ) { - chomp $EVAL_ERROR; - $o->save_error("--progress $EVAL_ERROR"); - } - } - if ( $o->get('type') !~ m/^(tcpdump|requests)$/ ) { - $o->save_error("--type must be tcpdump or requests"); - } - } - $o->usage_or_errors(); - - # ######################################################################## - # Set up objects and variables. - # ######################################################################## - my $fi = new FileIterator(); - my $parser; - if ( $o->get('type') eq 'tcpdump' ) { # Default: parse tcpdump - $parser = new SimpleTCPDumpParser(watch => $o->get('watch-server')); - } - else { - $parser = new TCPRequestAggregator( - interval => $o->get('run-time'), - quantile => $o->get('quantile') - ); - } - - # ######################################################################## - # This is the main loop over the input filenames. - # ######################################################################## - my $next_file = $fi->get_file_itr(@ARGV); - my ( $fh, $filename, $filesize ) = $next_file->(); - FILE: - while ( defined $fh ) { - - # Create a callback to get events from the input. - my $next_event = sub { return <$fh>; }; - my $tell = sub { return tell $fh; }; - my $event; - my $get_event = sub { - return $parser->parse_event( - event => $event, - next_event => $next_event, - tell => $tell, - oktorun => sub { return 1 }, - misc => {}, - stats => {}, - ); - }; - - # ##################################################################### - # Set up a progress reporter. For right now, we just do one per file. - # Maybe someday we can do a global progress report? - # ##################################################################### - my $pr; - if ( $o->get('progress') && $filename && -e $filename ) { - $pr = new Progress( - jobsize => -s $filename, - spec => $o->get('progress'), - name => $filename, - ); - } - - # ##################################################################### - # This is the main loop over the events in the input file. - # ##################################################################### - my ($ts, $end) = @{$o->get('start-end')}; - EVENT: - while ( $event = $get_event->() ) { - if ( $o->get('type') eq 'tcpdump' ) { - printf "%6d %.6f %.6f %9.6f %s:%s\n", - $event->{id}, - $event->{$ts}, - $event->{$end}, - $event->{$end} - $event->{$ts}, - $event->{host}, - $event->{port}; - } - else { - printf "%s %5.2f %9.3f %5d %5d %.6f %.6f %.6f %.6f %.6f %.6f\n", - @{$event}{qw( - ts concurrency throughput arrivals completions busy_time - weighted_time sum_time variance_mean quantile_time obs_time)}; - } - $pr->update($tell) if $pr; - } # EVENT - - ( $fh, $filename, $filesize ) = $next_file->(); - } # FILE - - return 0; -} # End main() - -# ############################################################################ -# Subroutines. -# ############################################################################ - -# Catches signals so we can exit gracefully. -sub sig_int { - my ( $signal ) = @_; - if ( $oktorun ) { - print STDERR "# Caught SIG$signal.\n"; - $oktorun = 0; - } - else { - print STDERR "# Exiting on SIG$signal.\n"; - exit(1); - } -} - -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"; -} - -# ############################################################################ -# Run the program. -# ############################################################################ -exit main(@ARGV) unless caller; - -1; # Because this is a module as well as a script. - -# ############################################################################# -# Documentation. -# ############################################################################# - -=pod - -=head1 NAME - -pt-tcp-model - Transform tcpdump into metrics that permit performance and scalability modeling. - -=head1 SYNOPSIS - -Usage: pt-tcp-model [OPTION...] [FILE] - -pt-tcp-model parses and analyzes tcpdump files. With no FILE, or when -FILE is -, it read standard input. - -Dump TCP requests and responses to a file, capturing only the packet headers to -avoid dropped packets, and ignoring any packets without a payload (such as -ack-only packets). Capture port 3306 (MySQL database traffic). Note that to -avoid line breaking in terminals and man pages, the TCP filtering expression -that follows has a line break at the end of the second line; you should omit -this from your tcpdump command. - - tcpdump -s 384 -i any -nnq -tttt \ - 'tcp port 3306 and (((ip[2:2] - ((ip[0]&0xf)<<2)) - - ((tcp[12]&0xf0)>>2)) != 0)' \ - > /path/to/tcp-file.txt - -Extract individual response times, sorted by end time: - - pt-tcp-model /path/to/tcp-file.txt > requests.txt - -Sort the result by arrival time, for input to the next step: - - sort -n -k1,1 requests.txt > sorted.txt - -Slice the result into 10-second intervals and emit throughput, concurrency, and -response time metrics for each interval: - - pt-tcp-model --type=requests --run-time=10 sorted.txt > sliced.txt - -Transform the result for modeling with Aspersa's usl tool, discarding the first -and last line of each file if you specify multiple files (the first and last -line are normally incomplete observation periods and are aberrant): - - for f in sliced.txt; do - tail -n +2 "$f" | head -n -1 | awk '{print $2, $3, $7/$4}' - done > usl-input.txt - -=head1 RISKS - -The following section is included to inform users about the potential risks, -whether known or unknown, of using this tool. The two main categories of risks -are those created by the nature of the tool (e.g. read-only tools vs. read-write -tools) and those created by bugs. - -pt-tcp-model merely reads and transforms its input, printing it to the output. -It should be very low risk. - -At the time of this release, we know of no bugs that could cause serious harm -to users. - -The authoritative source for updated information is always the online issue -tracking system. Issues that affect this tool will be marked as such. You can -see a list of such issues at the following URL: -L. - -See also L<"BUGS"> for more information on filing bugs and getting help. - -=head1 DESCRIPTION - -This tool recognizes requests and responses in a TCP stream, and extracts the -"conversations". You can use it to capture the response times of individual -queries to a database, for example. It expects the TCP input to be in the -following format, which should result from the sample shown in the SYNOPSIS: - - IP > : - -The tool watches for "incoming" packets to the port you specify with the -L<"--watch-server"> option. This begins a request. If multiple inbound packets -follow each other, then by default the last inbound packet seen determines the -time at which the request is assumed to begin. This is logical if one assumes -that a server must receive the whole SQL statement before beginning execution, -for example. - -When the first outbound packet is seen, the server is considered to have -responded to the request. The tool might see an inbound packet, but never see a -response. This can happen when the kernel drops packets, for example. As a -result, the tool never prints a request unless it sees the response to it. -However, the tool actually does not print any request until it sees the "last" -outbound packet. It determines this by waiting for either another inbound -packet, or EOF, and then considers the previous inbound/outbound pair to be -complete. As a result, the tool prints requests in a relatively random order. -Most types of analysis require processing in either arrival or completion order. -Therefore, the second type of processing this tool can do requires that you sort -the output from the first stage and supply it as input. - -The second type of processing is selected with the L<"--type"> option set to -"requests". In this mode, the tool reads a group of requests and aggregates -them, then emits the aggregated metrics. - -=head1 OUTPUT - -In the default mode (parsing tcpdump output), requests are printed out one per -line, in the following format: - - - -The ID is an incrementing number, assigned in arrival order in the original TCP -traffic. The start and end timestamps, and the elapsed time, can be customized -with the L<"--start-end"> option. - -In "--type=requests" mode, the tool prints out one line per time interval as -defined by L<"--run-time">, with the following columns: ts, concurrency, -throughput, arrivals, completions, busy_time, weighted_time, sum_time, -variance_mean, quantile_time, obs_time. A detailed explanation follows: - -=over - -=item ts - -The timestamp that defines the beginning of the interval. - -=item concurrency - -The average number of requests resident in the server during the interval. - -=item throughput - -The number of arrivals per second during the interval. - -=item arrivals - -The number of arrivals during the interval. - -=item completions - -The number of completions during the interval. - -=item busy_time - -The total amount of time during which at least one request was resident in -the server during the interval. - -=item weighted_time - -The total response time of all the requests resident in the server during the -interval, including requests that neither arrived nor completed during the -interval. - -=item sum_time - -The total response time of all the requests that arrived in the interval. - -=item variance_mean - -The variance-to-mean ratio (index of dispersion) of the response times of the -requests that arrived in the interval. - -=item quantile_time - -The Nth percentile response time for all the requests that arrived in the -interval. See also L<"--quantile">. - -=item obs_time - -The length of the observation time window. This will usually be the same as the -interval length, except for the first and last intervals in a file, which might -have a shorter observation time. - -=back - -=head1 OPTIONS - -This tool accepts additional command-line arguments. Refer to the -L<"SYNOPSIS"> and usage information for details. - -=over - -=item --config - -type: Array - -Read this comma-separated list of config files; if specified, this must be the -first option on the command line. - -=item --help - -Show help and exit. - -=item --progress - -type: array; default: time,30 - -Print progress reports to STDERR. The value is a comma-separated list with two -parts. The first part can be percentage, time, or iterations; the second part -specifies how often an update should be printed, in percentage, seconds, or -number of iterations. - -=item --quantile - -type: float - -The percentile for the second to last last column when L<"--type"> is -"requests" (default .99). - -=item --run-time - -type: float - -The size of the aggregation interval in seconds when L<"--type"> is "requests" -(default 1). Fractional values are permitted. - -=item --start-end - -type: Array; default: ts,end - -Define how the arrival and completion timestamps of a query, and thus its -response time (elapsed time) are computed. Recall that there may be multiple -inbound and outbound packets per request and response, and refer to the -following ASCII diagram. Suppose that a client sends a series of three inbound -(I) packets to the server, which computes the result and then sends two outbound -(O) packets back: - - I I I ..................... O O - |<---->|<---response time----->|<-->| - ts0 ts end end1 - -By default, the query is considered to arrive at time ts, and complete at time -end. However, this might not be what you want. Perhaps you do not want to -consider the query to have completed until time end1. You can accomplish this -by setting this option to C. - -=item --type - -type: string - -The type of input to parse (default tcpdump). The permitted types are - -=over - -=item tcpdump - -The parser expects the input to be formatted with the following options: C<-x -n --q -tttt>. For example, if you want to capture output from your local machine, -you can do something like the following (the port must come last on FreeBSD): - - tcpdump -s 65535 -x -nn -q -tttt -i any -c 1000 port 3306 \ - > mysql.tcp.txt - pt-query-digest --type tcpdump mysql.tcp.txt - -The other tcpdump parameters, such as -s, -c, and -i, are up to you. Just make -sure the output looks like this (there is a line break in the first line to -avoid man-page problems): - - 2009-04-12 09:50:16.804849 IP 127.0.0.1.42167 - > 127.0.0.1.3306: tcp 37 - -All MySQL servers running on port 3306 are automatically detected in the -tcpdump output. Therefore, if the tcpdump out contains packets from -multiple servers on port 3306 (for example, 10.0.0.1:3306, 10.0.0.2:3306, -etc.), all packets/queries from all these servers will be analyzed -together as if they were one server. - -If you're analyzing traffic for a protocol that is not running on port -3306, see L<"--watch-server">. - -=back - -=item --version - -Show version and exit. - -=item --watch-server - -type: string; default: 10.10.10.10:3306 - -This option tells pt-tcp-model which server IP address and port (such as -"10.0.0.1:3306") to watch when parsing tcpdump for L<"--type"> tcpdump. If you -don't specify it, the tool watches all servers by looking for any IP address -using port 3306. If you're watching a server with a non-standard port, this -won't work, so you must specify the IP address and port to watch. - -Currently, IP address filtering isn't implemented; so even though you must -specify the option in IP:port form, it ignores the IP and only looks at the port -number. - -=back - -=head1 ENVIRONMENT - -The environment variable C enables verbose debugging output to STDERR. -To enable debugging and capture all output to a file, run the tool like: - - PTDEBUG=1 pt-tcp-model ... > FILE 2>&1 - -Be careful: debugging output is voluminous and can generate several megabytes -of output. - -=head1 SYSTEM REQUIREMENTS - -You need Perl, DBI, DBD::mysql, and some core packages that ought to be -installed in any reasonably new version of Perl. - -=head1 BUGS - -For a list of known bugs, see L. - -Please report bugs at L. -Include the following information in your bug report: - -=over - -=item * Complete command-line used to run the tool - -=item * Tool L<"--version"> - -=item * MySQL version of all servers involved - -=item * Output from the tool including STDERR - -=item * Input files (log/dump/config files, etc.) - -=back - -If possible, include debugging output by running the tool with C; -see L<"ENVIRONMENT">. - -=head1 DOWNLOADING - -Visit L to download the -latest release of Percona Toolkit. Or, get the latest release from the -command line: - - wget percona.com/get/percona-toolkit.tar.gz - - wget percona.com/get/percona-toolkit.rpm - - wget percona.com/get/percona-toolkit.deb - -You can also get individual tools from the latest release: - - wget percona.com/get/TOOL - -Replace C with the name of any tool. - -=head1 AUTHORS - -Baron Schwartz - -=head1 ABOUT PERCONA TOOLKIT - -This tool is part of Percona Toolkit, a collection of advanced command-line -tools developed by Percona for MySQL support and consulting. Percona Toolkit -was forked from two projects in June, 2011: Maatkit and Aspersa. Those -projects were created by Baron Schwartz and developed primarily by him and -Daniel Nichter, both of whom are employed by Percona. Visit -L for more software developed by Percona. - -=head1 COPYRIGHT, LICENSE, AND WARRANTY - -This program is copyright 2011 Baron Schwartz, 2011-2012 Percona Inc. -Feedback and improvements are welcome. - -THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -This program is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 2; OR the Perl Artistic License. On UNIX and similar -systems, you can issue `man perlgpl' or `man perlartistic' to read these -licenses. - -You should have received a copy of the GNU General Public License along with -this program; if not, write to the Free Software Foundation, Inc., 59 Temple -Place, Suite 330, Boston, MA 02111-1307 USA. - -=head1 VERSION - -pt-tcp-model 2.1.7 - -=cut diff --git a/bin/pt-trend b/bin/pt-trend deleted file mode 100755 index 9ded235f..00000000 --- a/bin/pt-trend +++ /dev/null @@ -1,2235 +0,0 @@ -#!/usr/bin/env perl - -# This program is part of Percona Toolkit: http://www.percona.com/software/ -# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal -# 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( - OptionParser - Daemon - Progress - FileIterator - TimeSeriesTrender - Transformers - )); -} - -# ########################################################################### -# 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 Bazaar repository at, -# lib/OptionParser.pm -# t/lib/OptionParser.t -# See https://launchpad.net/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; - -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, - ); - - 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'), - }; - } - 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_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(?: ([^)]+))?/) ) { - $self->{defaults}->{$long} = defined $def ? $def : 1; - 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}++; - } - 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] 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"; - } - else { - print "Error parsing version. See the VERSION section of the tool's documentation.\n"; - } - exit 1; - } - - 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); - $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); - } - 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 $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 - && (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 _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 '# ', $^X, ' ', $], "\n"; - if ( my $uname = `uname -a` ) { - $uname =~ s/\s+/ /g; - print "# $uname\n"; - } - print '# Arguments: ', - join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; -} - -1; -} -# ########################################################################### -# End OptionParser package -# ########################################################################### - -# ########################################################################### -# Daemon package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Daemon.pm -# t/lib/Daemon.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Daemon; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use POSIX qw(setsid); - -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(o) ) { - die "I need a $arg argument" unless $args{$arg}; - } - my $o = $args{o}; - my $self = { - o => $o, - log_file => $o->has('log') ? $o->get('log') : undef, - PID_file => $o->has('pid') ? $o->get('pid') : undef, - }; - - check_PID_file(undef, $self->{PID_file}); - - PTDEBUG && _d('Daemonized child will log to', $self->{log_file}); - return bless $self, $class; -} - -sub daemonize { - my ( $self ) = @_; - - PTDEBUG && _d('About to fork and daemonize'); - defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR"; - if ( $pid ) { - PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid); - exit; - } - - PTDEBUG && _d('Daemonizing child PID', $PID); - $self->{PID_owner} = $PID; - $self->{child} = 1; - - POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; - chdir '/' or die "Cannot chdir to /: $OS_ERROR"; - - $self->_make_PID_file(); - - $OUTPUT_AUTOFLUSH = 1; - - PTDEBUG && _d('Redirecting STDIN to /dev/null'); - close STDIN; - open STDIN, '/dev/null' - or die "Cannot reopen STDIN to /dev/null: $OS_ERROR"; - - if ( $self->{log_file} ) { - PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file}); - close STDOUT; - open STDOUT, '>>', $self->{log_file} - or die "Cannot open log file $self->{log_file}: $OS_ERROR"; - - close STDERR; - open STDERR, ">&STDOUT" - or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; - } - else { - if ( -t STDOUT ) { - PTDEBUG && _d('No log file and STDOUT is a terminal;', - 'redirecting to /dev/null'); - close STDOUT; - open STDOUT, '>', '/dev/null' - or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR"; - } - if ( -t STDERR ) { - PTDEBUG && _d('No log file and STDERR is a terminal;', - 'redirecting to /dev/null'); - close STDERR; - open STDERR, '>', '/dev/null' - or die "Cannot reopen STDERR to /dev/null: $OS_ERROR"; - } - } - - return; -} - -sub check_PID_file { - my ( $self, $file ) = @_; - my $PID_file = $self ? $self->{PID_file} : $file; - PTDEBUG && _d('Checking PID file', $PID_file); - if ( $PID_file && -f $PID_file ) { - my $pid; - eval { - chomp($pid = (slurp_file($PID_file) || '')); - }; - if ( $EVAL_ERROR ) { - die "The PID file $PID_file already exists but it cannot be read: " - . $EVAL_ERROR; - } - PTDEBUG && _d('PID file exists; it contains PID', $pid); - if ( $pid ) { - my $pid_is_alive = kill 0, $pid; - if ( $pid_is_alive ) { - die "The PID file $PID_file already exists " - . " and the PID that it contains, $pid, is running"; - } - else { - warn "Overwriting PID file $PID_file because the PID that it " - . "contains, $pid, is not running"; - } - } - else { - die "The PID file $PID_file already exists but it does not " - . "contain a PID"; - } - } - else { - PTDEBUG && _d('No PID file'); - } - return; -} - -sub make_PID_file { - my ( $self ) = @_; - if ( exists $self->{child} ) { - die "Do not call Daemon::make_PID_file() for daemonized scripts"; - } - $self->_make_PID_file(); - $self->{PID_owner} = $PID; - return; -} - -sub _make_PID_file { - my ( $self ) = @_; - - my $PID_file = $self->{PID_file}; - if ( !$PID_file ) { - PTDEBUG && _d('No PID file to create'); - return; - } - - $self->check_PID_file(); - - open my $PID_FH, '>', $PID_file - or die "Cannot open PID file $PID_file: $OS_ERROR"; - print $PID_FH $PID - or die "Cannot print to PID file $PID_file: $OS_ERROR"; - close $PID_FH - or die "Cannot close PID file $PID_file: $OS_ERROR"; - - PTDEBUG && _d('Created PID file:', $self->{PID_file}); - return; -} - -sub _remove_PID_file { - my ( $self ) = @_; - if ( $self->{PID_file} && -f $self->{PID_file} ) { - unlink $self->{PID_file} - or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR"; - PTDEBUG && _d('Removed PID file'); - } - else { - PTDEBUG && _d('No PID to remove'); - } - return; -} - -sub DESTROY { - my ( $self ) = @_; - - $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID; - - return; -} - -sub slurp_file { - my ($file) = @_; - return unless $file; - open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; - return do { local $/; <$fh> }; -} - -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 Daemon package -# ########################################################################### - -# ########################################################################### -# Progress package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Progress.pm -# t/lib/Progress.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Progress; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -sub new { - my ( $class, %args ) = @_; - foreach my $arg (qw(jobsize)) { - die "I need a $arg argument" unless defined $args{$arg}; - } - if ( (!$args{report} || !$args{interval}) ) { - if ( $args{spec} && @{$args{spec}} == 2 ) { - @args{qw(report interval)} = @{$args{spec}}; - } - else { - die "I need either report and interval arguments, or a spec"; - } - } - - my $name = $args{name} || "Progress"; - $args{start} ||= time(); - my $self; - $self = { - last_reported => $args{start}, - fraction => 0, # How complete the job is - callback => sub { - my ($fraction, $elapsed, $remaining, $eta) = @_; - printf STDERR "$name: %3d%% %s remain\n", - $fraction * 100, - Transformers::secs_to_time($remaining), - Transformers::ts($eta); - }, - %args, - }; - return bless $self, $class; -} - -sub validate_spec { - shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress:: - my ( $spec ) = @_; - if ( @$spec != 2 ) { - die "spec array requires a two-part argument\n"; - } - if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) { - die "spec array's first element must be one of " - . "percentage,time,iterations\n"; - } - if ( $spec->[1] !~ m/^\d+$/ ) { - die "spec array's second element must be an integer\n"; - } -} - -sub set_callback { - my ( $self, $callback ) = @_; - $self->{callback} = $callback; -} - -sub start { - my ( $self, $start ) = @_; - $self->{start} = $self->{last_reported} = $start || time(); - $self->{first_report} = 0; -} - -sub update { - my ( $self, $callback, %args ) = @_; - my $jobsize = $self->{jobsize}; - my $now ||= $args{now} || time; - - $self->{iterations}++; # How many updates have happened; - - if ( !$self->{first_report} && $args{first_report} ) { - $args{first_report}->(); - $self->{first_report} = 1; - } - - if ( $self->{report} eq 'time' - && $self->{interval} > $now - $self->{last_reported} - ) { - return; - } - elsif ( $self->{report} eq 'iterations' - && ($self->{iterations} - 1) % $self->{interval} > 0 - ) { - return; - } - $self->{last_reported} = $now; - - my $completed = $callback->(); - $self->{updates}++; # How many times we have run the update callback - - return if $completed > $jobsize; - - my $fraction = $completed > 0 ? $completed / $jobsize : 0; - - if ( $self->{report} eq 'percentage' - && $self->fraction_modulo($self->{fraction}) - >= $self->fraction_modulo($fraction) - ) { - $self->{fraction} = $fraction; - return; - } - $self->{fraction} = $fraction; - - my $elapsed = $now - $self->{start}; - my $remaining = 0; - my $eta = $now; - if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) { - my $rate = $completed / $elapsed; - if ( $rate > 0 ) { - $remaining = ($jobsize - $completed) / $rate; - $eta = $now + int($remaining); - } - } - $self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed); -} - -sub fraction_modulo { - my ( $self, $num ) = @_; - $num *= 100; # Convert from fraction to percentage - return sprintf('%d', - sprintf('%d', $num / $self->{interval}) * $self->{interval}); -} - -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 Progress package -# ########################################################################### - -# ########################################################################### -# FileIterator package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/FileIterator.pm -# t/lib/FileIterator.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package FileIterator; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -sub new { - my ( $class, %args ) = @_; - my $self = { - %args, - }; - return bless $self, $class; -} - -sub get_file_itr { - my ( $self, @filenames ) = @_; - - my @final_filenames; - FILENAME: - foreach my $fn ( @filenames ) { - if ( !defined $fn ) { - warn "Skipping undefined filename"; - next FILENAME; - } - if ( $fn ne '-' ) { - if ( !-e $fn || !-r $fn ) { - warn "$fn does not exist or is not readable"; - next FILENAME; - } - } - push @final_filenames, $fn; - } - - if ( !@filenames ) { - push @final_filenames, '-'; - PTDEBUG && _d('Auto-adding "-" to the list of filenames'); - } - - PTDEBUG && _d('Final filenames:', @final_filenames); - return sub { - while ( @final_filenames ) { - my $fn = shift @final_filenames; - PTDEBUG && _d('Filename:', $fn); - if ( $fn eq '-' ) { # Magical STDIN filename. - return (*STDIN, undef, undef); - } - open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR"; - if ( $fh ) { - return ( $fh, $fn, -s $fn ); - } - } - return (); # Avoids $f being set to 0 in list context. - }; -} - -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 FileIterator package -# ########################################################################### - -# ########################################################################### -# TimeSeriesTrender package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/TimeSeriesTrender.pm -# t/lib/TimeSeriesTrender.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package TimeSeriesTrender; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(callback) ) { - die "I need a $arg argument" unless defined $args{$arg}; - } - my $self = { - %args, - ts => '', - numbers => [], - }; - return bless $self, $class; -} - -sub set_time { - my ( $self, $ts ) = @_; - my $cur_ts = $self->{ts}; - if ( !$cur_ts ) { - $self->{ts} = $ts; - } - elsif ( $ts gt $cur_ts ) { - my $statistics = $self->compute_stats($cur_ts, $self->{numbers}); - $self->{callback}->($statistics); - $self->{numbers} = []; - $self->{ts} = $ts; - } -} - -sub add_number { - my ( $self, $number ) = @_; - push @{$self->{numbers}}, $number; -} - -sub compute_stats { - my ( $self, $ts, $numbers ) = @_; - my $cnt = scalar @$numbers; - my $result = { - ts => $ts, - cnt => 0, - sum => 0, - min => 0, - max => 0, - avg => 0, - stdev => 0, - }; - return $result unless $cnt; - my ( $sum, $min, $max, $sumsq ) = (0, 2 ** 32, 0, 0); - foreach my $num ( @$numbers ) { - $sum += $num; - $min = $num < $min ? $num : $min; - $max = $num > $max ? $num : $max; - $sumsq += $num * $num; - } - my $avg = $sum / $cnt; - my $var = $sumsq / $cnt - ( $avg * $avg ); - my $stdev = $var > 0 ? sqrt($var) : 0; - @{$result}{qw(cnt sum min max avg stdev)} - = ($cnt, $sum, $min, $max, $avg, $stdev); - return $result; -} - -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 TimeSeriesTrender package -# ########################################################################### - - -# ########################################################################### -# Transformers package -# This package is a copy without comments from the original. The original -# with comments and its test file can be found in the Bazaar repository at, -# lib/Transformers.pm -# t/lib/Transformers.t -# See https://launchpad.net/percona-toolkit for more information. -# ########################################################################### -{ -package Transformers; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Time::Local qw(timegm timelocal); -use Digest::MD5 qw(md5_hex); -use B qw(); - -require Exporter; -our @ISA = qw(Exporter); -our %EXPORT_TAGS = (); -our @EXPORT = (); -our @EXPORT_OK = qw( - micro_t - percentage_of - secs_to_time - time_to_secs - shorten - ts - parse_timestamp - unix_timestamp - any_unix_timestamp - make_checksum - crc32 - encode_json -); - -our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/; -our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/; -our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks - -sub micro_t { - my ( $t, %args ) = @_; - my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals - my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals - my $f; - - $t = 0 if $t < 0; - - $t = sprintf('%.17f', $t) if $t =~ /e/; - - $t =~ s/\.(\d{1,6})\d*/\.$1/; - - if ($t > 0 && $t <= 0.000999) { - $f = ($t * 1000000) . 'us'; - } - elsif ($t >= 0.001000 && $t <= 0.999999) { - $f = sprintf("%.${p_ms}f", $t * 1000); - $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros - } - elsif ($t >= 1) { - $f = sprintf("%.${p_s}f", $t); - $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros - } - else { - $f = 0; # $t should = 0 at this point - } - - return $f; -} - -sub percentage_of { - my ( $is, $of, %args ) = @_; - my $p = $args{p} || 0; # float precision - my $fmt = $p ? "%.${p}f" : "%d"; - return sprintf $fmt, ($is * 100) / ($of ||= 1); -} - -sub secs_to_time { - my ( $secs, $fmt ) = @_; - $secs ||= 0; - return '00:00' unless $secs; - - $fmt ||= $secs >= 86_400 ? 'd' - : $secs >= 3_600 ? 'h' - : 'm'; - - return - $fmt eq 'd' ? sprintf( - "%d+%02d:%02d:%02d", - int($secs / 86_400), - int(($secs % 86_400) / 3_600), - int(($secs % 3_600) / 60), - $secs % 60) - : $fmt eq 'h' ? sprintf( - "%02d:%02d:%02d", - int(($secs % 86_400) / 3_600), - int(($secs % 3_600) / 60), - $secs % 60) - : sprintf( - "%02d:%02d", - int(($secs % 3_600) / 60), - $secs % 60); -} - -sub time_to_secs { - my ( $val, $default_suffix ) = @_; - die "I need a val argument" unless defined $val; - my $t = 0; - my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; - $suffix = $suffix || $default_suffix || 's'; - if ( $suffix =~ m/[smhd]/ ) { - $t = $suffix eq 's' ? $num * 1 # Seconds - : $suffix eq 'm' ? $num * 60 # Minutes - : $suffix eq 'h' ? $num * 3600 # Hours - : $num * 86400; # Days - - $t *= -1 if $prefix && $prefix eq '-'; - } - else { - die "Invalid suffix for $val: $suffix"; - } - return $t; -} - -sub shorten { - my ( $num, %args ) = @_; - my $p = defined $args{p} ? $args{p} : 2; # float precision - my $d = defined $args{d} ? $args{d} : 1_024; # divisor - my $n = 0; - my @units = ('', qw(k M G T P E Z Y)); - while ( $num >= $d && $n < @units - 1 ) { - $num /= $d; - ++$n; - } - return sprintf( - $num =~ m/\./ || $n - ? "%.${p}f%s" - : '%d', - $num, $units[$n]); -} - -sub ts { - my ( $time, $gmt ) = @_; - my ( $sec, $min, $hour, $mday, $mon, $year ) - = $gmt ? gmtime($time) : localtime($time); - $mon += 1; - $year += 1900; - my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d", - $year, $mon, $mday, $hour, $min, $sec); - if ( my ($us) = $time =~ m/(\.\d+)$/ ) { - $us = sprintf("%.6f", $us); - $us =~ s/^0\././; - $val .= $us; - } - return $val; -} - -sub parse_timestamp { - my ( $val ) = @_; - if ( my($y, $m, $d, $h, $i, $s, $f) - = $val =~ m/^$mysql_ts$/ ) - { - return sprintf "%d-%02d-%02d %02d:%02d:" - . (defined $f ? '%09.6f' : '%02d'), - $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s); - } - return $val; -} - -sub unix_timestamp { - my ( $val, $gmt ) = @_; - if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) { - $val = $gmt - ? timegm($s, $i, $h, $d, $m - 1, $y) - : timelocal($s, $i, $h, $d, $m - 1, $y); - if ( defined $us ) { - $us = sprintf('%.6f', $us); - $us =~ s/^0\././; - $val .= $us; - } - } - return $val; -} - -sub any_unix_timestamp { - my ( $val, $callback ) = @_; - - if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) { - $n = $suffix eq 's' ? $n # Seconds - : $suffix eq 'm' ? $n * 60 # Minutes - : $suffix eq 'h' ? $n * 3600 # Hours - : $suffix eq 'd' ? $n * 86400 # Days - : $n; # default: Seconds - PTDEBUG && _d('ts is now - N[shmd]:', $n); - return time - $n; - } - elsif ( $val =~ m/^\d{9,}/ ) { - PTDEBUG && _d('ts is already a unix timestamp'); - return $val; - } - elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) { - PTDEBUG && _d('ts is MySQL slow log timestamp'); - $val .= ' 00:00:00' unless $hms; - return unix_timestamp(parse_timestamp($val)); - } - elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) { - PTDEBUG && _d('ts is properly formatted timestamp'); - $val .= ' 00:00:00' unless $hms; - return unix_timestamp($val); - } - else { - PTDEBUG && _d('ts is MySQL expression'); - return $callback->($val) if $callback && ref $callback eq 'CODE'; - } - - PTDEBUG && _d('Unknown ts type:', $val); - return; -} - -sub make_checksum { - my ( $val ) = @_; - my $checksum = uc substr(md5_hex($val), -16); - PTDEBUG && _d($checksum, 'checksum for', $val); - return $checksum; -} - -sub crc32 { - my ( $string ) = @_; - return unless $string; - my $poly = 0xEDB88320; - my $crc = 0xFFFFFFFF; - foreach my $char ( split(//, $string) ) { - my $comp = ($crc ^ ord($char)) & 0xFF; - for ( 1 .. 8 ) { - $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1; - } - $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp; - } - return $crc ^ 0xFFFFFFFF; -} - -my $got_json = eval { require JSON }; -sub encode_json { - return JSON::encode_json(@_) if $got_json; - my ( $data ) = @_; - return (object_to_json($data) || ''); -} - - -sub object_to_json { - my ($obj) = @_; - my $type = ref($obj); - - if($type eq 'HASH'){ - return hash_to_json($obj); - } - elsif($type eq 'ARRAY'){ - return array_to_json($obj); - } - else { - return value_to_json($obj); - } -} - -sub hash_to_json { - my ($obj) = @_; - my @res; - for my $k ( sort { $a cmp $b } keys %$obj ) { - push @res, string_to_json( $k ) - . ":" - . ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) ); - } - return '{' . ( @res ? join( ",", @res ) : '' ) . '}'; -} - -sub array_to_json { - my ($obj) = @_; - my @res; - - for my $v (@$obj) { - push @res, object_to_json($v) || value_to_json($v); - } - - return '[' . ( @res ? join( ",", @res ) : '' ) . ']'; -} - -sub value_to_json { - my ($value) = @_; - - return 'null' if(!defined $value); - - my $b_obj = B::svref_2object(\$value); # for round trip problem - my $flags = $b_obj->FLAGS; - return $value # as is - if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? - - my $type = ref($value); - - if( !$type ) { - return string_to_json($value); - } - else { - return 'null'; - } - -} - -my %esc = ( - "\n" => '\n', - "\r" => '\r', - "\t" => '\t', - "\f" => '\f', - "\b" => '\b', - "\"" => '\"', - "\\" => '\\\\', - "\'" => '\\\'', -); - -sub string_to_json { - my ($arg) = @_; - - $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; - $arg =~ s/\//\\\//g; - $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; - - utf8::upgrade($arg); - utf8::encode($arg); - - return '"' . $arg . '"'; -} - -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 Transformers 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 just above main() for the call to main() which actually runs the -# program. -# ########################################################################### -package pt_trend; - -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; -Transformers->import(qw(any_unix_timestamp)); - -sub main { - @ARGV = @_; # set global ARGV for this package - - # ######################################################################## - # Get configuration information. - # ######################################################################## - my $o = new OptionParser(); - $o->get_specs(); - $o->get_opts(); - $o->set('progress', undef) if $o->get('quiet'); - if ( !$o->got('help') ) { - if ( $o->get('progress') ) { - eval { Progress->validate_spec($o->get('progress')) }; - if ( $EVAL_ERROR ) { - chomp $EVAL_ERROR; - $o->save_error("--progress $EVAL_ERROR"); - } - } - } - $o->usage_or_errors(); - - # Set up common modules. - my $fi = new FileIterator(); - my $tst = new TimeSeriesTrender(callback => \&print_report); - - # Print headers. - # https://bugs.launchpad.net/percona-toolkit/+bug/956981 - printf "%10s %10s %10s %10s %10s %10s\n", - qw(TS CNT SUM MIN MAX AVG STDDEV); - - # ######################################################################## - # If --pid, check it first since we'll die if it already exists. - # ######################################################################## - my $daemon; - if ( $o->get('pid') ) { - # We're not daemonizing, it just handles PID stuff. Keep $daemon - # in the the scope of main() because when it's destroyed it automatically - # removes the PID file. - $daemon = new Daemon(o=>$o); - $daemon->make_PID_file(); - } - - # ######################################################################## - # This is the main loop over the input filenames. - # ######################################################################## - my $next_file = $fi->get_file_itr(@ARGV); - my ( $fh, $filename, $filesize ) = $next_file->(); - FILE: - while ( defined $fh ) { - - # Create callbacks for getting data from the file. - my $tell = sub { return tell $fh; }; - - # ##################################################################### - # Set up a progress reporter. For right now, we just do one per file. - # Maybe someday we can do a global progress report? - # ##################################################################### - my $pr; - if ( $o->get('progress') && $filename && -e $filename ) { - $pr = new Progress( - jobsize => -s $filename, - spec => $o->get('progress'), - name => $filename, - ); - } - - # ##################################################################### - # This is the main loop over the queries in the log. - # ##################################################################### - LINE: - while ( defined(my $line = <$fh>) ) { - - # We are only interested in very specific lines from the file -- those - # that say what the current timestamp is, or those that say what the - # query response time is. This is to keep the tool fast. - if ( my ($ts) = $line =~ m/^# Time: (.*)$/ ) { - $tst->set_time($ts); - } - elsif ( my ($rt) = $line =~ m/^# Query_time: (\S+)/ ) { - $tst->add_number($rt); - } - - $pr->update($tell) if $pr; - } - - ( $fh, $filename, $filesize ) = $next_file->(); - } - - return 0; -} - -# ############################################################################ -# Subroutines -# ############################################################################ - -sub print_report { - my ( $stats ) = @_; - my $ts = any_unix_timestamp($stats->{ts}); - printf "%d %10.6f %10.6f %10.6f %10.6f %10.6f\n", - $ts, @${stats}{qw(cnt sum min max avg stdev)}; -} - -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"; -} - -# ############################################################################ -# Run the program. -# ############################################################################ -if ( !caller ) { exit main(@ARGV); } - -1; # Because this is a module as well as a script. - -# ############################################################################ -# Documentation -# ############################################################################ -=pod - -=head1 NAME - -pt-trend - (DEPRECATED) Compute statistics over a set of time-series data points. - -=head1 SYNOPSIS - -This tool is deprecated and will be removed in Percona Toolkit 2.2. - -Usage: pt-trend [OPTION...] [FILE ...] - -pt-trend reads a slow query log and outputs statistics on it. - -=head1 RISKS - -The following section is included to inform users about the potential risks, -whether known or unknown, of using this tool. The two main categories of risks -are those created by the nature of the tool (e.g. read-only tools vs. read-write -tools) and those created by bugs. - -pt-trend simply reads files give on the command-line. It should be very low-risk. - -At the time of this release, we know of no bugs that could cause serious harm to -users. - -The authoritative source for updated information is always the online issue -tracking system. Issues that affect this tool will be marked as such. You can -see a list of such issues at the following URL: -L. - -See also L<"BUGS"> for more information on filing bugs and getting help. - -=head1 DESCRIPTION - -You can specify multiple files on the command line. If you don't specify any, -or if you use the special filename C<->, lines are read from standard input. - -=head1 OPTIONS - -This tool accepts additional command-line arguments. Refer to the -L<"SYNOPSIS"> and usage information for details. - -=over - -=item --config - -type: Array - -Read this comma-separated list of config files; if specified, this must be the -first option on the command line. - -=item --help - -Show help and exit. - -=item --pid - -type: string - -Create the given PID file. The file contains the process ID of the script. -The PID file is removed when the script exits. Before starting, the script -checks if the PID file already exists. If it does not, then the script creates -and writes its own PID to it. If it does, then the script checks the following: -if the file contains a PID and a process is running with that PID, then -the script dies; or, if there is no process running with that PID, then the -script overwrites the file with its own PID and starts; else, if the file -contains no PID, then the script dies. - -=item --progress - -type: array; default: time,15 - -Print progress reports to STDERR. The value is a comma-separated list with two -parts. The first part can be percentage, time, or iterations; the second part -specifies how often an update should be printed, in percentage, seconds, or -number of iterations. - -=item --quiet - -short form: -q - -Disables L<"--progress">. - -=item --version - -Show version and exit. - -=back - -=head1 ENVIRONMENT - -The environment variable C enables verbose debugging output to STDERR. -To enable debugging and capture all output to a file, run the tool like: - - PTDEBUG=1 pt-trend ... > FILE 2>&1 - -Be careful: debugging output is voluminous and can generate several megabytes -of output. - -=head1 SYSTEM REQUIREMENTS - -You need Perl, DBI, DBD::mysql, and some core packages that ought to be -installed in any reasonably new version of Perl. - -=head1 BUGS - -For a list of known bugs, see L. - -Please report bugs at L. -Include the following information in your bug report: - -=over - -=item * Complete command-line used to run the tool - -=item * Tool L<"--version"> - -=item * MySQL version of all servers involved - -=item * Output from the tool including STDERR - -=item * Input files (log/dump/config files, etc.) - -=back - -If possible, include debugging output by running the tool with C; -see L<"ENVIRONMENT">. - -=head1 DOWNLOADING - -Visit L to download the -latest release of Percona Toolkit. Or, get the latest release from the -command line: - - wget percona.com/get/percona-toolkit.tar.gz - - wget percona.com/get/percona-toolkit.rpm - - wget percona.com/get/percona-toolkit.deb - -You can also get individual tools from the latest release: - - wget percona.com/get/TOOL - -Replace C with the name of any tool. - -=head1 AUTHORS - -Baron Schwartz - -=head1 ABOUT PERCONA TOOLKIT - -This tool is part of Percona Toolkit, a collection of advanced command-line -tools developed by Percona for MySQL support and consulting. Percona Toolkit -was forked from two projects in June, 2011: Maatkit and Aspersa. Those -projects were created by Baron Schwartz and developed primarily by him and -Daniel Nichter, both of whom are employed by Percona. Visit -L for more software developed by Percona. - -=head1 COPYRIGHT, LICENSE, AND WARRANTY - -This program is copyright 2010-2011 Baron Schwartz, 2011-2012 Percona Inc. -Feedback and improvements are welcome. - -THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -This program is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 2; OR the Perl Artistic License. On UNIX and similar -systems, you can issue `man perlgpl' or `man perlartistic' to read these -licenses. - -You should have received a copy of the GNU General Public License along with -this program; if not, write to the Free Software Foundation, Inc., 59 Temple -Place, Suite 330, Boston, MA 02111-1307 USA. - -=head1 VERSION - -pt-trend 2.1.7 - -=cut diff --git a/lib/LogSplitter.pm b/lib/LogSplitter.pm deleted file mode 100644 index 7e423612..00000000 --- a/lib/LogSplitter.pm +++ /dev/null @@ -1,443 +0,0 @@ -# This program is copyright 2008-2011 Percona Inc. -# Feedback and improvements are welcome. -# -# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar -# systems, you can issue `man perlgpl' or `man perlartistic' to read these -# licenses. -# -# You should have received a copy of the GNU General Public License along with -# this program; if not, write to the Free Software Foundation, Inc., 59 Temple -# Place, Suite 330, Boston, MA 02111-1307 USA. -# ########################################################################### -# LogSplitter package -# ########################################################################### -{ -# Package: LogSplitter -# LogSplitter splits MySQL query logs by sessions. -package LogSplitter; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -use Data::Dumper; -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; - -my $oktorun = 1; - -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(attribute base_dir parser session_files) ) { - die "I need a $arg argument" unless $args{$arg}; - } - - # TODO: this is probably problematic on Windows - $args{base_dir} .= '/' if substr($args{base_dir}, -1, 1) ne '/'; - - if ( $args{split_random} ) { - PTDEBUG && _d('Split random'); - $args{attribute} = '_sessionno'; # set round-robin 1..session_files - } - - my $self = { - # %args will override these default args if given explicitly. - base_file_name => 'session', - max_dirs => 1_000, - max_files_per_dir => 5_000, - max_sessions => 5_000_000, # max_dirs * max_files_per_dir - merge_sessions => 1, - session_files => 64, - quiet => 0, - verbose => 0, - max_open_files => 1_000, - close_lru_files => 100, - # Override default args above. - %args, - # These args cannot be overridden. - n_dirs_total => 0, # total number of dirs created - n_files_total => 0, # total number of session files created - n_files_this_dir => -1, # number of session files in current dir - session_fhs => [], # filehandles for each session - n_open_fhs => 0, # current number of open session filehandles - n_events_total => 0, # total number of events in log - n_events_saved => 0, # total number of events saved - n_sessions_skipped => 0, # total number of sessions skipped - n_sessions_saved => 0, # number of sessions saved - sessions => {}, # sessions data store - created_dirs => [], - }; - - PTDEBUG && _d('new LogSplitter final args:', Dumper($self)); - return bless $self, $class; -} - -sub split { - my ( $self, @logs ) = @_; - $oktorun = 1; # True as long as we haven't created too many - # session files or too many dirs and files - - my $callbacks = $self->{callbacks}; - - my $next_sessionno; - if ( $self->{split_random} ) { - # round-robin iterator - $next_sessionno = make_rr_iter(1, $self->{session_files}); - } - - if ( @logs == 0 ) { - PTDEBUG && _d('Implicitly reading STDIN because no logs were given'); - push @logs, '-'; - } - - # Split all the log files. - my $lp = $self->{parser}; - LOG: - foreach my $log ( @logs ) { - last unless $oktorun; - next unless defined $log; - - if ( !-f $log && $log ne '-' ) { - warn "Skipping $log because it is not a file"; - next LOG; - } - my $fh; - if ( $log eq '-' ) { - $fh = *STDIN; - } - else { - if ( !open $fh, "<", $log ) { - warn "Cannot open $log: $OS_ERROR\n"; - next LOG; - } - } - - PTDEBUG && _d('Splitting', $log); - my $event = {}; - my $more_events = 1; - my $more_events_sub = sub { $more_events = $_[0]; }; - EVENT: - while ( $oktorun ) { - $event = $lp->parse_event( - next_event => sub { return <$fh>; }, - tell => sub { return tell $fh; }, - oktorun => $more_events_sub, - ); - if ( $event ) { - $self->{n_events_total}++; - if ( $self->{split_random} ) { - $event->{_sessionno} = $next_sessionno->(); - } - if ( $callbacks ) { - foreach my $callback ( @$callbacks ) { - $event = $callback->($event); - last unless $event; - } - } - $self->_save_event($event) if $event; - } - if ( !$more_events ) { - PTDEBUG && _d('Done parsing', $log); - close $fh; - next LOG; - } - last LOG unless $oktorun; - } - } - - # Close session filehandles. - while ( my $fh = pop @{ $self->{session_fhs} } ) { - close $fh->{fh}; - } - $self->{n_open_fhs} = 0; - - $self->_merge_session_files() if $self->{merge_sessions}; - $self->print_split_summary() unless $self->{quiet}; - - return; -} - -sub _save_event { - my ( $self, $event ) = @_; - my ($session, $session_id) = $self->_get_session_ds($event); - return unless $session; - - if ( !defined $session->{fh} ) { - $self->{n_sessions_saved}++; - PTDEBUG && _d('New session:', $session_id, ',', - $self->{n_sessions_saved}, 'of', $self->{max_sessions}); - - my $session_file = $self->_get_next_session_file(); - if ( !$session_file ) { - $oktorun = 0; - PTDEBUG && _d('Not oktorun because no _get_next_session_file'); - return; - } - - # Close Last Recently Used session fhs if opening if this new - # session fh will cause us to have too many open files. - if ( $self->{n_open_fhs} >= $self->{max_open_files} ) { - $self->_close_lru_session() - } - - # Open a fh for this session file. - open my $fh, '>', $session_file - or die "Cannot open session file $session_file: $OS_ERROR"; - $session->{fh} = $fh; - $self->{n_open_fhs}++; - - # Save fh and session file in case we need to open/close it later. - $session->{active} = 1; - $session->{session_file} = $session_file; - - push @{$self->{session_fhs}}, { fh => $fh, session_id => $session_id }; - - PTDEBUG && _d('Created', $session_file, 'for session', - $self->{attribute}, '=', $session_id); - - # This special comment lets mk-log-player know when a session begins. - print $fh "-- START SESSION $session_id\n\n"; - } - elsif ( !$session->{active} ) { - # Reopen the existing but inactive session. This happens when - # a new session (above) had to close LRU session fhs. - - # Again, close Last Recently Used session fhs if reopening if this - # session's fh will cause us to have too many open files. - if ( $self->{n_open_fhs} >= $self->{max_open_files} ) { - $self->_close_lru_session(); - } - - # Reopen this session's fh. - open $session->{fh}, '>>', $session->{session_file} - or die "Cannot reopen session file " - . "$session->{session_file}: $OS_ERROR"; - - # Mark this session as active again. - $session->{active} = 1; - $self->{n_open_fhs}++; - - PTDEBUG && _d('Reopend', $session->{session_file}, 'for session', - $self->{attribute}, '=', $session_id); - } - else { - PTDEBUG && _d('Event belongs to active session', $session_id); - } - - my $session_fh = $session->{fh}; - - # Print USE db if 1) we haven't done so yet or 2) the db has changed. - my $db = $event->{db} || $event->{Schema}; - if ( $db && ( !defined $session->{db} || $session->{db} ne $db ) ) { - print $session_fh "use $db\n\n"; - $session->{db} = $db; - } - - print $session_fh $self->flatten($event->{arg}), "\n\n"; - $self->{n_events_saved}++; - - return; -} - -# Returns shortcut to session data store and id for the given event. -# The returned session will be undef if no more sessions are allowed. -sub _get_session_ds { - my ( $self, $event ) = @_; - - my $attrib = $self->{attribute}; - if ( !$event->{ $attrib } ) { - PTDEBUG && _d('No attribute', $attrib, 'in event:', Dumper($event)); - return; - } - - # This could indicate a problem in parser not parsing - # a log event correctly thereby leaving $event->{arg} undefined. - # Or, it could simply be an event like: - # use db; - # SET NAMES utf8; - return unless $event->{arg}; - - # Don't print admin commands like quit or ping because these - # cannot be played. - return if ($event->{cmd} || '') eq 'Admin'; - - my $session; - my $session_id = $event->{ $attrib }; - - # The following is necessary to prevent Perl from auto-vivifying - # a lot of empty hashes for new sessions that are ignored due to - # already having max_sessions. - if ( $self->{n_sessions_saved} < $self->{max_sessions} ) { - # Will auto-vivify if necessary. - $session = $self->{sessions}->{ $session_id } ||= {}; - } - elsif ( exists $self->{sessions}->{ $session_id } ) { - # Use only existing sessions. - $session = $self->{sessions}->{ $session_id }; - } - else { - $self->{n_sessions_skipped} += 1; - PTDEBUG && _d('Skipping new session', $session_id, - 'because max_sessions is reached'); - } - - return $session, $session_id; -} - -sub _close_lru_session { - my ( $self ) = @_; - my $session_fhs = $self->{session_fhs}; - my $lru_n = $self->{n_sessions_saved} - $self->{max_open_files} - 1; - my $close_to_n = $lru_n + $self->{close_lru_files} - 1; - - PTDEBUG && _d('Closing session fhs', $lru_n, '..', $close_to_n, - '(',$self->{n_sessions}, 'sessions', $self->{n_open_fhs}, 'open fhs)'); - - foreach my $session ( @$session_fhs[ $lru_n..$close_to_n ] ) { - close $session->{fh}; - $self->{n_open_fhs}--; - $self->{sessions}->{ $session->{session_id} }->{active} = 0; - } - - return; -} - -# Returns an empty string on failure, or the next session file name on success. -# This will fail if we have opened maxdirs and maxfiles. -sub _get_next_session_file { - my ( $self, $n ) = @_; - return if $self->{n_dirs_total} >= $self->{max_dirs}; - - # n_files_this_dir will only be < 0 for the first dir and file - # because n_file is set to -1 in new(). This is a hack - # to cause the first dir and file to be created automatically. - if ( ($self->{n_files_this_dir} >= $self->{max_files_per_dir}) - || $self->{n_files_this_dir} < 0 ) { - $self->{n_dirs_total}++; - $self->{n_files_this_dir} = 0; - my $new_dir = "$self->{base_dir}$self->{n_dirs_total}"; - if ( !-d $new_dir ) { - my $retval = system("mkdir $new_dir"); - if ( ($retval >> 8) != 0 ) { - die "Cannot create new directory $new_dir: $OS_ERROR"; - } - PTDEBUG && _d('Created new base_dir', $new_dir); - push @{$self->{created_dirs}}, $new_dir; - } - elsif ( PTDEBUG ) { - _d($new_dir, 'already exists'); - } - } - else { - PTDEBUG && _d('No dir created; n_files_this_dir:', - $self->{n_files_this_dir}, 'n_files_total:', - $self->{n_files_total}); - } - - $self->{n_files_total}++; - $self->{n_files_this_dir}++; - my $dir_n = $self->{n_dirs_total} . '/'; - my $session_n = sprintf '%d', $n || $self->{n_sessions_saved}; - my $session_file = $self->{base_dir} - . $dir_n - . $self->{base_file_name}."-$session_n.txt"; - PTDEBUG && _d('Next session file', $session_file); - return $session_file; -} - -# Flattens multiple new-line and spaces to single new-lines and spaces -# and remove /* comment */ blocks. -sub flatten { - my ( $self, $query ) = @_; - return unless $query; - $query =~ s!/\*.*?\*/! !g; - $query =~ s/^\s+//; - $query =~ s/\s{2,}/ /g; - return $query; -} - -sub _merge_session_files { - my ( $self ) = @_; - - print "Merging session files...\n" unless $self->{quiet}; - - my @multi_session_files; - for my $i ( 1..$self->{session_files} ) { - push @multi_session_files, $self->{base_dir} ."sessions-$i.txt"; - } - - my @single_session_files = map { - $_->{session_file}; - } values %{$self->{sessions}}; - - my $i = make_rr_iter(0, $#multi_session_files); # round-robin iterator - foreach my $single_session_file ( @single_session_files ) { - my $multi_session_file = $multi_session_files[ $i->() ]; - my $cmd; - if ( $self->{split_random} ) { - $cmd = "mv $single_session_file $multi_session_file"; - } - else { - $cmd = "cat $single_session_file >> $multi_session_file"; - } - eval { `$cmd`; }; - if ( $EVAL_ERROR ) { - warn "Failed to `$cmd`: $OS_ERROR"; - } - } - - foreach my $created_dir ( @{$self->{created_dirs}} ) { - my $cmd = "rm -rf $created_dir"; - eval { `$cmd`; }; - if ( $EVAL_ERROR ) { - warn "Failed to `$cmd`: $OS_ERROR"; - } - } - - return; -} - -sub make_rr_iter { - my ( $start, $end ) = @_; - my $current = $start; - return sub { - $current = $start if $current > $end ; - $current++; # For next iteration. - return $current - 1; - }; -} - -sub print_split_summary { - my ( $self ) = @_; - print "Split summary:\n"; - my $fmt = "%-20s %-10s\n"; - printf $fmt, 'Total sessions', - $self->{n_sessions_saved} + $self->{n_sessions_skipped}; - printf $fmt, 'Sessions saved', - $self->{n_sessions_saved}; - printf $fmt, 'Total events', $self->{n_events_total}; - printf $fmt, 'Events saved', $self->{n_events_saved}; - return; -} - -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 LogSplitter package -# ########################################################################### diff --git a/lib/TimeSeriesTrender.pm b/lib/TimeSeriesTrender.pm deleted file mode 100644 index 57c895da..00000000 --- a/lib/TimeSeriesTrender.pm +++ /dev/null @@ -1,119 +0,0 @@ -# This program is copyright 2010-2011 Percona Inc. -# Feedback and improvements are welcome. -# -# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free Software -# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar -# systems, you can issue `man perlgpl' or `man perlartistic' to read these -# licenses. -# -# You should have received a copy of the GNU General Public License along with -# this program; if not, write to the Free Software Foundation, Inc., 59 Temple -# Place, Suite 330, Boston, MA 02111-1307 USA. -# ########################################################################### -# TimeSeriesTrender package -# ########################################################################### -{ -# Package: TimeSeriesTrender -# TimeSeriesTrender calculates trends in time. -package TimeSeriesTrender; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; - -# Arguments: -# * callback Subroutine to call when the time is set to the next larger -# increment. Receives a hashref of the current timestamp's -# stats (see compute_stats()). -sub new { - my ( $class, %args ) = @_; - foreach my $arg ( qw(callback) ) { - die "I need a $arg argument" unless defined $args{$arg}; - } - my $self = { - %args, - ts => '', - numbers => [], - }; - return bless $self, $class; -} - -# Set the current timestamp to be applied to all subsequent values received -# through add_number(). If the timestamp changes to the "next larger -# increment," then fire the callback. It *is* possible for a timestamp to be -# less than one previously seen. In such cases, we simply lump those -# time-series data points into the current timestamp's bucket. -sub set_time { - my ( $self, $ts ) = @_; - my $cur_ts = $self->{ts}; - if ( !$cur_ts ) { - $self->{ts} = $ts; - } - elsif ( $ts gt $cur_ts ) { - my $statistics = $self->compute_stats($cur_ts, $self->{numbers}); - $self->{callback}->($statistics); - $self->{numbers} = []; - $self->{ts} = $ts; - } - # If $cur_ts > $ts, then we do nothing -- we do not want $self->{ts} to ever - # decrease! -} - -# Add a number to the current batch defined by the current timestamp, which is -# set by set_time(). -sub add_number { - my ( $self, $number ) = @_; - push @{$self->{numbers}}, $number; -} - -# Compute the desired statistics over the set of numbers, which is passed in as -# an arrayref. Returns a hashref. -sub compute_stats { - my ( $self, $ts, $numbers ) = @_; - my $cnt = scalar @$numbers; - my $result = { - ts => $ts, - cnt => 0, - sum => 0, - min => 0, - max => 0, - avg => 0, - stdev => 0, - }; - return $result unless $cnt; - my ( $sum, $min, $max, $sumsq ) = (0, 2 ** 32, 0, 0); - foreach my $num ( @$numbers ) { - $sum += $num; - $min = $num < $min ? $num : $min; - $max = $num > $max ? $num : $max; - $sumsq += $num * $num; - } - my $avg = $sum / $cnt; - my $var = $sumsq / $cnt - ( $avg * $avg ); - my $stdev = $var > 0 ? sqrt($var) : 0; - # TODO: must compute the significant digits of the input, and use that to - # round the output appropriately. - @{$result}{qw(cnt sum min max avg stdev)} - = ($cnt, $sum, $min, $max, $avg, $stdev); - return $result; -} - -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 TimeSeriesTrender package -# ########################################################################### diff --git a/t/lib/LogSplitter.t b/t/lib/LogSplitter.t deleted file mode 100644 index 98937d90..00000000 --- a/t/lib/LogSplitter.t +++ /dev/null @@ -1,319 +0,0 @@ -#!/usr/bin/perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 23; - -use LogSplitter; -use SlowLogParser; -use PerconaTest; - -my $output; -my $tmpdir = '/tmp/LogSplitter'; -diag(`rm -rf $tmpdir ; mkdir $tmpdir`); - -my $lp = new SlowLogParser(); -my $ls = new LogSplitter( - attribute => 'foo', - base_dir => $tmpdir, - parser => $lp, - session_files => 3, - quiet => 1, -); - -isa_ok($ls, 'LogSplitter'); - -diag(`rm -rf $tmpdir ; mkdir $tmpdir`); - -# This creates an implicit test to make sure that -# split_logs() will not die if the saveto_dir already -# exists. It should just use the existing dir. -diag(`mkdir $tmpdir/1`); - -$ls->split("$trunk/t/lib/samples/slowlogs/slow006.txt"); -is( - $ls->{n_sessions_saved}, - 0, - 'Parsed zero sessions for bad attribute' -); - -is( - $ls->{n_events_total}, - 6, - 'Parsed all events' -); - -# ############################################################################# -# Test a simple split of 6 events, 3 sessions into 3 session files. -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - session_files => 3, - quiet => 1, - merge_sessions => 0, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow006.txt"); -ok(-f "$tmpdir/1/session-1.txt", 'Basic split session 1 file exists'); -ok(-f "$tmpdir/1/session-2.txt", 'Basic split session 2 file exists'); -ok(-f "$tmpdir/1/session-3.txt", 'Basic split session 3 file exists'); - -$output = `diff $tmpdir/1/session-1.txt $trunk/t/lib/samples/slowlogs/slow006-session-1.txt`; -is( - $output, - '', - 'Session 1 file has correct SQL statements' -); - -$output = `diff $tmpdir/1/session-2.txt $trunk/t/lib/samples/slowlogs/slow006-session-2.txt`; -is( - $output, - '', - 'Session 2 file has correct SQL statements' -); - -$output = `diff $tmpdir/1/session-3.txt $trunk/t/lib/samples/slowlogs/slow006-session-3.txt`; -is( - $output, - '', - 'Session 3 file has correct SQL statements' -); - -# ############################################################################# -# Test splitting more sessions than we can have open filehandles at once. -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - session_files => 10, - quiet => 1, - merge_sessions => 0, - max_open_files => 200, - close_lru_files => 50, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow009.txt"); -chomp($output = `ls -1 $tmpdir/1/ | wc -l`); -$output =~ s/^\s*//; -is( - $output, - 2000, - 'Splits 2_000 sessions' -); - -$output = `cat $tmpdir/1/session-2000.txt`; -like( - $output, - qr/SELECT 2001 FROM foo/, - '2_000th session has correct SQL' -); - -$output = `cat $tmpdir/1/session-12.txt`; -like( - $output, qr/SELECT 12 FROM foo\n\nSELECT 1234 FROM foo/, - 'Reopened and appended to previously closed session' -); - -# ############################################################################# -# Test max_sessions. -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - session_files => 10, - quiet => 1, - merge_sessions => 0, - max_sessions => 10, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow009.txt"); -chomp($output = `ls -1 $tmpdir/1/ | wc -l`); -$output =~ s/^\s*//; -is( - $output, - '10', - 'max_sessions works (1/3)', -); -is( - $ls->{n_sessions_saved}, - '10', - 'max_sessions works (2/3)' -); -is( - $ls->{n_files_total}, - '10', - 'max_sessions works (3/3)' -); - -# ############################################################################# -# Check that all filehandles are closed. -# ############################################################################# -is_deeply( - $ls->{session_fhs}, - [], - 'Closes open fhs' -); - -#diag(`rm -rf $tmpdir/*`); -#$output = `cat $trunk/t/lib/samples/slow006.txt | $trunk/t/lib/samples/log_splitter.pl`; -#like($output, qr/Parsed sessions\s+3/, 'Reads STDIN implicitly'); - -#diag(`rm -rf $tmpdir/*`); -#$output = `cat $trunk/t/lib/samples/slow006.txt | $trunk/t/lib/samples/log_splitter.pl -`; -#like($output, qr/Parsed sessions\s+3/, 'Reads STDIN explicitly'); - -#diag(`rm -rf $tmpdir/*`); -#$output = `cat $trunk/t/lib/samples/slow006.txt | $trunk/t/lib/samples/log_splitter.pl blahblah`; -#like($output, qr/Parsed sessions\s+0/, 'Does nothing if no valid logs are given'); - -# ############################################################################# -# Test session file merging. -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - session_files => 10, - quiet => 1, - max_open_files => 200, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow009.txt"); -$output = `grep 'START SESSION' $tmpdir/sessions-*.txt | cut -d' ' -f 4 | sort -n`; -like( - $output, - qr/^1\n2\n3\n[\d\n]+2001$/, - 'Merges 2_000 sessions' -); - -ok( - !-d "$tmpdir/1", - 'Removes tmp dirs after merging' -); - -# ############################################################################# -# Issue 418: mk-log-player dies trying to play statements with blank lines -# ############################################################################# - -# LogSplitter should pre-process queries before writing them so that they -# do not contain blank lines. -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - quiet => 1, - session_files => 1, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow020.txt"); -$output = `diff $tmpdir/sessions-1.txt $trunk/t/lib/samples/split_slow020.txt`; -is( - $output, - '', - 'Collapse multiple \n and \s (issue 418)' -); - -# Make sure it works for --maxsessionfiles -#diag(`rm -rf $tmpdir/*`); -#$ls = new LogSplitter( -# attribute => 'Thread_id', -# saveto_dir => "$tmpdir/", -# lp => $lp, -# verbose => 0, -# maxsessionfiles => 1, -#); -#$ls->split(['t/lib/samples/slow020.txt' ]); -#$output = `diff $tmpdir/1/session-0001 $trunk/t/lib/samples/split_slow020_msf.txt`; -#is( -# $output, -# '', -# 'Collapse multiple \n and \s with --maxsessionfiles (issue 418)' -#); - -# ############################################################################# -# Issue 571: Add --filter to mk-log-player -# ############################################################################# -my $callback = sub { - return; -}; -$ls = new LogSplitter( - attribute => 'Thread_id', - base_dir => $tmpdir, - parser => $lp, - session_files => 3, - quiet => 1, - callbacks => [$callback], -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow006.txt"); -is( - $ls->{n_sessions_saved}, - 0, - 'callbacks' -); - -# ############################################################################# -# Issue 798: Make mk-log-player --split work without an attribute -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'Thread_id', - split_random => 1, - base_dir => $tmpdir, - parser => $lp, - session_files => 2, - quiet => 1, -); -$ls->split("$trunk/t/lib/samples/slowlogs/slow006.txt"); - -$output = `diff $tmpdir/sessions-1.txt $trunk/t/lib/samples/LogSplitter/slow006-random-1.txt`; -is( - $output, - '', - 'Random file 1 file has correct SQL statements' -); - -$output = `diff $tmpdir/sessions-2.txt $trunk/t/lib/samples/LogSplitter/slow006-random-2.txt`; -is( - $output, - '', - 'Random file 2 file has correct SQL statements' -); - -# ############################################################################# -# Issue 1179: mk-log-player --filter example does not work -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -$ls = new LogSplitter( - attribute => 'cmd', - base_dir => $tmpdir, - parser => $lp, - session_files => 2, - quiet => 1, -); -$ls->split("$trunk/t/lib/samples/binlogs/binlog010.txt"); -$output = `cat $tmpdir/sessions-1.txt`; -ok( - no_diff( - $output, - "t/lib/samples/LogSplitter/binlog010.txt", - cmd_output => 1, - ), - "Split binlog with RBR data (issue 1179)" -); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir`); -exit; diff --git a/t/lib/samples/LogSplitter/binlog010.txt b/t/lib/samples/LogSplitter/binlog010.txt deleted file mode 100644 index 03d28cd9..00000000 --- a/t/lib/samples/LogSplitter/binlog010.txt +++ /dev/null @@ -1,92 +0,0 @@ --- START SESSION Query - -; -DELIMITER - -ROLLBACK - -use test/*!*/ - -SET TIMESTAMP=1289247700 ; -SET @@session.pseudo_thread_id=15 ; -SET @@session.foreign_key_checks=1, @@session.sql_auto_is_null=1, @@session.unique_checks=1, @@session.autocommit=1 ; -SET @@session.sql_mode=0 ; -SET @@session.auto_increment_increment=1, @@session.auto_increment_offset=1 ; ; -SET @@session.character_set_client=8,@@session.collation_connection=8,@@session.collation_server=33 ; -SET @@session.lc_time_names=0 ; -SET @@session.collation_database=DEFAULT ; -CREATE TABLE `test1` ( `kwid` int(10) unsigned NOT NULL default '0', `keyword` varchar(80) NOT NULL default '' -) ENGINE=InnoDB DEFAULT CHARSET=utf8 - -SET TIMESTAMP=1289247700 ; -BEGIN - -SET TIMESTAMP=1289247700 ; -INSERT INTO `test1` VALUES -(1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -SET TIMESTAMP=1289247700 ; -CREATE TABLE `test2` ( `kwid` int(10) unsigned NOT NULL default '0', `keyword` varchar(80) NOT NULL default '' -) ENGINE=InnoDB DEFAULT CHARSET=latin1 - -SET TIMESTAMP=1289247701 ; -BEGIN - -SET TIMESTAMP=1289247701 ; -INSERT INTO `test2` VALUES -(1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -SET TIMESTAMP=1289247988 ; -BEGIN - -SET TIMESTAMP=1289247988 ; -INSERT INTO `test1` VALUES (1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -SET TIMESTAMP=1289247988 ; -BEGIN - -SET TIMESTAMP=1289247988 ; -INSERT INTO `test2` VALUES (1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -SET TIMESTAMP=1289247999 ; -drop table test1 - -SET TIMESTAMP=1289247999 ; -drop table test2 - -SET TIMESTAMP=1289248000 ; -CREATE TABLE `test1` ( `kwid` int(10) unsigned NOT NULL DEFAULT '0', `keyword` varchar(80) NOT NULL DEFAULT '' -) ENGINE=InnoDB DEFAULT CHARSET=utf8 - -SET TIMESTAMP=1289248000 ; -BEGIN - -SET TIMESTAMP=1289248000 ; -INSERT INTO `test1` VALUES (1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -SET TIMESTAMP=1289248000 ; -CREATE TABLE `test2` ( `kwid` int(10) unsigned NOT NULL DEFAULT '0', `keyword` varchar(80) NOT NULL DEFAULT '' -) ENGINE=InnoDB DEFAULT CHARSET=latin1 - -SET TIMESTAMP=1289248000 ; -BEGIN - -SET TIMESTAMP=1289248000 ; -INSERT INTO `test2` VALUES (1,'watching'),(2,'poet'),(3,'просмотра'),(4,'Поэту') - -COMMIT - -DELIMITER - -ROLLBACK ; - diff --git a/t/lib/samples/LogSplitter/slow006-random-1.txt b/t/lib/samples/LogSplitter/slow006-random-1.txt deleted file mode 100644 index b80026b5..00000000 --- a/t/lib/samples/LogSplitter/slow006-random-1.txt +++ /dev/null @@ -1,12 +0,0 @@ --- START SESSION 1 - -use foo - -SELECT col FROM foo_tbl - -use bar - -SELECT col FROM bar_tbl - -SELECT col FROM bar_tbl - diff --git a/t/lib/samples/LogSplitter/slow006-random-2.txt b/t/lib/samples/LogSplitter/slow006-random-2.txt deleted file mode 100644 index 04d2f5a4..00000000 --- a/t/lib/samples/LogSplitter/slow006-random-2.txt +++ /dev/null @@ -1,14 +0,0 @@ --- START SESSION 2 - -use foo - -SELECT col FROM foo_tbl - -use bar - -SELECT col FROM bar_tbl - -use foo - -SELECT col FROM foo_tbl - diff --git a/t/lib/samples/log_splitter.pl b/t/lib/samples/log_splitter.pl deleted file mode 100755 index 981dccc4..00000000 --- a/t/lib/samples/log_splitter.pl +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env perl - -use strict; -require '../LogSplitter.pm'; -require '../SlowLogParser.pm'; - -my $lp = new SlowLogParser(); -my $ls = new LogSplitter( - attribute => 'Thread_id', - saveto_dir => "/tmp/logettes/", - lp => $lp, - verbose => 1, -); - -my @logs; -push @logs, split(',', $ARGV[0]) if @ARGV; -$ls->split_logs(\@logs); - -exit; diff --git a/t/lib/samples/maxsessionfiles_01 b/t/lib/samples/maxsessionfiles_01 deleted file mode 100644 index 6d360673..00000000 --- a/t/lib/samples/maxsessionfiles_01 +++ /dev/null @@ -1,6 +0,0 @@ --- MULTIPLE SESSIONS -USE `foo` - -SELECT col FROM foo_tbl --- END SESSION - diff --git a/t/lib/samples/maxsessionfiles_02 b/t/lib/samples/maxsessionfiles_02 deleted file mode 100644 index f5c4e760..00000000 --- a/t/lib/samples/maxsessionfiles_02 +++ /dev/null @@ -1,19 +0,0 @@ --- MULTIPLE SESSIONS -USE `foo` - -SELECT col FROM foo_tbl - -SELECT col FROM foo_tbl - -USE `bar` - -SELECT col FROM bar_tbl --- END SESSION - -USE `bar` - -SELECT col FROM bar_tbl - -SELECT col FROM bar_tbl --- END SESSION - diff --git a/t/lib/samples/split_slow020.txt b/t/lib/samples/split_slow020.txt deleted file mode 100644 index e77d8aab..00000000 --- a/t/lib/samples/split_slow020.txt +++ /dev/null @@ -1,14 +0,0 @@ --- START SESSION 5 - -use db1 - -SELECT * FROM foo WHERE bar = 'bar' - -use db - -INSERT INTO tbl VALUES (1), (2), (3) - -use db2 - -SELECT * FROM foo - diff --git a/t/pt-log-player/filter.t b/t/pt-log-player/filter.t deleted file mode 100644 index 497b435c..00000000 --- a/t/pt-log-player/filter.t +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 1; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $output; -my $tmpdir = '/tmp/mk-log-player'; -my $cmd = "$trunk/bin/pt-log-player --base-dir $tmpdir"; - -diag(`rm -rf $tmpdir 2>/dev/null; mkdir $tmpdir`); - -# ############################################################################# -# Issue 571: Add --filter to mk-log-player -# ############################################################################# -`$cmd --split Thread_id $trunk/t/lib/samples/binlogs/binlog001.txt --type binlog --session-files 1 --filter '\$event->{arg} && \$event->{arg} eq \"foo\"'`; -ok( - !-f "$tmpdir/sessions-1.txt", - '--filter' -); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir 2>/dev/null`); -exit; diff --git a/t/pt-log-player/issue_799.t b/t/pt-log-player/issue_799.t deleted file mode 100644 index 2485e7ee..00000000 --- a/t/pt-log-player/issue_799.t +++ /dev/null @@ -1,60 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $dp = new DSNParser(opts=>$dsn_opts); -my $sb = new Sandbox(basedir => '/tmp', DSNParser => $dp); -my $dbh = $sb->get_dbh_for('master'); - -if ( !$dbh ) { - plan skip_all => 'Cannot connect to sandbox master'; -} -else { - plan tests => 3; -} - -# ############################################################################# -# Issue 799: Can --set-vars unset @@SQL_MODE='NO_AUTO_VALUE_ON_ZERO'? -# ############################################################################# - -$sb->load_file('master', 't/pt-log-player/samples/issue_799.sql'); - -my $output; -$output = `$trunk/bin/pt-log-player --threads 1 --play $trunk/t/pt-log-player/samples/issue_799.txt h=127.1,P=12345,u=msandbox,p=msandbox 2>/dev/null`; - -is_deeply( - $dbh->selectall_arrayref('select * from issue_799.t'), - [[0]], - "Default \@\@SQL_MODE='NO_AUTO_VALUE_ON_ZERO'" -); - -$sb->load_file('master', 't/pt-log-player/samples/issue_799.sql'); - -$output = `$trunk/bin/pt-log-player --threads 1 --play $trunk/t/pt-log-player/samples/issue_799.txt h=127.1,P=12345,u=msandbox,p=msandbox --set-vars \@\@SQL_MODE="''"`; - -is_deeply( - $dbh->selectall_arrayref('select * from issue_799.t'), - [[1]], - '--set-vars @@SQL_MODE=\'\' unsets default' -); - -# ############################################################################# -# Done. -# ############################################################################# -$sb->wipe_clean($dbh); -diag(`rm -rf ./session-results-*`); -ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox"); -exit; diff --git a/t/pt-log-player/issue_903.t b/t/pt-log-player/issue_903.t deleted file mode 100644 index 5ec1b138..00000000 --- a/t/pt-log-player/issue_903.t +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $dp = new DSNParser(opts=>$dsn_opts); -my $sb = new Sandbox(basedir => '/tmp', DSNParser => $dp); -my $dbh = $sb->get_dbh_for('master'); - -if ( !$dbh ) { - plan skip_all => 'Cannot connect to sandbox master'; -} -else { - plan tests => 3; -} - -# ############################################################################# -# Issue 903: mk-log-player --only-select does not handle comments -# ############################################################################# - -# This should not cause an error because the leading comment -# prevents the query from looking like a SELECT. -my $output; -$output = `$trunk/bin/pt-log-player --threads 1 --play $trunk/t/pt-log-player/samples/issue_903.txt h=127.1,P=12345,u=msandbox,p=msandbox,D=mysql 2>&1`; -like( - $output, - qr/caused an error/, - 'Error without --only-select' -); - -# This will cause an error now, too, because the leading comment -# is stripped. -$output = `$trunk/bin/pt-log-player --threads 1 --play $trunk/t/pt-log-player/samples/issue_903.txt h=127.1,P=12345,u=msandbox,p=msandbox,D=mysql --only-select 2>&1`; -like( - $output, - qr/caused an error/, - 'Error with --only-select' -); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf ./session-results-*`); -ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox"); -exit; diff --git a/t/pt-log-player/option_sanity.t b/t/pt-log-player/option_sanity.t deleted file mode 100644 index 877798ed..00000000 --- a/t/pt-log-player/option_sanity.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 4; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $output; -my $tmpdir = '/tmp/mk-log-player'; - -diag(`rm -rf $tmpdir 2>/dev/null; mkdir $tmpdir`); - -# ############################################################################# -# Test option sanity. -# ############################################################################# -$output = `$trunk/bin/pt-log-player 2>&1`; -like( - $output, - qr/Specify at least one of --play, --split or --split-random/, - 'Needs --play or --split to run' -); - -$output = `$trunk/bin/pt-log-player --play foo 2>&1`; -like( - $output, - qr/Missing or invalid host/, - '--play requires host' -); - -$output = `$trunk/bin/pt-log-player --play foo h=localhost --print 2>&1`; -like( - $output, - qr/foo is not a file/, - 'Dies if no valid session files are given' -); - -`$trunk/bin/pt-log-player --split Thread_id --base-dir $tmpdir $trunk/t/pt-log-player/samples/log001.txt`; -`$trunk/bin/pt-log-player --threads 1 --play $tmpdir/sessions-1.txt --print`; -$output = `cat $tmpdir/*`; -like( - $output, - qr/use mk_log/, - "Prints sessions' queries without DSN" -); -diag(`rm session-results-*.txt 2>/dev/null`); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir 2>/dev/null`); -exit; diff --git a/t/pt-log-player/play.t b/t/pt-log-player/play.t deleted file mode 100644 index b2f4e5d1..00000000 --- a/t/pt-log-player/play.t +++ /dev/null @@ -1,98 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $dp = new DSNParser(opts=>$dsn_opts); -my $sb = new Sandbox(basedir => '/tmp', DSNParser => $dp); -my $dbh = $sb->get_dbh_for('master'); - -if ( !$dbh ) { - plan skip_all => 'Cannot connect to sandbox master'; -} -else { - plan tests => 20; -} - -my $output; -my $tmpdir = '/tmp/mk-log-player'; -my $cmd = "$trunk/bin/pt-log-player --play $tmpdir -F /tmp/12345/my.sandbox.cnf h=127.1 --no-results"; - -diag(`rm -rf $tmpdir 2>/dev/null; mkdir $tmpdir`); - -# ############################################################################# -# Test that all session files gets assigned. -# ############################################################################# -my @args = (qw(--dry-run --play), "$trunk/t/pt-log-player/samples/16sessions"); -for my $n ( 1..16 ) { - ok( - no_diff( - sub { pt_log_player::main(@args, '--threads', $n) }, - "t/pt-log-player/samples/assigned16.txt", - sed => [ - "'s!$trunk/t/pt-log-player/samples/16sessions/!!g'", - "'s/Process [0-9]* plays //g'", - ], - sort => '', - ), - "Assigned 16 sessions to $n threads" - ); -} - -# ############################################################################# -# Test session playing. -# ############################################################################# - -$sb->load_file('master', 't/pt-log-player/samples/log.sql'); -`$trunk/bin/pt-log-player --base-dir $tmpdir --session-files 2 --split Thread_id $trunk/t/pt-log-player/samples/log001.txt`; -`$cmd`; -is_deeply( - $dbh->selectall_arrayref('select * from mk_log_player_1.tbl1 where a = 100 OR a = 555;'), - [[100], [555]], - '--play made table changes', -); - -$sb->load_file('master', 't/pt-log-player/samples/log.sql'); - -`$cmd --only-select`; -is_deeply( - $dbh->selectall_arrayref('select * from mk_log_player_1.tbl1 where a = 100 OR a = 555;'), - [], - 'No table changes with --only-select', -); - -# ############################################################################# -# Issue 418: mk-log-player dies trying to play statements with blank lines -# ############################################################################# -diag(`rm -rf $tmpdir 2>/dev/null; mkdir $tmpdir`); -`$trunk/bin/pt-log-player --split Thread_id --base-dir $tmpdir $trunk/t/lib/samples/slowlogs/slow020.txt`; - -ok( - no_diff( - "$cmd --threads 1 --print", - "t/pt-log-player/samples/play_slow020.txt", - ), - 'Play session from log with blank lines in queries (issue 418)' -); - -diag(`rm session-results-*.txt 2>/dev/null`); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir 2>/dev/null`); -$sb->wipe_clean($dbh); -ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox"); -exit; diff --git a/t/pt-log-player/samples/16sessions/s01 b/t/pt-log-player/samples/16sessions/s01 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s02 b/t/pt-log-player/samples/16sessions/s02 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s03 b/t/pt-log-player/samples/16sessions/s03 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s04 b/t/pt-log-player/samples/16sessions/s04 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s05 b/t/pt-log-player/samples/16sessions/s05 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s06 b/t/pt-log-player/samples/16sessions/s06 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s07 b/t/pt-log-player/samples/16sessions/s07 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s08 b/t/pt-log-player/samples/16sessions/s08 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s09 b/t/pt-log-player/samples/16sessions/s09 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s10 b/t/pt-log-player/samples/16sessions/s10 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s11 b/t/pt-log-player/samples/16sessions/s11 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s12 b/t/pt-log-player/samples/16sessions/s12 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s13 b/t/pt-log-player/samples/16sessions/s13 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s14 b/t/pt-log-player/samples/16sessions/s14 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s15 b/t/pt-log-player/samples/16sessions/s15 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/16sessions/s16 b/t/pt-log-player/samples/16sessions/s16 deleted file mode 100644 index e69de29b..00000000 diff --git a/t/pt-log-player/samples/assigned16.txt b/t/pt-log-player/samples/assigned16.txt deleted file mode 100644 index d8a9ff25..00000000 --- a/t/pt-log-player/samples/assigned16.txt +++ /dev/null @@ -1,17 +0,0 @@ -Found 16 session files. -s01 -s02 -s03 -s04 -s05 -s06 -s07 -s08 -s09 -s10 -s11 -s12 -s13 -s14 -s15 -s16 diff --git a/t/pt-log-player/samples/issue_799.sql b/t/pt-log-player/samples/issue_799.sql deleted file mode 100644 index 3211203b..00000000 --- a/t/pt-log-player/samples/issue_799.sql +++ /dev/null @@ -1,4 +0,0 @@ -drop database if exists issue_799; -create database issue_799; -use issue_799; -create table t (i int auto_increment unique key); diff --git a/t/pt-log-player/samples/issue_799.txt b/t/pt-log-player/samples/issue_799.txt deleted file mode 100644 index 317d37dd..00000000 --- a/t/pt-log-player/samples/issue_799.txt +++ /dev/null @@ -1,4 +0,0 @@ --- START SESSION 1 - -insert into issue_799.t values (0) - diff --git a/t/pt-log-player/samples/issue_903.txt b/t/pt-log-player/samples/issue_903.txt deleted file mode 100644 index 5cd2c92b..00000000 --- a/t/pt-log-player/samples/issue_903.txt +++ /dev/null @@ -1 +0,0 @@ -/* I'm a comment! */ SELECT a FROM tbl1; diff --git a/t/pt-log-player/samples/log.sql b/t/pt-log-player/samples/log.sql deleted file mode 100644 index 387cb6a5..00000000 --- a/t/pt-log-player/samples/log.sql +++ /dev/null @@ -1,28 +0,0 @@ --- These test tables and rows are meant to be used --- with the mk-log-player sample logs. The sample --- logs can (should be able to be) played against --- these dbs and tbls. --- --- !!! Please Remember !!! --- If you change even the smallest thing in this file, --- you must verfiy that the tests still pass. The tests --- rely closely on these values. --- Thank you. :-) - -DROP DATABASE IF EXISTS mk_log_player_1; -CREATE DATABASE mk_log_player_1; -USE mk_log_player_1; -DROP TABLE IF EXISTS tbl1; -CREATE TABLE tbl1 ( - a INT -); -INSERT INTO tbl1 VALUES (1),(3),(5),(7),(9),(11),(13),(15),(17),(19),(21),(NULL),(0),(-10),(492),(4),(-20); - -DROP DATABASE IF EXISTS mk_log_player_2; -CREATE DATABASE mk_log_player_2; -USE mk_log_player_2; -DROP TABLE IF EXISTS tbl2; -CREATE TABLE tbl2 ( - a INT -); -INSERT INTO tbl2 VALUES (2),(4),(6),(8),(10),(12),(14),(16),(18),(20),(22),(NULL); diff --git a/t/pt-log-player/samples/log001.txt b/t/pt-log-player/samples/log001.txt deleted file mode 100644 index f271d215..00000000 --- a/t/pt-log-player/samples/log001.txt +++ /dev/null @@ -1,58 +0,0 @@ -# Time: 071218 11:48:27 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 1 Schema: mk_log_player_1 -# Query_time: 0.000012 Lock_time: 0.000000 Rows_sent: 10 Rows_examined: 10 -# QC_Hit: No Full_scan: Yes Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -SELECT a FROM tbl1; -# Time: 071218 11:48:57 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 1 Schema: mk_log_player_1 -# Query_time: 0.000002 Lock_time: 0.000000 Rows_sent: 0 Rows_examined: 0 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -# administrator command: ping; -# Time: 071218 11:48:57 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 2 -# Query_time: 0.010012 Lock_time: 0.000022 Rows_sent: 3 Rows_examined: 3 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -use mk_log_player_2; -SELECT a FROM tbl2; -# Time: 071218 11:49:05 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 1 Schema: mk_log_player_2 -# Query_time: 0.000012 Lock_time: 0.000000 Rows_sent: 0 Rows_examined: 0 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -SELECT a FROM mk_log_player_2.tbl2; -# Time: 071218 11:49:07 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 2 -# Query_time: 0.000112 Lock_time: 0.000230 Rows_sent: 0 Rows_examined: 0 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -DELETE FROM mk_log_player_2.tbl2 WHERE a IS NULL; -# Time: 071218 11:49:30 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 3 Schema: mk_log_player_1 -# Query_time: 0.000012 Lock_time: 0.000000 Rows_sent: 1 Rows_examined: 10 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -use mk_log_player_1; -SELECT a FROM tbl1 WHERE a = 3; -# Time: 071218 11:48:27 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 1 Schema: mk_log_player_1 -# Query_time: 0.000012 Lock_time: 0.021000 Rows_sent: 0 Rows_examined: 0 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -UPDATE mk_log_player_1.tbl1 SET a = 100 WHERE a = 1; -# Time: 071218 11:48:27 # User@Host: [SQL_SLAVE] @ [] -# Thread_id: 4 Schema: mk_log_player_1 -# Query_time: 0.000012 Lock_time: 0.500000 Rows_sent: 0 Rows_examined: 0 -# QC_Hit: No Full_scan: No Full_join: No Tmp_table: No Tmp_table_on_disk: No -# Filesort: No Filesort_on_disk: No Merge_passes: 0 -# No InnoDB statistics available for this query -INSERT INTO mk_log_player_1.tbl1 VALUES (555); diff --git a/t/pt-log-player/samples/one_big_session.txt b/t/pt-log-player/samples/one_big_session.txt deleted file mode 100644 index 7f851fd3..00000000 --- a/t/pt-log-player/samples/one_big_session.txt +++ /dev/null @@ -1,61 +0,0 @@ --- ONE SESSION -USE `mk_log_player_1` - -SELECT a FROM tbl1 - -USE `mk_log_player_2` - -SELECT a FROM mk_log_player_2.tbl2 - -USE `mk_log_player_1` - -UPDATE mk_log_player_1.tbl1 SET a = 100 WHERE a = 1 - -SELECT a FROM tbl1 WHERE a < 10 - -SELECT * FROM tbl1 WHERE a IS NOT NULL - -USE `mk_log_player_2` - -SELECT * FROM tbl2 WHERE a > 2 - -SELECT * FROM tbl2 WHERE a < 1 AND a > 10 - -SELECT * FROM mk_log_player_1.tbl1 AS t1 LEFT JOIN mk_log_player_2.tbl2 AS t2 ON t1.a = t2.a - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -USE `mk_log_player_1` - -UPDATE mk_log_player_1.tbl1 SET a = 100 WHERE a = 1 - -SELECT a FROM tbl1 WHERE a < 10 - -SELECT * FROM tbl1 WHERE a IS NOT NULL - -USE `mk_log_player_2` - -SELECT * FROM tbl2 WHERE a > 2 - -SELECT * FROM tbl2 WHERE a < 1 AND a > 10 - -SELECT * FROM mk_log_player_1.tbl1 AS t1 LEFT JOIN mk_log_player_2.tbl2 AS t2 ON t1.a = t2.a - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - -SELECT a FROM tbl2 - diff --git a/t/pt-log-player/samples/play_slow020.txt b/t/pt-log-player/samples/play_slow020.txt deleted file mode 100644 index 5467c832..00000000 --- a/t/pt-log-player/samples/play_slow020.txt +++ /dev/null @@ -1,5 +0,0 @@ -Found 1 session files. -Running processes... -All processes are running; waiting for them to finish... -Process 1 finished with exit status 0. -All processes have finished. diff --git a/t/pt-log-player/samples/split_binlog001.txt b/t/pt-log-player/samples/split_binlog001.txt deleted file mode 100644 index df66c515..00000000 --- a/t/pt-log-player/samples/split_binlog001.txt +++ /dev/null @@ -1,18 +0,0 @@ --- START SESSION 103374 - -insert into test1.tbl6 (day, tbl5, misccol9type, misccol9, metric11, metric12, secs) values (convert_tz(current_timestamp,'EST5EDT','PST8PDT'), '239', 'foo', 'bar', 1, '1', '16.3574378490448') on duplicate key update metric11 = metric11 + 1, metric12 = metric12 + values(metric12), secs = secs + values(secs) - -update test2.tbl8 set last2metric1 = last1metric1, last2time = last1time, last1metric1 = last0metric1, last1time = last0time, last0metric1 = ondeckmetric1, last0time = now() where tbl8 in (10800712) - --- START SESSION 104168 - -BEGIN - -use test1 - -update test3.tblo as o inner join test3.tbl2 as e on o.animal = e.animal and o.oid = e.oid set e.tblo = o.tblo, e.col3 = o.col3 where e.tblo is null - -replace into test4.tbl9(tbl5, day, todo, comment) select distinct o.tbl5, date(o.col3), 'misc', right('foo', 50) from test3.tblo as o inner join test3.tbl2 as e on o.animal = e.animal and o.oid = e.oid where e.tblo is not null and o.col1 > 0 and o.tbl2 is null and o.col3 >= date_sub(current_date, interval 30 day) - -update test3.tblo as o inner join test3.tbl2 as e on o.animal = e.animal and o.oid = e.oid set o.tbl2 = e.tbl2, e.col9 = now() where o.tbl2 is null - diff --git a/t/pt-log-player/samples/split_genlog001.txt b/t/pt-log-player/samples/split_genlog001.txt deleted file mode 100644 index 54faa125..00000000 --- a/t/pt-log-player/samples/split_genlog001.txt +++ /dev/null @@ -1,12 +0,0 @@ --- START SESSION 42 - -use db1 - -SELECT foo FROM tbl WHERE col=12345 ORDER BY col - --- START SESSION 11 - -use my_webstats - -SELECT DISTINCT col FROM tbl WHERE foo=20061219 - diff --git a/t/pt-log-player/split.t b/t/pt-log-player/split.t deleted file mode 100644 index 58f51422..00000000 --- a/t/pt-log-player/split.t +++ /dev/null @@ -1,82 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 6; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $output; -my $tmpdir = '/tmp/mk-log-player'; -my $cmd = "$trunk/bin/pt-log-player --base-dir $tmpdir"; - -diag(`rm -rf $tmpdir 2>/dev/null; mkdir $tmpdir`); - -# ############################################################################# -# Test log splitting. -# ############################################################################# -$output = `$cmd --session-files 2 --split Thread_id $trunk/t/pt-log-player/samples/log001.txt`; -like( - $output, - qr/Sessions saved\s+4/, - 'Reports 2 sessions saved' -); - -ok( - -f "$tmpdir/sessions-1.txt", - "sessions-1.txt created" -); -ok( - -f "$tmpdir/sessions-2.txt", - "sessions-2.txt created" -); - -chomp($output = `cat $tmpdir/sessions-[12].txt | wc -l`); -$output =~ s/^\s+//; -is( - $output, - 34, - 'Session files have correct number of lines' -); - -# ############################################################################# -# Issue 570: Integrate BinaryLogPrarser into mk-log-player -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -`$cmd --split Thread_id $trunk/t/lib/samples/binlogs/binlog001.txt --type binlog --session-files 1`; -$output = `diff $tmpdir/sessions-1.txt $trunk/t/pt-log-player/samples/split_binlog001.txt`; - -is( - $output, - '', - 'Split binlog001.txt' -); - -# ############################################################################# -# Issue 172: Make mk-query-digest able to read general logs -# ############################################################################# -diag(`rm -rf $tmpdir/*`); -`$cmd --split Thread_id $trunk/t/lib/samples/genlogs/genlog001.txt --type genlog --session-files 1`; - -$output = `diff $tmpdir/sessions-1.txt $trunk/t/pt-log-player/samples/split_genlog001.txt`; - -is( - $output, - '', - 'Split genlog001.txt' -); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir 2>/dev/null`); -exit; diff --git a/t/pt-log-player/split_random.t b/t/pt-log-player/split_random.t deleted file mode 100644 index 8fa40f51..00000000 --- a/t/pt-log-player/split_random.t +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 5; - -use PerconaTest; -require "$trunk/bin/pt-log-player"; - -my $output; -my $tmpdir = '/tmp/mk-log-player'; -diag(`rm -rf $tmpdir; mkdir $tmpdir`); - -# ############################################################################# -# Issue 798: Make mk-log-player --split work without an attribute -# ############################################################################# -$output = `$trunk/bin/pt-log-player --base-dir $tmpdir --session-files 2 --split-random $trunk/t/lib/samples/slowlogs/slow006.txt`; - -like( - $output, - qr/Events saved\s+6/, - 'Reports 6 events saved' -); -ok( - -f "$tmpdir/sessions-1.txt", - "sessions-1.txt created" -); -ok( - -f "$tmpdir/sessions-2.txt", - "sessions-2.txt created" -); - -$output = `diff $tmpdir/sessions-1.txt $trunk/t/lib/samples/LogSplitter/slow006-random-1.txt`; -is( - $output, - '', - 'Random file 1 file has correct SQL statements' -); - -$output = `diff $tmpdir/sessions-2.txt $trunk/t/lib/samples/LogSplitter/slow006-random-2.txt`; -is( - $output, - '', - 'Random file 2 file has correct SQL statements' -); - -# ############################################################################# -# Done. -# ############################################################################# -diag(`rm -rf $tmpdir`); -diag(`rm -rf ./session-results-*`); -exit; diff --git a/t/pt-log-player/standard_options.t b/t/pt-log-player/standard_options.t deleted file mode 100644 index 6d087638..00000000 --- a/t/pt-log-player/standard_options.t +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 1; - -use PerconaTest; -use Sandbox; -require "$trunk/bin/pt-log-player"; - -my $output; - -# ############################################################################# -# Issue 391: Add --pid option to all scripts -# ############################################################################# -`touch /tmp/mk-script.pid`; -$output = `$trunk/bin/pt-log-player --split Thread_id $trunk/t/lib/samples/binlog001.txt --type binlog --session-files 1 --pid /tmp/mk-script.pid 2>&1`; -like( - $output, - qr{PID file /tmp/mk-script.pid already exists}, - 'Dies if PID file already exists (issue 391)' -); -`rm -rf /tmp/mk-script.pid`; - -# ############################################################################# -# Done. -# ############################################################################# -exit; diff --git a/t/pt-tcp-model/analyses.t b/t/pt-tcp-model/analyses.t deleted file mode 100644 index 13ba8918..00000000 --- a/t/pt-tcp-model/analyses.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More; - -use PerconaTest; - -require "$trunk/bin/pt-tcp-model"; - -my @args = qw(); -my $in1 = "$trunk/t/lib/samples/simple-tcpdump/"; -my $in2 = "$trunk/t/pt-tcp-model/samples/in/"; -my $out = "t/pt-tcp-model/samples/out/"; -my $output = ''; - -$ENV{TZ}='MST7MDT'; - -# ############################################################################ -# Basic queries that parse without problems. -# ############################################################################ -ok( - no_diff( - sub { pt_tcp_model::main(@args, "$in1/simpletcp001.txt") }, - "$out/simpletcp001.txt", - ), - 'Analysis for simpletcp001.txt' -); - -ok( - no_diff( - sub { pt_tcp_model::main(@args, "$in2/sorted001.txt", - qw(--type requests --run-time 1)) }, - "$out/sorted001.txt", - ), - 'Analysis for sorted001.txt (issue 1341)' -); - -($output) = full_output( - sub { pt_tcp_model::main(@args, - '--type=requests', "$trunk/t/lib/samples/empty.txt" - ) } -); - -is( - $output, - '', - "--type=requests doesn't die on an empty file", -); - -# ############################################################################# -# Done. -# ############################################################################# -done_testing; diff --git a/t/pt-tcp-model/samples/in/sorted001.txt b/t/pt-tcp-model/samples/in/sorted001.txt deleted file mode 100644 index 45223b69..00000000 --- a/t/pt-tcp-model/samples/in/sorted001.txt +++ /dev/null @@ -1,33 +0,0 @@ - 0 1318341891.407876 1318341891.407998 0.000122 127.0.0.1:59243 - 1 1318341891.408318 1318341891.408583 0.000265 127.0.0.1:59243 - 2 1318341893.456477 1318341893.456928 0.000451 127.0.0.1:59243 - 3 1318341893.457328 1318341893.457576 0.000248 127.0.0.1:59243 - 4 1318341893.461037 1318341893.461795 0.000758 127.0.0.1:59243 - 5 1318341893.462275 1318341893.463729 0.001454 127.0.0.1:59243 - 6 1318341893.464039 1318341893.464166 0.000127 127.0.0.1:59243 - 7 1318341893.464443 1318341893.464798 0.000355 127.0.0.1:59243 - 8 1318341893.464923 1318341893.465028 0.000105 127.0.0.1:59243 - 9 1318341893.465207 1318341893.465301 0.000094 127.0.0.1:59243 - 10 1318341893.465408 1318341893.465503 0.000095 127.0.0.1:59243 - 11 1318341893.465618 1318341893.465712 0.000094 127.0.0.1:59243 - 12 1318341893.465860 1318341893.465952 0.000092 127.0.0.1:59243 - 13 1318341893.466155 1318341893.466391 0.000236 127.0.0.1:59243 - 14 1318341893.466546 1318341893.466663 0.000117 127.0.0.1:59243 - 15 1318341893.466983 1318341893.467085 0.000102 127.0.0.1:59243 - 16 1318341893.467190 1318341893.467284 0.000094 127.0.0.1:59243 - 17 1318341893.467392 1318341893.467851 0.000459 127.0.0.1:59243 - 18 1318341893.468247 1318341893.468354 0.000107 127.0.0.1:59243 - 19 1318341893.468475 1318341893.468573 0.000098 127.0.0.1:59243 - 20 1318341893.468710 1318341893.468805 0.000095 127.0.0.1:59243 - 21 1318341893.468920 1318341893.469310 0.000390 127.0.0.1:59243 - 22 1318341893.469572 1318341893.469670 0.000098 127.0.0.1:59243 - 23 1318341893.469863 1318341893.469968 0.000105 127.0.0.1:59243 - 24 1318341893.470155 1318341893.470362 0.000207 127.0.0.1:59243 - 25 1318341893.470495 1318341893.470737 0.000242 127.0.0.1:59243 - 26 1318341893.470921 1318341893.471029 0.000108 127.0.0.1:59243 - 27 1318341893.471247 1318341893.471454 0.000207 127.0.0.1:59243 - 28 1318341893.471655 1318341893.471752 0.000097 127.0.0.1:59243 - 29 1318341897.750127 1318341897.752687 0.002560 127.0.0.1:59243 - 30 1318341900.468642 1318341900.472179 0.003537 127.0.0.1:59243 - 31 1318341906.516355 1318341906.521779 0.005424 127.0.0.1:59243 - 32 1318341914.969460 1318341914.972640 0.003180 127.0.0.1:59243 diff --git a/t/pt-tcp-model/samples/out/simpletcp001.txt b/t/pt-tcp-model/samples/out/simpletcp001.txt deleted file mode 100644 index 79109ccb..00000000 --- a/t/pt-tcp-model/samples/out/simpletcp001.txt +++ /dev/null @@ -1,3 +0,0 @@ - 0 1301965063.804195 1301965063.804465 0.000270 10.10.18.253:58297 - 1 1301965063.805481 1301965063.806026 0.000545 10.10.18.253:40135 - 2 1301965063.805801 1301965063.806003 0.000202 10.10.18.253:52726 diff --git a/t/pt-tcp-model/samples/out/sorted001.txt b/t/pt-tcp-model/samples/out/sorted001.txt deleted file mode 100644 index f6672301..00000000 --- a/t/pt-tcp-model/samples/out/sorted001.txt +++ /dev/null @@ -1,6 +0,0 @@ -1318341891 0.00 1.256 2 2 0.000387 0.000387 0.000387 0.000026 0.000265 1.592124 -1318341893 0.00 6.750 27 27 0.006635 0.006635 0.006635 0.000328 0.001454 4.000000 -1318341897 0.00 0.333 1 1 0.002560 0.002560 0.002560 0.000000 0.002560 3.000000 -1318341900 0.00 0.167 1 1 0.003537 0.003537 0.003537 0.000000 0.003537 6.000000 -1318341906 0.00 0.125 1 1 0.005424 0.005424 0.005424 0.000000 0.005424 8.000000 -1318341914 0.00 1.028 1 1 0.003180 0.003180 0.003180 0.000000 0.003180 0.972640 diff --git a/t/pt-trend/basics.t b/t/pt-trend/basics.t deleted file mode 100644 index 87eb4891..00000000 --- a/t/pt-trend/basics.t +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/env perl - -BEGIN { - die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" - unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; - unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; -}; - -use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use Test::More tests => 1; - -use PerconaTest; -require "$trunk/bin/pt-trend"; - - -my $in = "$trunk/t/lib/samples/slowlogs"; -my $out = "t/pt-trend/samples/"; -my @args = (); - -$ENV{TZ}='MST7MDT'; - -ok( - no_diff( - sub { pt_trend::main(@args, "$in/slow053.txt") }, - "$out/slow053.txt", - ), - "Analysis for slow053.txt" -); - -# ############################################################################# -# Done. -# ############################################################################# -exit; diff --git a/t/pt-trend/samples/slow053.txt b/t/pt-trend/samples/slow053.txt deleted file mode 100644 index 021b4575..00000000 --- a/t/pt-trend/samples/slow053.txt +++ /dev/null @@ -1,10 +0,0 @@ - TS CNT SUM MIN MAX AVG -1297191601 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191602 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191603 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191604 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191605 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191606 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191607 1.000000 0.000012 0.000012 0.000012 0.000012 -1297191608 1.000000 0.050012 0.050012 0.050012 0.050012 -1297191609 1.000000 1.000012 1.000012 1.000012 1.000012