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