Merge lp:~percona-toolkit-dev/percona-toolkit/remove-3-tools into lp:percona-toolkit/2.2
- remove-3-tools
- Merge into 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 |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
Brian Fraser (community) | Approve | ||
Daniel Nichter | Approve | ||
Review via email:
|
Commit message
Description of the change
To post a comment you must log in.
Revision history for this message
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
Daniel Nichter (daniel-nichter) : | # |
review:
Approve
Revision history for this message
![](/+icing/build/overlay/assets/skins/sam/images/close.gif)
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.