Merge lp:~percona-toolkit-dev/percona-toolkit/remove-3-tools into lp:percona-toolkit/2.2

Proposed by Daniel Nichter
Status: Merged
Approved by: Daniel Nichter
Approved revision: 504
Merged at revision: 505
Proposed branch: lp:~percona-toolkit-dev/percona-toolkit/remove-3-tools
Merge into: lp:percona-toolkit/2.2
Diff against target: 10564 lines (+0/-10336)
38 files modified
MANIFEST (+0/-3)
bin/pt-log-player (+0/-3662)
bin/pt-tcp-model (+0/-2534)
bin/pt-trend (+0/-2235)
lib/LogSplitter.pm (+0/-443)
lib/TimeSeriesTrender.pm (+0/-119)
t/lib/LogSplitter.t (+0/-319)
t/lib/samples/LogSplitter/binlog010.txt (+0/-92)
t/lib/samples/LogSplitter/slow006-random-1.txt (+0/-12)
t/lib/samples/LogSplitter/slow006-random-2.txt (+0/-14)
t/lib/samples/log_splitter.pl (+0/-19)
t/lib/samples/maxsessionfiles_01 (+0/-6)
t/lib/samples/maxsessionfiles_02 (+0/-19)
t/lib/samples/split_slow020.txt (+0/-14)
t/pt-log-player/filter.t (+0/-37)
t/pt-log-player/issue_799.t (+0/-60)
t/pt-log-player/issue_903.t (+0/-57)
t/pt-log-player/option_sanity.t (+0/-61)
t/pt-log-player/play.t (+0/-98)
t/pt-log-player/samples/assigned16.txt (+0/-17)
t/pt-log-player/samples/issue_799.sql (+0/-4)
t/pt-log-player/samples/issue_799.txt (+0/-4)
t/pt-log-player/samples/issue_903.txt (+0/-1)
t/pt-log-player/samples/log.sql (+0/-28)
t/pt-log-player/samples/log001.txt (+0/-58)
t/pt-log-player/samples/one_big_session.txt (+0/-61)
t/pt-log-player/samples/play_slow020.txt (+0/-5)
t/pt-log-player/samples/split_binlog001.txt (+0/-18)
t/pt-log-player/samples/split_genlog001.txt (+0/-12)
t/pt-log-player/split.t (+0/-82)
t/pt-log-player/split_random.t (+0/-59)
t/pt-log-player/standard_options.t (+0/-35)
t/pt-tcp-model/analyses.t (+0/-61)
t/pt-tcp-model/samples/in/sorted001.txt (+0/-33)
t/pt-tcp-model/samples/out/simpletcp001.txt (+0/-3)
t/pt-tcp-model/samples/out/sorted001.txt (+0/-6)
t/pt-trend/basics.t (+0/-35)
t/pt-trend/samples/slow053.txt (+0/-10)
To merge this branch: bzr merge lp:~percona-toolkit-dev/percona-toolkit/remove-3-tools
Reviewer Review Type Date Requested Status
Brian Fraser (community) Approve
Daniel Nichter Approve
Review via email: mp+139363@code.launchpad.net
To post a comment you must log in.
Revision history for this message
Daniel Nichter (daniel-nichter) :
review: Approve
Revision history for this message
Brian Fraser (fraserbn) :
review: Approve

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1=== modified file 'MANIFEST'
2--- MANIFEST 2012-04-03 19:42:45 +0000
3+++ MANIFEST 2012-12-12 01:33:34 +0000
4@@ -18,7 +18,6 @@
5 bin/pt-index-usage
6 bin/pt-ioprofile
7 bin/pt-kill
8-bin/pt-log-player
9 bin/pt-mext
10 bin/pt-mysql-summary
11 bin/pt-online-schema-change
12@@ -35,8 +34,6 @@
13 bin/pt-table-checksum
14 bin/pt-table-sync
15 bin/pt-table-usage
16-bin/pt-tcp-model
17-bin/pt-trend
18 bin/pt-upgrade
19 bin/pt-variable-advisor
20 bin/pt-visual-explain
21
22=== removed file 'bin/pt-log-player'
23--- bin/pt-log-player 2012-12-03 03:48:11 +0000
24+++ bin/pt-log-player 1970-01-01 00:00:00 +0000
25@@ -1,3662 +0,0 @@
26-#!/usr/bin/env perl
27-
28-# This program is part of Percona Toolkit: http://www.percona.com/software/
29-# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
30-# notices and disclaimers.
31-
32-use strict;
33-use warnings FATAL => 'all';
34-
35-# This tool is "fat-packed": most of its dependent modules are embedded
36-# in this file. Setting %INC to this file for each module makes Perl aware
37-# of this so it will not try to load the module from @INC. See the tool's
38-# documentation for a full list of dependencies.
39-BEGIN {
40- $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
41- OptionParser
42- SlowLogParser
43- BinaryLogParser
44- GeneralLogParser
45- LogSplitter
46- DSNParser
47- Daemon
48- ));
49-}
50-
51-# ###########################################################################
52-# OptionParser package
53-# This package is a copy without comments from the original. The original
54-# with comments and its test file can be found in the Bazaar repository at,
55-# lib/OptionParser.pm
56-# t/lib/OptionParser.t
57-# See https://launchpad.net/percona-toolkit for more information.
58-# ###########################################################################
59-{
60-package OptionParser;
61-
62-use strict;
63-use warnings FATAL => 'all';
64-use English qw(-no_match_vars);
65-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
66-
67-use List::Util qw(max);
68-use Getopt::Long;
69-
70-my $POD_link_re = '[LC]<"?([^">]+)"?>';
71-
72-sub new {
73- my ( $class, %args ) = @_;
74- my @required_args = qw();
75- foreach my $arg ( @required_args ) {
76- die "I need a $arg argument" unless $args{$arg};
77- }
78-
79- my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
80- $program_name ||= $PROGRAM_NAME;
81- my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
82-
83- my %attributes = (
84- 'type' => 1,
85- 'short form' => 1,
86- 'group' => 1,
87- 'default' => 1,
88- 'cumulative' => 1,
89- 'negatable' => 1,
90- );
91-
92- my $self = {
93- head1 => 'OPTIONS', # These args are used internally
94- skip_rules => 0, # to instantiate another Option-
95- item => '--(.*)', # Parser obj that parses the
96- attributes => \%attributes, # DSN OPTIONS section. Tools
97- parse_attributes => \&_parse_attribs, # don't tinker with these args.
98-
99- %args,
100-
101- strict => 1, # disabled by a special rule
102- program_name => $program_name,
103- opts => {},
104- got_opts => 0,
105- short_opts => {},
106- defaults => {},
107- groups => {},
108- allowed_groups => {},
109- errors => [],
110- rules => [], # desc of rules for --help
111- mutex => [], # rule: opts are mutually exclusive
112- atleast1 => [], # rule: at least one opt is required
113- disables => {}, # rule: opt disables other opts
114- defaults_to => {}, # rule: opt defaults to value of other opt
115- DSNParser => undef,
116- default_files => [
117- "/etc/percona-toolkit/percona-toolkit.conf",
118- "/etc/percona-toolkit/$program_name.conf",
119- "$home/.percona-toolkit.conf",
120- "$home/.$program_name.conf",
121- ],
122- types => {
123- string => 's', # standard Getopt type
124- int => 'i', # standard Getopt type
125- float => 'f', # standard Getopt type
126- Hash => 'H', # hash, formed from a comma-separated list
127- hash => 'h', # hash as above, but only if a value is given
128- Array => 'A', # array, similar to Hash
129- array => 'a', # array, similar to hash
130- DSN => 'd', # DSN
131- size => 'z', # size with kMG suffix (powers of 2^10)
132- time => 'm', # time, with an optional suffix of s/h/m/d
133- },
134- };
135-
136- return bless $self, $class;
137-}
138-
139-sub get_specs {
140- my ( $self, $file ) = @_;
141- $file ||= $self->{file} || __FILE__;
142- my @specs = $self->_pod_to_specs($file);
143- $self->_parse_specs(@specs);
144-
145- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
146- my $contents = do { local $/ = undef; <$fh> };
147- close $fh;
148- if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
149- PTDEBUG && _d('Parsing DSN OPTIONS');
150- my $dsn_attribs = {
151- dsn => 1,
152- copy => 1,
153- };
154- my $parse_dsn_attribs = sub {
155- my ( $self, $option, $attribs ) = @_;
156- map {
157- my $val = $attribs->{$_};
158- if ( $val ) {
159- $val = $val eq 'yes' ? 1
160- : $val eq 'no' ? 0
161- : $val;
162- $attribs->{$_} = $val;
163- }
164- } keys %$attribs;
165- return {
166- key => $option,
167- %$attribs,
168- };
169- };
170- my $dsn_o = new OptionParser(
171- description => 'DSN OPTIONS',
172- head1 => 'DSN OPTIONS',
173- dsn => 0, # XXX don't infinitely recurse!
174- item => '\* (.)', # key opts are a single character
175- skip_rules => 1, # no rules before opts
176- attributes => $dsn_attribs,
177- parse_attributes => $parse_dsn_attribs,
178- );
179- my @dsn_opts = map {
180- my $opts = {
181- key => $_->{spec}->{key},
182- dsn => $_->{spec}->{dsn},
183- copy => $_->{spec}->{copy},
184- desc => $_->{desc},
185- };
186- $opts;
187- } $dsn_o->_pod_to_specs($file);
188- $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
189- }
190-
191- if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
192- $self->{version} = $1;
193- PTDEBUG && _d($self->{version});
194- }
195-
196- return;
197-}
198-
199-sub DSNParser {
200- my ( $self ) = @_;
201- return $self->{DSNParser};
202-};
203-
204-sub get_defaults_files {
205- my ( $self ) = @_;
206- return @{$self->{default_files}};
207-}
208-
209-sub _pod_to_specs {
210- my ( $self, $file ) = @_;
211- $file ||= $self->{file} || __FILE__;
212- open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
213-
214- my @specs = ();
215- my @rules = ();
216- my $para;
217-
218- local $INPUT_RECORD_SEPARATOR = '';
219- while ( $para = <$fh> ) {
220- next unless $para =~ m/^=head1 $self->{head1}/;
221- last;
222- }
223-
224- while ( $para = <$fh> ) {
225- last if $para =~ m/^=over/;
226- next if $self->{skip_rules};
227- chomp $para;
228- $para =~ s/\s+/ /g;
229- $para =~ s/$POD_link_re/$1/go;
230- PTDEBUG && _d('Option rule:', $para);
231- push @rules, $para;
232- }
233-
234- die "POD has no $self->{head1} section" unless $para;
235-
236- do {
237- if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
238- chomp $para;
239- PTDEBUG && _d($para);
240- my %attribs;
241-
242- $para = <$fh>; # read next paragraph, possibly attributes
243-
244- if ( $para =~ m/: / ) { # attributes
245- $para =~ s/\s+\Z//g;
246- %attribs = map {
247- my ( $attrib, $val) = split(/: /, $_);
248- die "Unrecognized attribute for --$option: $attrib"
249- unless $self->{attributes}->{$attrib};
250- ($attrib, $val);
251- } split(/; /, $para);
252- if ( $attribs{'short form'} ) {
253- $attribs{'short form'} =~ s/-//;
254- }
255- $para = <$fh>; # read next paragraph, probably short help desc
256- }
257- else {
258- PTDEBUG && _d('Option has no attributes');
259- }
260-
261- $para =~ s/\s+\Z//g;
262- $para =~ s/\s+/ /g;
263- $para =~ s/$POD_link_re/$1/go;
264-
265- $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
266- PTDEBUG && _d('Short help:', $para);
267-
268- die "No description after option spec $option" if $para =~ m/^=item/;
269-
270- if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
271- $option = $base_option;
272- $attribs{'negatable'} = 1;
273- }
274-
275- push @specs, {
276- spec => $self->{parse_attributes}->($self, $option, \%attribs),
277- desc => $para
278- . (defined $attribs{default} ? " (default $attribs{default})" : ''),
279- group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
280- };
281- }
282- while ( $para = <$fh> ) {
283- last unless $para;
284- if ( $para =~ m/^=head1/ ) {
285- $para = undef; # Can't 'last' out of a do {} block.
286- last;
287- }
288- last if $para =~ m/^=item /;
289- }
290- } while ( $para );
291-
292- die "No valid specs in $self->{head1}" unless @specs;
293-
294- close $fh;
295- return @specs, @rules;
296-}
297-
298-sub _parse_specs {
299- my ( $self, @specs ) = @_;
300- my %disables; # special rule that requires deferred checking
301-
302- foreach my $opt ( @specs ) {
303- if ( ref $opt ) { # It's an option spec, not a rule.
304- PTDEBUG && _d('Parsing opt spec:',
305- map { ($_, '=>', $opt->{$_}) } keys %$opt);
306-
307- my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
308- if ( !$long ) {
309- die "Cannot parse long option from spec $opt->{spec}";
310- }
311- $opt->{long} = $long;
312-
313- die "Duplicate long option --$long" if exists $self->{opts}->{$long};
314- $self->{opts}->{$long} = $opt;
315-
316- if ( length $long == 1 ) {
317- PTDEBUG && _d('Long opt', $long, 'looks like short opt');
318- $self->{short_opts}->{$long} = $long;
319- }
320-
321- if ( $short ) {
322- die "Duplicate short option -$short"
323- if exists $self->{short_opts}->{$short};
324- $self->{short_opts}->{$short} = $long;
325- $opt->{short} = $short;
326- }
327- else {
328- $opt->{short} = undef;
329- }
330-
331- $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
332- $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
333- $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
334-
335- $opt->{group} ||= 'default';
336- $self->{groups}->{ $opt->{group} }->{$long} = 1;
337-
338- $opt->{value} = undef;
339- $opt->{got} = 0;
340-
341- my ( $type ) = $opt->{spec} =~ m/=(.)/;
342- $opt->{type} = $type;
343- PTDEBUG && _d($long, 'type:', $type);
344-
345-
346- $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
347-
348- if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
349- $self->{defaults}->{$long} = defined $def ? $def : 1;
350- PTDEBUG && _d($long, 'default:', $def);
351- }
352-
353- if ( $long eq 'config' ) {
354- $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
355- }
356-
357- if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
358- $disables{$long} = $dis;
359- PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
360- }
361-
362- $self->{opts}->{$long} = $opt;
363- }
364- else { # It's an option rule, not a spec.
365- PTDEBUG && _d('Parsing rule:', $opt);
366- push @{$self->{rules}}, $opt;
367- my @participants = $self->_get_participants($opt);
368- my $rule_ok = 0;
369-
370- if ( $opt =~ m/mutually exclusive|one and only one/ ) {
371- $rule_ok = 1;
372- push @{$self->{mutex}}, \@participants;
373- PTDEBUG && _d(@participants, 'are mutually exclusive');
374- }
375- if ( $opt =~ m/at least one|one and only one/ ) {
376- $rule_ok = 1;
377- push @{$self->{atleast1}}, \@participants;
378- PTDEBUG && _d(@participants, 'require at least one');
379- }
380- if ( $opt =~ m/default to/ ) {
381- $rule_ok = 1;
382- $self->{defaults_to}->{$participants[0]} = $participants[1];
383- PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
384- }
385- if ( $opt =~ m/restricted to option groups/ ) {
386- $rule_ok = 1;
387- my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
388- my @groups = split(',', $groups);
389- %{$self->{allowed_groups}->{$participants[0]}} = map {
390- s/\s+//;
391- $_ => 1;
392- } @groups;
393- }
394- if( $opt =~ m/accepts additional command-line arguments/ ) {
395- $rule_ok = 1;
396- $self->{strict} = 0;
397- PTDEBUG && _d("Strict mode disabled by rule");
398- }
399-
400- die "Unrecognized option rule: $opt" unless $rule_ok;
401- }
402- }
403-
404- foreach my $long ( keys %disables ) {
405- my @participants = $self->_get_participants($disables{$long});
406- $self->{disables}->{$long} = \@participants;
407- PTDEBUG && _d('Option', $long, 'disables', @participants);
408- }
409-
410- return;
411-}
412-
413-sub _get_participants {
414- my ( $self, $str ) = @_;
415- my @participants;
416- foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
417- die "Option --$long does not exist while processing rule $str"
418- unless exists $self->{opts}->{$long};
419- push @participants, $long;
420- }
421- PTDEBUG && _d('Participants for', $str, ':', @participants);
422- return @participants;
423-}
424-
425-sub opts {
426- my ( $self ) = @_;
427- my %opts = %{$self->{opts}};
428- return %opts;
429-}
430-
431-sub short_opts {
432- my ( $self ) = @_;
433- my %short_opts = %{$self->{short_opts}};
434- return %short_opts;
435-}
436-
437-sub set_defaults {
438- my ( $self, %defaults ) = @_;
439- $self->{defaults} = {};
440- foreach my $long ( keys %defaults ) {
441- die "Cannot set default for nonexistent option $long"
442- unless exists $self->{opts}->{$long};
443- $self->{defaults}->{$long} = $defaults{$long};
444- PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
445- }
446- return;
447-}
448-
449-sub get_defaults {
450- my ( $self ) = @_;
451- return $self->{defaults};
452-}
453-
454-sub get_groups {
455- my ( $self ) = @_;
456- return $self->{groups};
457-}
458-
459-sub _set_option {
460- my ( $self, $opt, $val ) = @_;
461- my $long = exists $self->{opts}->{$opt} ? $opt
462- : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
463- : die "Getopt::Long gave a nonexistent option: $opt";
464-
465- $opt = $self->{opts}->{$long};
466- if ( $opt->{is_cumulative} ) {
467- $opt->{value}++;
468- }
469- else {
470- $opt->{value} = $val;
471- }
472- $opt->{got} = 1;
473- PTDEBUG && _d('Got option', $long, '=', $val);
474-}
475-
476-sub get_opts {
477- my ( $self ) = @_;
478-
479- foreach my $long ( keys %{$self->{opts}} ) {
480- $self->{opts}->{$long}->{got} = 0;
481- $self->{opts}->{$long}->{value}
482- = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
483- : $self->{opts}->{$long}->{is_cumulative} ? 0
484- : undef;
485- }
486- $self->{got_opts} = 0;
487-
488- $self->{errors} = [];
489-
490- if ( @ARGV && $ARGV[0] eq "--config" ) {
491- shift @ARGV;
492- $self->_set_option('config', shift @ARGV);
493- }
494- if ( $self->has('config') ) {
495- my @extra_args;
496- foreach my $filename ( split(',', $self->get('config')) ) {
497- eval {
498- push @extra_args, $self->_read_config_file($filename);
499- };
500- if ( $EVAL_ERROR ) {
501- if ( $self->got('config') ) {
502- die $EVAL_ERROR;
503- }
504- elsif ( PTDEBUG ) {
505- _d($EVAL_ERROR);
506- }
507- }
508- }
509- unshift @ARGV, @extra_args;
510- }
511-
512- Getopt::Long::Configure('no_ignore_case', 'bundling');
513- GetOptions(
514- map { $_->{spec} => sub { $self->_set_option(@_); } }
515- grep { $_->{long} ne 'config' } # --config is handled specially above.
516- values %{$self->{opts}}
517- ) or $self->save_error('Error parsing options');
518-
519- if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
520- if ( $self->{version} ) {
521- print $self->{version}, "\n";
522- }
523- else {
524- print "Error parsing version. See the VERSION section of the tool's documentation.\n";
525- }
526- exit 1;
527- }
528-
529- if ( @ARGV && $self->{strict} ) {
530- $self->save_error("Unrecognized command-line options @ARGV");
531- }
532-
533- foreach my $mutex ( @{$self->{mutex}} ) {
534- my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
535- if ( @set > 1 ) {
536- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
537- @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
538- . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
539- . ' are mutually exclusive.';
540- $self->save_error($err);
541- }
542- }
543-
544- foreach my $required ( @{$self->{atleast1}} ) {
545- my @set = grep { $self->{opts}->{$_}->{got} } @$required;
546- if ( @set == 0 ) {
547- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
548- @{$required}[ 0 .. scalar(@$required) - 2] )
549- .' or --'.$self->{opts}->{$required->[-1]}->{long};
550- $self->save_error("Specify at least one of $err");
551- }
552- }
553-
554- $self->_check_opts( keys %{$self->{opts}} );
555- $self->{got_opts} = 1;
556- return;
557-}
558-
559-sub _check_opts {
560- my ( $self, @long ) = @_;
561- my $long_last = scalar @long;
562- while ( @long ) {
563- foreach my $i ( 0..$#long ) {
564- my $long = $long[$i];
565- next unless $long;
566- my $opt = $self->{opts}->{$long};
567- if ( $opt->{got} ) {
568- if ( exists $self->{disables}->{$long} ) {
569- my @disable_opts = @{$self->{disables}->{$long}};
570- map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
571- PTDEBUG && _d('Unset options', @disable_opts,
572- 'because', $long,'disables them');
573- }
574-
575- if ( exists $self->{allowed_groups}->{$long} ) {
576-
577- my @restricted_groups = grep {
578- !exists $self->{allowed_groups}->{$long}->{$_}
579- } keys %{$self->{groups}};
580-
581- my @restricted_opts;
582- foreach my $restricted_group ( @restricted_groups ) {
583- RESTRICTED_OPT:
584- foreach my $restricted_opt (
585- keys %{$self->{groups}->{$restricted_group}} )
586- {
587- next RESTRICTED_OPT if $restricted_opt eq $long;
588- push @restricted_opts, $restricted_opt
589- if $self->{opts}->{$restricted_opt}->{got};
590- }
591- }
592-
593- if ( @restricted_opts ) {
594- my $err;
595- if ( @restricted_opts == 1 ) {
596- $err = "--$restricted_opts[0]";
597- }
598- else {
599- $err = join(', ',
600- map { "--$self->{opts}->{$_}->{long}" }
601- grep { $_ }
602- @restricted_opts[0..scalar(@restricted_opts) - 2]
603- )
604- . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
605- }
606- $self->save_error("--$long is not allowed with $err");
607- }
608- }
609-
610- }
611- elsif ( $opt->{is_required} ) {
612- $self->save_error("Required option --$long must be specified");
613- }
614-
615- $self->_validate_type($opt);
616- if ( $opt->{parsed} ) {
617- delete $long[$i];
618- }
619- else {
620- PTDEBUG && _d('Temporarily failed to parse', $long);
621- }
622- }
623-
624- die "Failed to parse options, possibly due to circular dependencies"
625- if @long == $long_last;
626- $long_last = @long;
627- }
628-
629- return;
630-}
631-
632-sub _validate_type {
633- my ( $self, $opt ) = @_;
634- return unless $opt;
635-
636- if ( !$opt->{type} ) {
637- $opt->{parsed} = 1;
638- return;
639- }
640-
641- my $val = $opt->{value};
642-
643- if ( $val && $opt->{type} eq 'm' ) { # type time
644- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
645- my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
646- if ( !$suffix ) {
647- my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
648- $suffix = $s || 's';
649- PTDEBUG && _d('No suffix given; using', $suffix, 'for',
650- $opt->{long}, '(value:', $val, ')');
651- }
652- if ( $suffix =~ m/[smhd]/ ) {
653- $val = $suffix eq 's' ? $num # Seconds
654- : $suffix eq 'm' ? $num * 60 # Minutes
655- : $suffix eq 'h' ? $num * 3600 # Hours
656- : $num * 86400; # Days
657- $opt->{value} = ($prefix || '') . $val;
658- PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
659- }
660- else {
661- $self->save_error("Invalid time suffix for --$opt->{long}");
662- }
663- }
664- elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
665- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
666- my $prev = {};
667- my $from_key = $self->{defaults_to}->{ $opt->{long} };
668- if ( $from_key ) {
669- PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
670- if ( $self->{opts}->{$from_key}->{parsed} ) {
671- $prev = $self->{opts}->{$from_key}->{value};
672- }
673- else {
674- PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
675- $from_key, 'parsed');
676- return;
677- }
678- }
679- my $defaults = $self->{DSNParser}->parse_options($self);
680- $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
681- }
682- elsif ( $val && $opt->{type} eq 'z' ) { # type size
683- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
684- $self->_parse_size($opt, $val);
685- }
686- elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
687- $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
688- }
689- elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
690- $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
691- }
692- else {
693- PTDEBUG && _d('Nothing to validate for option',
694- $opt->{long}, 'type', $opt->{type}, 'value', $val);
695- }
696-
697- $opt->{parsed} = 1;
698- return;
699-}
700-
701-sub get {
702- my ( $self, $opt ) = @_;
703- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
704- die "Option $opt does not exist"
705- unless $long && exists $self->{opts}->{$long};
706- return $self->{opts}->{$long}->{value};
707-}
708-
709-sub got {
710- my ( $self, $opt ) = @_;
711- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
712- die "Option $opt does not exist"
713- unless $long && exists $self->{opts}->{$long};
714- return $self->{opts}->{$long}->{got};
715-}
716-
717-sub has {
718- my ( $self, $opt ) = @_;
719- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
720- return defined $long ? exists $self->{opts}->{$long} : 0;
721-}
722-
723-sub set {
724- my ( $self, $opt, $val ) = @_;
725- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
726- die "Option $opt does not exist"
727- unless $long && exists $self->{opts}->{$long};
728- $self->{opts}->{$long}->{value} = $val;
729- return;
730-}
731-
732-sub save_error {
733- my ( $self, $error ) = @_;
734- push @{$self->{errors}}, $error;
735- return;
736-}
737-
738-sub errors {
739- my ( $self ) = @_;
740- return $self->{errors};
741-}
742-
743-sub usage {
744- my ( $self ) = @_;
745- warn "No usage string is set" unless $self->{usage}; # XXX
746- return "Usage: " . ($self->{usage} || '') . "\n";
747-}
748-
749-sub descr {
750- my ( $self ) = @_;
751- warn "No description string is set" unless $self->{description}; # XXX
752- my $descr = ($self->{description} || $self->{program_name} || '')
753- . " For more details, please use the --help option, "
754- . "or try 'perldoc $PROGRAM_NAME' "
755- . "for complete documentation.";
756- $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
757- unless $ENV{DONT_BREAK_LINES};
758- $descr =~ s/ +$//mg;
759- return $descr;
760-}
761-
762-sub usage_or_errors {
763- my ( $self, $file, $return ) = @_;
764- $file ||= $self->{file} || __FILE__;
765-
766- if ( !$self->{description} || !$self->{usage} ) {
767- PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
768- my %synop = $self->_parse_synopsis($file);
769- $self->{description} ||= $synop{description};
770- $self->{usage} ||= $synop{usage};
771- PTDEBUG && _d("Description:", $self->{description},
772- "\nUsage:", $self->{usage});
773- }
774-
775- if ( $self->{opts}->{help}->{got} ) {
776- print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
777- exit 0 unless $return;
778- }
779- elsif ( scalar @{$self->{errors}} ) {
780- print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
781- exit 1 unless $return;
782- }
783-
784- return;
785-}
786-
787-sub print_errors {
788- my ( $self ) = @_;
789- my $usage = $self->usage() . "\n";
790- if ( (my @errors = @{$self->{errors}}) ) {
791- $usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
792- . "\n";
793- }
794- return $usage . "\n" . $self->descr();
795-}
796-
797-sub print_usage {
798- my ( $self ) = @_;
799- die "Run get_opts() before print_usage()" unless $self->{got_opts};
800- my @opts = values %{$self->{opts}};
801-
802- my $maxl = max(
803- map {
804- length($_->{long}) # option long name
805- + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
806- + ($_->{type} ? 2 : 0) # "=x" where x is the opt type
807- }
808- @opts);
809-
810- my $maxs = max(0,
811- map {
812- length($_)
813- + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
814- + ($self->{opts}->{$_}->{type} ? 2 : 0)
815- }
816- values %{$self->{short_opts}});
817-
818- my $lcol = max($maxl, ($maxs + 3));
819- my $rcol = 80 - $lcol - 6;
820- my $rpad = ' ' x ( 80 - $rcol );
821-
822- $maxs = max($lcol - 3, $maxs);
823-
824- my $usage = $self->descr() . "\n" . $self->usage();
825-
826- my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
827- push @groups, 'default';
828-
829- foreach my $group ( reverse @groups ) {
830- $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
831- foreach my $opt (
832- sort { $a->{long} cmp $b->{long} }
833- grep { $_->{group} eq $group }
834- @opts )
835- {
836- my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
837- my $short = $opt->{short};
838- my $desc = $opt->{desc};
839-
840- $long .= $opt->{type} ? "=$opt->{type}" : "";
841-
842- if ( $opt->{type} && $opt->{type} eq 'm' ) {
843- my ($s) = $desc =~ m/\(suffix (.)\)/;
844- $s ||= 's';
845- $desc =~ s/\s+\(suffix .\)//;
846- $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
847- . "d=days; if no suffix, $s is used.";
848- }
849- $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
850- $desc =~ s/ +$//mg;
851- if ( $short ) {
852- $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
853- }
854- else {
855- $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
856- }
857- }
858- }
859-
860- $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
861-
862- if ( (my @rules = @{$self->{rules}}) ) {
863- $usage .= "\nRules:\n\n";
864- $usage .= join("\n", map { " $_" } @rules) . "\n";
865- }
866- if ( $self->{DSNParser} ) {
867- $usage .= "\n" . $self->{DSNParser}->usage();
868- }
869- $usage .= "\nOptions and values after processing arguments:\n\n";
870- foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
871- my $val = $opt->{value};
872- my $type = $opt->{type} || '';
873- my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
874- $val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
875- : !defined $val ? '(No value)'
876- : $type eq 'd' ? $self->{DSNParser}->as_string($val)
877- : $type =~ m/H|h/ ? join(',', sort keys %$val)
878- : $type =~ m/A|a/ ? join(',', @$val)
879- : $val;
880- $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
881- }
882- return $usage;
883-}
884-
885-sub prompt_noecho {
886- shift @_ if ref $_[0] eq __PACKAGE__;
887- my ( $prompt ) = @_;
888- local $OUTPUT_AUTOFLUSH = 1;
889- print $prompt
890- or die "Cannot print: $OS_ERROR";
891- my $response;
892- eval {
893- require Term::ReadKey;
894- Term::ReadKey::ReadMode('noecho');
895- chomp($response = <STDIN>);
896- Term::ReadKey::ReadMode('normal');
897- print "\n"
898- or die "Cannot print: $OS_ERROR";
899- };
900- if ( $EVAL_ERROR ) {
901- die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
902- }
903- return $response;
904-}
905-
906-sub _read_config_file {
907- my ( $self, $filename ) = @_;
908- open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
909- my @args;
910- my $prefix = '--';
911- my $parse = 1;
912-
913- LINE:
914- while ( my $line = <$fh> ) {
915- chomp $line;
916- next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
917- $line =~ s/\s+#.*$//g;
918- $line =~ s/^\s+|\s+$//g;
919- if ( $line eq '--' ) {
920- $prefix = '';
921- $parse = 0;
922- next LINE;
923- }
924- if ( $parse
925- && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
926- ) {
927- push @args, grep { defined $_ } ("$prefix$opt", $arg);
928- }
929- elsif ( $line =~ m/./ ) {
930- push @args, $line;
931- }
932- else {
933- die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
934- }
935- }
936- close $fh;
937- return @args;
938-}
939-
940-sub read_para_after {
941- my ( $self, $file, $regex ) = @_;
942- open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
943- local $INPUT_RECORD_SEPARATOR = '';
944- my $para;
945- while ( $para = <$fh> ) {
946- next unless $para =~ m/^=pod$/m;
947- last;
948- }
949- while ( $para = <$fh> ) {
950- next unless $para =~ m/$regex/;
951- last;
952- }
953- $para = <$fh>;
954- chomp($para);
955- close $fh or die "Can't close $file: $OS_ERROR";
956- return $para;
957-}
958-
959-sub clone {
960- my ( $self ) = @_;
961-
962- my %clone = map {
963- my $hashref = $self->{$_};
964- my $val_copy = {};
965- foreach my $key ( keys %$hashref ) {
966- my $ref = ref $hashref->{$key};
967- $val_copy->{$key} = !$ref ? $hashref->{$key}
968- : $ref eq 'HASH' ? { %{$hashref->{$key}} }
969- : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
970- : $hashref->{$key};
971- }
972- $_ => $val_copy;
973- } qw(opts short_opts defaults);
974-
975- foreach my $scalar ( qw(got_opts) ) {
976- $clone{$scalar} = $self->{$scalar};
977- }
978-
979- return bless \%clone;
980-}
981-
982-sub _parse_size {
983- my ( $self, $opt, $val ) = @_;
984-
985- if ( lc($val || '') eq 'null' ) {
986- PTDEBUG && _d('NULL size for', $opt->{long});
987- $opt->{value} = 'null';
988- return;
989- }
990-
991- my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
992- my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
993- if ( defined $num ) {
994- if ( $factor ) {
995- $num *= $factor_for{$factor};
996- PTDEBUG && _d('Setting option', $opt->{y},
997- 'to num', $num, '* factor', $factor);
998- }
999- $opt->{value} = ($pre || '') . $num;
1000- }
1001- else {
1002- $self->save_error("Invalid size for --$opt->{long}: $val");
1003- }
1004- return;
1005-}
1006-
1007-sub _parse_attribs {
1008- my ( $self, $option, $attribs ) = @_;
1009- my $types = $self->{types};
1010- return $option
1011- . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
1012- . ($attribs->{'negatable'} ? '!' : '' )
1013- . ($attribs->{'cumulative'} ? '+' : '' )
1014- . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
1015-}
1016-
1017-sub _parse_synopsis {
1018- my ( $self, $file ) = @_;
1019- $file ||= $self->{file} || __FILE__;
1020- PTDEBUG && _d("Parsing SYNOPSIS in", $file);
1021-
1022- local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
1023- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1024- my $para;
1025- 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
1026- die "$file does not contain a SYNOPSIS section" unless $para;
1027- my @synop;
1028- for ( 1..2 ) { # 1 for the usage, 2 for the description
1029- my $para = <$fh>;
1030- push @synop, $para;
1031- }
1032- close $fh;
1033- PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
1034- my ($usage, $desc) = @synop;
1035- die "The SYNOPSIS section in $file is not formatted properly"
1036- unless $usage && $desc;
1037-
1038- $usage =~ s/^\s*Usage:\s+(.+)/$1/;
1039- chomp $usage;
1040-
1041- $desc =~ s/\n/ /g;
1042- $desc =~ s/\s{2,}/ /g;
1043- $desc =~ s/\. ([A-Z][a-z])/. $1/g;
1044- $desc =~ s/\s+$//;
1045-
1046- return (
1047- description => $desc,
1048- usage => $usage,
1049- );
1050-};
1051-
1052-sub _d {
1053- my ($package, undef, $line) = caller 0;
1054- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1055- map { defined $_ ? $_ : 'undef' }
1056- @_;
1057- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1058-}
1059-
1060-if ( PTDEBUG ) {
1061- print '# ', $^X, ' ', $], "\n";
1062- if ( my $uname = `uname -a` ) {
1063- $uname =~ s/\s+/ /g;
1064- print "# $uname\n";
1065- }
1066- print '# Arguments: ',
1067- join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
1068-}
1069-
1070-1;
1071-}
1072-# ###########################################################################
1073-# End OptionParser package
1074-# ###########################################################################
1075-
1076-# ###########################################################################
1077-# SlowLogParser package
1078-# This package is a copy without comments from the original. The original
1079-# with comments and its test file can be found in the Bazaar repository at,
1080-# lib/SlowLogParser.pm
1081-# t/lib/SlowLogParser.t
1082-# See https://launchpad.net/percona-toolkit for more information.
1083-# ###########################################################################
1084-{
1085-package SlowLogParser;
1086-
1087-use strict;
1088-use warnings FATAL => 'all';
1089-use English qw(-no_match_vars);
1090-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1091-
1092-use Data::Dumper;
1093-$Data::Dumper::Indent = 1;
1094-$Data::Dumper::Sortkeys = 1;
1095-$Data::Dumper::Quotekeys = 0;
1096-
1097-sub new {
1098- my ( $class ) = @_;
1099- my $self = {
1100- pending => [],
1101- };
1102- return bless $self, $class;
1103-}
1104-
1105-my $slow_log_ts_line = qr/^# Time: ([0-9: ]{15})/;
1106-my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]/;
1107-my $slow_log_hd_line = qr{
1108- ^(?:
1109- T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix
1110- |
1111- [/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary)
1112- |
1113- Time\s+Id\s+Command
1114- ).*\n
1115- }xm;
1116-
1117-sub parse_event {
1118- my ( $self, %args ) = @_;
1119- my @required_args = qw(next_event tell);
1120- foreach my $arg ( @required_args ) {
1121- die "I need a $arg argument" unless $args{$arg};
1122- }
1123- my ($next_event, $tell) = @args{@required_args};
1124-
1125- my $pending = $self->{pending};
1126- local $INPUT_RECORD_SEPARATOR = ";\n#";
1127- my $trimlen = length($INPUT_RECORD_SEPARATOR);
1128- my $pos_in_log = $tell->();
1129- my $stmt;
1130-
1131- EVENT:
1132- while (
1133- defined($stmt = shift @$pending)
1134- or defined($stmt = $next_event->())
1135- ) {
1136- my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log);
1137- $pos_in_log = $tell->();
1138-
1139- if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log
1140- my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt);
1141- if ( @chunks > 1 ) {
1142- PTDEBUG && _d("Found multiple chunks");
1143- $stmt = shift @chunks;
1144- unshift @$pending, @chunks;
1145- }
1146- }
1147-
1148- $stmt = '#' . $stmt unless $stmt =~ m/\A#/;
1149- $stmt =~ s/;\n#?\Z//;
1150-
1151-
1152- my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed);
1153- my $pos = 0;
1154- my $len = length($stmt);
1155- my $found_arg = 0;
1156- LINE:
1157- while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match.
1158- $pos = pos($stmt); # Be careful not to mess this up!
1159- my $line = $1; # Necessary for /g and pos() to work.
1160- PTDEBUG && _d($line);
1161-
1162- if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) {
1163-
1164- if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) {
1165- PTDEBUG && _d("Got ts", $time);
1166- push @properties, 'ts', $time;
1167- ++$got_ts;
1168- if ( !$got_uh
1169- && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
1170- ) {
1171- PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
1172- push @properties, 'user', $user, 'host', $host, 'ip', $ip;
1173- ++$got_uh;
1174- }
1175- }
1176-
1177- elsif ( !$got_uh
1178- && ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
1179- ) {
1180- PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
1181- push @properties, 'user', $user, 'host', $host, 'ip', $ip;
1182- ++$got_uh;
1183- }
1184-
1185- elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) {
1186- PTDEBUG && _d("Got admin command");
1187- $line =~ s/^#\s+//; # string leading "# ".
1188- push @properties, 'cmd', 'Admin', 'arg', $line;
1189- push @properties, 'bytes', length($properties[-1]);
1190- ++$found_arg;
1191- ++$got_ac;
1192- }
1193-
1194- elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap!
1195- PTDEBUG && _d("Got some line with properties");
1196-
1197- if ( $line =~ m/Schema:\s+\w+: / ) {
1198- PTDEBUG && _d('Removing empty Schema attrib');
1199- $line =~ s/Schema:\s+//;
1200- PTDEBUG && _d($line);
1201- }
1202-
1203- my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g;
1204- push @properties, @temp;
1205- }
1206-
1207- elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) {
1208- PTDEBUG && _d("Got a default database:", $db);
1209- push @properties, 'db', $db;
1210- ++$got_db;
1211- }
1212-
1213- elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) {
1214- PTDEBUG && _d("Got some setting:", $setting);
1215- push @properties, split(/,|\s*=\s*/, $setting);
1216- ++$got_set;
1217- }
1218-
1219- if ( !$found_arg && $pos == $len ) {
1220- PTDEBUG && _d("Did not find arg, looking for special cases");
1221- local $INPUT_RECORD_SEPARATOR = ";\n";
1222- if ( defined(my $l = $next_event->()) ) {
1223- chomp $l;
1224- $l =~ s/^\s+//;
1225- PTDEBUG && _d("Found admin statement", $l);
1226- push @properties, 'cmd', 'Admin', 'arg', $l;
1227- push @properties, 'bytes', length($properties[-1]);
1228- $found_arg++;
1229- }
1230- else {
1231- PTDEBUG && _d("I can't figure out what to do with this line");
1232- next EVENT;
1233- }
1234- }
1235- }
1236- else {
1237- PTDEBUG && _d("Got the query/arg line");
1238- my $arg = substr($stmt, $pos - length($line));
1239- push @properties, 'arg', $arg, 'bytes', length($arg);
1240- if ( $args{misc} && $args{misc}->{embed}
1241- && ( my ($e) = $arg =~ m/($args{misc}->{embed})/)
1242- ) {
1243- push @properties, $e =~ m/$args{misc}->{capture}/g;
1244- }
1245- last LINE;
1246- }
1247- }
1248-
1249- PTDEBUG && _d('Properties of event:', Dumper(\@properties));
1250- my $event = { @properties };
1251- if ( $args{stats} ) {
1252- $args{stats}->{events_read}++;
1253- $args{stats}->{events_parsed}++;
1254- }
1255- return $event;
1256- } # EVENT
1257-
1258- @$pending = ();
1259- $args{oktorun}->(0) if $args{oktorun};
1260- return;
1261-}
1262-
1263-sub _d {
1264- my ($package, undef, $line) = caller 0;
1265- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1266- map { defined $_ ? $_ : 'undef' }
1267- @_;
1268- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1269-}
1270-
1271-1;
1272-}
1273-# ###########################################################################
1274-# End SlowLogParser package
1275-# ###########################################################################
1276-
1277-# ###########################################################################
1278-# BinaryLogParser package
1279-# This package is a copy without comments from the original. The original
1280-# with comments and its test file can be found in the Bazaar repository at,
1281-# lib/BinaryLogParser.pm
1282-# t/lib/BinaryLogParser.t
1283-# See https://launchpad.net/percona-toolkit for more information.
1284-# ###########################################################################
1285-{
1286-package BinaryLogParser;
1287-
1288-use strict;
1289-use warnings FATAL => 'all';
1290-use English qw(-no_match_vars);
1291-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1292-
1293-use Data::Dumper;
1294-$Data::Dumper::Indent = 1;
1295-$Data::Dumper::Sortkeys = 1;
1296-$Data::Dumper::Quotekeys = 0;
1297-
1298-my $binlog_line_1 = qr/at (\d+)$/m;
1299-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;
1300-my $binlog_line_2_rest = qr/thread_id=(\d+)\s+exec_time=(\d+)\s+error_code=(\d+)/m;
1301-
1302-sub new {
1303- my ( $class, %args ) = @_;
1304- my $self = {
1305- delim => undef,
1306- delim_len => 0,
1307- };
1308- return bless $self, $class;
1309-}
1310-
1311-
1312-sub parse_event {
1313- my ( $self, %args ) = @_;
1314- my @required_args = qw(next_event tell);
1315- foreach my $arg ( @required_args ) {
1316- die "I need a $arg argument" unless $args{$arg};
1317- }
1318- my ($next_event, $tell) = @args{@required_args};
1319-
1320- local $INPUT_RECORD_SEPARATOR = ";\n#";
1321- my $pos_in_log = $tell->();
1322- my $stmt;
1323- my ($delim, $delim_len) = ($self->{delim}, $self->{delim_len});
1324-
1325- EVENT:
1326- while ( defined($stmt = $next_event->()) ) {
1327- my @properties = ('pos_in_log', $pos_in_log);
1328- my ($ts, $sid, $end, $type, $rest);
1329- $pos_in_log = $tell->();
1330- $stmt =~ s/;\n#?\Z//;
1331-
1332- my ( $got_offset, $got_hdr );
1333- my $pos = 0;
1334- my $len = length($stmt);
1335- my $found_arg = 0;
1336- LINE:
1337- while ( $stmt =~ m/^(.*)$/mg ) { # /g requires scalar match.
1338- $pos = pos($stmt); # Be careful not to mess this up!
1339- my $line = $1; # Necessary for /g and pos() to work.
1340- $line =~ s/$delim// if $delim;
1341- PTDEBUG && _d($line);
1342-
1343- if ( $line =~ m/^\/\*.+\*\/;/ ) {
1344- PTDEBUG && _d('Comment line');
1345- next LINE;
1346- }
1347-
1348- if ( $line =~ m/^DELIMITER/m ) {
1349- my ( $del ) = $line =~ m/^DELIMITER (\S*)$/m;
1350- if ( $del ) {
1351- $self->{delim_len} = $delim_len = length $del;
1352- $self->{delim} = $delim = quotemeta $del;
1353- PTDEBUG && _d('delimiter:', $delim);
1354- }
1355- else {
1356- PTDEBUG && _d('Delimiter reset to ;');
1357- $self->{delim} = $delim = undef;
1358- $self->{delim_len} = $delim_len = 0;
1359- }
1360- next LINE;
1361- }
1362-
1363- next LINE if $line =~ m/End of log file/;
1364-
1365- if ( !$got_offset && (my ( $offset ) = $line =~ m/$binlog_line_1/m) ) {
1366- PTDEBUG && _d('Got the at offset line');
1367- push @properties, 'offset', $offset;
1368- $got_offset++;
1369- }
1370-
1371- elsif ( !$got_hdr && $line =~ m/^#(\d{6}\s+\d{1,2}:\d\d:\d\d)/ ) {
1372- ($ts, $sid, $end, $type, $rest) = $line =~ m/$binlog_line_2/m;
1373- PTDEBUG && _d('Got the header line; type:', $type, 'rest:', $rest);
1374- push @properties, 'cmd', 'Query', 'ts', $ts, 'server_id', $sid,
1375- 'end_log_pos', $end;
1376- $got_hdr++;
1377- }
1378-
1379- elsif ( $line =~ m/^(?:#|use |SET)/i ) {
1380-
1381- if ( my ( $db ) = $line =~ m/^use ([^;]+)/ ) {
1382- PTDEBUG && _d("Got a default database:", $db);
1383- push @properties, 'db', $db;
1384- }
1385-
1386- elsif ( my ($setting) = $line =~ m/^SET\s+([^;]*)/ ) {
1387- PTDEBUG && _d("Got some setting:", $setting);
1388- push @properties, map { s/\s+//; lc } split(/,|\s*=\s*/, $setting);
1389- }
1390-
1391- }
1392- else {
1393- PTDEBUG && _d("Got the query/arg line at pos", $pos);
1394- $found_arg++;
1395- if ( $got_offset && $got_hdr ) {
1396- if ( $type eq 'Xid' ) {
1397- my ($xid) = $rest =~ m/(\d+)/;
1398- push @properties, 'Xid', $xid;
1399- }
1400- elsif ( $type eq 'Query' ) {
1401- my ($i, $t, $c) = $rest =~ m/$binlog_line_2_rest/m;
1402- push @properties, 'Thread_id', $i, 'Query_time', $t,
1403- 'error_code', $c;
1404- }
1405- elsif ( $type eq 'Start:' ) {
1406- PTDEBUG && _d("Binlog start");
1407- }
1408- else {
1409- PTDEBUG && _d('Unknown event type:', $type);
1410- next EVENT;
1411- }
1412- }
1413- else {
1414- PTDEBUG && _d("It's not a query/arg, it's just some SQL fluff");
1415- push @properties, 'cmd', 'Query', 'ts', undef;
1416- }
1417-
1418- my $delim_len = ($pos == length($stmt) ? $delim_len : 0);
1419- my $arg = substr($stmt, $pos - length($line) - $delim_len);
1420-
1421- $arg =~ s/$delim// if $delim; # Remove the delimiter.
1422-
1423- if ( $arg =~ m/^DELIMITER/m ) {
1424- my ( $del ) = $arg =~ m/^DELIMITER (\S*)$/m;
1425- if ( $del ) {
1426- $self->{delim_len} = $delim_len = length $del;
1427- $self->{delim} = $delim = quotemeta $del;
1428- PTDEBUG && _d('delimiter:', $delim);
1429- }
1430- else {
1431- PTDEBUG && _d('Delimiter reset to ;');
1432- $del = ';';
1433- $self->{delim} = $delim = undef;
1434- $self->{delim_len} = $delim_len = 0;
1435- }
1436-
1437- $arg =~ s/^DELIMITER.*$//m; # Remove DELIMITER from arg.
1438- }
1439-
1440- $arg =~ s/;$//gm; # Ensure ending ; are gone.
1441- $arg =~ s/\s+$//; # Remove trailing spaces and newlines.
1442-
1443- push @properties, 'arg', $arg, 'bytes', length($arg);
1444- last LINE;
1445- }
1446- } # LINE
1447-
1448- if ( $found_arg ) {
1449- PTDEBUG && _d('Properties of event:', Dumper(\@properties));
1450- my $event = { @properties };
1451- if ( $args{stats} ) {
1452- $args{stats}->{events_read}++;
1453- $args{stats}->{events_parsed}++;
1454- }
1455- return $event;
1456- }
1457- else {
1458- PTDEBUG && _d('Event had no arg');
1459- }
1460- } # EVENT
1461-
1462- $args{oktorun}->(0) if $args{oktorun};
1463- return;
1464-}
1465-
1466-sub _d {
1467- my ($package, undef, $line) = caller 0;
1468- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1469- map { defined $_ ? $_ : 'undef' }
1470- @_;
1471- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1472-}
1473-
1474-1;
1475-}
1476-# ###########################################################################
1477-# End BinaryLogParser package
1478-# ###########################################################################
1479-
1480-# ###########################################################################
1481-# GeneralLogParser package
1482-# This package is a copy without comments from the original. The original
1483-# with comments and its test file can be found in the Bazaar repository at,
1484-# lib/GeneralLogParser.pm
1485-# t/lib/GeneralLogParser.t
1486-# See https://launchpad.net/percona-toolkit for more information.
1487-# ###########################################################################
1488-{
1489-package GeneralLogParser;
1490-
1491-use strict;
1492-use warnings FATAL => 'all';
1493-use English qw(-no_match_vars);
1494-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1495-
1496-use Data::Dumper;
1497-$Data::Dumper::Indent = 1;
1498-$Data::Dumper::Sortkeys = 1;
1499-$Data::Dumper::Quotekeys = 0;
1500-
1501-sub new {
1502- my ( $class ) = @_;
1503- my $self = {
1504- pending => [],
1505- db_for => {},
1506- };
1507- return bless $self, $class;
1508-}
1509-
1510-my $genlog_line_1= qr{
1511- \A
1512- (?:(\d{6}\s+\d{1,2}:\d\d:\d\d))? # Timestamp
1513- \s+
1514- (?:\s*(\d+)) # Thread ID
1515- \s
1516- (\w+) # Command
1517- \s+
1518- (.*) # Argument
1519- \Z
1520-}xs;
1521-
1522-sub parse_event {
1523- my ( $self, %args ) = @_;
1524- my @required_args = qw(next_event tell);
1525- foreach my $arg ( @required_args ) {
1526- die "I need a $arg argument" unless $args{$arg};
1527- }
1528- my ($next_event, $tell) = @args{@required_args};
1529-
1530- my $pending = $self->{pending};
1531- my $db_for = $self->{db_for};
1532- my $line;
1533- my $pos_in_log = $tell->();
1534- LINE:
1535- while (
1536- defined($line = shift @$pending)
1537- or defined($line = $next_event->())
1538- ) {
1539- PTDEBUG && _d($line);
1540- my ($ts, $thread_id, $cmd, $arg) = $line =~ m/$genlog_line_1/;
1541- if ( !($thread_id && $cmd) ) {
1542- PTDEBUG && _d('Not start of general log event');
1543- next;
1544- }
1545- my @properties = ('pos_in_log', $pos_in_log, 'ts', $ts,
1546- 'Thread_id', $thread_id);
1547-
1548- $pos_in_log = $tell->();
1549-
1550- @$pending = ();
1551- if ( $cmd eq 'Query' ) {
1552- my $done = 0;
1553- do {
1554- $line = $next_event->();
1555- if ( $line ) {
1556- my (undef, $next_thread_id, $next_cmd)
1557- = $line =~ m/$genlog_line_1/;
1558- if ( $next_thread_id && $next_cmd ) {
1559- PTDEBUG && _d('Event done');
1560- $done = 1;
1561- push @$pending, $line;
1562- }
1563- else {
1564- PTDEBUG && _d('More arg:', $line);
1565- $arg .= $line;
1566- }
1567- }
1568- else {
1569- PTDEBUG && _d('No more lines');
1570- $done = 1;
1571- }
1572- } until ( $done );
1573-
1574- chomp $arg;
1575- push @properties, 'cmd', 'Query', 'arg', $arg;
1576- push @properties, 'bytes', length($properties[-1]);
1577- push @properties, 'db', $db_for->{$thread_id} if $db_for->{$thread_id};
1578- }
1579- else {
1580- push @properties, 'cmd', 'Admin';
1581-
1582- if ( $cmd eq 'Connect' ) {
1583- if ( $arg =~ m/^Access denied/ ) {
1584- $cmd = $arg;
1585- }
1586- else {
1587- my ($user, undef, $db) = $arg =~ /(\S+)/g;
1588- my $host;
1589- ($user, $host) = split(/@/, $user);
1590- PTDEBUG && _d('Connect', $user, '@', $host, 'on', $db);
1591-
1592- push @properties, 'user', $user if $user;
1593- push @properties, 'host', $host if $host;
1594- push @properties, 'db', $db if $db;
1595- $db_for->{$thread_id} = $db;
1596- }
1597- }
1598- elsif ( $cmd eq 'Init' ) {
1599- $cmd = 'Init DB';
1600- $arg =~ s/^DB\s+//;
1601- my ($db) = $arg =~ /(\S+)/;
1602- PTDEBUG && _d('Init DB:', $db);
1603- push @properties, 'db', $db if $db;
1604- $db_for->{$thread_id} = $db;
1605- }
1606-
1607- push @properties, 'arg', "administrator command: $cmd";
1608- push @properties, 'bytes', length($properties[-1]);
1609- }
1610-
1611- push @properties, 'Query_time', 0;
1612-
1613- PTDEBUG && _d('Properties of event:', Dumper(\@properties));
1614- my $event = { @properties };
1615- if ( $args{stats} ) {
1616- $args{stats}->{events_read}++;
1617- $args{stats}->{events_parsed}++;
1618- }
1619- return $event;
1620- } # LINE
1621-
1622- @{$self->{pending}} = ();
1623- $args{oktorun}->(0) if $args{oktorun};
1624- return;
1625-}
1626-
1627-sub _d {
1628- my ($package, undef, $line) = caller 0;
1629- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1630- map { defined $_ ? $_ : 'undef' }
1631- @_;
1632- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1633-}
1634-
1635-1;
1636-}
1637-# ###########################################################################
1638-# End GeneralLogParser package
1639-# ###########################################################################
1640-
1641-# ###########################################################################
1642-# LogSplitter package
1643-# This package is a copy without comments from the original. The original
1644-# with comments and its test file can be found in the Bazaar repository at,
1645-# lib/LogSplitter.pm
1646-# t/lib/LogSplitter.t
1647-# See https://launchpad.net/percona-toolkit for more information.
1648-# ###########################################################################
1649-{
1650-package LogSplitter;
1651-
1652-use strict;
1653-use warnings FATAL => 'all';
1654-use English qw(-no_match_vars);
1655-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1656-
1657-use Data::Dumper;
1658-$Data::Dumper::Indent = 1;
1659-$Data::Dumper::Sortkeys = 1;
1660-$Data::Dumper::Quotekeys = 0;
1661-
1662-my $oktorun = 1;
1663-
1664-sub new {
1665- my ( $class, %args ) = @_;
1666- foreach my $arg ( qw(attribute base_dir parser session_files) ) {
1667- die "I need a $arg argument" unless $args{$arg};
1668- }
1669-
1670- $args{base_dir} .= '/' if substr($args{base_dir}, -1, 1) ne '/';
1671-
1672- if ( $args{split_random} ) {
1673- PTDEBUG && _d('Split random');
1674- $args{attribute} = '_sessionno'; # set round-robin 1..session_files
1675- }
1676-
1677- my $self = {
1678- base_file_name => 'session',
1679- max_dirs => 1_000,
1680- max_files_per_dir => 5_000,
1681- max_sessions => 5_000_000, # max_dirs * max_files_per_dir
1682- merge_sessions => 1,
1683- session_files => 64,
1684- quiet => 0,
1685- verbose => 0,
1686- max_open_files => 1_000,
1687- close_lru_files => 100,
1688- %args,
1689- n_dirs_total => 0, # total number of dirs created
1690- n_files_total => 0, # total number of session files created
1691- n_files_this_dir => -1, # number of session files in current dir
1692- session_fhs => [], # filehandles for each session
1693- n_open_fhs => 0, # current number of open session filehandles
1694- n_events_total => 0, # total number of events in log
1695- n_events_saved => 0, # total number of events saved
1696- n_sessions_skipped => 0, # total number of sessions skipped
1697- n_sessions_saved => 0, # number of sessions saved
1698- sessions => {}, # sessions data store
1699- created_dirs => [],
1700- };
1701-
1702- PTDEBUG && _d('new LogSplitter final args:', Dumper($self));
1703- return bless $self, $class;
1704-}
1705-
1706-sub split {
1707- my ( $self, @logs ) = @_;
1708- $oktorun = 1; # True as long as we haven't created too many
1709-
1710- my $callbacks = $self->{callbacks};
1711-
1712- my $next_sessionno;
1713- if ( $self->{split_random} ) {
1714- $next_sessionno = make_rr_iter(1, $self->{session_files});
1715- }
1716-
1717- if ( @logs == 0 ) {
1718- PTDEBUG && _d('Implicitly reading STDIN because no logs were given');
1719- push @logs, '-';
1720- }
1721-
1722- my $lp = $self->{parser};
1723- LOG:
1724- foreach my $log ( @logs ) {
1725- last unless $oktorun;
1726- next unless defined $log;
1727-
1728- if ( !-f $log && $log ne '-' ) {
1729- warn "Skipping $log because it is not a file";
1730- next LOG;
1731- }
1732- my $fh;
1733- if ( $log eq '-' ) {
1734- $fh = *STDIN;
1735- }
1736- else {
1737- if ( !open $fh, "<", $log ) {
1738- warn "Cannot open $log: $OS_ERROR\n";
1739- next LOG;
1740- }
1741- }
1742-
1743- PTDEBUG && _d('Splitting', $log);
1744- my $event = {};
1745- my $more_events = 1;
1746- my $more_events_sub = sub { $more_events = $_[0]; };
1747- EVENT:
1748- while ( $oktorun ) {
1749- $event = $lp->parse_event(
1750- next_event => sub { return <$fh>; },
1751- tell => sub { return tell $fh; },
1752- oktorun => $more_events_sub,
1753- );
1754- if ( $event ) {
1755- $self->{n_events_total}++;
1756- if ( $self->{split_random} ) {
1757- $event->{_sessionno} = $next_sessionno->();
1758- }
1759- if ( $callbacks ) {
1760- foreach my $callback ( @$callbacks ) {
1761- $event = $callback->($event);
1762- last unless $event;
1763- }
1764- }
1765- $self->_save_event($event) if $event;
1766- }
1767- if ( !$more_events ) {
1768- PTDEBUG && _d('Done parsing', $log);
1769- close $fh;
1770- next LOG;
1771- }
1772- last LOG unless $oktorun;
1773- }
1774- }
1775-
1776- while ( my $fh = pop @{ $self->{session_fhs} } ) {
1777- close $fh->{fh};
1778- }
1779- $self->{n_open_fhs} = 0;
1780-
1781- $self->_merge_session_files() if $self->{merge_sessions};
1782- $self->print_split_summary() unless $self->{quiet};
1783-
1784- return;
1785-}
1786-
1787-sub _save_event {
1788- my ( $self, $event ) = @_;
1789- my ($session, $session_id) = $self->_get_session_ds($event);
1790- return unless $session;
1791-
1792- if ( !defined $session->{fh} ) {
1793- $self->{n_sessions_saved}++;
1794- PTDEBUG && _d('New session:', $session_id, ',',
1795- $self->{n_sessions_saved}, 'of', $self->{max_sessions});
1796-
1797- my $session_file = $self->_get_next_session_file();
1798- if ( !$session_file ) {
1799- $oktorun = 0;
1800- PTDEBUG && _d('Not oktorun because no _get_next_session_file');
1801- return;
1802- }
1803-
1804- if ( $self->{n_open_fhs} >= $self->{max_open_files} ) {
1805- $self->_close_lru_session()
1806- }
1807-
1808- open my $fh, '>', $session_file
1809- or die "Cannot open session file $session_file: $OS_ERROR";
1810- $session->{fh} = $fh;
1811- $self->{n_open_fhs}++;
1812-
1813- $session->{active} = 1;
1814- $session->{session_file} = $session_file;
1815-
1816- push @{$self->{session_fhs}}, { fh => $fh, session_id => $session_id };
1817-
1818- PTDEBUG && _d('Created', $session_file, 'for session',
1819- $self->{attribute}, '=', $session_id);
1820-
1821- print $fh "-- START SESSION $session_id\n\n";
1822- }
1823- elsif ( !$session->{active} ) {
1824-
1825- if ( $self->{n_open_fhs} >= $self->{max_open_files} ) {
1826- $self->_close_lru_session();
1827- }
1828-
1829- open $session->{fh}, '>>', $session->{session_file}
1830- or die "Cannot reopen session file "
1831- . "$session->{session_file}: $OS_ERROR";
1832-
1833- $session->{active} = 1;
1834- $self->{n_open_fhs}++;
1835-
1836- PTDEBUG && _d('Reopend', $session->{session_file}, 'for session',
1837- $self->{attribute}, '=', $session_id);
1838- }
1839- else {
1840- PTDEBUG && _d('Event belongs to active session', $session_id);
1841- }
1842-
1843- my $session_fh = $session->{fh};
1844-
1845- my $db = $event->{db} || $event->{Schema};
1846- if ( $db && ( !defined $session->{db} || $session->{db} ne $db ) ) {
1847- print $session_fh "use $db\n\n";
1848- $session->{db} = $db;
1849- }
1850-
1851- print $session_fh $self->flatten($event->{arg}), "\n\n";
1852- $self->{n_events_saved}++;
1853-
1854- return;
1855-}
1856-
1857-sub _get_session_ds {
1858- my ( $self, $event ) = @_;
1859-
1860- my $attrib = $self->{attribute};
1861- if ( !$event->{ $attrib } ) {
1862- PTDEBUG && _d('No attribute', $attrib, 'in event:', Dumper($event));
1863- return;
1864- }
1865-
1866- return unless $event->{arg};
1867-
1868- return if ($event->{cmd} || '') eq 'Admin';
1869-
1870- my $session;
1871- my $session_id = $event->{ $attrib };
1872-
1873- if ( $self->{n_sessions_saved} < $self->{max_sessions} ) {
1874- $session = $self->{sessions}->{ $session_id } ||= {};
1875- }
1876- elsif ( exists $self->{sessions}->{ $session_id } ) {
1877- $session = $self->{sessions}->{ $session_id };
1878- }
1879- else {
1880- $self->{n_sessions_skipped} += 1;
1881- PTDEBUG && _d('Skipping new session', $session_id,
1882- 'because max_sessions is reached');
1883- }
1884-
1885- return $session, $session_id;
1886-}
1887-
1888-sub _close_lru_session {
1889- my ( $self ) = @_;
1890- my $session_fhs = $self->{session_fhs};
1891- my $lru_n = $self->{n_sessions_saved} - $self->{max_open_files} - 1;
1892- my $close_to_n = $lru_n + $self->{close_lru_files} - 1;
1893-
1894- PTDEBUG && _d('Closing session fhs', $lru_n, '..', $close_to_n,
1895- '(',$self->{n_sessions}, 'sessions', $self->{n_open_fhs}, 'open fhs)');
1896-
1897- foreach my $session ( @$session_fhs[ $lru_n..$close_to_n ] ) {
1898- close $session->{fh};
1899- $self->{n_open_fhs}--;
1900- $self->{sessions}->{ $session->{session_id} }->{active} = 0;
1901- }
1902-
1903- return;
1904-}
1905-
1906-sub _get_next_session_file {
1907- my ( $self, $n ) = @_;
1908- return if $self->{n_dirs_total} >= $self->{max_dirs};
1909-
1910- if ( ($self->{n_files_this_dir} >= $self->{max_files_per_dir})
1911- || $self->{n_files_this_dir} < 0 ) {
1912- $self->{n_dirs_total}++;
1913- $self->{n_files_this_dir} = 0;
1914- my $new_dir = "$self->{base_dir}$self->{n_dirs_total}";
1915- if ( !-d $new_dir ) {
1916- my $retval = system("mkdir $new_dir");
1917- if ( ($retval >> 8) != 0 ) {
1918- die "Cannot create new directory $new_dir: $OS_ERROR";
1919- }
1920- PTDEBUG && _d('Created new base_dir', $new_dir);
1921- push @{$self->{created_dirs}}, $new_dir;
1922- }
1923- elsif ( PTDEBUG ) {
1924- _d($new_dir, 'already exists');
1925- }
1926- }
1927- else {
1928- PTDEBUG && _d('No dir created; n_files_this_dir:',
1929- $self->{n_files_this_dir}, 'n_files_total:',
1930- $self->{n_files_total});
1931- }
1932-
1933- $self->{n_files_total}++;
1934- $self->{n_files_this_dir}++;
1935- my $dir_n = $self->{n_dirs_total} . '/';
1936- my $session_n = sprintf '%d', $n || $self->{n_sessions_saved};
1937- my $session_file = $self->{base_dir}
1938- . $dir_n
1939- . $self->{base_file_name}."-$session_n.txt";
1940- PTDEBUG && _d('Next session file', $session_file);
1941- return $session_file;
1942-}
1943-
1944-sub flatten {
1945- my ( $self, $query ) = @_;
1946- return unless $query;
1947- $query =~ s!/\*.*?\*/! !g;
1948- $query =~ s/^\s+//;
1949- $query =~ s/\s{2,}/ /g;
1950- return $query;
1951-}
1952-
1953-sub _merge_session_files {
1954- my ( $self ) = @_;
1955-
1956- print "Merging session files...\n" unless $self->{quiet};
1957-
1958- my @multi_session_files;
1959- for my $i ( 1..$self->{session_files} ) {
1960- push @multi_session_files, $self->{base_dir} ."sessions-$i.txt";
1961- }
1962-
1963- my @single_session_files = map {
1964- $_->{session_file};
1965- } values %{$self->{sessions}};
1966-
1967- my $i = make_rr_iter(0, $#multi_session_files); # round-robin iterator
1968- foreach my $single_session_file ( @single_session_files ) {
1969- my $multi_session_file = $multi_session_files[ $i->() ];
1970- my $cmd;
1971- if ( $self->{split_random} ) {
1972- $cmd = "mv $single_session_file $multi_session_file";
1973- }
1974- else {
1975- $cmd = "cat $single_session_file >> $multi_session_file";
1976- }
1977- eval { `$cmd`; };
1978- if ( $EVAL_ERROR ) {
1979- warn "Failed to `$cmd`: $OS_ERROR";
1980- }
1981- }
1982-
1983- foreach my $created_dir ( @{$self->{created_dirs}} ) {
1984- my $cmd = "rm -rf $created_dir";
1985- eval { `$cmd`; };
1986- if ( $EVAL_ERROR ) {
1987- warn "Failed to `$cmd`: $OS_ERROR";
1988- }
1989- }
1990-
1991- return;
1992-}
1993-
1994-sub make_rr_iter {
1995- my ( $start, $end ) = @_;
1996- my $current = $start;
1997- return sub {
1998- $current = $start if $current > $end ;
1999- $current++; # For next iteration.
2000- return $current - 1;
2001- };
2002-}
2003-
2004-sub print_split_summary {
2005- my ( $self ) = @_;
2006- print "Split summary:\n";
2007- my $fmt = "%-20s %-10s\n";
2008- printf $fmt, 'Total sessions',
2009- $self->{n_sessions_saved} + $self->{n_sessions_skipped};
2010- printf $fmt, 'Sessions saved',
2011- $self->{n_sessions_saved};
2012- printf $fmt, 'Total events', $self->{n_events_total};
2013- printf $fmt, 'Events saved', $self->{n_events_saved};
2014- return;
2015-}
2016-
2017-sub _d {
2018- my ($package, undef, $line) = caller 0;
2019- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2020- map { defined $_ ? $_ : 'undef' }
2021- @_;
2022- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2023-}
2024-
2025-1;
2026-}
2027-# ###########################################################################
2028-# End LogSplitter package
2029-# ###########################################################################
2030-
2031-# ###########################################################################
2032-# DSNParser package
2033-# This package is a copy without comments from the original. The original
2034-# with comments and its test file can be found in the Bazaar repository at,
2035-# lib/DSNParser.pm
2036-# t/lib/DSNParser.t
2037-# See https://launchpad.net/percona-toolkit for more information.
2038-# ###########################################################################
2039-{
2040-package DSNParser;
2041-
2042-use strict;
2043-use warnings FATAL => 'all';
2044-use English qw(-no_match_vars);
2045-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2046-
2047-use Data::Dumper;
2048-$Data::Dumper::Indent = 0;
2049-$Data::Dumper::Quotekeys = 0;
2050-
2051-my $dsn_sep = qr/(?<!\\),/;
2052-
2053-eval {
2054- require DBI;
2055-};
2056-my $have_dbi = $EVAL_ERROR ? 0 : 1;
2057-
2058-sub new {
2059- my ( $class, %args ) = @_;
2060- foreach my $arg ( qw(opts) ) {
2061- die "I need a $arg argument" unless $args{$arg};
2062- }
2063- my $self = {
2064- opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
2065- };
2066- foreach my $opt ( @{$args{opts}} ) {
2067- if ( !$opt->{key} || !$opt->{desc} ) {
2068- die "Invalid DSN option: ", Dumper($opt);
2069- }
2070- PTDEBUG && _d('DSN option:',
2071- join(', ',
2072- map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
2073- keys %$opt
2074- )
2075- );
2076- $self->{opts}->{$opt->{key}} = {
2077- dsn => $opt->{dsn},
2078- desc => $opt->{desc},
2079- copy => $opt->{copy} || 0,
2080- };
2081- }
2082- return bless $self, $class;
2083-}
2084-
2085-sub prop {
2086- my ( $self, $prop, $value ) = @_;
2087- if ( @_ > 2 ) {
2088- PTDEBUG && _d('Setting', $prop, 'property');
2089- $self->{$prop} = $value;
2090- }
2091- return $self->{$prop};
2092-}
2093-
2094-sub parse {
2095- my ( $self, $dsn, $prev, $defaults ) = @_;
2096- if ( !$dsn ) {
2097- PTDEBUG && _d('No DSN to parse');
2098- return;
2099- }
2100- PTDEBUG && _d('Parsing', $dsn);
2101- $prev ||= {};
2102- $defaults ||= {};
2103- my %given_props;
2104- my %final_props;
2105- my $opts = $self->{opts};
2106-
2107- foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
2108- $dsn_part =~ s/\\,/,/g;
2109- if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
2110- $given_props{$prop_key} = $prop_val;
2111- }
2112- else {
2113- PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
2114- $given_props{h} = $dsn_part;
2115- }
2116- }
2117-
2118- foreach my $key ( keys %$opts ) {
2119- PTDEBUG && _d('Finding value for', $key);
2120- $final_props{$key} = $given_props{$key};
2121- if ( !defined $final_props{$key}
2122- && defined $prev->{$key} && $opts->{$key}->{copy} )
2123- {
2124- $final_props{$key} = $prev->{$key};
2125- PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
2126- }
2127- if ( !defined $final_props{$key} ) {
2128- $final_props{$key} = $defaults->{$key};
2129- PTDEBUG && _d('Copying value for', $key, 'from defaults');
2130- }
2131- }
2132-
2133- foreach my $key ( keys %given_props ) {
2134- die "Unknown DSN option '$key' in '$dsn'. For more details, "
2135- . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2136- . "for complete documentation."
2137- unless exists $opts->{$key};
2138- }
2139- if ( (my $required = $self->prop('required')) ) {
2140- foreach my $key ( keys %$required ) {
2141- die "Missing required DSN option '$key' in '$dsn'. For more details, "
2142- . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2143- . "for complete documentation."
2144- unless $final_props{$key};
2145- }
2146- }
2147-
2148- return \%final_props;
2149-}
2150-
2151-sub parse_options {
2152- my ( $self, $o ) = @_;
2153- die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
2154- my $dsn_string
2155- = join(',',
2156- map { "$_=".$o->get($_); }
2157- grep { $o->has($_) && $o->get($_) }
2158- keys %{$self->{opts}}
2159- );
2160- PTDEBUG && _d('DSN string made from options:', $dsn_string);
2161- return $self->parse($dsn_string);
2162-}
2163-
2164-sub as_string {
2165- my ( $self, $dsn, $props ) = @_;
2166- return $dsn unless ref $dsn;
2167- my @keys = $props ? @$props : sort keys %$dsn;
2168- return join(',',
2169- map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
2170- grep {
2171- exists $self->{opts}->{$_}
2172- && exists $dsn->{$_}
2173- && defined $dsn->{$_}
2174- } @keys);
2175-}
2176-
2177-sub usage {
2178- my ( $self ) = @_;
2179- my $usage
2180- = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
2181- . " KEY COPY MEANING\n"
2182- . " === ==== =============================================\n";
2183- my %opts = %{$self->{opts}};
2184- foreach my $key ( sort keys %opts ) {
2185- $usage .= " $key "
2186- . ($opts{$key}->{copy} ? 'yes ' : 'no ')
2187- . ($opts{$key}->{desc} || '[No description]')
2188- . "\n";
2189- }
2190- $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
2191- return $usage;
2192-}
2193-
2194-sub get_cxn_params {
2195- my ( $self, $info ) = @_;
2196- my $dsn;
2197- my %opts = %{$self->{opts}};
2198- my $driver = $self->prop('dbidriver') || '';
2199- if ( $driver eq 'Pg' ) {
2200- $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
2201- . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2202- grep { defined $info->{$_} }
2203- qw(h P));
2204- }
2205- else {
2206- $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
2207- . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2208- grep { defined $info->{$_} }
2209- qw(F h P S A))
2210- . ';mysql_read_default_group=client'
2211- . ($info->{L} ? ';mysql_local_infile=1' : '');
2212- }
2213- PTDEBUG && _d($dsn);
2214- return ($dsn, $info->{u}, $info->{p});
2215-}
2216-
2217-sub fill_in_dsn {
2218- my ( $self, $dbh, $dsn ) = @_;
2219- my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
2220- my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
2221- $user =~ s/@.*//;
2222- $dsn->{h} ||= $vars->{hostname}->{Value};
2223- $dsn->{S} ||= $vars->{'socket'}->{Value};
2224- $dsn->{P} ||= $vars->{port}->{Value};
2225- $dsn->{u} ||= $user;
2226- $dsn->{D} ||= $db;
2227-}
2228-
2229-sub get_dbh {
2230- my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
2231- $opts ||= {};
2232- my $defaults = {
2233- AutoCommit => 0,
2234- RaiseError => 1,
2235- PrintError => 0,
2236- ShowErrorStatement => 1,
2237- mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
2238- };
2239- @{$defaults}{ keys %$opts } = values %$opts;
2240- if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
2241- $defaults->{mysql_local_infile} = 1;
2242- }
2243-
2244- if ( $opts->{mysql_use_result} ) {
2245- $defaults->{mysql_use_result} = 1;
2246- }
2247-
2248- if ( !$have_dbi ) {
2249- die "Cannot connect to MySQL because the Perl DBI module is not "
2250- . "installed or not found. Run 'perl -MDBI' to see the directories "
2251- . "that Perl searches for DBI. If DBI is not installed, try:\n"
2252- . " Debian/Ubuntu apt-get install libdbi-perl\n"
2253- . " RHEL/CentOS yum install perl-DBI\n"
2254- . " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
2255-
2256- }
2257-
2258- my $dbh;
2259- my $tries = 2;
2260- while ( !$dbh && $tries-- ) {
2261- PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
2262- join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
2263-
2264- $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
2265-
2266- if ( !$dbh && $EVAL_ERROR ) {
2267- if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
2268- die "Cannot connect to MySQL because the Perl DBD::mysql module is "
2269- . "not installed or not found. Run 'perl -MDBD::mysql' to see "
2270- . "the directories that Perl searches for DBD::mysql. If "
2271- . "DBD::mysql is not installed, try:\n"
2272- . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
2273- . " RHEL/CentOS yum install perl-DBD-MySQL\n"
2274- . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
2275- }
2276- elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
2277- PTDEBUG && _d('Going to try again without utf8 support');
2278- delete $defaults->{mysql_enable_utf8};
2279- }
2280- if ( !$tries ) {
2281- die $EVAL_ERROR;
2282- }
2283- }
2284- }
2285-
2286- if ( $cxn_string =~ m/mysql/i ) {
2287- my $sql;
2288-
2289- $sql = 'SELECT @@SQL_MODE';
2290- PTDEBUG && _d($dbh, $sql);
2291- my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
2292- if ( $EVAL_ERROR ) {
2293- die "Error getting the current SQL_MODE: $EVAL_ERROR";
2294- }
2295-
2296- if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
2297- $sql = qq{/*!40101 SET NAMES "$charset"*/};
2298- PTDEBUG && _d($dbh, ':', $sql);
2299- eval { $dbh->do($sql) };
2300- if ( $EVAL_ERROR ) {
2301- die "Error setting NAMES to $charset: $EVAL_ERROR";
2302- }
2303- PTDEBUG && _d('Enabling charset for STDOUT');
2304- if ( $charset eq 'utf8' ) {
2305- binmode(STDOUT, ':utf8')
2306- or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
2307- }
2308- else {
2309- binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
2310- }
2311- }
2312-
2313- if ( my $var = $self->prop('set-vars') ) {
2314- $sql = "SET $var";
2315- PTDEBUG && _d($dbh, ':', $sql);
2316- eval { $dbh->do($sql) };
2317- if ( $EVAL_ERROR ) {
2318- die "Error setting $var: $EVAL_ERROR";
2319- }
2320- }
2321-
2322- $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
2323- . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
2324- . ($sql_mode ? ",$sql_mode" : '')
2325- . '\'*/';
2326- PTDEBUG && _d($dbh, $sql);
2327- eval { $dbh->do($sql) };
2328- if ( $EVAL_ERROR ) {
2329- die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
2330- . ($sql_mode ? " and $sql_mode" : '')
2331- . ": $EVAL_ERROR";
2332- }
2333- }
2334-
2335- PTDEBUG && _d('DBH info: ',
2336- $dbh,
2337- Dumper($dbh->selectrow_hashref(
2338- 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
2339- 'Connection info:', $dbh->{mysql_hostinfo},
2340- 'Character set info:', Dumper($dbh->selectall_arrayref(
2341- "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
2342- '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
2343- '$DBI::VERSION:', $DBI::VERSION,
2344- );
2345-
2346- return $dbh;
2347-}
2348-
2349-sub get_hostname {
2350- my ( $self, $dbh ) = @_;
2351- if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
2352- return $host;
2353- }
2354- my ( $hostname, $one ) = $dbh->selectrow_array(
2355- 'SELECT /*!50038 @@hostname, */ 1');
2356- return $hostname;
2357-}
2358-
2359-sub disconnect {
2360- my ( $self, $dbh ) = @_;
2361- PTDEBUG && $self->print_active_handles($dbh);
2362- $dbh->disconnect;
2363-}
2364-
2365-sub print_active_handles {
2366- my ( $self, $thing, $level ) = @_;
2367- $level ||= 0;
2368- printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
2369- $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
2370- or die "Cannot print: $OS_ERROR";
2371- foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
2372- $self->print_active_handles( $handle, $level + 1 );
2373- }
2374-}
2375-
2376-sub copy {
2377- my ( $self, $dsn_1, $dsn_2, %args ) = @_;
2378- die 'I need a dsn_1 argument' unless $dsn_1;
2379- die 'I need a dsn_2 argument' unless $dsn_2;
2380- my %new_dsn = map {
2381- my $key = $_;
2382- my $val;
2383- if ( $args{overwrite} ) {
2384- $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
2385- }
2386- else {
2387- $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
2388- }
2389- $key => $val;
2390- } keys %{$self->{opts}};
2391- return \%new_dsn;
2392-}
2393-
2394-sub _d {
2395- my ($package, undef, $line) = caller 0;
2396- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2397- map { defined $_ ? $_ : 'undef' }
2398- @_;
2399- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2400-}
2401-
2402-1;
2403-}
2404-# ###########################################################################
2405-# End DSNParser package
2406-# ###########################################################################
2407-
2408-# ###########################################################################
2409-# Daemon package
2410-# This package is a copy without comments from the original. The original
2411-# with comments and its test file can be found in the Bazaar repository at,
2412-# lib/Daemon.pm
2413-# t/lib/Daemon.t
2414-# See https://launchpad.net/percona-toolkit for more information.
2415-# ###########################################################################
2416-{
2417-package Daemon;
2418-
2419-use strict;
2420-use warnings FATAL => 'all';
2421-use English qw(-no_match_vars);
2422-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2423-
2424-use POSIX qw(setsid);
2425-
2426-sub new {
2427- my ( $class, %args ) = @_;
2428- foreach my $arg ( qw(o) ) {
2429- die "I need a $arg argument" unless $args{$arg};
2430- }
2431- my $o = $args{o};
2432- my $self = {
2433- o => $o,
2434- log_file => $o->has('log') ? $o->get('log') : undef,
2435- PID_file => $o->has('pid') ? $o->get('pid') : undef,
2436- };
2437-
2438- check_PID_file(undef, $self->{PID_file});
2439-
2440- PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
2441- return bless $self, $class;
2442-}
2443-
2444-sub daemonize {
2445- my ( $self ) = @_;
2446-
2447- PTDEBUG && _d('About to fork and daemonize');
2448- defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
2449- if ( $pid ) {
2450- PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
2451- exit;
2452- }
2453-
2454- PTDEBUG && _d('Daemonizing child PID', $PID);
2455- $self->{PID_owner} = $PID;
2456- $self->{child} = 1;
2457-
2458- POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
2459- chdir '/' or die "Cannot chdir to /: $OS_ERROR";
2460-
2461- $self->_make_PID_file();
2462-
2463- $OUTPUT_AUTOFLUSH = 1;
2464-
2465- PTDEBUG && _d('Redirecting STDIN to /dev/null');
2466- close STDIN;
2467- open STDIN, '/dev/null'
2468- or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
2469-
2470- if ( $self->{log_file} ) {
2471- PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
2472- close STDOUT;
2473- open STDOUT, '>>', $self->{log_file}
2474- or die "Cannot open log file $self->{log_file}: $OS_ERROR";
2475-
2476- close STDERR;
2477- open STDERR, ">&STDOUT"
2478- or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
2479- }
2480- else {
2481- if ( -t STDOUT ) {
2482- PTDEBUG && _d('No log file and STDOUT is a terminal;',
2483- 'redirecting to /dev/null');
2484- close STDOUT;
2485- open STDOUT, '>', '/dev/null'
2486- or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
2487- }
2488- if ( -t STDERR ) {
2489- PTDEBUG && _d('No log file and STDERR is a terminal;',
2490- 'redirecting to /dev/null');
2491- close STDERR;
2492- open STDERR, '>', '/dev/null'
2493- or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
2494- }
2495- }
2496-
2497- return;
2498-}
2499-
2500-sub check_PID_file {
2501- my ( $self, $file ) = @_;
2502- my $PID_file = $self ? $self->{PID_file} : $file;
2503- PTDEBUG && _d('Checking PID file', $PID_file);
2504- if ( $PID_file && -f $PID_file ) {
2505- my $pid;
2506- eval {
2507- chomp($pid = (slurp_file($PID_file) || ''));
2508- };
2509- if ( $EVAL_ERROR ) {
2510- die "The PID file $PID_file already exists but it cannot be read: "
2511- . $EVAL_ERROR;
2512- }
2513- PTDEBUG && _d('PID file exists; it contains PID', $pid);
2514- if ( $pid ) {
2515- my $pid_is_alive = kill 0, $pid;
2516- if ( $pid_is_alive ) {
2517- die "The PID file $PID_file already exists "
2518- . " and the PID that it contains, $pid, is running";
2519- }
2520- else {
2521- warn "Overwriting PID file $PID_file because the PID that it "
2522- . "contains, $pid, is not running";
2523- }
2524- }
2525- else {
2526- die "The PID file $PID_file already exists but it does not "
2527- . "contain a PID";
2528- }
2529- }
2530- else {
2531- PTDEBUG && _d('No PID file');
2532- }
2533- return;
2534-}
2535-
2536-sub make_PID_file {
2537- my ( $self ) = @_;
2538- if ( exists $self->{child} ) {
2539- die "Do not call Daemon::make_PID_file() for daemonized scripts";
2540- }
2541- $self->_make_PID_file();
2542- $self->{PID_owner} = $PID;
2543- return;
2544-}
2545-
2546-sub _make_PID_file {
2547- my ( $self ) = @_;
2548-
2549- my $PID_file = $self->{PID_file};
2550- if ( !$PID_file ) {
2551- PTDEBUG && _d('No PID file to create');
2552- return;
2553- }
2554-
2555- $self->check_PID_file();
2556-
2557- open my $PID_FH, '>', $PID_file
2558- or die "Cannot open PID file $PID_file: $OS_ERROR";
2559- print $PID_FH $PID
2560- or die "Cannot print to PID file $PID_file: $OS_ERROR";
2561- close $PID_FH
2562- or die "Cannot close PID file $PID_file: $OS_ERROR";
2563-
2564- PTDEBUG && _d('Created PID file:', $self->{PID_file});
2565- return;
2566-}
2567-
2568-sub _remove_PID_file {
2569- my ( $self ) = @_;
2570- if ( $self->{PID_file} && -f $self->{PID_file} ) {
2571- unlink $self->{PID_file}
2572- or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
2573- PTDEBUG && _d('Removed PID file');
2574- }
2575- else {
2576- PTDEBUG && _d('No PID to remove');
2577- }
2578- return;
2579-}
2580-
2581-sub DESTROY {
2582- my ( $self ) = @_;
2583-
2584- $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
2585-
2586- return;
2587-}
2588-
2589-sub slurp_file {
2590- my ($file) = @_;
2591- return unless $file;
2592- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2593- return do { local $/; <$fh> };
2594-}
2595-
2596-sub _d {
2597- my ($package, undef, $line) = caller 0;
2598- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2599- map { defined $_ ? $_ : 'undef' }
2600- @_;
2601- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2602-}
2603-
2604-1;
2605-}
2606-# ###########################################################################
2607-# End Daemon package
2608-# ###########################################################################
2609-
2610-# ###########################################################################
2611-# This is a combination of modules and programs in one -- a runnable module.
2612-# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
2613-# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
2614-#
2615-# Check at the end of this package for the call to main() which actually runs
2616-# the program.
2617-# ###########################################################################
2618-package pt_log_player;
2619-
2620-use POSIX;
2621-use Time::HiRes qw(time usleep);
2622-use File::Basename qw(dirname);
2623-use File::Find;
2624-use File::Spec;
2625-use List::Util qw(max);
2626-use Data::Dumper;
2627-$Data::Dumper::Indent = 1;
2628-$Data::Dumper::Sortkeys = 1;
2629-$Data::Dumper::Quotekeys = 0;
2630-
2631-use English qw(-no_match_vars);
2632-
2633-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2634-
2635-# These are global so the --play threads can access them.
2636-my $o;
2637-my $dp;
2638-
2639-sub main {
2640- @ARGV = @_; # set global ARGV for this package
2641-
2642- # #########################################################################
2643- # Get configuration information.
2644- # #########################################################################
2645- $o = new OptionParser();
2646- $o->get_specs();
2647- $o->get_opts();
2648-
2649- $dp = $o->DSNParser();
2650- $dp->prop('set-vars', $o->get('set-vars'));
2651-
2652- # LogSplitter will override the split attribute if split_random is true.
2653- # Set --split to some arbitrary value so we don't have to check for both
2654- # and --play will not be invoked.
2655- $o->set('split', 'random') if $o->get('split-random');
2656-
2657- # If not --split then the remaining arg should be a DSN for --play.
2658- my $dsn;
2659- if ( !$o->get('split') && !$o->get('print') && !$o->get('dry-run') ) {
2660- my $dsn_defaults = $dp->parse_options($o);
2661- $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults) : $dsn_defaults;
2662- if ( !$dsn ) {
2663- $o->save_error('Missing or invalid host');
2664- }
2665- }
2666-
2667- if ( !-d $o->get('base-dir') ) {
2668- $o->save_error('Invalid --base-dir: '
2669- . $o->get('base-dir') . ' is not a directory');
2670- }
2671-
2672- $o->set('threads', max(2, get_number_of_cpus()))
2673- unless $o->got('threads');
2674-
2675- $o->set('verbose', 0) if $o->get('quiet');
2676-
2677- $o->usage_or_errors();
2678-
2679- # ########################################################################
2680- # If --pid, check it first since we'll die if it already exits.
2681- # ########################################################################
2682- my $daemon;
2683- if ( $o->get('pid') ) {
2684- # We're not daemoninzing, it just handles PID stuff. Keep $daemon
2685- # in the the scope of main() because when it's destroyed it automatically
2686- # removes the PID file.
2687- $daemon = new Daemon(o=>$o);
2688- $daemon->make_PID_file();
2689- }
2690-
2691- # #########################################################################
2692- # Split the logs into session files and exit.
2693- # #########################################################################
2694- my $split = $o->get('split');
2695- my $base_dir = $o->get('base-dir');
2696- if ( $split ) {
2697- die "$base_dir is not a directory" if !-d $base_dir;
2698-
2699- # It's sad because I wrote this script but I still frequently forget
2700- # to specify the split attribute (Thread_id, etc.). So the log file
2701- # is taken to be the split attrib and then LogSplitter tries to read
2702- # from STDIN. This is my self-reminder.
2703- warn "The --split attribute $split does not appear valid"
2704- if $split !~ m/^[\w]+$/;
2705-
2706- $ARGV[0] = '-' if scalar @ARGV == 0; # causes LogSplitter to read STDIN
2707-
2708- my @callbacks;
2709- if ( $o->get('filter') ) {
2710- my $filter = $o->get('filter');
2711- if ( -f $filter && -r $filter ) {
2712- PTDEBUG && _d('Reading file', $filter, 'for --filter code');
2713- open my $fh, "<", $filter or die "Cannot open $filter: $OS_ERROR";
2714- $filter = do { local $/ = undef; <$fh> };
2715- close $fh;
2716- }
2717- else {
2718- $filter = "( $filter )"; # issue 565
2719- }
2720- my $code = "sub { PTDEBUG && _d('callback: filter'); my(\$event) = shift; $filter && return \$event; };";
2721- PTDEBUG && _d('--filter code:', $code);
2722- my $sub = eval $code
2723- or die "Error compiling --filter code: $code\n$EVAL_ERROR";
2724- push @callbacks, $sub;
2725- }
2726-
2727- my $parser = $o->get('type') eq 'slowlog' ? new SlowLogParser()
2728- : $o->get('type') eq 'binlog' ? new BinaryLogParser()
2729- : $o->get('type') eq 'genlog' ? new GeneralLogParser()
2730- : die("Unknown type " . $o->get('type'));
2731- my $ls = new LogSplitter(
2732- attribute => $split,
2733- split_random => $o->get('split-random'),
2734- base_dir => $base_dir,
2735- base_file_name => $o->get('base-file-name'),
2736- max_sessions => $o->get('max-sessions'),
2737- session_files => $o->get('session-files'),
2738- quiet => $o->get('quiet'),
2739- verbose => $o->get('verbose'),
2740- parser => $parser,
2741- callbacks => \@callbacks,
2742- );
2743- $ls->split(@ARGV);
2744-
2745- return 0;
2746- }
2747-
2748- # #########################################################################
2749- # Make list of session files to play. If playing a whole, the log is
2750- # treated as one big session file.
2751- # #########################################################################
2752- my @session_files;
2753- foreach my $session_file ( split ',', $o->get('play') ) {
2754- # The session "file" might actually be a dir, in which case we
2755- # read ALL files in that dir.
2756- if ( -d $session_file ) {
2757- PTDEBUG && _d('Reading all session log files in', $session_file);
2758- opendir my $dir, $session_file
2759- or die "Cannot open directory $session_file: $OS_ERROR";
2760- push @session_files,
2761- map { "$session_file/$_" } # 3. Save full dir/file
2762- grep { -f "$session_file/$_" } # 2. If it's a file
2763- readdir $dir; # 1. Each file in dir
2764- closedir $dir;
2765- }
2766- else {
2767- if ( !-f $session_file ) {
2768- warn "$session_file is not a file";
2769- }
2770- else {
2771- push @session_files, $session_file;
2772- }
2773- }
2774- }
2775-
2776- PTDEBUG && _d('Session files:', @session_files);
2777-
2778- if ( @session_files == 0 ) {
2779- warn 'No valid session files';
2780- return 0;
2781- }
2782-
2783- my $n_session_files = scalar @session_files;
2784- print "Found $n_session_files session files.\n" unless $o->get('quiet');
2785-
2786- if ( $o->get('threads') > $n_session_files ) {
2787- warn "--threads is greater than the number of session files. "
2788- . "Only $n_session_files concurrent process will be ran";
2789- $o->set('threads', $n_session_files);
2790- }
2791- my $threads = $o->get('threads');
2792-
2793- my @child_tasks;
2794- my $childno = LogSplitter::make_rr_iter(0, $threads-1);
2795- while ( defined (my $session_file = pop @session_files) ) {
2796- push @{$child_tasks[$childno->()]}, $session_file;
2797- }
2798-
2799- # Shouldn't happen...
2800- warn "There are unassigned session files" if @session_files > 0;
2801-
2802- if ( $o->get('dry-run') || $o->get('verbose') ) {
2803- for my $i ( 0..($threads-1) ) {
2804- print "Process $i plays $_\n" for @{$child_tasks[$i]};
2805- }
2806- # Shouldn't happen...
2807- print "Unassigned session files: " . join(', ', @session_files), "\n"
2808- if @session_files;
2809- return 0 if $o->get('dry-run');
2810- }
2811-
2812- # #########################################################################
2813- # Connect parent to MySQL.
2814- # #########################################################################
2815- my $parent_dbh;
2816- if ( !$o->get('print') ) {
2817- if ( $o->get('ask-pass') ) {
2818- $o->set('password', OptionParser::prompt_noecho("Enter password: "));
2819- }
2820- $parent_dbh = get_cxn($dsn);
2821- $parent_dbh->{InactiveDestroy} = 1; # Don't die on fork().
2822- }
2823-
2824- # #########################################################################
2825- # Assign sessions to child processes.
2826- # #########################################################################
2827- my %children;
2828- my %exited_children;
2829- # This signal handler will do nothing but wake up the sleeping parent process
2830- # and record the exit status and time of the child that exited (as a side
2831- # effect of not discarding the signal).
2832- # -- Presently, however, we do not use this information.
2833- $SIG{CHLD} = sub {
2834- my $pid;
2835- while (($pid = waitpid(-1, POSIX::WNOHANG)) > 0) {
2836- # Must right-shift to get the actual exit status of the child.
2837- $exited_children{$pid}->{exit_status} = $CHILD_ERROR >> 8;
2838- $exited_children{$pid}->{exit_time} = time;
2839- }
2840- };
2841-
2842- # Fork the child processes.
2843- print "Running processes...\n" unless $o->get('quiet');
2844- for my $childno ( 0..($threads-1) ) {
2845- my $child_tasks = $child_tasks[$childno];
2846-
2847- my $pid = fork();
2848- die "Cannot fork process $childno: $OS_ERROR" unless defined $pid;
2849- if ( $pid ) { # I'm the parent.
2850- $children{$pid} = $childno + 1;
2851- }
2852- else { # I'm the child.
2853- $SIG{CHLD} = 'DEFAULT'; # See bug #1886444
2854- PTDEBUG && _d('Child PID', $PID, 'started');
2855- play_session($dsn, ($childno + 1), $child_tasks);
2856- PTDEBUG && _d('Child PID', $PID, 'finished');
2857- return 0;
2858- }
2859- }
2860- print "All processes are running; waiting for them to finish...\n"
2861- unless $o->get('quiet');
2862-
2863- # Wait for and reap the child processes.
2864- do {
2865- # Possibly wait for child.
2866- my $reaped = 0;
2867- foreach my $pid ( keys %exited_children ) {
2868- $reaped = 1;
2869- print "Process ", $children{$pid}, " finished with exit status ",
2870- $exited_children{$pid}->{exit_status}, ".\n"
2871- unless $o->get('quiet');
2872- PTDEBUG && _d('Reaped child PID', $pid);
2873- delete $children{$pid};
2874- delete $exited_children{$pid};
2875- }
2876-
2877- if ( keys %children && !$reaped ) {
2878- # Don't busy-wait. But don't wait forever either, as a child may exit
2879- # and signal while we're not sleeping, so if we sleep forever we may
2880- # not get the signal.
2881- PTDEBUG && _d('Sleeping to wait for children');
2882- sleep 1;
2883- }
2884- PTDEBUG && _d(scalar keys %children, 'children are still working');
2885-
2886- } while ( keys %children );
2887-
2888- print "All processes have finished.\n" unless $o->get('quiet');
2889- return 0;
2890-}
2891-
2892-# #############################################################################
2893-# Subroutines.
2894-# #############################################################################
2895-sub play_session {
2896- my ( $dsn, $childno, $session_files ) = @_;
2897-
2898- my $query_time;
2899- my $slowlog_fmt = "# Thread_id: %s Query_time: %.6f Schema: %s\n%s;\n";
2900- my $only_select = $o->get('only-select');
2901- my $warnings = $o->get('warnings');
2902- my $print = $o->get('print');
2903- my $results = $o->get('results');
2904- my $dbh = get_cxn($dsn) unless $print;
2905-
2906- # Each thread writes to its own file because contention will not allow
2907- # them all to write correctly to STDOUT at once.
2908- my $base_dir = $o->get('base-dir');
2909- my $output_file = $o->get('base-dir')
2910- . '/'
2911- . $o->get('base-file-name') . "-results-$PID.txt";
2912- my $output_fh;
2913- if ( $results || $print ) {
2914- open $output_fh, '>', $output_file
2915- or die "Cannot open $output_file for writing: $OS_ERROR";
2916- PTDEBUG && _d('Proc', $childno, 'writing to', $output_file);
2917- }
2918- else {
2919- PTDEBUG && _d('Proc', $childno, 'not writing results');
2920- }
2921-
2922- local $INPUT_RECORD_SEPARATOR = '';
2923-
2924- ITERATION:
2925- for my $iteration_n ( 1..$o->get('iterations') ) {
2926- PTDEBUG && _d('Proc', $childno, 'starting iteration', $iteration_n);
2927-
2928- SESSION_FILE:
2929- foreach my $session_file ( @$session_files ) {
2930- my $session_fh;
2931- my $session_n;
2932- if ( !open $session_fh, '<', $session_file ) {
2933- warn "Cannot open session file $session_file: $OS_ERROR";
2934- next SESSION_FILE;
2935- }
2936-
2937- my $db;
2938- QUERY:
2939- while ( my $query = <$session_fh> ) {
2940- if ( $print ) {
2941- print $output_fh $query;
2942- next QUERY;
2943- }
2944-
2945- if ( $query =~ m/^-- START SESSION (\S+)/ ) {
2946- $session_n = $1;
2947- next QUERY;
2948- }
2949-
2950- if ( $only_select ) {
2951- # Remove leading /* comments */ (issue 903)
2952- $query =~ s!^/\*.*?\*/\s*!!;
2953- if ( $query !~ m/^(?:SELECT|USE) /i ) {
2954- PTDEBUG && _d('Skipping query for --only-select:', $query);
2955- next QUERY;
2956- }
2957- }
2958-
2959- if ( $query =~ m/^use (\S+)/ ) {
2960- $db = $1;
2961- eval { $dbh->do($query); };
2962- if ( $EVAL_ERROR && $warnings ) {
2963- warn_error($childno, $session_n, $query,$dbh->errstr());
2964- }
2965- next QUERY;
2966- }
2967-
2968- $query_time = time;
2969- eval { $dbh->do($query); };
2970- if ( $EVAL_ERROR && $warnings ) {
2971- warn_error($childno, $session_n, $query, $dbh->errstr());
2972- next QUERY;
2973- }
2974-
2975- if ( $results ) {
2976- chomp $query;
2977- printf $output_fh $slowlog_fmt,
2978- "$childno$session_n",
2979- time - $query_time,
2980- ($db || ''),
2981- $query;
2982- }
2983- } # QUERY
2984-
2985- PTDEBUG && _d('No more sessions in', $session_file);
2986- close $session_fh;
2987- } # SESSION_FILE
2988- } # ITERATION
2989-
2990- close $output_fh if $output_fh;
2991- if ($dbh) {
2992- $dbh->commit() unless $dbh->{AutoCommit};
2993- $dbh->disconnect();
2994- }
2995- return;
2996-}
2997-
2998-sub get_delay {
2999- my ( $delay ) = @_;
3000- return 0 if !defined $delay || scalar @$delay == 0;
3001- my $t = 0;
3002-
3003- my ( $from, $to ) = @$delay[0..1];
3004- if ( defined $to ) {
3005- $t = rand($to) + $from;
3006- }
3007- else {
3008- $t = $from;
3009- }
3010-
3011- # Return time is expressed in microseconds because this value
3012- # is used with usleep() which takes a microsecond time value.
3013- return $t *= 1_000_000;
3014-}
3015-
3016-sub get_cxn {
3017- my ( $dsn ) = @_;
3018- return $dp->get_dbh( $dp->get_cxn_params($dsn) );
3019-}
3020-
3021-sub warn_error {
3022- my ( $childno, $session_n, $query, $warning ) = @_;
3023- $childno = -1 unless defined $childno;
3024- $session_n = -1 unless defined $session_n;
3025- $query ||= "";
3026- $warning ||= "";
3027- warn "Query '$query' in proc $childno session $session_n caused an error: "
3028- . "$warning\n";
3029- return;
3030-}
3031-
3032-# Returns the number of CPUs. If no sys info is given, then it's gotten
3033-# from /proc/cpuinfo, sysctl or whatever method will work. If sys info
3034-# is given, then we try to parse the number of CPUs from it. Passing in
3035-# $sys_info makes this code easy to test.
3036-sub get_number_of_cpus {
3037- my ( $sys_info ) = @_;
3038- my $n_cpus;
3039-
3040- # Try to read the number of CPUs in /proc/cpuinfo.
3041- # This only works on GNU/Linux.
3042- my $cpuinfo;
3043- if ( $sys_info || (open $cpuinfo, "<", "/proc/cpuinfo") ) {
3044- local $INPUT_RECORD_SEPARATOR = undef;
3045- my $contents = $sys_info || <$cpuinfo>;
3046- PTDEBUG && _d('sys info:', $contents);
3047- close $cpuinfo if $cpuinfo;
3048- $n_cpus = scalar( map { $_ } $contents =~ m/(processor)/g );
3049- PTDEBUG && _d('Got', $n_cpus, 'cpus from /proc/cpuinfo');
3050- return $n_cpus if $n_cpus;
3051- }
3052-
3053- # Alternatives to /proc/cpuinfo:
3054-
3055- # FreeBSD and Mac OS X
3056- if ( $sys_info || ($OSNAME =~ m/freebsd/i) || ($OSNAME =~ m/darwin/i) ) {
3057- my $contents = $sys_info || `sysctl hw.ncpu`;
3058- PTDEBUG && _d('sys info:', $contents);
3059- ($n_cpus) = $contents =~ m/(\d)/ if $contents;
3060- PTDEBUG && _d('Got', $n_cpus, 'cpus from sysctl hw.ncpu');
3061- return $n_cpus if $n_cpus;
3062- }
3063-
3064- # Windows
3065- $n_cpus ||= $ENV{NUMBER_OF_PROCESSORS};
3066-
3067- return $n_cpus || 1; # There has to be at least 1 CPU.
3068-}
3069-
3070-sub _d {
3071- my ($package, undef, $line) = caller 0;
3072- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3073- map { defined $_ ? $_ : 'undef' }
3074- @_;
3075- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3076-}
3077-
3078-# ############################################################################
3079-# Run the program.
3080-# ############################################################################
3081-if ( !caller ) { exit main(@ARGV); }
3082-
3083-1; # Because this is a module as well as a script.
3084-
3085-# ############################################################################
3086-# Documentation.
3087-# ############################################################################
3088-
3089-=pod
3090-
3091-=head1 NAME
3092-
3093-pt-log-player - Replay MySQL query logs.
3094-
3095-=head1 SYNOPSIS
3096-
3097-This tool is deprecated and will be removed in Percona Toolkit 2.2.
3098-
3099-Usage: pt-log-player [OPTION...] [DSN]
3100-
3101-pt-log-player splits and plays slow log files.
3102-
3103-Split slow.log on Thread_id into 16 session files, save in ./sessions:
3104-
3105- pt-log-player --split Thread_id --session-files 16 --base-dir ./sessions slow.log
3106-
3107-Play all those sessions on host1, save results in ./results:
3108-
3109- pt-log-player --play ./sessions --base-dir ./results h=host1
3110-
3111-Use L<pt-query-digest> to summarize the results:
3112-
3113- pt-query-digest ./results/*
3114-
3115-=head1 RISKS
3116-
3117-The following section is included to inform users about the potential risks,
3118-whether known or unknown, of using this tool. The two main categories of risks
3119-are those created by the nature of the tool (e.g. read-only tools vs. read-write
3120-tools) and those created by bugs.
3121-
3122-This tool is meant to load a server as much as possible, for stress-testing
3123-purposes. It is not designed to be used on production servers.
3124-
3125-At the time of this release there is a bug which causes pt-log-player to
3126-exceed max open files during L<"--split">.
3127-
3128-The authoritative source for updated information is always the online issue
3129-tracking system. Issues that affect this tool will be marked as such. You can
3130-see a list of such issues at the following URL:
3131-L<http://www.percona.com/bugs/pt-log-player>.
3132-
3133-See also L<"BUGS"> for more information on filing bugs and getting help.
3134-
3135-=head1 DESCRIPTION
3136-
3137-pt-log-player does two things: it splits MySQL query logs into session files
3138-and it plays (executes) queries in session files on a MySQL server. Only
3139-session files can be played; slow logs cannot be played directly without
3140-being split.
3141-
3142-A session is a group of queries from the slow log that all share a common
3143-attribute, usually Thread_id. The common attribute is specified with
3144-L<"--split">. Multiple sessions are saved into a single session file.
3145-See L<"--session-files">, L<"--max-sessions">, L<"--base-file-name"> and
3146-L<"--base-dir">. These session files are played with L<"--play">.
3147-
3148-pt-log-player will L<"--play"> session files in parallel using N number of
3149-L<"--threads">. (They're not technically threads, but we call them that
3150-anyway.) Each thread will play all the sessions in its given session files.
3151-The sessions are played as fast as possible (there are no delays) because the
3152-goal is to stress-test and load-test the server. So be careful using this
3153-script on a production server!
3154-
3155-Each L<"--play"> thread writes its results to a separate file. These result
3156-files are in slow log format so they can be aggregated and summarized with
3157-L<pt-query-digest>. See L<"OUTPUT">.
3158-
3159-=head1 OUTPUT
3160-
3161-Both L<"--split"> and L<"--play"> have two outputs: status messages printed to
3162-STDOUT to let you know what the script is doing, and session or result files
3163-written to separate files saved in L<"--base-dir">. You can suppress all
3164-output to STDOUT for each with L<"--quiet">, or increase output with
3165-L<"--verbose">.
3166-
3167-The session files written by L<"--split"> are simple text files containing
3168-queries grouped into sessions. For example:
3169-
3170- -- START SESSION 10
3171-
3172- use foo
3173-
3174- SELECT col FROM foo_tbl
3175-
3176-The format of these session files is important: each query must be a single
3177-line separated by a single blank line. And the "-- START SESSION" comment
3178-tells pt-log-player where individual sessions begin and end so that L<"--play">
3179-can correctly fake Thread_id in its result files.
3180-
3181-The result files written by L<"--play"> are in slow log format with a minimal
3182-header: the only attributes printed are Thread_id, Query_time and Schema.
3183-
3184-=head1 OPTIONS
3185-
3186-Specify at least one of L<"--play">, L<"--split"> or L<"--split-random">.
3187-
3188-L<"--play"> and L<"--split"> are mutually exclusive.
3189-
3190-This tool accepts additional command-line arguments. Refer to the
3191-L<"SYNOPSIS"> and usage information for details.
3192-
3193-=over
3194-
3195-=item --ask-pass
3196-
3197-group: Play
3198-
3199-Prompt for a password when connecting to MySQL.
3200-
3201-=item --base-dir
3202-
3203-type: string; default: ./
3204-
3205-Base directory for L<"--split"> session files and L<"--play"> result file.
3206-
3207-=item --base-file-name
3208-
3209-type: string; default: session
3210-
3211-Base file name for L<"--split"> session files and L<"--play"> result file.
3212-
3213-Each L<"--split"> session file will be saved as <base-file-name>-N.txt, where
3214-N is a four digit, zero-padded session ID. For example: session-0003.txt.
3215-
3216-Each L<"--play"> result file will be saved as <base-file-name>-results-PID.txt,
3217-where PID is the process ID of the executing thread.
3218-
3219-All files are saved in L<"--base-dir">.
3220-
3221-=item --charset
3222-
3223-short form: -A; type: string; group: Play
3224-
3225-Default character set. If the value is utf8, sets Perl's binmode on STDOUT to
3226-utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET NAMES UTF8
3227-after connecting to MySQL. Any other value sets binmode on STDOUT without the
3228-utf8 layer, and runs SET NAMES after connecting to MySQL.
3229-
3230-=item --config
3231-
3232-type: Array
3233-
3234-Read this comma-separated list of config files; if specified, this must be the
3235-first option on the command line.
3236-
3237-=item --defaults-file
3238-
3239-short form: -F; type: string
3240-
3241-Only read mysql options from the given file.
3242-
3243-=item --dry-run
3244-
3245-Print which processes play which session files then exit.
3246-
3247-=item --filter
3248-
3249-type: string; group: Split
3250-
3251-Discard L<"--split"> events for which this Perl code doesn't return true.
3252-
3253-This option only works with L<"--split">.
3254-
3255-This option allows you to inject Perl code into the tool to affect how the
3256-tool runs. Usually your code should examine C<$event> to decided whether
3257-or not to allow the event. C<$event> is a hashref of attributes and values of
3258-the event being filtered. Or, your code could add new attribute-value pairs
3259-to C<$event> for use by other options that accept event attributes as their
3260-value. You can find an explanation of the structure of C<$event> at
3261-L<http://code.google.com/p/maatkit/wiki/EventAttributes>.
3262-
3263-There are two ways to supply your code: on the command line or in a file.
3264-If you supply your code on the command line, it is injected into the following
3265-subroutine where C<$filter> is your code:
3266-
3267- sub {
3268- PTDEBUG && _d('callback: filter');
3269- my( $event ) = shift;
3270- ( $filter ) && return $event;
3271- }
3272-
3273-Therefore you must ensure two things: first, that you correctly escape any
3274-special characters that need to be escaped on the command line for your
3275-shell, and two, that your code is syntactically valid when injected into
3276-the subroutine above.
3277-
3278-Here's an example filter supplied on the command line that discards
3279-events that are not SELECT statements:
3280-
3281- --filter '$event->{arg} =~ m/^select/i'
3282-
3283-The second way to supply your code is in a file. If your code is too complex
3284-to be expressed on the command line that results in valid syntax in the
3285-subroutine above, then you need to put the code in a file and give the file
3286-name as the value to L<"--filter">. The file should not contain a shebang
3287-(C<#!/usr/bin/perl>) line. The entire contents of the file is injected into
3288-the following subroutine:
3289-
3290- sub {
3291- PTDEBUG && _d('callback: filter');
3292- my( $event ) = shift;
3293- $filter && return $event;
3294- }
3295-
3296-That subroutine is almost identical to the one above except your code is
3297-not wrapped in parentheses. This allows you to write multi-line code like:
3298-
3299- my $event_ok;
3300- if (...) {
3301- $event_ok = 1;
3302- }
3303- else {
3304- $event_ok = 0;
3305- }
3306- $event_ok
3307-
3308-Notice that the last line is not syntactically valid by itself, but it
3309-becomes syntactically valid when injected into the subroutine because it
3310-becomes:
3311-
3312- $event_ok && return $event;
3313-
3314-If your code doesn't compile, the tool will die with an error. Even if your
3315-code compiles, it may crash to tool during runtime if, for example, it tries
3316-a pattern match an undefined value. No safeguards of any kind are provided so
3317-code carefully!
3318-
3319-=item --help
3320-
3321-Show help and exit.
3322-
3323-=item --host
3324-
3325-short form: -h; type: string; group: Play
3326-
3327-Connect to host.
3328-
3329-=item --iterations
3330-
3331-type: int; default: 1; group: Play
3332-
3333-How many times each thread should play all its session files.
3334-
3335-=item --max-sessions
3336-
3337-type: int; default: 5000000; group: Split
3338-
3339-Maximum number of sessions to L<"--split">.
3340-
3341-By default, C<pt-log-player> tries to split every session from the log file.
3342-For huge logs, however, this can result in millions of sessions. This
3343-option causes only the first N number of sessions to be saved. All sessions
3344-after this number are ignored, but sessions split before this number will
3345-continue to have their queries split even if those queries appear near the end
3346-of the log and after this number has been reached.
3347-
3348-=item --only-select
3349-
3350-group: Play
3351-
3352-Play only SELECT and USE queries; ignore all others.
3353-
3354-=item --password
3355-
3356-short form: -p; type: string; group: Play
3357-
3358-Password to use when connecting.
3359-
3360-=item --pid
3361-
3362-type: string
3363-
3364-Create the given PID file. The file contains the process ID of the script.
3365-The PID file is removed when the script exits. Before starting, the script
3366-checks if the PID file already exists. If it does not, then the script creates
3367-and writes its own PID to it. If it does, then the script checks the following:
3368-if the file contains a PID and a process is running with that PID, then
3369-the script dies; or, if there is no process running with that PID, then the
3370-script overwrites the file with its own PID and starts; else, if the file
3371-contains no PID, then the script dies.
3372-
3373-=item --play
3374-
3375-type: string; group: Play
3376-
3377-Play (execute) session files created by L<"--split">.
3378-
3379-The argument to play must be a comma-separated list of session files
3380-created by L<"--split"> or a directory. If the argument is a directory,
3381-ALL files in that directory will be played.
3382-
3383-=item --port
3384-
3385-short form: -P; type: int; group: Play
3386-
3387-Port number to use for connection.
3388-
3389-=item --print
3390-
3391-group: Play
3392-
3393-Print queries instead of playing them; requires L<"--play">.
3394-
3395-You must also specify L<"--play"> with L<"--print">. Although the queries
3396-will not be executed, L<"--play"> is required to specify which session files to
3397-read.
3398-
3399-=item --quiet
3400-
3401-short form: -q
3402-
3403-Do not print anything; disables L<"--verbose">.
3404-
3405-=item --[no]results
3406-
3407-default: yes
3408-
3409-Print L<"--play"> results to files in L<"--base-dir">.
3410-
3411-=item --session-files
3412-
3413-type: int; default: 8; group: Split
3414-
3415-Number of session files to create with L<"--split">.
3416-
3417-The number of session files should either be equal to the number of
3418-L<"--threads"> you intend to L<"--play"> or be an even multiple of
3419-L<"--threads">. This number is important for maximum performance because it:
3420-
3421- * allows each thread to have roughly the same amount of sessions to play
3422- * avoids having to open/close many session files
3423- * avoids disk IO overhead by doing large sequential reads
3424-
3425-You may want to increase this number beyond L<"--threads"> if each session
3426-file becomes too large. For example, splitting a 20G log into 8 sessions
3427-files may yield roughly eight 2G session files.
3428-
3429-See also L<"--max-sessions">.
3430-
3431-=item --set-vars
3432-
3433-type: string; group: Play; default: wait_timeout=10000
3434-
3435-Set these MySQL variables. Immediately after connecting to MySQL, this string
3436-will be appended to SET and executed.
3437-
3438-=item --socket
3439-
3440-short form: -S; type: string; group: Play
3441-
3442-Socket file to use for connection.
3443-
3444-=item --split
3445-
3446-type: string; group: Split
3447-
3448-Split log by given attribute to create session files.
3449-
3450-Valid attributes are any which appear in the log: Thread_id, Schema,
3451-etc.
3452-
3453-=item --split-random
3454-
3455-group: Split
3456-
3457-Split log without an attribute, write queries round-robin to session files.
3458-
3459-This option, if specified, overrides L<"--split"> and causes the log to be
3460-split query-by-query, writing each query to the next session file in round-robin
3461-style. If you don't care about "sessions" and just want to split a lot into
3462-N many session files and the relation or order of the queries does not matter,
3463-then use this option.
3464-
3465-=item --threads
3466-
3467-type: int; default: 2; group: Play
3468-
3469-Number of threads used to play sessions concurrently.
3470-
3471-Specifies the number of parallel processes to run. The default is 2. On
3472-GNU/Linux machines, the default is the number of times 'processor' appears in
3473-F</proc/cpuinfo>. On Windows, the default is read from the environment.
3474-In any case, the default is at least 2, even when there's only a single
3475-processor.
3476-
3477-See also L<"--session-files">.
3478-
3479-=item --type
3480-
3481-type: string; group: Split
3482-
3483-The type of log to L<"--split"> (default slowlog). The permitted types are
3484-
3485-=over
3486-
3487-=item binlog
3488-
3489-Split the output of running C<mysqlbinlog> against a binary log file.
3490-Currently, splitting binary logs does not always work well depending
3491-on what the binary logs contain. Be sure to check the session files
3492-after splitting to ensure proper L<"OUTPUT">.
3493-
3494-If the binary log contains row-based replication data, you need to run
3495-C<mysqlbinlog> with options C<--base64-output=decode-rows --verbose>,
3496-else invalid statements will be written to the session files.
3497-
3498-=item genlog
3499-
3500-Split a general log file.
3501-
3502-=item slowlog
3503-
3504-Split a log file in any variation of MySQL slow-log format.
3505-
3506-=back
3507-
3508-=item --user
3509-
3510-short form: -u; type: string; group: Play
3511-
3512-User for login if not current user.
3513-
3514-=item --verbose
3515-
3516-short form: -v; cumulative: yes; default: 0
3517-
3518-Increase verbosity; can be specified multiple times.
3519-
3520-This option is disabled by L<"--quiet">.
3521-
3522-=item --version
3523-
3524-Show version and exit.
3525-
3526-=item --[no]warnings
3527-
3528-default: no; group: Play
3529-
3530-Print warnings about SQL errors such as invalid queries to STDERR.
3531-
3532-=back
3533-
3534-=head1 DSN OPTIONS
3535-
3536-These DSN options are used to create a DSN. Each option is given like
3537-C<option=value>. The options are case-sensitive, so P and p are not the
3538-same option. There cannot be whitespace before or after the C<=> and
3539-if the value contains whitespace it must be quoted. DSN options are
3540-comma-separated. See the L<percona-toolkit> manpage for full details.
3541-
3542-=over
3543-
3544-=item * A
3545-
3546-dsn: charset; copy: yes
3547-
3548-Default character set.
3549-
3550-=item * D
3551-
3552-dsn: database; copy: yes
3553-
3554-Default database.
3555-
3556-=item * F
3557-
3558-dsn: mysql_read_default_file; copy: yes
3559-
3560-Only read default options from the given file
3561-
3562-=item * h
3563-
3564-dsn: host; copy: yes
3565-
3566-Connect to host.
3567-
3568-=item * p
3569-
3570-dsn: password; copy: yes
3571-
3572-Password to use when connecting.
3573-
3574-=item * P
3575-
3576-dsn: port; copy: yes
3577-
3578-Port number to use for connection.
3579-
3580-=item * S
3581-
3582-dsn: mysql_socket; copy: yes
3583-
3584-Socket file to use for connection.
3585-
3586-=item * u
3587-
3588-dsn: user; copy: yes
3589-
3590-User for login if not current user.
3591-
3592-=back
3593-
3594-=head1 ENVIRONMENT
3595-
3596-The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
3597-To enable debugging and capture all output to a file, run the tool like:
3598-
3599- PTDEBUG=1 pt-log-player ... > FILE 2>&1
3600-
3601-Be careful: debugging output is voluminous and can generate several megabytes
3602-of output.
3603-
3604-=head1 SYSTEM REQUIREMENTS
3605-
3606-You need Perl, DBI, DBD::mysql, and some core packages that ought to be
3607-installed in any reasonably new version of Perl.
3608-
3609-=head1 BUGS
3610-
3611-For a list of known bugs, see L<http://www.percona.com/bugs/pt-log-player>.
3612-
3613-Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
3614-Include the following information in your bug report:
3615-
3616-=over
3617-
3618-=item * Complete command-line used to run the tool
3619-
3620-=item * Tool L<"--version">
3621-
3622-=item * MySQL version of all servers involved
3623-
3624-=item * Output from the tool including STDERR
3625-
3626-=item * Input files (log/dump/config files, etc.)
3627-
3628-=back
3629-
3630-If possible, include debugging output by running the tool with C<PTDEBUG>;
3631-see L<"ENVIRONMENT">.
3632-
3633-=head1 DOWNLOADING
3634-
3635-Visit L<http://www.percona.com/software/percona-toolkit/> to download the
3636-latest release of Percona Toolkit. Or, get the latest release from the
3637-command line:
3638-
3639- wget percona.com/get/percona-toolkit.tar.gz
3640-
3641- wget percona.com/get/percona-toolkit.rpm
3642-
3643- wget percona.com/get/percona-toolkit.deb
3644-
3645-You can also get individual tools from the latest release:
3646-
3647- wget percona.com/get/TOOL
3648-
3649-Replace C<TOOL> with the name of any tool.
3650-
3651-=head1 AUTHORS
3652-
3653-Daniel Nichter
3654-
3655-=head1 ABOUT PERCONA TOOLKIT
3656-
3657-This tool is part of Percona Toolkit, a collection of advanced command-line
3658-tools developed by Percona for MySQL support and consulting. Percona Toolkit
3659-was forked from two projects in June, 2011: Maatkit and Aspersa. Those
3660-projects were created by Baron Schwartz and developed primarily by him and
3661-Daniel Nichter, both of whom are employed by Percona. Visit
3662-L<http://www.percona.com/software/> for more software developed by Percona.
3663-
3664-=head1 COPYRIGHT, LICENSE, AND WARRANTY
3665-
3666-This program is copyright 2008-2012 Percona Inc.
3667-Feedback and improvements are welcome.
3668-
3669-THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
3670-WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
3671-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
3672-
3673-This program is free software; you can redistribute it and/or modify it under
3674-the terms of the GNU General Public License as published by the Free Software
3675-Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
3676-systems, you can issue `man perlgpl' or `man perlartistic' to read these
3677-licenses.
3678-
3679-You should have received a copy of the GNU General Public License along with
3680-this program; if not, write to the Free Software Foundation, Inc., 59 Temple
3681-Place, Suite 330, Boston, MA 02111-1307 USA.
3682-
3683-=head1 VERSION
3684-
3685-pt-log-player 2.1.7
3686-
3687-=cut
3688
3689=== removed file 'bin/pt-tcp-model'
3690--- bin/pt-tcp-model 2012-12-03 03:48:11 +0000
3691+++ bin/pt-tcp-model 1970-01-01 00:00:00 +0000
3692@@ -1,2534 +0,0 @@
3693-#!/usr/bin/env perl
3694-
3695-# This program is part of Percona Toolkit: http://www.percona.com/software/
3696-# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
3697-# notices and disclaimers.
3698-
3699-use strict;
3700-use warnings FATAL => 'all';
3701-
3702-# This tool is "fat-packed": most of its dependent modules are embedded
3703-# in this file. Setting %INC to this file for each module makes Perl aware
3704-# of this so it will not try to load the module from @INC. See the tool's
3705-# documentation for a full list of dependencies.
3706-BEGIN {
3707- $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
3708- OptionParser
3709- Transformers
3710- Progress
3711- FileIterator
3712- SimpleTCPDumpParser
3713- TCPRequestAggregator
3714- ));
3715-}
3716-
3717-# ###########################################################################
3718-# OptionParser package
3719-# This package is a copy without comments from the original. The original
3720-# with comments and its test file can be found in the Bazaar repository at,
3721-# lib/OptionParser.pm
3722-# t/lib/OptionParser.t
3723-# See https://launchpad.net/percona-toolkit for more information.
3724-# ###########################################################################
3725-{
3726-package OptionParser;
3727-
3728-use strict;
3729-use warnings FATAL => 'all';
3730-use English qw(-no_match_vars);
3731-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3732-
3733-use List::Util qw(max);
3734-use Getopt::Long;
3735-
3736-my $POD_link_re = '[LC]<"?([^">]+)"?>';
3737-
3738-sub new {
3739- my ( $class, %args ) = @_;
3740- my @required_args = qw();
3741- foreach my $arg ( @required_args ) {
3742- die "I need a $arg argument" unless $args{$arg};
3743- }
3744-
3745- my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
3746- $program_name ||= $PROGRAM_NAME;
3747- my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
3748-
3749- my %attributes = (
3750- 'type' => 1,
3751- 'short form' => 1,
3752- 'group' => 1,
3753- 'default' => 1,
3754- 'cumulative' => 1,
3755- 'negatable' => 1,
3756- );
3757-
3758- my $self = {
3759- head1 => 'OPTIONS', # These args are used internally
3760- skip_rules => 0, # to instantiate another Option-
3761- item => '--(.*)', # Parser obj that parses the
3762- attributes => \%attributes, # DSN OPTIONS section. Tools
3763- parse_attributes => \&_parse_attribs, # don't tinker with these args.
3764-
3765- %args,
3766-
3767- strict => 1, # disabled by a special rule
3768- program_name => $program_name,
3769- opts => {},
3770- got_opts => 0,
3771- short_opts => {},
3772- defaults => {},
3773- groups => {},
3774- allowed_groups => {},
3775- errors => [],
3776- rules => [], # desc of rules for --help
3777- mutex => [], # rule: opts are mutually exclusive
3778- atleast1 => [], # rule: at least one opt is required
3779- disables => {}, # rule: opt disables other opts
3780- defaults_to => {}, # rule: opt defaults to value of other opt
3781- DSNParser => undef,
3782- default_files => [
3783- "/etc/percona-toolkit/percona-toolkit.conf",
3784- "/etc/percona-toolkit/$program_name.conf",
3785- "$home/.percona-toolkit.conf",
3786- "$home/.$program_name.conf",
3787- ],
3788- types => {
3789- string => 's', # standard Getopt type
3790- int => 'i', # standard Getopt type
3791- float => 'f', # standard Getopt type
3792- Hash => 'H', # hash, formed from a comma-separated list
3793- hash => 'h', # hash as above, but only if a value is given
3794- Array => 'A', # array, similar to Hash
3795- array => 'a', # array, similar to hash
3796- DSN => 'd', # DSN
3797- size => 'z', # size with kMG suffix (powers of 2^10)
3798- time => 'm', # time, with an optional suffix of s/h/m/d
3799- },
3800- };
3801-
3802- return bless $self, $class;
3803-}
3804-
3805-sub get_specs {
3806- my ( $self, $file ) = @_;
3807- $file ||= $self->{file} || __FILE__;
3808- my @specs = $self->_pod_to_specs($file);
3809- $self->_parse_specs(@specs);
3810-
3811- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
3812- my $contents = do { local $/ = undef; <$fh> };
3813- close $fh;
3814- if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
3815- PTDEBUG && _d('Parsing DSN OPTIONS');
3816- my $dsn_attribs = {
3817- dsn => 1,
3818- copy => 1,
3819- };
3820- my $parse_dsn_attribs = sub {
3821- my ( $self, $option, $attribs ) = @_;
3822- map {
3823- my $val = $attribs->{$_};
3824- if ( $val ) {
3825- $val = $val eq 'yes' ? 1
3826- : $val eq 'no' ? 0
3827- : $val;
3828- $attribs->{$_} = $val;
3829- }
3830- } keys %$attribs;
3831- return {
3832- key => $option,
3833- %$attribs,
3834- };
3835- };
3836- my $dsn_o = new OptionParser(
3837- description => 'DSN OPTIONS',
3838- head1 => 'DSN OPTIONS',
3839- dsn => 0, # XXX don't infinitely recurse!
3840- item => '\* (.)', # key opts are a single character
3841- skip_rules => 1, # no rules before opts
3842- attributes => $dsn_attribs,
3843- parse_attributes => $parse_dsn_attribs,
3844- );
3845- my @dsn_opts = map {
3846- my $opts = {
3847- key => $_->{spec}->{key},
3848- dsn => $_->{spec}->{dsn},
3849- copy => $_->{spec}->{copy},
3850- desc => $_->{desc},
3851- };
3852- $opts;
3853- } $dsn_o->_pod_to_specs($file);
3854- $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
3855- }
3856-
3857- if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
3858- $self->{version} = $1;
3859- PTDEBUG && _d($self->{version});
3860- }
3861-
3862- return;
3863-}
3864-
3865-sub DSNParser {
3866- my ( $self ) = @_;
3867- return $self->{DSNParser};
3868-};
3869-
3870-sub get_defaults_files {
3871- my ( $self ) = @_;
3872- return @{$self->{default_files}};
3873-}
3874-
3875-sub _pod_to_specs {
3876- my ( $self, $file ) = @_;
3877- $file ||= $self->{file} || __FILE__;
3878- open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
3879-
3880- my @specs = ();
3881- my @rules = ();
3882- my $para;
3883-
3884- local $INPUT_RECORD_SEPARATOR = '';
3885- while ( $para = <$fh> ) {
3886- next unless $para =~ m/^=head1 $self->{head1}/;
3887- last;
3888- }
3889-
3890- while ( $para = <$fh> ) {
3891- last if $para =~ m/^=over/;
3892- next if $self->{skip_rules};
3893- chomp $para;
3894- $para =~ s/\s+/ /g;
3895- $para =~ s/$POD_link_re/$1/go;
3896- PTDEBUG && _d('Option rule:', $para);
3897- push @rules, $para;
3898- }
3899-
3900- die "POD has no $self->{head1} section" unless $para;
3901-
3902- do {
3903- if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
3904- chomp $para;
3905- PTDEBUG && _d($para);
3906- my %attribs;
3907-
3908- $para = <$fh>; # read next paragraph, possibly attributes
3909-
3910- if ( $para =~ m/: / ) { # attributes
3911- $para =~ s/\s+\Z//g;
3912- %attribs = map {
3913- my ( $attrib, $val) = split(/: /, $_);
3914- die "Unrecognized attribute for --$option: $attrib"
3915- unless $self->{attributes}->{$attrib};
3916- ($attrib, $val);
3917- } split(/; /, $para);
3918- if ( $attribs{'short form'} ) {
3919- $attribs{'short form'} =~ s/-//;
3920- }
3921- $para = <$fh>; # read next paragraph, probably short help desc
3922- }
3923- else {
3924- PTDEBUG && _d('Option has no attributes');
3925- }
3926-
3927- $para =~ s/\s+\Z//g;
3928- $para =~ s/\s+/ /g;
3929- $para =~ s/$POD_link_re/$1/go;
3930-
3931- $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
3932- PTDEBUG && _d('Short help:', $para);
3933-
3934- die "No description after option spec $option" if $para =~ m/^=item/;
3935-
3936- if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
3937- $option = $base_option;
3938- $attribs{'negatable'} = 1;
3939- }
3940-
3941- push @specs, {
3942- spec => $self->{parse_attributes}->($self, $option, \%attribs),
3943- desc => $para
3944- . (defined $attribs{default} ? " (default $attribs{default})" : ''),
3945- group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
3946- };
3947- }
3948- while ( $para = <$fh> ) {
3949- last unless $para;
3950- if ( $para =~ m/^=head1/ ) {
3951- $para = undef; # Can't 'last' out of a do {} block.
3952- last;
3953- }
3954- last if $para =~ m/^=item /;
3955- }
3956- } while ( $para );
3957-
3958- die "No valid specs in $self->{head1}" unless @specs;
3959-
3960- close $fh;
3961- return @specs, @rules;
3962-}
3963-
3964-sub _parse_specs {
3965- my ( $self, @specs ) = @_;
3966- my %disables; # special rule that requires deferred checking
3967-
3968- foreach my $opt ( @specs ) {
3969- if ( ref $opt ) { # It's an option spec, not a rule.
3970- PTDEBUG && _d('Parsing opt spec:',
3971- map { ($_, '=>', $opt->{$_}) } keys %$opt);
3972-
3973- my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
3974- if ( !$long ) {
3975- die "Cannot parse long option from spec $opt->{spec}";
3976- }
3977- $opt->{long} = $long;
3978-
3979- die "Duplicate long option --$long" if exists $self->{opts}->{$long};
3980- $self->{opts}->{$long} = $opt;
3981-
3982- if ( length $long == 1 ) {
3983- PTDEBUG && _d('Long opt', $long, 'looks like short opt');
3984- $self->{short_opts}->{$long} = $long;
3985- }
3986-
3987- if ( $short ) {
3988- die "Duplicate short option -$short"
3989- if exists $self->{short_opts}->{$short};
3990- $self->{short_opts}->{$short} = $long;
3991- $opt->{short} = $short;
3992- }
3993- else {
3994- $opt->{short} = undef;
3995- }
3996-
3997- $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
3998- $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
3999- $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
4000-
4001- $opt->{group} ||= 'default';
4002- $self->{groups}->{ $opt->{group} }->{$long} = 1;
4003-
4004- $opt->{value} = undef;
4005- $opt->{got} = 0;
4006-
4007- my ( $type ) = $opt->{spec} =~ m/=(.)/;
4008- $opt->{type} = $type;
4009- PTDEBUG && _d($long, 'type:', $type);
4010-
4011-
4012- $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
4013-
4014- if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
4015- $self->{defaults}->{$long} = defined $def ? $def : 1;
4016- PTDEBUG && _d($long, 'default:', $def);
4017- }
4018-
4019- if ( $long eq 'config' ) {
4020- $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
4021- }
4022-
4023- if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
4024- $disables{$long} = $dis;
4025- PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
4026- }
4027-
4028- $self->{opts}->{$long} = $opt;
4029- }
4030- else { # It's an option rule, not a spec.
4031- PTDEBUG && _d('Parsing rule:', $opt);
4032- push @{$self->{rules}}, $opt;
4033- my @participants = $self->_get_participants($opt);
4034- my $rule_ok = 0;
4035-
4036- if ( $opt =~ m/mutually exclusive|one and only one/ ) {
4037- $rule_ok = 1;
4038- push @{$self->{mutex}}, \@participants;
4039- PTDEBUG && _d(@participants, 'are mutually exclusive');
4040- }
4041- if ( $opt =~ m/at least one|one and only one/ ) {
4042- $rule_ok = 1;
4043- push @{$self->{atleast1}}, \@participants;
4044- PTDEBUG && _d(@participants, 'require at least one');
4045- }
4046- if ( $opt =~ m/default to/ ) {
4047- $rule_ok = 1;
4048- $self->{defaults_to}->{$participants[0]} = $participants[1];
4049- PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
4050- }
4051- if ( $opt =~ m/restricted to option groups/ ) {
4052- $rule_ok = 1;
4053- my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
4054- my @groups = split(',', $groups);
4055- %{$self->{allowed_groups}->{$participants[0]}} = map {
4056- s/\s+//;
4057- $_ => 1;
4058- } @groups;
4059- }
4060- if( $opt =~ m/accepts additional command-line arguments/ ) {
4061- $rule_ok = 1;
4062- $self->{strict} = 0;
4063- PTDEBUG && _d("Strict mode disabled by rule");
4064- }
4065-
4066- die "Unrecognized option rule: $opt" unless $rule_ok;
4067- }
4068- }
4069-
4070- foreach my $long ( keys %disables ) {
4071- my @participants = $self->_get_participants($disables{$long});
4072- $self->{disables}->{$long} = \@participants;
4073- PTDEBUG && _d('Option', $long, 'disables', @participants);
4074- }
4075-
4076- return;
4077-}
4078-
4079-sub _get_participants {
4080- my ( $self, $str ) = @_;
4081- my @participants;
4082- foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
4083- die "Option --$long does not exist while processing rule $str"
4084- unless exists $self->{opts}->{$long};
4085- push @participants, $long;
4086- }
4087- PTDEBUG && _d('Participants for', $str, ':', @participants);
4088- return @participants;
4089-}
4090-
4091-sub opts {
4092- my ( $self ) = @_;
4093- my %opts = %{$self->{opts}};
4094- return %opts;
4095-}
4096-
4097-sub short_opts {
4098- my ( $self ) = @_;
4099- my %short_opts = %{$self->{short_opts}};
4100- return %short_opts;
4101-}
4102-
4103-sub set_defaults {
4104- my ( $self, %defaults ) = @_;
4105- $self->{defaults} = {};
4106- foreach my $long ( keys %defaults ) {
4107- die "Cannot set default for nonexistent option $long"
4108- unless exists $self->{opts}->{$long};
4109- $self->{defaults}->{$long} = $defaults{$long};
4110- PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
4111- }
4112- return;
4113-}
4114-
4115-sub get_defaults {
4116- my ( $self ) = @_;
4117- return $self->{defaults};
4118-}
4119-
4120-sub get_groups {
4121- my ( $self ) = @_;
4122- return $self->{groups};
4123-}
4124-
4125-sub _set_option {
4126- my ( $self, $opt, $val ) = @_;
4127- my $long = exists $self->{opts}->{$opt} ? $opt
4128- : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
4129- : die "Getopt::Long gave a nonexistent option: $opt";
4130-
4131- $opt = $self->{opts}->{$long};
4132- if ( $opt->{is_cumulative} ) {
4133- $opt->{value}++;
4134- }
4135- else {
4136- $opt->{value} = $val;
4137- }
4138- $opt->{got} = 1;
4139- PTDEBUG && _d('Got option', $long, '=', $val);
4140-}
4141-
4142-sub get_opts {
4143- my ( $self ) = @_;
4144-
4145- foreach my $long ( keys %{$self->{opts}} ) {
4146- $self->{opts}->{$long}->{got} = 0;
4147- $self->{opts}->{$long}->{value}
4148- = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
4149- : $self->{opts}->{$long}->{is_cumulative} ? 0
4150- : undef;
4151- }
4152- $self->{got_opts} = 0;
4153-
4154- $self->{errors} = [];
4155-
4156- if ( @ARGV && $ARGV[0] eq "--config" ) {
4157- shift @ARGV;
4158- $self->_set_option('config', shift @ARGV);
4159- }
4160- if ( $self->has('config') ) {
4161- my @extra_args;
4162- foreach my $filename ( split(',', $self->get('config')) ) {
4163- eval {
4164- push @extra_args, $self->_read_config_file($filename);
4165- };
4166- if ( $EVAL_ERROR ) {
4167- if ( $self->got('config') ) {
4168- die $EVAL_ERROR;
4169- }
4170- elsif ( PTDEBUG ) {
4171- _d($EVAL_ERROR);
4172- }
4173- }
4174- }
4175- unshift @ARGV, @extra_args;
4176- }
4177-
4178- Getopt::Long::Configure('no_ignore_case', 'bundling');
4179- GetOptions(
4180- map { $_->{spec} => sub { $self->_set_option(@_); } }
4181- grep { $_->{long} ne 'config' } # --config is handled specially above.
4182- values %{$self->{opts}}
4183- ) or $self->save_error('Error parsing options');
4184-
4185- if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
4186- if ( $self->{version} ) {
4187- print $self->{version}, "\n";
4188- }
4189- else {
4190- print "Error parsing version. See the VERSION section of the tool's documentation.\n";
4191- }
4192- exit 1;
4193- }
4194-
4195- if ( @ARGV && $self->{strict} ) {
4196- $self->save_error("Unrecognized command-line options @ARGV");
4197- }
4198-
4199- foreach my $mutex ( @{$self->{mutex}} ) {
4200- my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
4201- if ( @set > 1 ) {
4202- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
4203- @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
4204- . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
4205- . ' are mutually exclusive.';
4206- $self->save_error($err);
4207- }
4208- }
4209-
4210- foreach my $required ( @{$self->{atleast1}} ) {
4211- my @set = grep { $self->{opts}->{$_}->{got} } @$required;
4212- if ( @set == 0 ) {
4213- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
4214- @{$required}[ 0 .. scalar(@$required) - 2] )
4215- .' or --'.$self->{opts}->{$required->[-1]}->{long};
4216- $self->save_error("Specify at least one of $err");
4217- }
4218- }
4219-
4220- $self->_check_opts( keys %{$self->{opts}} );
4221- $self->{got_opts} = 1;
4222- return;
4223-}
4224-
4225-sub _check_opts {
4226- my ( $self, @long ) = @_;
4227- my $long_last = scalar @long;
4228- while ( @long ) {
4229- foreach my $i ( 0..$#long ) {
4230- my $long = $long[$i];
4231- next unless $long;
4232- my $opt = $self->{opts}->{$long};
4233- if ( $opt->{got} ) {
4234- if ( exists $self->{disables}->{$long} ) {
4235- my @disable_opts = @{$self->{disables}->{$long}};
4236- map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
4237- PTDEBUG && _d('Unset options', @disable_opts,
4238- 'because', $long,'disables them');
4239- }
4240-
4241- if ( exists $self->{allowed_groups}->{$long} ) {
4242-
4243- my @restricted_groups = grep {
4244- !exists $self->{allowed_groups}->{$long}->{$_}
4245- } keys %{$self->{groups}};
4246-
4247- my @restricted_opts;
4248- foreach my $restricted_group ( @restricted_groups ) {
4249- RESTRICTED_OPT:
4250- foreach my $restricted_opt (
4251- keys %{$self->{groups}->{$restricted_group}} )
4252- {
4253- next RESTRICTED_OPT if $restricted_opt eq $long;
4254- push @restricted_opts, $restricted_opt
4255- if $self->{opts}->{$restricted_opt}->{got};
4256- }
4257- }
4258-
4259- if ( @restricted_opts ) {
4260- my $err;
4261- if ( @restricted_opts == 1 ) {
4262- $err = "--$restricted_opts[0]";
4263- }
4264- else {
4265- $err = join(', ',
4266- map { "--$self->{opts}->{$_}->{long}" }
4267- grep { $_ }
4268- @restricted_opts[0..scalar(@restricted_opts) - 2]
4269- )
4270- . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
4271- }
4272- $self->save_error("--$long is not allowed with $err");
4273- }
4274- }
4275-
4276- }
4277- elsif ( $opt->{is_required} ) {
4278- $self->save_error("Required option --$long must be specified");
4279- }
4280-
4281- $self->_validate_type($opt);
4282- if ( $opt->{parsed} ) {
4283- delete $long[$i];
4284- }
4285- else {
4286- PTDEBUG && _d('Temporarily failed to parse', $long);
4287- }
4288- }
4289-
4290- die "Failed to parse options, possibly due to circular dependencies"
4291- if @long == $long_last;
4292- $long_last = @long;
4293- }
4294-
4295- return;
4296-}
4297-
4298-sub _validate_type {
4299- my ( $self, $opt ) = @_;
4300- return unless $opt;
4301-
4302- if ( !$opt->{type} ) {
4303- $opt->{parsed} = 1;
4304- return;
4305- }
4306-
4307- my $val = $opt->{value};
4308-
4309- if ( $val && $opt->{type} eq 'm' ) { # type time
4310- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
4311- my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
4312- if ( !$suffix ) {
4313- my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
4314- $suffix = $s || 's';
4315- PTDEBUG && _d('No suffix given; using', $suffix, 'for',
4316- $opt->{long}, '(value:', $val, ')');
4317- }
4318- if ( $suffix =~ m/[smhd]/ ) {
4319- $val = $suffix eq 's' ? $num # Seconds
4320- : $suffix eq 'm' ? $num * 60 # Minutes
4321- : $suffix eq 'h' ? $num * 3600 # Hours
4322- : $num * 86400; # Days
4323- $opt->{value} = ($prefix || '') . $val;
4324- PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
4325- }
4326- else {
4327- $self->save_error("Invalid time suffix for --$opt->{long}");
4328- }
4329- }
4330- elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
4331- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
4332- my $prev = {};
4333- my $from_key = $self->{defaults_to}->{ $opt->{long} };
4334- if ( $from_key ) {
4335- PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
4336- if ( $self->{opts}->{$from_key}->{parsed} ) {
4337- $prev = $self->{opts}->{$from_key}->{value};
4338- }
4339- else {
4340- PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
4341- $from_key, 'parsed');
4342- return;
4343- }
4344- }
4345- my $defaults = $self->{DSNParser}->parse_options($self);
4346- $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
4347- }
4348- elsif ( $val && $opt->{type} eq 'z' ) { # type size
4349- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
4350- $self->_parse_size($opt, $val);
4351- }
4352- elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
4353- $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
4354- }
4355- elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
4356- $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
4357- }
4358- else {
4359- PTDEBUG && _d('Nothing to validate for option',
4360- $opt->{long}, 'type', $opt->{type}, 'value', $val);
4361- }
4362-
4363- $opt->{parsed} = 1;
4364- return;
4365-}
4366-
4367-sub get {
4368- my ( $self, $opt ) = @_;
4369- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
4370- die "Option $opt does not exist"
4371- unless $long && exists $self->{opts}->{$long};
4372- return $self->{opts}->{$long}->{value};
4373-}
4374-
4375-sub got {
4376- my ( $self, $opt ) = @_;
4377- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
4378- die "Option $opt does not exist"
4379- unless $long && exists $self->{opts}->{$long};
4380- return $self->{opts}->{$long}->{got};
4381-}
4382-
4383-sub has {
4384- my ( $self, $opt ) = @_;
4385- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
4386- return defined $long ? exists $self->{opts}->{$long} : 0;
4387-}
4388-
4389-sub set {
4390- my ( $self, $opt, $val ) = @_;
4391- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
4392- die "Option $opt does not exist"
4393- unless $long && exists $self->{opts}->{$long};
4394- $self->{opts}->{$long}->{value} = $val;
4395- return;
4396-}
4397-
4398-sub save_error {
4399- my ( $self, $error ) = @_;
4400- push @{$self->{errors}}, $error;
4401- return;
4402-}
4403-
4404-sub errors {
4405- my ( $self ) = @_;
4406- return $self->{errors};
4407-}
4408-
4409-sub usage {
4410- my ( $self ) = @_;
4411- warn "No usage string is set" unless $self->{usage}; # XXX
4412- return "Usage: " . ($self->{usage} || '') . "\n";
4413-}
4414-
4415-sub descr {
4416- my ( $self ) = @_;
4417- warn "No description string is set" unless $self->{description}; # XXX
4418- my $descr = ($self->{description} || $self->{program_name} || '')
4419- . " For more details, please use the --help option, "
4420- . "or try 'perldoc $PROGRAM_NAME' "
4421- . "for complete documentation.";
4422- $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
4423- unless $ENV{DONT_BREAK_LINES};
4424- $descr =~ s/ +$//mg;
4425- return $descr;
4426-}
4427-
4428-sub usage_or_errors {
4429- my ( $self, $file, $return ) = @_;
4430- $file ||= $self->{file} || __FILE__;
4431-
4432- if ( !$self->{description} || !$self->{usage} ) {
4433- PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
4434- my %synop = $self->_parse_synopsis($file);
4435- $self->{description} ||= $synop{description};
4436- $self->{usage} ||= $synop{usage};
4437- PTDEBUG && _d("Description:", $self->{description},
4438- "\nUsage:", $self->{usage});
4439- }
4440-
4441- if ( $self->{opts}->{help}->{got} ) {
4442- print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
4443- exit 0 unless $return;
4444- }
4445- elsif ( scalar @{$self->{errors}} ) {
4446- print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
4447- exit 1 unless $return;
4448- }
4449-
4450- return;
4451-}
4452-
4453-sub print_errors {
4454- my ( $self ) = @_;
4455- my $usage = $self->usage() . "\n";
4456- if ( (my @errors = @{$self->{errors}}) ) {
4457- $usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
4458- . "\n";
4459- }
4460- return $usage . "\n" . $self->descr();
4461-}
4462-
4463-sub print_usage {
4464- my ( $self ) = @_;
4465- die "Run get_opts() before print_usage()" unless $self->{got_opts};
4466- my @opts = values %{$self->{opts}};
4467-
4468- my $maxl = max(
4469- map {
4470- length($_->{long}) # option long name
4471- + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
4472- + ($_->{type} ? 2 : 0) # "=x" where x is the opt type
4473- }
4474- @opts);
4475-
4476- my $maxs = max(0,
4477- map {
4478- length($_)
4479- + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
4480- + ($self->{opts}->{$_}->{type} ? 2 : 0)
4481- }
4482- values %{$self->{short_opts}});
4483-
4484- my $lcol = max($maxl, ($maxs + 3));
4485- my $rcol = 80 - $lcol - 6;
4486- my $rpad = ' ' x ( 80 - $rcol );
4487-
4488- $maxs = max($lcol - 3, $maxs);
4489-
4490- my $usage = $self->descr() . "\n" . $self->usage();
4491-
4492- my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
4493- push @groups, 'default';
4494-
4495- foreach my $group ( reverse @groups ) {
4496- $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
4497- foreach my $opt (
4498- sort { $a->{long} cmp $b->{long} }
4499- grep { $_->{group} eq $group }
4500- @opts )
4501- {
4502- my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
4503- my $short = $opt->{short};
4504- my $desc = $opt->{desc};
4505-
4506- $long .= $opt->{type} ? "=$opt->{type}" : "";
4507-
4508- if ( $opt->{type} && $opt->{type} eq 'm' ) {
4509- my ($s) = $desc =~ m/\(suffix (.)\)/;
4510- $s ||= 's';
4511- $desc =~ s/\s+\(suffix .\)//;
4512- $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
4513- . "d=days; if no suffix, $s is used.";
4514- }
4515- $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
4516- $desc =~ s/ +$//mg;
4517- if ( $short ) {
4518- $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
4519- }
4520- else {
4521- $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
4522- }
4523- }
4524- }
4525-
4526- $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
4527-
4528- if ( (my @rules = @{$self->{rules}}) ) {
4529- $usage .= "\nRules:\n\n";
4530- $usage .= join("\n", map { " $_" } @rules) . "\n";
4531- }
4532- if ( $self->{DSNParser} ) {
4533- $usage .= "\n" . $self->{DSNParser}->usage();
4534- }
4535- $usage .= "\nOptions and values after processing arguments:\n\n";
4536- foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
4537- my $val = $opt->{value};
4538- my $type = $opt->{type} || '';
4539- my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
4540- $val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
4541- : !defined $val ? '(No value)'
4542- : $type eq 'd' ? $self->{DSNParser}->as_string($val)
4543- : $type =~ m/H|h/ ? join(',', sort keys %$val)
4544- : $type =~ m/A|a/ ? join(',', @$val)
4545- : $val;
4546- $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
4547- }
4548- return $usage;
4549-}
4550-
4551-sub prompt_noecho {
4552- shift @_ if ref $_[0] eq __PACKAGE__;
4553- my ( $prompt ) = @_;
4554- local $OUTPUT_AUTOFLUSH = 1;
4555- print $prompt
4556- or die "Cannot print: $OS_ERROR";
4557- my $response;
4558- eval {
4559- require Term::ReadKey;
4560- Term::ReadKey::ReadMode('noecho');
4561- chomp($response = <STDIN>);
4562- Term::ReadKey::ReadMode('normal');
4563- print "\n"
4564- or die "Cannot print: $OS_ERROR";
4565- };
4566- if ( $EVAL_ERROR ) {
4567- die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
4568- }
4569- return $response;
4570-}
4571-
4572-sub _read_config_file {
4573- my ( $self, $filename ) = @_;
4574- open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
4575- my @args;
4576- my $prefix = '--';
4577- my $parse = 1;
4578-
4579- LINE:
4580- while ( my $line = <$fh> ) {
4581- chomp $line;
4582- next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
4583- $line =~ s/\s+#.*$//g;
4584- $line =~ s/^\s+|\s+$//g;
4585- if ( $line eq '--' ) {
4586- $prefix = '';
4587- $parse = 0;
4588- next LINE;
4589- }
4590- if ( $parse
4591- && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
4592- ) {
4593- push @args, grep { defined $_ } ("$prefix$opt", $arg);
4594- }
4595- elsif ( $line =~ m/./ ) {
4596- push @args, $line;
4597- }
4598- else {
4599- die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
4600- }
4601- }
4602- close $fh;
4603- return @args;
4604-}
4605-
4606-sub read_para_after {
4607- my ( $self, $file, $regex ) = @_;
4608- open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
4609- local $INPUT_RECORD_SEPARATOR = '';
4610- my $para;
4611- while ( $para = <$fh> ) {
4612- next unless $para =~ m/^=pod$/m;
4613- last;
4614- }
4615- while ( $para = <$fh> ) {
4616- next unless $para =~ m/$regex/;
4617- last;
4618- }
4619- $para = <$fh>;
4620- chomp($para);
4621- close $fh or die "Can't close $file: $OS_ERROR";
4622- return $para;
4623-}
4624-
4625-sub clone {
4626- my ( $self ) = @_;
4627-
4628- my %clone = map {
4629- my $hashref = $self->{$_};
4630- my $val_copy = {};
4631- foreach my $key ( keys %$hashref ) {
4632- my $ref = ref $hashref->{$key};
4633- $val_copy->{$key} = !$ref ? $hashref->{$key}
4634- : $ref eq 'HASH' ? { %{$hashref->{$key}} }
4635- : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
4636- : $hashref->{$key};
4637- }
4638- $_ => $val_copy;
4639- } qw(opts short_opts defaults);
4640-
4641- foreach my $scalar ( qw(got_opts) ) {
4642- $clone{$scalar} = $self->{$scalar};
4643- }
4644-
4645- return bless \%clone;
4646-}
4647-
4648-sub _parse_size {
4649- my ( $self, $opt, $val ) = @_;
4650-
4651- if ( lc($val || '') eq 'null' ) {
4652- PTDEBUG && _d('NULL size for', $opt->{long});
4653- $opt->{value} = 'null';
4654- return;
4655- }
4656-
4657- my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
4658- my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
4659- if ( defined $num ) {
4660- if ( $factor ) {
4661- $num *= $factor_for{$factor};
4662- PTDEBUG && _d('Setting option', $opt->{y},
4663- 'to num', $num, '* factor', $factor);
4664- }
4665- $opt->{value} = ($pre || '') . $num;
4666- }
4667- else {
4668- $self->save_error("Invalid size for --$opt->{long}: $val");
4669- }
4670- return;
4671-}
4672-
4673-sub _parse_attribs {
4674- my ( $self, $option, $attribs ) = @_;
4675- my $types = $self->{types};
4676- return $option
4677- . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
4678- . ($attribs->{'negatable'} ? '!' : '' )
4679- . ($attribs->{'cumulative'} ? '+' : '' )
4680- . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
4681-}
4682-
4683-sub _parse_synopsis {
4684- my ( $self, $file ) = @_;
4685- $file ||= $self->{file} || __FILE__;
4686- PTDEBUG && _d("Parsing SYNOPSIS in", $file);
4687-
4688- local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
4689- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
4690- my $para;
4691- 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
4692- die "$file does not contain a SYNOPSIS section" unless $para;
4693- my @synop;
4694- for ( 1..2 ) { # 1 for the usage, 2 for the description
4695- my $para = <$fh>;
4696- push @synop, $para;
4697- }
4698- close $fh;
4699- PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
4700- my ($usage, $desc) = @synop;
4701- die "The SYNOPSIS section in $file is not formatted properly"
4702- unless $usage && $desc;
4703-
4704- $usage =~ s/^\s*Usage:\s+(.+)/$1/;
4705- chomp $usage;
4706-
4707- $desc =~ s/\n/ /g;
4708- $desc =~ s/\s{2,}/ /g;
4709- $desc =~ s/\. ([A-Z][a-z])/. $1/g;
4710- $desc =~ s/\s+$//;
4711-
4712- return (
4713- description => $desc,
4714- usage => $usage,
4715- );
4716-};
4717-
4718-sub _d {
4719- my ($package, undef, $line) = caller 0;
4720- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4721- map { defined $_ ? $_ : 'undef' }
4722- @_;
4723- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4724-}
4725-
4726-if ( PTDEBUG ) {
4727- print '# ', $^X, ' ', $], "\n";
4728- if ( my $uname = `uname -a` ) {
4729- $uname =~ s/\s+/ /g;
4730- print "# $uname\n";
4731- }
4732- print '# Arguments: ',
4733- join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
4734-}
4735-
4736-1;
4737-}
4738-# ###########################################################################
4739-# End OptionParser package
4740-# ###########################################################################
4741-
4742-# ###########################################################################
4743-# Transformers package
4744-# This package is a copy without comments from the original. The original
4745-# with comments and its test file can be found in the Bazaar repository at,
4746-# lib/Transformers.pm
4747-# t/lib/Transformers.t
4748-# See https://launchpad.net/percona-toolkit for more information.
4749-# ###########################################################################
4750-{
4751-package Transformers;
4752-
4753-use strict;
4754-use warnings FATAL => 'all';
4755-use English qw(-no_match_vars);
4756-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4757-
4758-use Time::Local qw(timegm timelocal);
4759-use Digest::MD5 qw(md5_hex);
4760-use B qw();
4761-
4762-require Exporter;
4763-our @ISA = qw(Exporter);
4764-our %EXPORT_TAGS = ();
4765-our @EXPORT = ();
4766-our @EXPORT_OK = qw(
4767- micro_t
4768- percentage_of
4769- secs_to_time
4770- time_to_secs
4771- shorten
4772- ts
4773- parse_timestamp
4774- unix_timestamp
4775- any_unix_timestamp
4776- make_checksum
4777- crc32
4778- encode_json
4779-);
4780-
4781-our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
4782-our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
4783-our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
4784-
4785-sub micro_t {
4786- my ( $t, %args ) = @_;
4787- my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
4788- my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
4789- my $f;
4790-
4791- $t = 0 if $t < 0;
4792-
4793- $t = sprintf('%.17f', $t) if $t =~ /e/;
4794-
4795- $t =~ s/\.(\d{1,6})\d*/\.$1/;
4796-
4797- if ($t > 0 && $t <= 0.000999) {
4798- $f = ($t * 1000000) . 'us';
4799- }
4800- elsif ($t >= 0.001000 && $t <= 0.999999) {
4801- $f = sprintf("%.${p_ms}f", $t * 1000);
4802- $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
4803- }
4804- elsif ($t >= 1) {
4805- $f = sprintf("%.${p_s}f", $t);
4806- $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
4807- }
4808- else {
4809- $f = 0; # $t should = 0 at this point
4810- }
4811-
4812- return $f;
4813-}
4814-
4815-sub percentage_of {
4816- my ( $is, $of, %args ) = @_;
4817- my $p = $args{p} || 0; # float precision
4818- my $fmt = $p ? "%.${p}f" : "%d";
4819- return sprintf $fmt, ($is * 100) / ($of ||= 1);
4820-}
4821-
4822-sub secs_to_time {
4823- my ( $secs, $fmt ) = @_;
4824- $secs ||= 0;
4825- return '00:00' unless $secs;
4826-
4827- $fmt ||= $secs >= 86_400 ? 'd'
4828- : $secs >= 3_600 ? 'h'
4829- : 'm';
4830-
4831- return
4832- $fmt eq 'd' ? sprintf(
4833- "%d+%02d:%02d:%02d",
4834- int($secs / 86_400),
4835- int(($secs % 86_400) / 3_600),
4836- int(($secs % 3_600) / 60),
4837- $secs % 60)
4838- : $fmt eq 'h' ? sprintf(
4839- "%02d:%02d:%02d",
4840- int(($secs % 86_400) / 3_600),
4841- int(($secs % 3_600) / 60),
4842- $secs % 60)
4843- : sprintf(
4844- "%02d:%02d",
4845- int(($secs % 3_600) / 60),
4846- $secs % 60);
4847-}
4848-
4849-sub time_to_secs {
4850- my ( $val, $default_suffix ) = @_;
4851- die "I need a val argument" unless defined $val;
4852- my $t = 0;
4853- my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
4854- $suffix = $suffix || $default_suffix || 's';
4855- if ( $suffix =~ m/[smhd]/ ) {
4856- $t = $suffix eq 's' ? $num * 1 # Seconds
4857- : $suffix eq 'm' ? $num * 60 # Minutes
4858- : $suffix eq 'h' ? $num * 3600 # Hours
4859- : $num * 86400; # Days
4860-
4861- $t *= -1 if $prefix && $prefix eq '-';
4862- }
4863- else {
4864- die "Invalid suffix for $val: $suffix";
4865- }
4866- return $t;
4867-}
4868-
4869-sub shorten {
4870- my ( $num, %args ) = @_;
4871- my $p = defined $args{p} ? $args{p} : 2; # float precision
4872- my $d = defined $args{d} ? $args{d} : 1_024; # divisor
4873- my $n = 0;
4874- my @units = ('', qw(k M G T P E Z Y));
4875- while ( $num >= $d && $n < @units - 1 ) {
4876- $num /= $d;
4877- ++$n;
4878- }
4879- return sprintf(
4880- $num =~ m/\./ || $n
4881- ? "%.${p}f%s"
4882- : '%d',
4883- $num, $units[$n]);
4884-}
4885-
4886-sub ts {
4887- my ( $time, $gmt ) = @_;
4888- my ( $sec, $min, $hour, $mday, $mon, $year )
4889- = $gmt ? gmtime($time) : localtime($time);
4890- $mon += 1;
4891- $year += 1900;
4892- my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
4893- $year, $mon, $mday, $hour, $min, $sec);
4894- if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
4895- $us = sprintf("%.6f", $us);
4896- $us =~ s/^0\././;
4897- $val .= $us;
4898- }
4899- return $val;
4900-}
4901-
4902-sub parse_timestamp {
4903- my ( $val ) = @_;
4904- if ( my($y, $m, $d, $h, $i, $s, $f)
4905- = $val =~ m/^$mysql_ts$/ )
4906- {
4907- return sprintf "%d-%02d-%02d %02d:%02d:"
4908- . (defined $f ? '%09.6f' : '%02d'),
4909- $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
4910- }
4911- return $val;
4912-}
4913-
4914-sub unix_timestamp {
4915- my ( $val, $gmt ) = @_;
4916- if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
4917- $val = $gmt
4918- ? timegm($s, $i, $h, $d, $m - 1, $y)
4919- : timelocal($s, $i, $h, $d, $m - 1, $y);
4920- if ( defined $us ) {
4921- $us = sprintf('%.6f', $us);
4922- $us =~ s/^0\././;
4923- $val .= $us;
4924- }
4925- }
4926- return $val;
4927-}
4928-
4929-sub any_unix_timestamp {
4930- my ( $val, $callback ) = @_;
4931-
4932- if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
4933- $n = $suffix eq 's' ? $n # Seconds
4934- : $suffix eq 'm' ? $n * 60 # Minutes
4935- : $suffix eq 'h' ? $n * 3600 # Hours
4936- : $suffix eq 'd' ? $n * 86400 # Days
4937- : $n; # default: Seconds
4938- PTDEBUG && _d('ts is now - N[shmd]:', $n);
4939- return time - $n;
4940- }
4941- elsif ( $val =~ m/^\d{9,}/ ) {
4942- PTDEBUG && _d('ts is already a unix timestamp');
4943- return $val;
4944- }
4945- elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
4946- PTDEBUG && _d('ts is MySQL slow log timestamp');
4947- $val .= ' 00:00:00' unless $hms;
4948- return unix_timestamp(parse_timestamp($val));
4949- }
4950- elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
4951- PTDEBUG && _d('ts is properly formatted timestamp');
4952- $val .= ' 00:00:00' unless $hms;
4953- return unix_timestamp($val);
4954- }
4955- else {
4956- PTDEBUG && _d('ts is MySQL expression');
4957- return $callback->($val) if $callback && ref $callback eq 'CODE';
4958- }
4959-
4960- PTDEBUG && _d('Unknown ts type:', $val);
4961- return;
4962-}
4963-
4964-sub make_checksum {
4965- my ( $val ) = @_;
4966- my $checksum = uc substr(md5_hex($val), -16);
4967- PTDEBUG && _d($checksum, 'checksum for', $val);
4968- return $checksum;
4969-}
4970-
4971-sub crc32 {
4972- my ( $string ) = @_;
4973- return unless $string;
4974- my $poly = 0xEDB88320;
4975- my $crc = 0xFFFFFFFF;
4976- foreach my $char ( split(//, $string) ) {
4977- my $comp = ($crc ^ ord($char)) & 0xFF;
4978- for ( 1 .. 8 ) {
4979- $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
4980- }
4981- $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
4982- }
4983- return $crc ^ 0xFFFFFFFF;
4984-}
4985-
4986-my $got_json = eval { require JSON };
4987-sub encode_json {
4988- return JSON::encode_json(@_) if $got_json;
4989- my ( $data ) = @_;
4990- return (object_to_json($data) || '');
4991-}
4992-
4993-
4994-sub object_to_json {
4995- my ($obj) = @_;
4996- my $type = ref($obj);
4997-
4998- if($type eq 'HASH'){
4999- return hash_to_json($obj);
5000- }
The diff has been truncated for viewing.

Subscribers

People subscribed via source and target branches